-- | @push@ input handler
module Unison.Codebase.Editor.HandleInput.Push
  ( handlePushRemoteBranch,
  )
where

import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, readTVarIO)
import Control.Lens (_1, _2)
import Data.Set.NonEmpty qualified as Set.NonEmpty
import Data.Text as Text
import Data.These (These (..))
import System.Console.Regions qualified as Console.Regions
import TextBuilder qualified
import U.Codebase.HashTags (CausalHash (..))
import U.Codebase.Sqlite.DbId
import U.Codebase.Sqlite.Operations qualified as Operations
import U.Codebase.Sqlite.Project qualified as Sqlite (Project)
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch)
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch)
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.Monad (Cli)
import Unison.Cli.Monad qualified as Cli
import Unison.Cli.MonadUtils qualified as Cli
import Unison.Cli.ProjectUtils qualified as ProjectUtils
import Unison.Cli.Share.Projects qualified as Share
import Unison.Codebase.Editor.HandleInput.AuthLogin qualified as AuthLogin
import Unison.Codebase.Editor.Input
  ( PushRemoteBranchInput (..),
    PushSource (..),
    PushSourceTarget (..),
  )
import Unison.Codebase.Editor.Output
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.PushBehavior qualified as PushBehavior
import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName))
import Unison.Hash32 (Hash32)
import Unison.Hash32 qualified as Hash32
import Unison.Prelude
import Unison.Project
  ( ProjectAndBranch (..),
    ProjectBranchNameKind (..),
    ProjectName,
    classifyProjectBranchName,
    defaultBranchName,
    prependUserSlugToProjectName,
    projectNameUserSlug,
  )
import Unison.Share.API.Hash qualified as Share.API
import Unison.Share.API.Projects qualified as Share.API
import Unison.Share.Codeserver qualified as Codeserver
import Unison.Share.HistoryComments qualified as HC
import Unison.Share.Sync qualified as Share
import Unison.Share.Sync.Types qualified as Share
import Unison.Share.Types (codeserverBaseURL)
import Unison.Sqlite qualified as Sqlite
import Unison.Sync.Types qualified as Share

-- | Handle a @push@ command.
handlePushRemoteBranch :: PushRemoteBranchInput -> Cli ()
handlePushRemoteBranch :: PushRemoteBranchInput -> Cli ()
handlePushRemoteBranch PushRemoteBranchInput {PushSourceTarget
sourceTarget :: PushSourceTarget
sourceTarget :: PushRemoteBranchInput -> PushSourceTarget
sourceTarget, PushBehavior
pushBehavior :: PushBehavior
pushBehavior :: PushRemoteBranchInput -> PushBehavior
pushBehavior} = do
  case PushSourceTarget
sourceTarget of
    -- push <implicit> to <implicit>
    PushSourceTarget
PushSourceTarget0 -> do
      localProjectAndBranch <- Cli (ProjectAndBranch Project ProjectBranch)
Cli.getCurrentProjectAndBranch
      pushProjectBranchToProjectBranch force localProjectAndBranch Nothing
    -- push <implicit> to .some.path (share)
    -- push <implicit> to @some/project
    PushSourceTarget1 These ProjectName ProjectBranchName
remoteProjectAndBranch0 -> do
      localProjectAndBranch <- Cli (ProjectAndBranch Project ProjectBranch)
Cli.getCurrentProjectAndBranch
      pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0)
    -- push @some/project to @some/project
    PushSourceTarget2 (ProjySource These ProjectName ProjectBranchName
localProjectAndBranch0) These ProjectName ProjectBranchName
remoteProjectAndBranch -> do
      localProjectAndBranch <- These ProjectName ProjectBranchName
-> Cli (ProjectAndBranch Project ProjectBranch)
ProjectUtils.expectProjectAndBranchByTheseNames These ProjectName ProjectBranchName
localProjectAndBranch0
      pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch)
  where
    force :: Bool
force =
      case PushBehavior
pushBehavior of
        PushBehavior
PushBehavior.ForcePush -> Bool
True
        PushBehavior
PushBehavior.RequireEmpty -> Bool
False
        PushBehavior
PushBehavior.RequireNonEmpty -> Bool
False

-- | Push a local project branch to a remote project branch. If the remote project branch is left unspecified, we either
-- use a pre-existing mapping for the local branch, or else infer what remote branch to push to (possibly creating it).
pushProjectBranchToProjectBranch ::
  Bool ->
  ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch ->
  Maybe (These ProjectName ProjectBranchName) ->
  Cli ()
pushProjectBranchToProjectBranch :: Bool
-> ProjectAndBranch Project ProjectBranch
-> Maybe (These ProjectName ProjectBranchName)
-> Cli ()
pushProjectBranchToProjectBranch Bool
force ProjectAndBranch Project ProjectBranch
localProjectAndBranch Maybe (These ProjectName ProjectBranchName)
maybeRemoteProjectAndBranchNames = do
  _ <- CodeserverURI -> Cli UserInfo
AuthLogin.ensureAuthenticatedWithCodeserver CodeserverURI
Codeserver.defaultCodeserver
  let localProjectAndBranchIds = ProjectAndBranch Project ProjectBranch
localProjectAndBranch ProjectAndBranch Project ProjectBranch
-> (ProjectAndBranch Project ProjectBranch
    -> ProjectAndBranch ProjectId ProjectBranch)
-> ProjectAndBranch ProjectId ProjectBranch
forall a b. a -> (a -> b) -> b
& ASetter
  (ProjectAndBranch Project ProjectBranch)
  (ProjectAndBranch ProjectId ProjectBranch)
  Project
  ProjectId
-> (Project -> ProjectId)
-> ProjectAndBranch Project ProjectBranch
-> ProjectAndBranch ProjectId ProjectBranch
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (ProjectAndBranch Project ProjectBranch)
  (ProjectAndBranch ProjectId ProjectBranch)
  Project
  ProjectId
#project (Getting ProjectId Project ProjectId -> Project -> ProjectId
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ProjectId Project ProjectId
#projectId) ProjectAndBranch ProjectId ProjectBranch
-> (ProjectAndBranch ProjectId ProjectBranch
    -> ProjectAndBranch ProjectId ProjectBranchId)
-> ProjectAndBranch ProjectId ProjectBranchId
forall a b. a -> (a -> b) -> b
& ASetter
  (ProjectAndBranch ProjectId ProjectBranch)
  (ProjectAndBranch ProjectId ProjectBranchId)
  ProjectBranch
  ProjectBranchId
-> (ProjectBranch -> ProjectBranchId)
-> ProjectAndBranch ProjectId ProjectBranch
-> ProjectAndBranch ProjectId ProjectBranchId
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (ProjectAndBranch ProjectId ProjectBranch)
  (ProjectAndBranch ProjectId ProjectBranchId)
  ProjectBranch
  ProjectBranchId
