-- | @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 Text.Builder 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,
    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.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
import Witch (unsafeFrom)

-- | Handle a @push@ command.
handlePushRemoteBranch :: PushRemoteBranchInput -> Cli ()
handlePushRemoteBranch :: PushRemoteBranchInput -> Cli ()
handlePushRemoteBranch PushRemoteBranchInput {PushSourceTarget
sourceTarget :: PushSourceTarget
$sel:sourceTarget:PushRemoteBranchInput :: PushRemoteBranchInput -> PushSourceTarget
sourceTarget, PushBehavior
pushBehavior :: PushBehavior
$sel:pushBehavior:PushRemoteBranchInput :: PushRemoteBranchInput -> PushBehavior
pushBehavior} = do
  case PushSourceTarget
sourceTarget of
    -- push <implicit> to <implicit>
    PushSourceTarget
PushSourceTarget0 -> do
      ProjectAndBranch Project ProjectBranch
localProjectAndBranch <- Cli (ProjectAndBranch Project ProjectBranch)
Cli.getCurrentProjectAndBranch
      Bool
-> ProjectAndBranch Project ProjectBranch
-> Maybe (These ProjectName ProjectBranchName)
-> Cli ()
pushProjectBranchToProjectBranch Bool
force ProjectAndBranch Project ProjectBranch
localProjectAndBranch Maybe (These ProjectName ProjectBranchName)
forall a. Maybe a
Nothing
    -- push <implicit> to .some.path (share)
    -- push <implicit> to @some/project
    PushSourceTarget1 These ProjectName ProjectBranchName
remoteProjectAndBranch0 -> do
      ProjectAndBranch Project ProjectBranch
localProjectAndBranch <- Cli (ProjectAndBranch Project ProjectBranch)
Cli.getCurrentProjectAndBranch
      Bool
-> ProjectAndBranch Project ProjectBranch
-> Maybe (These ProjectName ProjectBranchName)
-> Cli ()
pushProjectBranchToProjectBranch Bool
force ProjectAndBranch Project ProjectBranch
localProjectAndBranch (These ProjectName ProjectBranchName
-> Maybe (These ProjectName ProjectBranchName)
forall a. a -> Maybe a
Just These ProjectName ProjectBranchName
remoteProjectAndBranch0)
    -- push @some/project to @some/project
    PushSourceTarget2 (ProjySource These ProjectName ProjectBranchName
localProjectAndBranch0) These ProjectName ProjectBranchName
remoteProjectAndBranch -> do
      ProjectAndBranch Project ProjectBranch
localProjectAndBranch <- These ProjectName ProjectBranchName
-> Cli (ProjectAndBranch Project ProjectBranch)
ProjectUtils.expectProjectAndBranchByTheseNames These ProjectName ProjectBranchName
localProjectAndBranch0
      Bool