#branch (Getting ProjectBranchId ProjectBranch ProjectBranchId
-> ProjectBranch -> ProjectBranchId
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ProjectBranchId ProjectBranch ProjectBranchId
#branchId)

  -- Load local project and branch from database and get the causal hash to push
  (localProjectAndBranch, localBranchHead) <-
    Cli.runTransaction do
      hash <- expectCausalHashToPush (localProjectAndBranch ^. #branch)
      localProjectAndBranch <- expectProjectAndBranch localProjectAndBranchIds
      pure (localProjectAndBranch, hash)

  uploadPlan <-
    case maybeRemoteProjectAndBranchNames of
      Maybe (These ProjectName ProjectBranchName)
Nothing ->
        Bool
-> ProjectAndBranch Project ProjectBranch
-> Hash32
-> Maybe ProjectBranchName
-> Cli UploadPlan
pushProjectBranchToProjectBranch'InferredProject
          Bool
force
          ProjectAndBranch Project ProjectBranch
localProjectAndBranch
          Hash32
localBranchHead
          Maybe ProjectBranchName
forall a. Maybe a
Nothing
      Just (This ProjectName
remoteProjectName) ->
        Bool
-> ProjectAndBranch Project ProjectBranch
-> Hash32
-> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
-> Cli UploadPlan
pushProjectBranchToProjectBranch'IgnoreRemoteMapping
          Bool
force
          ProjectAndBranch Project ProjectBranch
localProjectAndBranch
          Hash32
localBranchHead
          (Maybe ProjectName
-> Maybe ProjectBranchName
-> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch (ProjectName -> Maybe ProjectName
forall a. a -> Maybe a
Just ProjectName
remoteProjectName) Maybe ProjectBranchName
forall a. Maybe a
Nothing)
      Just (That ProjectBranchName
remoteBranchName) ->
        Bool
-> ProjectAndBranch Project ProjectBranch
-> Hash32
-> Maybe ProjectBranchName
-> Cli UploadPlan
pushProjectBranchToProjectBranch'InferredProject
          Bool
force
          ProjectAndBranch Project ProjectBranch
localProjectAndBranch
          Hash32
localBranchHead
          (ProjectBranchName -> Maybe ProjectBranchName
forall a. a -> Maybe a
Just ProjectBranchName
remoteBranchName)
      Just (These ProjectName
remoteProjectName ProjectBranchName
remoteBranchName) ->
        Bool
-> WhatAreWePushing
-> Hash32
-> ProjectAndBranch ProjectName ProjectBranchName
-> Cli UploadPlan
pushToProjectBranch0
          Bool
force
          (ProjectAndBranch Project ProjectBranch -> WhatAreWePushing
PushingProjectBranch ProjectAndBranch Project ProjectBranch
localProjectAndBranch)
          Hash32
localBranchHead
          (ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch ProjectName
remoteProjectName ProjectBranchName
remoteBranchName)

  executeUploadPlan uploadPlan

-- "push" or "push /foo", remote mapping unknown
pushProjectBranchToProjectBranch'InferredProject ::
  Bool ->
  ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch ->
  Hash32 ->
  Maybe ProjectBranchName ->
  Cli UploadPlan
pushProjectBranchToProjectBranch'InferredProject :: Bool
-> ProjectAndBranch Project ProjectBranch
-> Hash32
-> Maybe ProjectBranchName
-> Cli UploadPlan
pushProjectBranchToProjectBranch'InferredProject Bool
force ProjectAndBranch Project ProjectBranch
localProjectAndBranch Hash32
localBranchHead Maybe ProjectBranchName
maybeRemoteBranchName = do
  let loadRemoteProjectInfo ::
        Sqlite.Transaction
          ( Maybe
              ( RemoteProjectId,
                ProjectName,
                Maybe (RemoteProjectBranchId, ProjectBranchName)
              )
          )
      loadRemoteProjectInfo :: Transaction
  (Maybe
     (RemoteProjectId, ProjectName,
      Maybe (RemoteProjectBranchId, ProjectBranchName)))
loadRemoteProjectInfo =
        ProjectId
-> URI
-> ProjectBranchId
-> Transaction
     (Maybe (RemoteProjectId, Maybe RemoteProjectBranchId))
Queries.loadRemoteProjectBranch ProjectId
localProjectId URI
Share.hardCodedUri ProjectBranchId
localBranchId Transaction (Maybe (RemoteProjectId, Maybe RemoteProjectBranchId))
-> (Maybe (RemoteProjectId, Maybe RemoteProjectBranchId)
    -> Transaction
         (Maybe
            (RemoteProjectId, ProjectName,
             Maybe (RemoteProjectBranchId, ProjectBranchName))))
-> Transaction
     (Maybe
        (RemoteProjectId, ProjectName,
         Maybe (RemoteProjectBranchId, ProjectBranchName)))
forall a b. Transaction a -> (a -> Transaction b) -> Transaction b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Maybe (RemoteProjectId, Maybe RemoteProjectBranchId)
Nothing -> Maybe
  (RemoteProjectId, ProjectName,
   Maybe (RemoteProjectBranchId, ProjectBranchName))
-> Transaction
     (Maybe
        (RemoteProjectId, ProjectName,
         Maybe (RemoteProjectBranchId, ProjectBranchName)))
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe
  (RemoteProjectId, ProjectName,
   Maybe (RemoteProjectBranchId, ProjectBranchName))
forall a. Maybe a
Nothing
          Just (RemoteProjectId
remoteProjectId, Maybe RemoteProjectBranchId
maybeRemoteBranchId) -> do
            remoteProjectName <- RemoteProjectId -> URI -> Transaction ProjectName
Queries.expectRemoteProjectName RemoteProjectId
remoteProjectId URI
Share.hardCodedUri
            maybeRemoteBranchInfo <-
              for maybeRemoteBranchId \RemoteProjectBranchId
remoteBranchId -> do
                remoteBranchName <-
                  URI
-> RemoteProjectId
-> RemoteProjectBranchId
-> Transaction ProjectBranchName
Queries.expectRemoteProjectBranchName URI
Share.hardCodedUri RemoteProjectId
remoteProjectId RemoteProjectBranchId
remoteBranchId
                pure (remoteBranchId, remoteBranchName)
            pure (Just (remoteProjectId, remoteProjectName, maybeRemoteBranchInfo))

  Transaction
  (Maybe
     (RemoteProjectId, ProjectName,
      Maybe (RemoteProjectBranchId, ProjectBranchName)))
-> Cli
     (Maybe
        (RemoteProjectId, ProjectName,
         Maybe (RemoteProjectBranchId, ProjectBranchName)))
forall a. Transaction a -> Cli a
Cli.runTransaction Transaction
  (Maybe
     (RemoteProjectId, ProjectName,
      Maybe (RemoteProjectBranchId, ProjectBranchName)))
loadRemoteProjectInfo Cli
  (Maybe
     (RemoteProjectId, ProjectName,
      Maybe (RemoteProjectBranchId, ProjectBranchName)))
-> (Maybe
      (RemoteProjectId, ProjectName,
       Maybe (RemoteProjectBranchId, ProjectBranchName))
    -> Cli UploadPlan)
-> Cli UploadPlan
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe
  (RemoteProjectId, ProjectName,
   Maybe (RemoteProjectBranchId, ProjectBranchName))
Nothing ->
      Bool
-> ProjectAndBranch Project ProjectBranch
-> Hash32
-> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
-> Cli UploadPlan
pushProjectBranchToProjectBranch'IgnoreRemoteMapping
        Bool
force
        ProjectAndBranch Project ProjectBranch
localProjectAndBranch
        Hash32
localBranchHead
        (Maybe ProjectName
-> Maybe ProjectBranchName
-> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch Maybe ProjectName
forall a. Maybe a
Nothing Maybe ProjectBranchName
maybeRemoteBranchName)
    Just (RemoteProjectId
remoteProjectId, ProjectName
remoteProjectName, Maybe (RemoteProjectBranchId, ProjectBranchName)
maybeRemoteBranchInfo) ->
      case Maybe ProjectBranchName
maybeRemoteBranchName of
        Maybe ProjectBranchName
Nothing -> do
          case Maybe (RemoteProjectBranchId, ProjectBranchName)
maybeRemoteBranchInfo of
            -- "push" with remote mapping for project from ancestor branch
            Maybe (RemoteProjectBranchId, ProjectBranchName)
Nothing -> do
              myUserHandle <- Getting Text UserInfo Text -> UserInfo -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text UserInfo Text
#handle (UserInfo -> Text) -> Cli UserInfo -> Cli Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CodeserverURI -> Cli UserInfo
AuthLogin.ensureAuthenticatedWithCodeserver CodeserverURI
Codeserver.defaultCodeserver
              let localBranchName = ProjectAndBranch Project ProjectBranch
localProjectAndBranch ProjectAndBranch Project ProjectBranch
-> Getting
     ProjectBranchName
     (ProjectAndBranch Project ProjectBranch)
     ProjectBranchName
-> ProjectBranchName
forall s a. s -> Getting a s a -> a
^. (ProjectBranch -> Const ProjectBranchName ProjectBranch)
-> ProjectAndBranch Project ProjectBranch
-> Const ProjectBranchName (ProjectAndBranch Project ProjectBranch)
#branch ((ProjectBranch -> Const ProjectBranchName ProjectBranch)
 -> ProjectAndBranch Project ProjectBranch
 -> Const
      ProjectBranchName (ProjectAndBranch Project ProjectBranch))
-> ((ProjectBranchName
     -> Const ProjectBranchName ProjectBranchName)
    -> ProjectBranch -> Const ProjectBranchName ProjectBranch)
-> Getting
     ProjectBranchName
     (ProjectAndBranch Project ProjectBranch)
     ProjectBranchName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProjectBranchName -> Const ProjectBranchName ProjectBranchName)
-> ProjectBranch -> Const ProjectBranchName ProjectBranch
#name
              let remoteBranchName = Text -> ProjectBranchName -> ProjectBranchName
deriveRemoteBranchName Text
myUserHandle ProjectBranchName
localBranchName
              pushToProjectBranch1
                force
                localProjectAndBranch
                localBranchHead
                (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
            -- "push" with remote mapping for branch
            Just (RemoteProjectBranchId
remoteBranchId, ProjectBranchName
remoteBranchName) -> do
              let remoteProjectBranchDoesntExist :: Cli UploadPlan
remoteProjectBranchDoesntExist = do
                    Transaction () -> Cli ()
forall a. Transaction a -> Cli a
Cli.runTransaction (Transaction () -> Cli ()) -> Transaction () -> Cli ()
forall a b. (a -> b) -> a -> b
$
                      ProjectId -> ProjectBranchId -> URI -> Transaction ()
Queries.deleteBranchRemoteMapping
                        ProjectId
localProjectId
                        ProjectBranchId
localBranchId
                        URI
Share.hardCodedUri
                    Output -> Cli UploadPlan
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli UploadPlan) -> Output -> Cli UploadPlan
forall a b. (a -> b) -> a -> b
$
                      URI -> ProjectAndBranch ProjectName ProjectBranchName -> Output
Output.RemoteProjectBranchDoesntExist'Push
                        URI
Share.hardCodedUri
                        (ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch ProjectName
remoteProjectName ProjectBranchName
remoteBranchName)
              IncludeSquashedHead
-> ProjectAndBranch RemoteProjectId RemoteProjectBranchId
-> Cli GetProjectBranchResponse
Share.getProjectBranchById IncludeSquashedHead
Share.NoSquashedHead (RemoteProjectId
-> RemoteProjectBranchId
-> ProjectAndBranch RemoteProjectId RemoteProjectBranchId
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch RemoteProjectId
remoteProjectId RemoteProjectBranchId
remoteBranchId) Cli GetProjectBranchResponse
-> (GetProjectBranchResponse -> Cli UploadPlan) -> Cli UploadPlan
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                GetProjectBranchResponse
Share.GetProjectBranchResponseBranchNotFound -> Cli UploadPlan
remoteProjectBranchDoesntExist
                GetProjectBranchResponse
Share.GetProjectBranchResponseProjectNotFound -> Cli UploadPlan
remoteProjectBranchDoesntExist
                Share.GetProjectBranchResponseSuccess RemoteProjectBranch
remoteBranch -> do
                  afterUploadAction <-
                    Bool
-> WhatAreWePushing
-> Hash32
-> RemoteProjectBranch
-> Cli (Cli ())
makeSetHeadAfterUploadAction
                      Bool
force
                      (ProjectAndBranch Project ProjectBranch -> WhatAreWePushing
PushingProjectBranch ProjectAndBranch Project ProjectBranch
localProjectAndBranch)
                      Hash32
localBranchHead
                      RemoteProjectBranch
remoteBranch
                  pure
                    UploadPlan
                      { remoteBranch = ProjectAndBranch (remoteBranch ^. #projectName) (remoteBranch ^. #branchName),
                        remoteHead = Just $ Share.API.hashJWTHash remoteBranch.branchHead,
                        causalHash = localBranchHead,
                        afterUploadAction
                      }
        -- "push /foo" with remote mapping for project from ancestor branch
        Just ProjectBranchName
remoteBranchName ->
          Bool
-> ProjectAndBranch Project ProjectBranch
-> Hash32
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
-> Cli UploadPlan
pushToProjectBranch1
            Bool
force
            ProjectAndBranch Project ProjectBranch
localProjectAndBranch
            Hash32
localBranchHead
            ((RemoteProjectId, ProjectName)
-> ProjectBranchName
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch (RemoteProjectId
remoteProjectId, ProjectName
remoteProjectName) ProjectBranchName
remoteBranchName)
  where
    localProjectId :: ProjectId
localProjectId = ProjectAndBranch Project ProjectBranch
localProjectAndBranch ProjectAndBranch Project ProjectBranch
-> Getting
     ProjectId (ProjectAndBranch Project ProjectBranch) ProjectId
-> ProjectId
forall s a. s -> Getting a s a -> a
^. (Project -> Const ProjectId Project)
-> ProjectAndBranch Project ProjectBranch
-> Const ProjectId (ProjectAndBranch Project ProjectBranch)
#project ((Project -> Const ProjectId Project)
 -> ProjectAndBranch Project ProjectBranch
 -> Const ProjectId (ProjectAndBranch Project ProjectBranch))
-> Getting ProjectId Project ProjectId
-> Getting
     ProjectId (ProjectAndBranch Project ProjectBranch) ProjectId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ProjectId Project ProjectId
#projectId
    localBranchId :: ProjectBranchId
localBranchId = ProjectAndBranch Project ProjectBranch
localProjectAndBranch ProjectAndBranch Project ProjectBranch
-> Getting
     ProjectBranchId
     (ProjectAndBranch Project ProjectBranch)
     ProjectBranchId
-> ProjectBranchId
forall s a. s -> Getting a s a -> a
^. (ProjectBranch -> Const ProjectBranchId ProjectBranch)
-> ProjectAndBranch Project ProjectBranch
-> Const ProjectBranchId (ProjectAndBranch Project ProjectBranch)
#branch ((ProjectBranch -> Const ProjectBranchId ProjectBranch)
 -> ProjectAndBranch Project ProjectBranch
 -> Const ProjectBranchId (ProjectAndBranch Project ProjectBranch))
-> Getting ProjectBranchId ProjectBranch ProjectBranchId
-> Getting
     ProjectBranchId
     (ProjectAndBranch Project ProjectBranch)
     ProjectBranchId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ProjectBranchId ProjectBranch ProjectBranchId
#branchId

-- "push", "push foo", or "push /foo" ignoring remote mapping (if any)
pushProjectBranchToProjectBranch'IgnoreRemoteMapping ::
  Bool ->
  ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch ->
  Hash32 ->
  ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) ->
  Cli UploadPlan
pushProjectBranchToProjectBranch'IgnoreRemoteMapping :: Bool
-> ProjectAndBranch Project ProjectBranch
-> Hash32
-> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
-> Cli UploadPlan
pushProjectBranchToProjectBranch'IgnoreRemoteMapping
  Bool
force
  ProjectAndBranch Project ProjectBranch
localProjectAndBranch
  Hash32
localBranchHead
  ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
remoteProjectAndBranchMaybes = do
    myUserHandle <- Getting Text UserInfo Text -> UserInfo -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text UserInfo Text
#handle (UserInfo -> Text) -> Cli UserInfo -> Cli Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CodeserverURI -> Cli UserInfo
AuthLogin.ensureAuthenticatedWithCodeserver CodeserverURI
Codeserver.defaultCodeserver
    let localProjectName = ProjectAndBranch Project ProjectBranch
localProjectAndBranch ProjectAndBranch Project ProjectBranch
-> Getting
     ProjectName (ProjectAndBranch Project ProjectBranch) ProjectName
-> ProjectName
forall s a. s -> Getting a s a -> a
^. (Project -> Const ProjectName Project)
-> ProjectAndBranch Project ProjectBranch
-> Const ProjectName (ProjectAndBranch Project ProjectBranch)
#project ((Project -> Const ProjectName Project)
 -> ProjectAndBranch Project ProjectBranch
 -> Const ProjectName (ProjectAndBranch Project ProjectBranch))
-> ((ProjectName -> Const ProjectName ProjectName)
    -> Project -> Const ProjectName Project)
-> Getting
     ProjectName (ProjectAndBranch Project ProjectBranch) ProjectName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProjectName -> Const ProjectName ProjectName)
-> Project -> Const ProjectName Project
#name
    let localBranchName = ProjectAndBranch Project ProjectBranch
localProjectAndBranch ProjectAndBranch Project ProjectBranch
-> Getting
     ProjectBranchName
     (ProjectAndBranch Project ProjectBranch)
     ProjectBranchName
-> ProjectBranchName
forall s a. s -> Getting a s a -> a
^. (ProjectBranch -> Const ProjectBranchName ProjectBranch)
-> ProjectAndBranch Project ProjectBranch
-> Const ProjectBranchName (ProjectAndBranch Project ProjectBranch)
#branch ((ProjectBranch -> Const ProjectBranchName ProjectBranch)
 -> ProjectAndBranch Project ProjectBranch
 -> Const
      ProjectBranchName (ProjectAndBranch Project ProjectBranch))
-> ((ProjectBranchName
     -> Const ProjectBranchName ProjectBranchName)
    -> ProjectBranch -> Const ProjectBranchName ProjectBranch)
-> Getting
     ProjectBranchName
     (ProjectAndBranch Project ProjectBranch)
     ProjectBranchName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProjectBranchName -> Const ProjectBranchName ProjectBranchName)
-> ProjectBranch -> Const ProjectBranchName ProjectBranch
#name
    let remoteProjectName =
          case ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
remoteProjectAndBranchMaybes ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
-> Getting
     (Maybe ProjectName)
     (ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName))
     (Maybe ProjectName)
-> Maybe ProjectName
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe ProjectName)
  (ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName))
  (Maybe ProjectName)
#project of
            Maybe ProjectName
Nothing -> Text -> ProjectName -> ProjectName
prependUserSlugToProjectName Text
myUserHandle ProjectName
localProjectName
            Just ProjectName
remoteProjectName1 -> ProjectName
remoteProjectName1
    let remoteBranchName =
          case ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
remoteProjectAndBranchMaybes ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)
-> Getting
     (Maybe ProjectBranchName)
     (ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName))
     (Maybe ProjectBranchName)