-> ProjectAndBranch Project ProjectBranch
-> Maybe (These ProjectName ProjectBranchName)
-> Cli ()
pushProjectBranchToProjectBranch Bool
force ProjectAndBranch Project ProjectBranch
localProjectAndBranch (These ProjectName ProjectBranchName
-> Maybe (These ProjectName ProjectBranchName)
forall a. a -> Maybe a
Just These ProjectName ProjectBranchName
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
  UserInfo
_ <- CodeserverURI -> Cli UserInfo
AuthLogin.ensureAuthenticatedWithCodeserver CodeserverURI
Codeserver.defaultCodeserver
  let localProjectAndBranchIds :: ProjectAndBranch ProjectId ProjectBranchId
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
  (ProjectAndBranch Project ProjectBranch
localProjectAndBranch, Hash32
localBranchHead) <-
    Transaction (ProjectAndBranch Project ProjectBranch, Hash32)
-> Cli (ProjectAndBranch Project ProjectBranch, Hash32)
forall a. Transaction a -> Cli a
Cli.runTransaction do
      Hash32
hash <- ProjectBranch -> Transaction Hash32
expectCausalHashToPush (ProjectAndBranch Project ProjectBranch
localProjectAndBranch ProjectAndBranch Project ProjectBranch
-> Getting
     ProjectBranch
     (ProjectAndBranch Project ProjectBranch)
     ProjectBranch
-> ProjectBranch
forall s a. s -> Getting a s a -> a
^. Getting
  ProjectBranch
  (ProjectAndBranch Project ProjectBranch)
  ProjectBranch
#branch)
      ProjectAndBranch Project ProjectBranch
localProjectAndBranch <- ProjectAndBranch ProjectId ProjectBranchId
-> Transaction (ProjectAndBranch Project ProjectBranch)
expectProjectAndBranch ProjectAndBranch ProjectId ProjectBranchId
localProjectAndBranchIds
      pure (ProjectAndBranch Project ProjectBranch
localProjectAndBranch, Hash32
hash)

  UploadPlan
uploadPlan <-
    case Maybe (These ProjectName ProjectBranchName)
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)

  UploadPlan -> Cli ()
executeUploadPlan UploadPlan
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
            ProjectName
remoteProjectName <- RemoteProjectId -> URI -> Transaction ProjectName
Queries.expectRemoteProjectName RemoteProjectId
remoteProjectId URI
Share.hardCodedUri
            Maybe (RemoteProjectBranchId, ProjectBranchName)
maybeRemoteBranchInfo <-
              Maybe RemoteProjectBranchId
-> (RemoteProjectBranchId
    -> Transaction (RemoteProjectBranchId, ProjectBranchName))
-> Transaction (Maybe (RemoteProjectBranchId, ProjectBranchName))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for Maybe RemoteProjectBranchId
maybeRemoteBranchId \RemoteProjectBranchId
remoteBranchId -> do
                ProjectBranchName
remoteBranchName <-
                  URI
-> RemoteProjectId
-> RemoteProjectBranchId
-> Transaction ProjectBranchName
Queries.expectRemoteProjectBranchName URI
Share.hardCodedUri RemoteProjectId
remoteProjectId RemoteProjectBranchId
remoteBranchId
                pure (RemoteProjectBranchId
remoteBranchId, ProjectBranchName
remoteBranchName)
            pure ((RemoteProjectId, ProjectName,
 Maybe (RemoteProjectBranchId, ProjectBranchName))
-> Maybe
     (RemoteProjectId, ProjectName,
      Maybe (RemoteProjectBranchId, ProjectBranchName))
forall a. a -> Maybe a
Just (RemoteProjectId
remoteProjectId, ProjectName
remoteProjectName, Maybe (RemoteProjectBranchId, ProjectBranchName)
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
              Text
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 :: ProjectBranchName
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 :: ProjectBranchName
remoteBranchName = Text -> ProjectBranchName -> ProjectBranchName
deriveRemoteBranchName Text
myUserHandle ProjectBranchName
localBranchName
              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)
            -- "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
                  Cli ()
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
                      { $sel:remoteBranch:UploadPlan :: ProjectAndBranch ProjectName ProjectBranchName
remoteBranch = ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch (RemoteProjectBranch
remoteBranch RemoteProjectBranch
-> Getting ProjectName RemoteProjectBranch ProjectName
-> ProjectName
forall s a. s -> Getting a s a -> a
^. Getting ProjectName RemoteProjectBranch ProjectName
#projectName) (RemoteProjectBranch
remoteBranch RemoteProjectBranch
-> Getting ProjectBranchName RemoteProjectBranch ProjectBranchName
-> ProjectBranchName
forall s a. s -> Getting a s a -> a
^. Getting ProjectBranchName RemoteProjectBranch ProjectBranchName
#branchName),
                        $sel:causalHash:UploadPlan :: Hash32
causalHash = Hash32
localBranchHead,
                        Cli ()
afterUploadAction :: Cli ()
$sel:afterUploadAction:UploadPlan :: Cli ()
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
    Text
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 :: ProjectName
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 :: ProjectBranchName
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 :: ProjectName
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 :: ProjectBranchName
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 :: ProjectAndBranch ProjectName ProjectBranchName
remoteProjectAndBranch = ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch 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 ProjectAndBranch ProjectName ProjectBranchName
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
== forall source target.
(HasCallStack, TryFrom source target, Show source, Typeable source,
 Typeable target) =>
source -> target
unsafeFrom @Text Text
"main" -> ProjectBranchName
localBranchName
      | Bool
otherwise ->
          (Text -> ProjectBranchName
UnsafeProjectBranchName (Text -> ProjectBranchName)
-> ([Builder] -> Text) -> [Builder] -> ProjectBranchName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
Text.Builder.run (Builder -> Text) -> ([Builder] -> Builder) -> [Builder] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Builder] -> Builder
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold)
            [ Char -> Builder
Text.Builder.char Char
'@',
              Text -> Builder
Text.Builder.text Text
userHandle,
              Char -> Builder
Text.Builder.char Char
'/',
              Text -> Builder
Text.Builder.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
  Text
_ <-
    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)

  ProjectName -> Cli (Maybe RemoteProject)
Share.getProjectByName ProjectName
remoteProjectName Cli (Maybe RemoteProject)
-> (Maybe RemoteProject -> 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 RemoteProject
Nothing -> do
      RemoteProject
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
          { $sel:remoteBranch:UploadPlan :: ProjectAndBranch ProjectName ProjectBranchName
remoteBranch = ProjectAndBranch ProjectName ProjectBranchName
remoteProjectAndBranch,
            $sel:causalHash:UploadPlan :: Hash32
causalHash = Hash32
localBranchHead,
            $sel:afterUploadAction:UploadPlan :: Cli ()
afterUploadAction =
              WhatAreWePushing
-> Bool
-> Hash32
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
-> Cli ()
createBranchAfterUploadAction
                WhatAreWePushing
pushing
                Bool
True -- just created 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 (RemoteProject
remoteProject RemoteProject
-> Getting RemoteProjectId RemoteProject RemoteProjectId
-> RemoteProjectId
forall s a. s -> Getting a s a -> a
^. Getting RemoteProjectId RemoteProject RemoteProjectId
#projectId,) ProjectAndBranch ProjectName ProjectBranchName
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
              { $sel:remoteBranch:UploadPlan :: ProjectAndBranch ProjectName ProjectBranchName
remoteBranch = ProjectAndBranch ProjectName ProjectBranchName
remoteProjectAndBranch,
                $sel:causalHash:UploadPlan :: Hash32
causalHash = Hash32
localBranchHead,
                $sel:afterUploadAction:UploadPlan :: 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
          Cli ()
afterUploadAction <- Bool
-> WhatAreWePushing
-> Hash32
-> RemoteProjectBranch
-> Cli (Cli ())
makeSetHeadAfterUploadAction Bool
force WhatAreWePushing
pushing Hash32
localBranchHead RemoteProjectBranch
remoteBranch
          pure
            UploadPlan
              { $sel:remoteBranch:UploadPlan :: ProjectAndBranch ProjectName ProjectBranchName
remoteBranch = ProjectAndBranch ProjectName ProjectBranchName
remoteProjectAndBranch,
                $sel:causalHash:UploadPlan :: Hash32
causalHash = Hash32
localBranchHead,
                Cli ()
$sel:afterUploadAction:UploadPlan :: Cli ()
afterUploadAction :: Cli ()
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
          { $sel:remoteBranch:UploadPlan :: 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,
            $sel:causalHash:UploadPlan :: Hash32
causalHash = Hash32
localBranchHead,
            $sel:afterUploadAction:UploadPlan :: 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
      Cli ()
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
          { $sel:remoteBranch:UploadPlan :: 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,
            $sel:causalHash:UploadPlan :: Hash32
causalHash = Hash32
localBranchHead,
            Cli ()
$sel:afterUploadAction:UploadPlan :: Cli ()
afterUploadAction :: Cli ()
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 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
$sel:remoteBranch:UploadPlan :: UploadPlan -> ProjectAndBranch ProjectName ProjectBranchName
remoteBranch :: ProjectAndBranch ProjectName ProjectBranchName
remoteBranch, Hash32
$sel:causalHash:UploadPlan :: UploadPlan -> Hash32
causalHash :: Hash32
causalHash, Cli ()
$sel:afterUploadAction:UploadPlan :: UploadPlan -> Cli ()
afterUploadAction :: Cli ()
afterUploadAction} = do
  (Either (SyncError UploadEntitiesError) ()
uploadResult, Int
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
      Either (SyncError UploadEntitiesError) ()
uploadResult <-
        BaseUrl
-> RepoInfo
-> NESet Hash32
-> (Int -> IO ())
-> Cli (Either (SyncError UploadEntitiesError) ())
Share.uploadEntities
          (CodeserverURI -> BaseUrl
codeserverBaseURL CodeserverURI
Codeserver.defaultCodeserver)
          -- On the wire, the remote branch is encoded as e.g.
          --   { "repo_info": "@unison/base/@arya/topic", ... }
          (Text -> RepoInfo
Share.RepoInfo (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))))
          (Hash32 -> NESet Hash32
forall a. a -> NESet a
Set.NonEmpty.singleton Hash32
causalHash)
          Int -> IO ()
uploadedCallback
      Int
numUploaded <- IO Int -> Cli Int
forall a. IO a -> Cli a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO Int
getNumUploaded
      pure (Either (SyncError UploadEntitiesError) ()
uploadResult, Int
numUploaded)
  Output -> Cli ()
Cli.respond (Int -> Output
Output.UploadedEntities Int
numUploaded)
  Either (SyncError UploadEntitiesError) ()
uploadResult Either (SyncError UploadEntitiesError) ()
-> (Either (SyncError UploadEntitiesError) () -> Cli ()) -> Cli ()
forall a b. a -> (a -> b) -> b
& (SyncError UploadEntitiesError -> Cli ())
-> Either (SyncError UploadEntitiesError) () -> Cli ()
forall (m :: * -> *) a b.
Applicative m =>
(a -> m b) -> Either a b -> m b
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
  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
  Maybe ProjectBranchIds
branchMergeTarget <-
    MaybeT Cli ProjectBranchIds -> Cli (Maybe ProjectBranchIds)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
      ProjectAndBranch Project
localProject ProjectBranch
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
      (RemoteProjectId
mergeTargetProjectId, RemoteProjectBranchId
mergeTargetBranchId) <-
        Cli (Maybe (RemoteProjectId, RemoteProjectBranchId))
-> MaybeT Cli (RemoteProjectId, RemoteProjectBranchId)
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (Cli (Maybe (RemoteProjectId, RemoteProjectBranchId))
 -> MaybeT Cli (RemoteProjectId, RemoteProjectBranchId))
-> Cli (Maybe (RemoteProjectId, RemoteProjectBranchId))
-> MaybeT Cli (RemoteProjectId, RemoteProjectBranchId)
forall a b. (a -> b) -> a -> b
$
          Transaction (Maybe (RemoteProjectId, RemoteProjectBranchId))
-> Cli (Maybe (RemoteProjectId, RemoteProjectBranchId))
forall a. Transaction a -> Cli a
Cli.runTransaction do
            ProjectId
-> URI
-> ProjectBranchId
-> Transaction (Maybe (RemoteProjectId, RemoteProjectBranchId))
Queries.loadDefaultMergeTargetForLocalProjectBranch
              (Project
localProject Project -> Getting ProjectId Project ProjectId -> ProjectId
forall s a. s -> Getting a s a -> a
^. Getting ProjectId Project ProjectId
#projectId)
              URI
Share.hardCodedUri
              (ProjectBranch
localBranch ProjectBranch
-> Getting ProjectBranchId ProjectBranch ProjectBranchId
-> ProjectBranchId
forall s a. s -> Getting a s a -> a
^. Getting ProjectBranchId ProjectBranch ProjectBranchId
#branchId)
      ProjectBranchIds -> MaybeT Cli ProjectBranchIds
forall a. a -> MaybeT Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProjectBranchIds -> MaybeT Cli ProjectBranchIds)
-> ProjectBranchIds -> MaybeT Cli ProjectBranchIds
forall a b. (a -> b) -> a -> b
$
        Text -> Text -> ProjectBranchIds
Share.API.ProjectBranchIds
          (RemoteProjectId -> Text
unRemoteProjectId RemoteProjectId
mergeTargetProjectId)
          (RemoteProjectBranchId -> Text
unRemoteProjectBranchId RemoteProjectBranchId
mergeTargetBranchId)
  let createProjectBranchRequest :: CreateProjectBranchRequest
createProjectBranchRequest =
        Share.API.CreateProjectBranchRequest
          { $sel:projectId:CreateProjectBranchRequest :: Text
projectId = RemoteProjectId -> Text
unRemoteProjectId RemoteProjectId
remoteProjectId,
            $sel:branchName:CreateProjectBranchRequest :: Text
branchName = forall target source. From source target => source -> target
into @Text ProjectBranchName
remoteBranchName,
            $sel:branchCausalHash:CreateProjectBranchRequest :: Hash32
branchCausalHash = Hash32
localBranchHead,
            Maybe ProjectBranchIds
branchMergeTarget :: Maybe ProjectBranchIds
$sel:branchMergeTarget:CreateProjectBranchRequest :: Maybe ProjectBranchIds
branchMergeTarget
          }
  RemoteProjectBranch
remoteBranch <-
    CreateProjectBranchRequest -> Cli (Maybe RemoteProjectBranch)
Share.createProjectBranch CreateProjectBranchRequest
createProjectBranchRequest Cli (Maybe RemoteProjectBranch)
-> (Cli (Maybe RemoteProjectBranch) -> Cli RemoteProjectBranch)
-> Cli RemoteProjectBranch
forall a b. a -> (a -> b) -> b
& Cli RemoteProjectBranch
-> Cli (Maybe RemoteProjectBranch) -> Cli RemoteProjectBranch
forall (m :: * -> *) a. Monad m => m a -> m (Maybe a) -> m a
onNothingM do
      Output -> Cli RemoteProjectBranch
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli RemoteProjectBranch)
-> Output -> Cli RemoteProjectBranch
forall a b. (a -> b) -> a -> b
$
        URI -> ProjectName -> Output
Output.RemoteProjectDoesntExist URI
Share.hardCodedUri (ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName
remoteProjectAndBranch ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName
-> Getting
     ProjectName
     (ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName)
     ProjectName
-> ProjectName
forall s a. s -> Getting a s a -> a
^. ((RemoteProjectId, ProjectName)
 -> Const ProjectName (RemoteProjectId, ProjectName))
-> ProjectAndBranch
     (RemoteProjectId, ProjectName) ProjectBranchName
-> Const
     ProjectName
     (ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName)
#project (((RemoteProjectId, ProjectName)
  -> Const ProjectName (RemoteProjectId, ProjectName))
 -> ProjectAndBranch
      (RemoteProjectId, ProjectName) ProjectBranchName
 -> Const
      ProjectName
      (ProjectAndBranch
         (RemoteProjectId, ProjectName) ProjectBranchName))
-> ((ProjectName -> Const ProjectName ProjectName)
    -> (RemoteProjectId, ProjectName)
    -> Const ProjectName (RemoteProjectId, ProjectName))
-> Getting
     ProjectName
     (ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName)
     ProjectName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ProjectName -> Const ProjectName ProjectName)
-> (RemoteProjectId, ProjectName)
-> Const ProjectName (RemoteProjectId, ProjectName)
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (RemoteProjectId, ProjectName)
  (RemoteProjectId, ProjectName)
  ProjectName
  ProjectName
_2)
  Output -> Cli ()
Cli.respond
    if Bool
justCreatedProject
      then URI -> ProjectAndBranch ProjectName ProjectBranchName -> Output
Output.CreatedRemoteProject 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)
      else URI -> ProjectAndBranch ProjectName ProjectBranchName -> Output
Output.CreatedRemoteProjectBranch 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)
  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) ->
      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 (Hash32
localBranchHead Hash32 -> Hash32 -> Bool
forall a. Eq a => a -> a -> Bool
== HashJWT -> Hash32
Share.API.hashJWTHash RemoteProjectBranch
remoteBranch.branchHead) do
    Output -> Cli ()
Cli.respond (URI -> ProjectAndBranch ProjectName ProjectBranchName -> Output
RemoteProjectBranchIsUpToDate URI
Share.hardCodedUri ProjectAndBranch ProjectName ProjectBranchName
remoteProjectAndBranchNames)
    Output -> Cli ()
forall a. Output -> Cli a
Cli.returnEarly ((URI, ProjectName, ProjectBranchName) -> Output
ViewOnShare (URI
Share.hardCodedUri, 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)

  pure do
    let request :: SetProjectBranchHeadRequest
request =
          Share.API.SetProjectBranchHeadRequest
            { $sel:projectId:SetProjectBranchHeadRequest :: 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),
              $sel:branchId:SetProjectBranchHeadRequest :: 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),
              $sel:branchOldCausalHash:SetProjectBranchHeadRequest :: Maybe Hash32
branchOldCausalHash = Hash32 -> Maybe Hash32
forall a. a -> Maybe a
Just Hash32
remoteBranchHead,
              $sel:branchNewCausalHash:SetProjectBranchHeadRequest :: 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
  TVar Int
entitiesUploadedVar <- Int -> IO (TVar Int)
forall a. a -> IO (TVar a)
newTVarIO Int
0
  IO a -> IO a
forall (m :: * -> *) a. (MonadIO m, MonadMask m) => m a -> m a
Console.Regions.displayConsoleRegions do
    RegionLayout -> (ConsoleRegion -> IO a) -> IO a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
RegionLayout -> (ConsoleRegion -> m a) -> m a
Console.Regions.withConsoleRegion RegionLayout
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
        Int
entitiesUploaded <- TVar Int -> STM Int
forall a. TVar a -> STM a
readTVar TVar Int
entitiesUploadedVar
        pure $
          Text
"\n  Uploaded "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Show a => a -> Text
tShow Int
entitiesUploaded
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" 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 Hash
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)
  Hash32 -> Transaction Hash32
forall a. a -> Transaction a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Hash -> Hash32
Hash32.fromHash Hash
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
  Maybe (CausalHashId, CausalHashId)
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 Maybe (CausalHashId, CausalHashId)
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