-> Maybe ProjectBranchName
forall s a. s -> Getting a s a -> a
^. Getting
  (Maybe ProjectBranchName)
  (ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName))
  (Maybe ProjectBranchName)
#branch of
            Maybe ProjectBranchName
Nothing -> Text -> ProjectBranchName -> ProjectBranchName
deriveRemoteBranchName Text
myUserHandle ProjectBranchName
localBranchName
            Just ProjectBranchName
remoteBranchName1 -> ProjectBranchName
remoteBranchName1
    let remoteProjectAndBranch = ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch ProjectName
remoteProjectName ProjectBranchName
remoteBranchName
    pushToProjectBranch0 force (PushingProjectBranch localProjectAndBranch) localBranchHead remoteProjectAndBranch

-- If left unspecified (and we don't yet have a remote mapping), we derive the remote branch name from the user's
-- handle and local branch name as follows:
--
--   * If the local branch name already has a user slug prefix or a (draft) release prefix, then we leave it alone.
--   * Otherwise, if the local branch name is "main", then we leave it alone.
--   * Otherwise, we prepend the user's handle to the local branch name.
--
-- This way, users (who let us infer remote branch names) tend to make topic branches, even when contributing to their
-- own project (e.g. pushing a local branch "foo" to my own project "@runar/lens" will create a remote branch called
-- "@runar/foo", not "foo"), because ephemeral topic branches are far more common than long-lived branches.
--
-- If a user wants to create a long-lived branch alongside their "main" branch (say "oldstuff"), they'll just have to
-- name "oldstuff" explicitly when pushing (the first time).
--
-- And "main" is an exception to the rule that we prefix your local branch name with your user handle. That way, you
-- won't end up with a *topic branch* called "@arya/main" when pushing a local branch called "main". Of course,
-- special-casing "main" in this way is only temporary, before we have a first-class notion of a default branch.
deriveRemoteBranchName :: Text -> ProjectBranchName -> ProjectBranchName
deriveRemoteBranchName :: Text -> ProjectBranchName -> ProjectBranchName
deriveRemoteBranchName Text
userHandle ProjectBranchName
localBranchName =
  case ProjectBranchName -> ProjectBranchNameKind
classifyProjectBranchName ProjectBranchName
localBranchName of
    ProjectBranchNameKind'Contributor Text
_ ProjectBranchName
_ -> ProjectBranchName
localBranchName
    ProjectBranchNameKind'DraftRelease Semver
_ -> ProjectBranchName
localBranchName
    ProjectBranchNameKind'Release Semver
_ -> ProjectBranchName
localBranchName
    ProjectBranchNameKind
ProjectBranchNameKind'NothingSpecial
      | ProjectBranchName
localBranchName ProjectBranchName -> ProjectBranchName -> Bool
forall a. Eq a => a -> a -> Bool
== ProjectBranchName
defaultBranchName -> ProjectBranchName
localBranchName
      | Bool
otherwise ->
          (Text -> ProjectBranchName
UnsafeProjectBranchName (Text -> ProjectBranchName)
-> ([TextBuilder] -> Text) -> [TextBuilder] -> ProjectBranchName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TextBuilder -> Text
TextBuilder.toText (TextBuilder -> Text)
-> ([TextBuilder] -> TextBuilder) -> [TextBuilder] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TextBuilder] -> TextBuilder
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold)
            [ Char -> TextBuilder
TextBuilder.char Char
'@',
              Text -> TextBuilder
TextBuilder.text Text
userHandle,
              Char -> TextBuilder
TextBuilder.char Char
'/',
              Text -> TextBuilder
TextBuilder.text (forall target source. From source target => source -> target
into @Text ProjectBranchName
localBranchName)
            ]

-- What are we pushing, a project branch or loose code?
data WhatAreWePushing
  = PushingProjectBranch (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
  | PushingLooseCode

-- we have the remote project and branch names, but we don't know whether either already exist
pushToProjectBranch0 ::
  Bool ->
  WhatAreWePushing ->
  Hash32 ->
  ProjectAndBranch ProjectName ProjectBranchName ->
  Cli UploadPlan
pushToProjectBranch0 :: Bool
-> WhatAreWePushing
-> Hash32
-> ProjectAndBranch ProjectName ProjectBranchName
-> Cli UploadPlan
pushToProjectBranch0 Bool
force WhatAreWePushing
pushing Hash32
localBranchHead ProjectAndBranch ProjectName ProjectBranchName
remoteProjectAndBranch = do
  let remoteProjectName :: ProjectName
remoteProjectName = ProjectAndBranch ProjectName ProjectBranchName
remoteProjectAndBranch ProjectAndBranch ProjectName ProjectBranchName
-> Getting
     ProjectName
     (ProjectAndBranch ProjectName ProjectBranchName)
     ProjectName
-> ProjectName
forall s a. s -> Getting a s a -> a
^. Getting
  ProjectName
  (ProjectAndBranch ProjectName ProjectBranchName)
  ProjectName
#project

  -- Assert that this project name has a user slug before bothering to hit Share
  _ <-
    ProjectName -> Maybe Text
projectNameUserSlug ProjectName
remoteProjectName Maybe Text -> (Maybe Text -> Cli Text) -> Cli Text
forall a b. a -> (a -> b) -> b
& Cli Text -> Maybe Text -> Cli Text
forall (m :: * -> *) a. Applicative m => m a -> Maybe a -> m a
onNothing do
      Output -> Cli Text
forall a. Output -> Cli a
Cli.returnEarly (ProjectName -> Output
Output.ProjectNameRequiresUserSlug ProjectName
remoteProjectName)

  Share.getProjectByName remoteProjectName >>= \case
    Maybe RemoteProject
Nothing -> do
      remoteProject <-
        ProjectName -> Cli (Maybe RemoteProject)
Share.createProject ProjectName
remoteProjectName Cli (Maybe RemoteProject)
-> (Cli (Maybe RemoteProject) -> Cli RemoteProject)
-> Cli RemoteProject
forall a b. a -> (a -> b) -> b
& Cli RemoteProject -> Cli (Maybe RemoteProject) -> Cli RemoteProject
forall (m :: * -> *) a. Monad m => m a -> m (Maybe a) -> m a
onNothingM do
          Output -> Cli RemoteProject
forall a. Output -> Cli a
Cli.returnEarly (URI -> ProjectName -> Output
Output.RemoteProjectDoesntExist URI
Share.hardCodedUri ProjectName
remoteProjectName)
      pure
        UploadPlan
          { remoteBranch = remoteProjectAndBranch,
            remoteHead = Nothing,
            causalHash = localBranchHead,
            afterUploadAction =
              createBranchAfterUploadAction
                pushing
                True -- just created the project
                localBranchHead
                (over #project (remoteProject ^. #projectId,) remoteProjectAndBranch)
          }
    Just RemoteProject
remoteProject -> do
      let remoteProjectId :: RemoteProjectId
remoteProjectId = RemoteProject
remoteProject RemoteProject
-> Getting RemoteProjectId RemoteProject RemoteProjectId
-> RemoteProjectId
forall s a. s -> Getting a s a -> a
^. Getting RemoteProjectId RemoteProject RemoteProjectId
#projectId
      IncludeSquashedHead
-> ProjectAndBranch RemoteProjectId ProjectBranchName
-> Cli GetProjectBranchResponse
Share.getProjectBranchByName IncludeSquashedHead
Share.NoSquashedHead (ProjectAndBranch ProjectName ProjectBranchName
remoteProjectAndBranch ProjectAndBranch ProjectName ProjectBranchName
-> (ProjectAndBranch ProjectName ProjectBranchName
    -> ProjectAndBranch RemoteProjectId ProjectBranchName)
-> ProjectAndBranch RemoteProjectId ProjectBranchName
forall a b. a -> (a -> b) -> b
& ASetter
  (ProjectAndBranch ProjectName ProjectBranchName)
  (ProjectAndBranch RemoteProjectId ProjectBranchName)
  ProjectName
  RemoteProjectId
#project ASetter
  (ProjectAndBranch ProjectName ProjectBranchName)
  (ProjectAndBranch RemoteProjectId ProjectBranchName)
  ProjectName
  RemoteProjectId
-> RemoteProjectId
-> ProjectAndBranch ProjectName ProjectBranchName
-> ProjectAndBranch RemoteProjectId ProjectBranchName
forall s t a b. ASetter s t a b -> b -> s -> t
.~ RemoteProjectId
remoteProjectId) Cli GetProjectBranchResponse
-> (GetProjectBranchResponse -> Cli UploadPlan) -> Cli UploadPlan
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        GetProjectBranchResponse
Share.GetProjectBranchResponseBranchNotFound -> do
          UploadPlan -> Cli UploadPlan
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
            UploadPlan
              { remoteBranch :: ProjectAndBranch ProjectName ProjectBranchName
remoteBranch = ProjectAndBranch ProjectName ProjectBranchName
remoteProjectAndBranch,
                remoteHead :: Maybe Hash32
remoteHead = Maybe Hash32
forall a. Maybe a
Nothing,
                causalHash :: Hash32
causalHash = Hash32
localBranchHead,
                afterUploadAction :: Cli ()
afterUploadAction =
                  WhatAreWePushing
-> Bool
-> Hash32
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
-> Cli ()
createBranchAfterUploadAction
                    WhatAreWePushing
pushing
                    Bool
False -- didn't just create the project
                    Hash32
localBranchHead
                    (ASetter
  (ProjectAndBranch ProjectName ProjectBranchName)
  (ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName)
  ProjectName
  (RemoteProjectId, ProjectName)
-> (ProjectName -> (RemoteProjectId, ProjectName))
-> ProjectAndBranch ProjectName ProjectBranchName
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (ProjectAndBranch ProjectName ProjectBranchName)
  (ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName)
  ProjectName
  (RemoteProjectId, ProjectName)
#project (RemoteProjectId
remoteProjectId,) ProjectAndBranch ProjectName ProjectBranchName
remoteProjectAndBranch)
              }
        GetProjectBranchResponse
Share.GetProjectBranchResponseProjectNotFound ->
          Output -> Cli UploadPlan
forall a. Output -> Cli a
Cli.returnEarly (URI -> ProjectAndBranch ProjectName ProjectBranchName -> Output
Output.RemoteProjectBranchDoesntExist URI
Share.hardCodedUri ProjectAndBranch ProjectName ProjectBranchName
remoteProjectAndBranch)
        Share.GetProjectBranchResponseSuccess RemoteProjectBranch
remoteBranch -> do
          afterUploadAction <- Bool
-> WhatAreWePushing
-> Hash32
-> RemoteProjectBranch
-> Cli (Cli ())
makeSetHeadAfterUploadAction Bool
force WhatAreWePushing
pushing Hash32
localBranchHead RemoteProjectBranch
remoteBranch
          pure
            UploadPlan
              { remoteBranch = remoteProjectAndBranch,
                remoteHead = Just (Share.API.hashJWTHash remoteBranch.branchHead),
                causalHash = localBranchHead,
                afterUploadAction
              }

-- "push /foo" with a remote mapping for the project (either from this branch or one of our ancestors)
-- but we don't know whether the remote branch exists
pushToProjectBranch1 ::
  Bool ->
  ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch ->
  Hash32 ->
  ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName ->
  Cli UploadPlan
pushToProjectBranch1 :: Bool
-> ProjectAndBranch Project ProjectBranch
-> Hash32
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
-> Cli UploadPlan
pushToProjectBranch1 Bool
force ProjectAndBranch Project ProjectBranch
localProjectAndBranch Hash32
localBranchHead ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName
remoteProjectAndBranch = do
  IncludeSquashedHead
-> ProjectAndBranch RemoteProjectId ProjectBranchName
-> Cli GetProjectBranchResponse
Share.getProjectBranchByName IncludeSquashedHead
Share.NoSquashedHead (ASetter
  (ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName)
  (ProjectAndBranch RemoteProjectId ProjectBranchName)
  (RemoteProjectId, ProjectName)
  RemoteProjectId
-> ((RemoteProjectId, ProjectName) -> RemoteProjectId)
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
-> ProjectAndBranch RemoteProjectId ProjectBranchName
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName)
  (ProjectAndBranch RemoteProjectId ProjectBranchName)
  (RemoteProjectId, ProjectName)
  RemoteProjectId
#project (RemoteProjectId, ProjectName) -> RemoteProjectId
forall a b. (a, b) -> a
fst ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName
remoteProjectAndBranch) Cli GetProjectBranchResponse
-> (GetProjectBranchResponse -> Cli UploadPlan) -> Cli UploadPlan
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    GetProjectBranchResponse
Share.GetProjectBranchResponseBranchNotFound -> do
      UploadPlan -> Cli UploadPlan
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
        UploadPlan
          { remoteBranch :: ProjectAndBranch ProjectName ProjectBranchName
remoteBranch = ASetter
  (ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName)
  (ProjectAndBranch ProjectName ProjectBranchName)
  (RemoteProjectId, ProjectName)
  ProjectName
-> ((RemoteProjectId, ProjectName) -> ProjectName)
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName)
  (ProjectAndBranch ProjectName ProjectBranchName)
  (RemoteProjectId, ProjectName)
  ProjectName
#project (RemoteProjectId, ProjectName) -> ProjectName
forall a b. (a, b) -> b
snd ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName
remoteProjectAndBranch,
            remoteHead :: Maybe Hash32
remoteHead = Maybe Hash32
forall a. Maybe a
Nothing,
            causalHash :: Hash32
causalHash = Hash32
localBranchHead,
            afterUploadAction :: Cli ()
afterUploadAction =
              WhatAreWePushing
-> Bool
-> Hash32
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
-> Cli ()
createBranchAfterUploadAction
                (ProjectAndBranch Project ProjectBranch -> WhatAreWePushing
PushingProjectBranch ProjectAndBranch Project ProjectBranch
localProjectAndBranch)
                Bool
False -- didn't just create the project
                Hash32
localBranchHead
                ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName
remoteProjectAndBranch
          }
    GetProjectBranchResponse
Share.GetProjectBranchResponseProjectNotFound -> Cli UploadPlan
forall void. Cli void
remoteProjectBranchDoesntExist
    Share.GetProjectBranchResponseSuccess RemoteProjectBranch
remoteBranch -> do
      afterUploadAction <-
        Bool
-> WhatAreWePushing
-> Hash32
-> RemoteProjectBranch
-> Cli (Cli ())
makeSetHeadAfterUploadAction Bool
force (ProjectAndBranch Project ProjectBranch -> WhatAreWePushing
PushingProjectBranch ProjectAndBranch Project ProjectBranch
localProjectAndBranch) Hash32
localBranchHead RemoteProjectBranch
remoteBranch
      pure
        UploadPlan
          { remoteBranch = over #project snd remoteProjectAndBranch,
            remoteHead = Just (Share.API.hashJWTHash remoteBranch.branchHead),
            causalHash = localBranchHead,
            afterUploadAction
          }
  where
    remoteProjectBranchDoesntExist :: Cli void
    remoteProjectBranchDoesntExist :: forall void. Cli void
remoteProjectBranchDoesntExist =
      Output -> Cli void
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli void) -> Output -> Cli void
forall a b. (a -> b) -> a -> b
$
        URI -> ProjectAndBranch ProjectName ProjectBranchName -> Output
Output.RemoteProjectBranchDoesntExist
          URI
Share.hardCodedUri
          (ASetter
  (ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName)
  (ProjectAndBranch ProjectName ProjectBranchName)
  (RemoteProjectId, ProjectName)
  ProjectName
-> ((RemoteProjectId, ProjectName) -> ProjectName)
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName)
  (ProjectAndBranch ProjectName ProjectBranchName)
  (RemoteProjectId, ProjectName)
  ProjectName
#project (RemoteProjectId, ProjectName) -> ProjectName
forall a b. (a, b) -> b
snd ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName
remoteProjectAndBranch)

------------------------------------------------------------------------------------------------------------------------
-- Upload plan

-- A plan for uploading to a remote branch and doing something afterwards.
data UploadPlan = UploadPlan
  { -- The remote branch we are uploading entities for.
    UploadPlan -> ProjectAndBranch ProjectName ProjectBranchName
remoteBranch :: ProjectAndBranch ProjectName ProjectBranchName,
    -- The current head of the remote branch.
    UploadPlan -> Maybe Hash32
remoteHead :: Maybe Hash32,
    -- The causal hash to upload.
    UploadPlan -> Hash32
causalHash :: Hash32,
    -- The action to call after a successful upload.
    UploadPlan -> Cli ()
afterUploadAction :: AfterUploadAction
  }

-- Execute an upload plan.
executeUploadPlan :: UploadPlan -> Cli ()
executeUploadPlan :: UploadPlan -> Cli ()
executeUploadPlan UploadPlan {ProjectAndBranch ProjectName ProjectBranchName
remoteBranch :: UploadPlan -> ProjectAndBranch ProjectName ProjectBranchName
remoteBranch :: ProjectAndBranch ProjectName ProjectBranchName
remoteBranch, Maybe Hash32
remoteHead :: UploadPlan -> Maybe Hash32
remoteHead :: Maybe Hash32
remoteHead, Hash32
causalHash :: UploadPlan -> Hash32
causalHash :: Hash32
causalHash, Cli ()
afterUploadAction :: UploadPlan -> Cli ()
afterUploadAction :: Cli ()
afterUploadAction} = do
  let codeserverURI :: CodeserverURI
codeserverURI = CodeserverURI
Codeserver.defaultCodeserver
  let remoteTarget :: Text
remoteTarget = forall target source. From source target => source -> target
into @Text (ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch (ProjectAndBranch ProjectName ProjectBranchName
remoteBranch ProjectAndBranch ProjectName ProjectBranchName
-> Getting
     ProjectName
     (ProjectAndBranch ProjectName ProjectBranchName)
     ProjectName
-> ProjectName
forall s a. s -> Getting a s a -> a
^. Getting
  ProjectName
  (ProjectAndBranch ProjectName ProjectBranchName)
  ProjectName
#project) (ProjectAndBranch ProjectName ProjectBranchName
remoteBranch ProjectAndBranch ProjectName ProjectBranchName
-> Getting
     ProjectBranchName
     (ProjectAndBranch ProjectName ProjectBranchName)
     ProjectBranchName
-> ProjectBranchName
forall s a. s -> Getting a s a -> a
^. Getting
  ProjectBranchName
  (ProjectAndBranch ProjectName ProjectBranchName)
  ProjectBranchName
#branch))
  case Maybe Hash32
remoteHead of
    Just Hash32
remoteHeadHash | Hash32
remoteHeadHash Hash32 -> Hash32 -> Bool
forall a. Eq a => a -> a -> Bool
== Hash32
causalHash -> do
      Output -> Cli ()
Cli.respond (URI -> ProjectAndBranch ProjectName ProjectBranchName -> Output
RemoteProjectBranchIsUpToDate URI
Share.hardCodedUri ProjectAndBranch ProjectName ProjectBranchName
remoteBranch)
    Maybe Hash32
_ -> do
      (uploadResult, numUploaded) <-
        (forall x. ((Int -> IO (), IO Int) -> IO x) -> IO x)
-> ((Int -> IO (), IO Int)
    -> Cli (Either (SyncError UploadEntitiesError) (), Int))
-> Cli (Either (SyncError UploadEntitiesError) (), Int)
forall a b.
(forall x. (a -> IO x) -> IO x) -> (a -> Cli b) -> Cli b
Cli.with ((Int -> IO (), IO Int) -> IO x) -> IO x
forall x. ((Int -> IO (), IO Int) -> IO x) -> IO x
withEntitiesUploadedProgressCallback \(Int -> IO ()
uploadedCallback, IO Int
getNumUploaded) -> do
          uploadResult <-
            BaseUrl
-> RepoInfo
-> NESet Hash32
-> (Int -> IO ())
-> Cli (Either (SyncError UploadEntitiesError) ())
Share.uploadEntities
              (CodeserverURI -> BaseUrl
codeserverBaseURL CodeserverURI
codeserverURI)
              -- On the wire, the remote branch is encoded as e.g.
              --   { "repo_info": "@unison/base/@arya/topic", ... }
              (Text -> RepoInfo
Share.RepoInfo Text
remoteTarget)
              (Hash32 -> NESet Hash32
forall a. a -> NESet a
Set.NonEmpty.singleton Hash32
causalHash)
              Int -> IO ()
uploadedCallback
          numUploaded <- liftIO getNumUploaded
          pure (uploadResult, numUploaded)
      Cli.respond (Output.UploadedEntities numUploaded)
      uploadResult & onLeft \SyncError UploadEntitiesError
err0 -> do
        (Output -> Cli ()
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli ())
-> (ShareError -> Output) -> ShareError -> Cli ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShareError -> Output
Output.ShareError) case SyncError UploadEntitiesError
err0 of
          Share.SyncError UploadEntitiesError
err -> UploadEntitiesError -> ShareError
ShareErrorUploadEntities UploadEntitiesError
err
          Share.TransportError CodeserverTransportError
err -> CodeserverTransportError -> ShareError
ShareErrorTransport CodeserverTransportError
err
  Cli ()
afterUploadAction
  Text -> Cli () -> Cli ()
forall a. Text -> Cli a -> Cli a
Cli.time Text
"Uploading History Comments" (Cli () -> Cli ()) -> Cli () -> Cli ()
forall a b. (a -> b) -> a -> b
$ Hash32 -> CodeserverURI -> RepoInfo -> Cli ()
HC.uploadHistoryComments Hash32
causalHash CodeserverURI
codeserverURI (Text -> RepoInfo
Share.RepoInfo Text
remoteTarget)
  let ProjectAndBranch ProjectName
projectName ProjectBranchName
branchName = ProjectAndBranch ProjectName ProjectBranchName
remoteBranch
  Output -> Cli ()
Cli.respond ((URI, ProjectName, ProjectBranchName) -> Output
ViewOnShare (URI
Share.hardCodedUri, ProjectName
projectName, ProjectBranchName
branchName))

------------------------------------------------------------------------------------------------------------------------
-- After upload actions
--
-- Depending on the state of the local and remote projects, we may need to do one of a few different things after
-- uploading entities:
--
--   - Create a remote project, then create a remote branch
--   - Create a remote branch
--   - Fast-forward a remote branch
--   - Force-push a remote branch (not here yet)

-- An action to call after a successful upload.
type AfterUploadAction = Cli ()

-- An after-upload action that creates a remote branch.
--
-- Precondition: the remote project exists, but the remote branch doesn't.
createBranchAfterUploadAction ::
  WhatAreWePushing ->
  Bool ->
  Hash32 ->
  ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName ->
  AfterUploadAction
createBranchAfterUploadAction :: WhatAreWePushing
-> Bool
-> Hash32
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
-> Cli ()
createBranchAfterUploadAction WhatAreWePushing
pushing Bool
justCreatedProject Hash32
localBranchHead ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName
remoteProjectAndBranch = do
  let remoteProjectId :: RemoteProjectId
remoteProjectId = ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName
remoteProjectAndBranch ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName
-> Getting
     RemoteProjectId
     (ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName)
     RemoteProjectId
-> RemoteProjectId
forall s a. s -> Getting a s a -> a
^. ((RemoteProjectId, ProjectName)
 -> Const RemoteProjectId (RemoteProjectId, ProjectName))
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
-> Const
     RemoteProjectId
     (ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName)
#project (((RemoteProjectId, ProjectName)
  -> Const RemoteProjectId (RemoteProjectId, ProjectName))
 -> ProjectAndBranch
      (RemoteProjectId, ProjectName) ProjectBranchName
 -> Const
      RemoteProjectId
      (ProjectAndBranch
         (RemoteProjectId, ProjectName) ProjectBranchName))
-> ((RemoteProjectId -> Const RemoteProjectId RemoteProjectId)
    -> (RemoteProjectId, ProjectName)
    -> Const RemoteProjectId (RemoteProjectId, ProjectName))
-> Getting
     RemoteProjectId
     (ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName)
     RemoteProjectId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RemoteProjectId -> Const RemoteProjectId RemoteProjectId)
-> (RemoteProjectId, ProjectName)
-> Const RemoteProjectId (RemoteProjectId, ProjectName)
forall s t a b. Field1 s t a b => Lens s t a b
Lens
  (RemoteProjectId, ProjectName)
  (RemoteProjectId, ProjectName)
  RemoteProjectId
  RemoteProjectId
_1
  let remoteBranchName :: ProjectBranchName
remoteBranchName = ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName
remoteProjectAndBranch ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName
-> Getting
     ProjectBranchName
     (ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName)
     ProjectBranchName
-> ProjectBranchName
forall s a. s -> Getting a s a -> a
^. Getting
  ProjectBranchName
  (ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName)
  ProjectBranchName
#branch
  branchMergeTarget <-
    MaybeT Cli ProjectBranchIds -> Cli (Maybe ProjectBranchIds)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
      ProjectAndBranch localProject localBranch <-
        case WhatAreWePushing
pushing of
          PushingProjectBranch ProjectAndBranch Project ProjectBranch
localProjectAndBranch -> ProjectAndBranch Project ProjectBranch
-> MaybeT Cli (ProjectAndBranch Project ProjectBranch)
forall a. a -> MaybeT Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectAndBranch Project ProjectBranch
localProjectAndBranch
          WhatAreWePushing
PushingLooseCode -> MaybeT Cli (ProjectAndBranch Project ProjectBranch)
forall a. MaybeT Cli a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      (mergeTargetProjectId, mergeTargetBranchId) <-
        MaybeT $
          Cli.runTransaction do
            Queries.loadDefaultMergeTargetForLocalProjectBranch
              (localProject ^. #projectId)
              Share.hardCodedUri
              (localBranch ^. #branchId)
      pure $
        Share.API.ProjectBranchIds
          (unRemoteProjectId mergeTargetProjectId)
          (unRemoteProjectBranchId mergeTargetBranchId)
  let createProjectBranchRequest =
        Share.API.CreateProjectBranchRequest
          { projectId :: Text
projectId = RemoteProjectId -> Text
unRemoteProjectId RemoteProjectId
remoteProjectId,
            branchName :: Text
branchName = forall target source. From source target => source -> target
into @Text ProjectBranchName
remoteBranchName,
            branchCausalHash :: Hash32
branchCausalHash = Hash32
localBranchHead,
            Maybe ProjectBranchIds
branchMergeTarget :: Maybe ProjectBranchIds
branchMergeTarget :: Maybe ProjectBranchIds
branchMergeTarget
          }
  remoteBranch <-
    Share.createProjectBranch createProjectBranchRequest & onNothingM do
      Cli.returnEarly $
        Output.RemoteProjectDoesntExist Share.hardCodedUri (remoteProjectAndBranch ^. #project . _2)
  Cli.respond
    if justCreatedProject
      then Output.CreatedRemoteProject Share.hardCodedUri (over #project snd remoteProjectAndBranch)
      else Output.CreatedRemoteProjectBranch Share.hardCodedUri (over #project snd remoteProjectAndBranch)
  case pushing of
    WhatAreWePushing
PushingLooseCode -> () -> Cli ()
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    PushingProjectBranch (ProjectAndBranch Project
localProject ProjectBranch
localBranch) ->
      Transaction () -> Cli ()
forall a. Transaction a -> Cli a
Cli.runTransaction do
        -- If the local branch has no associated remote then we
        -- associate this newly created branch.
        ProjectId
-> ProjectBranchId
-> RemoteProjectId
-> URI
-> RemoteProjectBranchId
-> Transaction ()
Queries.ensureBranchRemoteMapping
          (Project
localProject Project -> Getting ProjectId Project ProjectId -> ProjectId
forall s a. s -> Getting a s a -> a
^. Getting ProjectId Project ProjectId
#projectId)
          (ProjectBranch
localBranch ProjectBranch
-> Getting ProjectBranchId ProjectBranch ProjectBranchId
-> ProjectBranchId
forall s a. s -> Getting a s a -> a
^. Getting ProjectBranchId ProjectBranch ProjectBranchId
#branchId)
          (RemoteProjectBranch
remoteBranch RemoteProjectBranch
-> Getting RemoteProjectId RemoteProjectBranch RemoteProjectId
-> RemoteProjectId
forall s a. s -> Getting a s a -> a
^. Getting RemoteProjectId RemoteProjectBranch RemoteProjectId
#projectId)
          URI
Share.hardCodedUri
          (RemoteProjectBranch
remoteBranch RemoteProjectBranch
-> Getting
     RemoteProjectBranchId RemoteProjectBranch RemoteProjectBranchId
-> RemoteProjectBranchId
forall s a. s -> Getting a s a -> a
^. Getting
  RemoteProjectBranchId RemoteProjectBranch RemoteProjectBranchId
#branchId)

-- We intend to push to a remote branch.
--
-- There are two last checks to do that may cause this action to short-circuit:
--
--   1. If the remote branch head is equal to the hash we intend to set it to, then there's nothing to upload.
--
--   2. If the remote branch head is ahead of the hash we intend to fast-forward it to, and this isn't a force-push,
--      then we will refuse to push (until we implement some syntax for a force-push).
makeSetHeadAfterUploadAction ::
  Bool ->
  WhatAreWePushing ->
  Hash32 ->
  Share.RemoteProjectBranch ->
  Cli AfterUploadAction
makeSetHeadAfterUploadAction :: Bool
-> WhatAreWePushing
-> Hash32
-> RemoteProjectBranch
-> Cli (Cli ())
makeSetHeadAfterUploadAction Bool
force WhatAreWePushing
pushing Hash32
localBranchHead RemoteProjectBranch
remoteBranch = do
  let remoteProjectAndBranchNames :: ProjectAndBranch ProjectName ProjectBranchName
remoteProjectAndBranchNames = ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch RemoteProjectBranch
remoteBranch.projectName RemoteProjectBranch
remoteBranch.branchName

  Bool -> Cli () -> Cli ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
force) do
    Cli Bool -> Cli () -> Cli ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Transaction Bool -> Cli Bool
forall a. Transaction a -> Cli a
Cli.runTransaction (Hash32 -> Hash32 -> Transaction Bool
wouldNotBeFastForward Hash32
localBranchHead Hash32
remoteBranchHead)) do
      Output -> Cli ()
forall a. Output -> Cli a
Cli.returnEarly (URI -> ProjectAndBranch ProjectName ProjectBranchName -> Output
RemoteProjectBranchHeadMismatch URI
Share.hardCodedUri ProjectAndBranch ProjectName ProjectBranchName
remoteProjectAndBranchNames)

  if
    | Hash32
localBranchHead Hash32 -> Hash32 -> Bool
forall a. Eq a => a -> a -> Bool
== HashJWT -> Hash32
Share.API.hashJWTHash RemoteProjectBranch
remoteBranch.branchHead -> do
        Cli () -> Cli (Cli ())
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Cli () -> Cli (Cli ())) -> Cli () -> Cli (Cli ())
forall a b. (a -> b) -> a -> b
$ () -> Cli ()
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    | Bool
otherwise -> Cli () -> Cli (Cli ())
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure do
        let request :: SetProjectBranchHeadRequest
request =
              Share.API.SetProjectBranchHeadRequest
                { projectId :: Text
projectId = RemoteProjectId -> Text
unRemoteProjectId (RemoteProjectBranch
remoteBranch RemoteProjectBranch
-> Getting RemoteProjectId RemoteProjectBranch RemoteProjectId
-> RemoteProjectId
forall s a. s -> Getting a s a -> a
^. Getting RemoteProjectId RemoteProjectBranch RemoteProjectId
#projectId),
                  branchId :: Text
branchId = RemoteProjectBranchId -> Text
unRemoteProjectBranchId (RemoteProjectBranch
remoteBranch RemoteProjectBranch
-> Getting
     RemoteProjectBranchId RemoteProjectBranch RemoteProjectBranchId
-> RemoteProjectBranchId
forall s a. s -> Getting a s a -> a
^. Getting
  RemoteProjectBranchId RemoteProjectBranch RemoteProjectBranchId
#branchId),
                  branchOldCausalHash :: Maybe Hash32
branchOldCausalHash = Hash32 -> Maybe Hash32
forall a. a -> Maybe a
Just Hash32
remoteBranchHead,
                  branchNewCausalHash :: Hash32
branchNewCausalHash = Hash32
localBranchHead
                }
        let onSuccess :: Cli ()
onSuccess =
              case WhatAreWePushing
pushing of
                WhatAreWePushing
PushingLooseCode -> () -> Cli ()
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
                PushingProjectBranch (ProjectAndBranch Project
localProject ProjectBranch
localBranch) -> do
                  Transaction () -> Cli ()
forall a. Transaction a -> Cli a
Cli.runTransaction do
                    ProjectId
-> ProjectBranchId
-> RemoteProjectId
-> URI
-> RemoteProjectBranchId
-> Transaction ()
Queries.ensureBranchRemoteMapping
                      (Project
localProject Project -> Getting ProjectId Project ProjectId -> ProjectId
forall s a. s -> Getting a s a -> a
^. Getting ProjectId Project ProjectId
#projectId)
                      (ProjectBranch
localBranch ProjectBranch
-> Getting ProjectBranchId ProjectBranch ProjectBranchId
-> ProjectBranchId
forall s a. s -> Getting a s a -> a
^. Getting ProjectBranchId ProjectBranch ProjectBranchId
#branchId)
                      (RemoteProjectBranch
remoteBranch RemoteProjectBranch
-> Getting RemoteProjectId RemoteProjectBranch RemoteProjectId
-> RemoteProjectId
forall s a. s -> Getting a s a -> a
^. Getting RemoteProjectId RemoteProjectBranch RemoteProjectId
#projectId)
                      URI
Share.hardCodedUri
                      (RemoteProjectBranch
remoteBranch RemoteProjectBranch
-> Getting
     RemoteProjectBranchId RemoteProjectBranch RemoteProjectBranchId
-> RemoteProjectBranchId
forall s a. s -> Getting a s a -> a
^. Getting
  RemoteProjectBranchId RemoteProjectBranch RemoteProjectBranchId
#branchId)
        SetProjectBranchHeadRequest -> Cli SetProjectBranchHeadResponse
Share.setProjectBranchHead SetProjectBranchHeadRequest
request Cli SetProjectBranchHeadResponse
-> (SetProjectBranchHeadResponse -> Cli ()) -> Cli ()
forall a b. Cli a -> (a -> Cli b) -> Cli b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          SetProjectBranchHeadResponse
Share.SetProjectBranchHeadResponseSuccess -> Cli ()
onSuccess
          -- Sometimes a different request gets through in between checking the remote head and
          -- executing the check-and-set push, if it managed to set the head to what we wanted
          -- then the goal was achieved and we can consider it a success.
          Share.SetProjectBranchHeadResponseExpectedCausalHashMismatch Hash32
_expected Hash32
actual
            | Hash32
actual Hash32 -> Hash32 -> Bool
forall a. Eq a => a -> a -> Bool
== Hash32
localBranchHead -> Cli ()
onSuccess
          Share.SetProjectBranchHeadResponseExpectedCausalHashMismatch Hash32
_expected Hash32
_actual ->
            Output -> Cli ()
forall a. Output -> Cli a
Cli.returnEarly (URI -> ProjectAndBranch ProjectName ProjectBranchName -> Output
RemoteProjectBranchHeadMismatch URI
Share.hardCodedUri ProjectAndBranch ProjectName ProjectBranchName
remoteProjectAndBranchNames)
          SetProjectBranchHeadResponse
Share.SetProjectBranchHeadResponseNotFound -> do
            Output -> Cli ()
forall a. Output -> Cli a
Cli.returnEarly (URI -> ProjectAndBranch ProjectName ProjectBranchName -> Output
Output.RemoteProjectBranchDoesntExist URI
Share.hardCodedUri ProjectAndBranch ProjectName ProjectBranchName
remoteProjectAndBranchNames)
          SetProjectBranchHeadResponse
Share.SetProjectBranchHeadResponseDeprecatedReleaseIsImmutable -> do
            Output -> Cli ()
forall a. Output -> Cli a
Cli.returnEarly (URI -> ProjectAndBranch ProjectName ProjectBranchName -> Output
Output.RemoteProjectReleaseIsDeprecated URI
Share.hardCodedUri ProjectAndBranch ProjectName ProjectBranchName
remoteProjectAndBranchNames)
          SetProjectBranchHeadResponse
Share.SetProjectBranchHeadResponsePublishedReleaseIsImmutable -> do
            Output -> Cli ()
forall a. Output -> Cli a
Cli.returnEarly (URI -> ProjectAndBranch ProjectName ProjectBranchName -> Output
Output.RemoteProjectPublishedReleaseCannotBeChanged URI
Share.hardCodedUri ProjectAndBranch ProjectName ProjectBranchName
remoteProjectAndBranchNames)
  where
    remoteBranchHead :: Hash32
remoteBranchHead =
      HashJWT -> Hash32
Share.API.hashJWTHash (RemoteProjectBranch
remoteBranch RemoteProjectBranch
-> Getting HashJWT RemoteProjectBranch HashJWT -> HashJWT
forall s a. s -> Getting a s a -> a
^. Getting HashJWT RemoteProjectBranch HashJWT
#branchHead)

-- Provide the given action a callback that displays to the terminal.
withEntitiesUploadedProgressCallback :: ((Int -> IO (), IO Int) -> IO a) -> IO a
withEntitiesUploadedProgressCallback :: forall x. ((Int -> IO (), IO Int) -> IO x) -> IO x
withEntitiesUploadedProgressCallback (Int -> IO (), IO Int) -> IO a
action = do
  entitiesUploadedVar <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
0
  Console.Regions.displayConsoleRegions do
    Console.Regions.withConsoleRegion Console.Regions.Linear \ConsoleRegion
region -> do
      ConsoleRegion -> STM Text -> IO ()
forall v (m :: * -> *).
(ToRegionContent v, LiftRegion m) =>
ConsoleRegion -> v -> m ()
Console.Regions.setConsoleRegion ConsoleRegion
region do
        entitiesUploaded <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
entitiesUploadedVar
        pure $
          "\n  Uploaded "
            <> tShow entitiesUploaded
            <> " entities...\n\n"
      (Int -> IO (), IO Int) -> IO a
action ((\Int
n -> STM () -> IO ()
forall a. STM a -> IO a
atomically (TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Int
entitiesUploadedVar (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n))), TVar Int -> IO Int
forall a. TVar a -> IO a
readTVarIO TVar Int
entitiesUploadedVar)

------------------------------------------------------------------------------------------------------------------------
-- Misc. sqlite queries

-- Resolve project/branch ids to project/branch records.
expectProjectAndBranch ::
  ProjectAndBranch ProjectId ProjectBranchId ->
  Sqlite.Transaction (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
expectProjectAndBranch :: ProjectAndBranch ProjectId ProjectBranchId
-> Transaction (ProjectAndBranch Project ProjectBranch)
expectProjectAndBranch (ProjectAndBranch ProjectId
projectId ProjectBranchId
branchId) =
  Project -> ProjectBranch -> ProjectAndBranch Project ProjectBranch
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch
    (Project
 -> ProjectBranch -> ProjectAndBranch Project ProjectBranch)
-> Transaction Project
-> Transaction
     (ProjectBranch -> ProjectAndBranch Project ProjectBranch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProjectId -> Transaction Project
Queries.expectProject ProjectId
projectId
    Transaction
  (ProjectBranch -> ProjectAndBranch Project ProjectBranch)
-> Transaction ProjectBranch
-> Transaction (ProjectAndBranch Project ProjectBranch)
forall a b. Transaction (a -> b) -> Transaction a -> Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ProjectId -> ProjectBranchId -> Transaction ProjectBranch
Queries.expectProjectBranch ProjectId
projectId ProjectBranchId
branchId

-- Get the causal hash for the given project branch.
expectCausalHashToPush :: ProjectBranch -> Sqlite.Transaction Hash32
expectCausalHashToPush :: ProjectBranch -> Transaction Hash32
expectCausalHashToPush ProjectBranch
pb = do
  CausalHash causalHash <- ProjectId -> ProjectBranchId -> Transaction CausalHash
Operations.expectProjectBranchHead (ProjectBranch
pb ProjectBranch
-> Getting ProjectId ProjectBranch ProjectId -> ProjectId
forall s a. s -> Getting a s a -> a
^. Getting ProjectId ProjectBranch ProjectId
#projectId) (ProjectBranch
pb ProjectBranch
-> Getting ProjectBranchId ProjectBranch ProjectBranchId
-> ProjectBranchId
forall s a. s -> Getting a s a -> a
^. Getting ProjectBranchId ProjectBranch ProjectBranchId
#branchId)
  pure (Hash32.fromHash causalHash)

-- Were we to try to advance `remoteBranchHead` to `localBranchHead`, would it *not* be a fast-forward?
wouldNotBeFastForward :: Hash32 -> Hash32 -> Sqlite.Transaction Bool
wouldNotBeFastForward :: Hash32 -> Hash32 -> Transaction Bool
wouldNotBeFastForward Hash32
localBranchHead Hash32
remoteBranchHead = do
  maybeHashIds <-
    MaybeT Transaction (CausalHashId, CausalHashId)
-> Transaction (Maybe (CausalHashId, CausalHashId))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT Transaction (CausalHashId, CausalHashId)
 -> Transaction (Maybe (CausalHashId, CausalHashId)))
-> MaybeT Transaction (CausalHashId, CausalHashId)
-> Transaction (Maybe (CausalHashId, CausalHashId))
forall a b. (a -> b) -> a -> b
$
      (,)
        (CausalHashId -> CausalHashId -> (CausalHashId, CausalHashId))
-> MaybeT Transaction CausalHashId
-> MaybeT
     Transaction (CausalHashId -> (CausalHashId, CausalHashId))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Transaction (Maybe CausalHashId) -> MaybeT Transaction CausalHashId
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (CausalHash -> Transaction (Maybe CausalHashId)
Queries.loadCausalHashIdByCausalHash (Hash -> CausalHash
CausalHash (Hash32 -> Hash
Hash32.toHash Hash32
localBranchHead)))
        MaybeT Transaction (CausalHashId -> (CausalHashId, CausalHashId))
-> MaybeT Transaction CausalHashId
-> MaybeT Transaction (CausalHashId, CausalHashId)
forall a b.
MaybeT Transaction (a -> b)
-> MaybeT Transaction a -> MaybeT Transaction b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Transaction (Maybe CausalHashId) -> MaybeT Transaction CausalHashId
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (CausalHash -> Transaction (Maybe CausalHashId)
Queries.loadCausalHashIdByCausalHash (Hash -> CausalHash
CausalHash (Hash32 -> Hash
Hash32.toHash Hash32
remoteBranchHead)))
  case maybeHashIds of
    Maybe (CausalHashId, CausalHashId)
Nothing -> Bool -> Transaction Bool
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    Just (CausalHashId
localBranchHead1, CausalHashId
remoteBranchHead1) -> Bool -> Bool
not (Bool -> Bool) -> Transaction Bool -> Transaction Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CausalHashId -> CausalHashId -> Transaction Bool
Queries.before CausalHashId
remoteBranchHead1 CausalHashId
localBranchHead1