-- | @pull@ input handler
module Unison.Codebase.Editor.HandleInput.Pull
  ( handlePull,
  )
where

import Control.Monad.Reader (ask)
import Data.Text qualified as Text
import Data.These
import U.Codebase.Branch qualified as V2.Branch
import U.Codebase.Causal qualified
import U.Codebase.Sqlite.Operations qualified as Operations
import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..))
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite (ProjectBranch (..))
import U.Codebase.Sqlite.Queries qualified as Queries
import Unison.Cli.DownloadUtils
import Unison.Cli.MergeTypes (MergeSource (..))
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 qualified as Codebase
import Unison.Codebase.Branch qualified as Branch
import Unison.Codebase.Editor.HandleInput.Merge2 (AliceMergeInfo (..), BobMergeInfo (..), LcaMergeInfo (..), MergeInfo (..), doMerge)
import Unison.Codebase.Editor.Input
import Unison.Codebase.Editor.Input qualified as Input
import Unison.Codebase.Editor.Output
import Unison.Codebase.Editor.Output qualified as Output
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace (..), printReadRemoteNamespace)
import Unison.Codebase.ProjectPath qualified as PP
import Unison.CommandLine.InputPattern qualified as InputPattern
import Unison.CommandLine.InputPatterns qualified as InputPatterns
import Unison.Prelude
import Unison.Project (ProjectAndBranch (..), ProjectBranchNameOrLatestRelease (..), ProjectName, defaultBranchName)
import Unison.Share.Codeserver qualified as Codeserver
import Unison.Share.HistoryComments qualified as HC
import Unison.Sync.Types (RepoInfo (..))

handlePull :: PullSourceTarget -> PullMode -> Cli ()
handlePull :: PullSourceTarget -> PullMode -> Cli ()
handlePull PullSourceTarget
unresolvedSourceAndTarget PullMode
pullMode = do
  let includeSquashed :: IncludeSquashedHead
includeSquashed = case PullMode
pullMode of
        PullMode
Input.PullWithHistory -> IncludeSquashedHead
Share.NoSquashedHead
        PullMode
Input.PullWithoutHistory -> IncludeSquashedHead
Share.IncludeSquashedHead

  (source, target) <- IncludeSquashedHead
-> PullSourceTarget
-> Cli
     (ReadRemoteNamespace RemoteProjectBranch,
      ProjectAndBranch Project ProjectBranch)
resolveSourceAndTarget IncludeSquashedHead
includeSquashed PullSourceTarget
unresolvedSourceAndTarget

  remoteCausalHash <- do
    case source of
      ReadShare'LooseCode ReadShareLooseCode
repo -> ReadShareLooseCode -> Cli (Either ShareError CausalHash)
downloadLooseCodeFromShare ReadShareLooseCode
repo Cli (Either ShareError CausalHash)
-> (Cli (Either ShareError CausalHash) -> Cli CausalHash)
-> Cli CausalHash
forall a b. a -> (a -> b) -> b
& (ShareError -> Cli CausalHash)
-> Cli (Either ShareError CausalHash) -> Cli CausalHash
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
onLeftM (Output -> Cli CausalHash
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli CausalHash)
-> (ShareError -> Output) -> ShareError -> Cli CausalHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShareError -> Output
Output.ShareError)
      ReadShare'ProjectBranch RemoteProjectBranch
remoteBranch -> do
        result <-
          HasCallStack =>
IncludeSquashedHead
-> RemoteProjectBranch
-> Bool
-> Cli (Either ShareError CausalHash)
IncludeSquashedHead
-> RemoteProjectBranch
-> Bool
-> Cli (Either ShareError CausalHash)
downloadProjectBranchFromShare
            ( case PullMode
pullMode of
                PullMode
Input.PullWithHistory -> IncludeSquashedHead
Share.NoSquashedHead
                PullMode
Input.PullWithoutHistory -> IncludeSquashedHead
Share.IncludeSquashedHead
            )
            RemoteProjectBranch
remoteBranch
            Bool
True
            Cli (Either ShareError CausalHash)
-> (Cli (Either ShareError CausalHash) -> Cli CausalHash)
-> Cli CausalHash
forall a b. a -> (a -> b) -> b
& (ShareError -> Cli CausalHash)
-> Cli (Either ShareError CausalHash) -> Cli CausalHash
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
onLeftM
              (Output -> Cli CausalHash
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli CausalHash)
-> (ShareError -> Output) -> ShareError -> Cli CausalHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ShareError -> Output
Output.ShareError)
        HC.downloadHistoryComments
          Codeserver.defaultCodeserver
          (RepoInfo $ into @Text $ ProjectAndBranch remoteBranch.projectName remoteBranch.branchName)
        pure result

  remoteBranchIsEmpty <-
    Cli.runTransaction do
      causal <- Operations.expectCausalBranchByCausalHash remoteCausalHash
      branch <- causal.value
      V2.Branch.isEmpty branch

  when remoteBranchIsEmpty (Cli.respond (PulledEmptyBranch source))

  let targetProjectPath = ProjectAndBranch Project ProjectBranch -> ProjectPath
PP.projectBranchRoot (Project -> ProjectBranch -> ProjectAndBranch Project ProjectBranch
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch ProjectAndBranch Project ProjectBranch
target.project ProjectAndBranch Project ProjectBranch
target.branch)

  let description =
        [Text] -> Text
Text.unwords
          [ String -> Text
Text.pack (String -> Text)
-> (InputPattern -> String) -> InputPattern -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. InputPattern -> String
InputPattern.patternName (InputPattern -> Text) -> InputPattern -> Text
forall a b. (a -> b) -> a -> b
$
              case PullMode
pullMode of
                PullMode
PullWithoutHistory -> InputPattern
InputPatterns.pullWithoutHistory
                PullMode
PullWithHistory -> InputPattern
InputPatterns.pull,
            (RemoteProjectBranch -> Text)
-> ReadRemoteNamespace RemoteProjectBranch -> Text
forall a. (a -> Text) -> ReadRemoteNamespace a -> Text
printReadRemoteNamespace (\RemoteProjectBranch
remoteBranch -> forall target source. From source target => source -> target
into @Text (ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch RemoteProjectBranch
remoteBranch.projectName RemoteProjectBranch
remoteBranch.branchName)) ReadRemoteNamespace RemoteProjectBranch
source,
            case ProjectAndBranch Project ProjectBranch
target of
              ProjectAndBranch Project
project ProjectBranch
branch -> forall target source. From source target => source -> target
into @Text (ProjectName
-> ProjectBranchName
-> ProjectAndBranch ProjectName ProjectBranchName
forall a b. a -> b -> ProjectAndBranch a b
ProjectAndBranch Project
project.name ProjectBranch
branch.name)
          ]

  case pullMode of
    PullMode
Input.PullWithHistory -> do
      targetBranch <- ProjectPath -> Cli (Branch IO)
Cli.getBranchFromProjectPath ProjectPath
targetProjectPath

      if Branch.isEmpty0 $ Branch.head targetBranch
        then do
          Cli.Env {codebase} <- ask
          remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash)
          void $ Cli.updateAtM description targetProjectPath (const $ pure remoteBranchObject)
          Cli.respond $ MergeOverEmpty target
        else do
          let aliceCausalHash = Branch IO -> CausalHash
forall (m :: * -> *). Branch m -> CausalHash
Branch.headHash Branch IO
targetBranch
          lcaCausalHash <- Cli.runTransaction (Operations.lca aliceCausalHash remoteCausalHash)

          doMerge
            MergeInfo
              { alice =
                  AliceMergeInfo
                    { causalHash = aliceCausalHash,
                      projectAndBranch = target
                    },
                bob =
                  BobMergeInfo
                    { causalHash = remoteCausalHash,
                      source =
                        case source of
                          ReadShare'ProjectBranch RemoteProjectBranch
remoteBranch -> RemoteProjectBranch -> MergeSource
MergeSource'RemoteProjectBranch RemoteProjectBranch
remoteBranch
                          ReadShare'LooseCode ReadShareLooseCode
info -> ReadShareLooseCode -> MergeSource
MergeSource'RemoteLooseCode ReadShareLooseCode
info
                    },
                lca =
                  LcaMergeInfo
                    { causalHash = lcaCausalHash
                    },
                description
              }
    PullMode
Input.PullWithoutHistory -> do
      Cli.Env {codebase} <- Cli Env
forall r (m :: * -> *). MonadReader r m => m r
ask
      remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase remoteCausalHash)

      didUpdate <-
        Cli.updateAtM
          description
          targetProjectPath
          (\Branch IO
targetBranchObject -> Branch IO -> Cli (Branch IO)
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Branch IO -> Cli (Branch IO)) -> Branch IO -> Cli (Branch IO)
forall a b. (a -> b) -> a -> b
$ Branch IO
remoteBranchObject Branch IO -> Branch IO -> Branch IO
forall (m :: * -> *). Monad m => Branch m -> Branch m -> Branch m
`Branch.consBranchSnapshot` Branch IO
targetBranchObject)

      Cli.respond
        if didUpdate
          then PullSuccessful source target
          else PullAlreadyUpToDate source target

resolveSourceAndTarget ::
  Share.IncludeSquashedHead ->
  PullSourceTarget ->
  Cli
    ( ReadRemoteNamespace Share.RemoteProjectBranch,
      ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch
    )
resolveSourceAndTarget :: IncludeSquashedHead
-> PullSourceTarget
-> Cli
     (ReadRemoteNamespace RemoteProjectBranch,
      ProjectAndBranch Project ProjectBranch)
resolveSourceAndTarget IncludeSquashedHead
includeSquashed = \case
  PullSourceTarget
Input.PullSourceTarget0 -> (ReadRemoteNamespace RemoteProjectBranch
 -> ProjectAndBranch Project ProjectBranch
 -> (ReadRemoteNamespace RemoteProjectBranch,
     ProjectAndBranch Project ProjectBranch))
-> Cli (ReadRemoteNamespace RemoteProjectBranch)
-> Cli (ProjectAndBranch Project ProjectBranch)
-> Cli
     (ReadRemoteNamespace RemoteProjectBranch,
      ProjectAndBranch Project ProjectBranch)
forall a b c. (a -> b -> c) -> Cli a -> Cli b -> Cli c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (IncludeSquashedHead
-> Cli (ReadRemoteNamespace RemoteProjectBranch)
resolveImplicitSource IncludeSquashedHead
includeSquashed) Cli (ProjectAndBranch Project ProjectBranch)
resolveImplicitTarget
  Input.PullSourceTarget1 ReadRemoteNamespace
  (These ProjectName ProjectBranchNameOrLatestRelease)
source -> (ReadRemoteNamespace RemoteProjectBranch
 -> ProjectAndBranch Project ProjectBranch
 -> (ReadRemoteNamespace RemoteProjectBranch,
     ProjectAndBranch Project ProjectBranch))
-> Cli (ReadRemoteNamespace RemoteProjectBranch)
-> Cli (ProjectAndBranch Project ProjectBranch)
-> Cli
     (ReadRemoteNamespace RemoteProjectBranch,
      ProjectAndBranch Project ProjectBranch)
forall a b c. (a -> b -> c) -> Cli a -> Cli b -> Cli c
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) (IncludeSquashedHead
-> ReadRemoteNamespace
     (These ProjectName ProjectBranchNameOrLatestRelease)
-> Cli (ReadRemoteNamespace RemoteProjectBranch)
resolveExplicitSource IncludeSquashedHead
includeSquashed ReadRemoteNamespace
  (These ProjectName ProjectBranchNameOrLatestRelease)
source) Cli (ProjectAndBranch Project ProjectBranch)
resolveImplicitTarget
  Input.PullSourceTarget2 ReadRemoteNamespace
  (These ProjectName ProjectBranchNameOrLatestRelease)
source0 ProjectAndBranch (Maybe ProjectName) ProjectBranchName
target0 -> do
    source <- IncludeSquashedHead
-> ReadRemoteNamespace
     (These ProjectName ProjectBranchNameOrLatestRelease)
-> Cli (ReadRemoteNamespace RemoteProjectBranch)
resolveExplicitSource IncludeSquashedHead
includeSquashed ReadRemoteNamespace
  (These ProjectName ProjectBranchNameOrLatestRelease)
source0
    maybeTarget <-
      ProjectUtils.getProjectAndBranchByTheseNames case target0 of
        ProjectAndBranch Maybe ProjectName
Nothing ProjectBranchName
branch -> ProjectBranchName -> These ProjectName ProjectBranchName
forall a b. b -> These a b
That ProjectBranchName
branch
        ProjectAndBranch (Just ProjectName
project) ProjectBranchName
branch -> ProjectName
-> ProjectBranchName -> These ProjectName ProjectBranchName
forall a b. a -> b -> These a b
These ProjectName
project ProjectBranchName
branch
    target <- maybeTarget & onNothing (Cli.returnEarly (Output.PullIntoMissingBranch source target0))
    pure (source, target)

resolveImplicitSource :: Share.IncludeSquashedHead -> Cli (ReadRemoteNamespace Share.RemoteProjectBranch)
resolveImplicitSource :: IncludeSquashedHead
-> Cli (ReadRemoteNamespace RemoteProjectBranch)
resolveImplicitSource IncludeSquashedHead
includeSquashed = do
  pp <- Cli ProjectPath
Cli.getCurrentProjectPath
  let localProjectAndBranch = ProjectPath -> ProjectAndBranch Project ProjectBranch
forall p b. ProjectPathG p b -> ProjectAndBranch p b
PP.toProjectAndBranch ProjectPath
pp
  (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName) <-
    Cli.runTransactionWithRollback \forall void. Output -> Transaction void
rollback -> do
      let localProjectId :: ProjectId
localProjectId = ProjectAndBranch Project ProjectBranch
localProjectAndBranch.project.projectId
      let localBranchId :: ProjectBranchId
localBranchId = ProjectAndBranch Project ProjectBranch
localProjectAndBranch.branch.branchId
      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
         (RemoteProjectId, ProjectName, RemoteProjectBranchId,
          ProjectBranchName))
-> Transaction
     (RemoteProjectId, ProjectName, 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
        Just (RemoteProjectId
remoteProjectId, Just RemoteProjectBranchId
remoteBranchId) -> do
          remoteProjectName <- RemoteProjectId -> URI -> Transaction ProjectName
Queries.expectRemoteProjectName RemoteProjectId
remoteProjectId URI
Share.hardCodedUri
          remoteBranchName <-
            Queries.expectRemoteProjectBranchName
              Share.hardCodedUri
              remoteProjectId
              remoteBranchId
          pure (remoteProjectId, remoteProjectName, remoteBranchId, remoteBranchName)
        Maybe (RemoteProjectId, Maybe RemoteProjectBranchId)
_ -> Output
-> Transaction
     (RemoteProjectId, ProjectName, RemoteProjectBranchId,
      ProjectBranchName)
forall void. Output -> Transaction void
rollback (URI -> ProjectAndBranch Project ProjectBranch -> Output
Output.NoAssociatedRemoteProjectBranch URI
Share.hardCodedUri ProjectAndBranch Project ProjectBranch
localProjectAndBranch)
  remoteBranch <-
    ProjectUtils.expectRemoteProjectBranchById includeSquashed $
      ProjectAndBranch
        (remoteProjectId, remoteProjectName)
        (remoteBranchId, remoteBranchName)
  pure (ReadShare'ProjectBranch remoteBranch)

resolveExplicitSource ::
  Share.IncludeSquashedHead ->
  ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease) ->
  Cli (ReadRemoteNamespace Share.RemoteProjectBranch)
resolveExplicitSource :: IncludeSquashedHead
-> ReadRemoteNamespace
     (These ProjectName ProjectBranchNameOrLatestRelease)
-> Cli (ReadRemoteNamespace RemoteProjectBranch)
resolveExplicitSource IncludeSquashedHead
includeSquashed = \case
  ReadShare'LooseCode ReadShareLooseCode
namespace -> ReadRemoteNamespace RemoteProjectBranch
-> Cli (ReadRemoteNamespace RemoteProjectBranch)
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ReadShareLooseCode -> ReadRemoteNamespace RemoteProjectBranch
forall a. ReadShareLooseCode -> ReadRemoteNamespace a
ReadShare'LooseCode ReadShareLooseCode
namespace)
  ReadShare'ProjectBranch (This ProjectName
remoteProjectName) -> do
    remoteProject <- ProjectName -> Cli RemoteProject
ProjectUtils.expectRemoteProjectByName ProjectName
remoteProjectName
    let remoteProjectId = RemoteProject
remoteProject.projectId
    let remoteBranchName = ProjectBranchName
defaultBranchName
    remoteProjectBranch <-
      ProjectUtils.expectRemoteProjectBranchByName
        includeSquashed
        (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
    pure (ReadShare'ProjectBranch remoteProjectBranch)
  ReadShare'ProjectBranch (That ProjectBranchNameOrLatestRelease
branchNameOrLatestRelease) -> do
    localProjectAndBranch <- ProjectPath -> ProjectAndBranch Project ProjectBranch
forall p b. ProjectPathG p b -> ProjectAndBranch p b
PP.toProjectAndBranch (ProjectPath -> ProjectAndBranch Project ProjectBranch)
-> Cli ProjectPath -> Cli (ProjectAndBranch Project ProjectBranch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cli ProjectPath
Cli.getCurrentProjectPath
    let localProjectId = ProjectAndBranch Project ProjectBranch
localProjectAndBranch.project.projectId
    let localBranchId = ProjectAndBranch Project ProjectBranch
localProjectAndBranch.branch.branchId
    Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case
      Just (RemoteProjectId
remoteProjectId, Maybe RemoteProjectBranchId
_maybeProjectBranchId) -> do
        remoteProjectName <- Transaction ProjectName -> Cli ProjectName
forall a. Transaction a -> Cli a
Cli.runTransaction (RemoteProjectId -> URI -> Transaction ProjectName
Queries.expectRemoteProjectName RemoteProjectId
remoteProjectId URI
Share.hardCodedUri)
        remoteBranchName <-
          case branchNameOrLatestRelease of
            ProjectBranchNameOrLatestRelease'Name ProjectBranchName
name -> ProjectBranchName -> Cli ProjectBranchName
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectBranchName
name
            ProjectBranchNameOrLatestRelease
ProjectBranchNameOrLatestRelease'LatestRelease -> do
              remoteProject <- RemoteProjectId -> ProjectName -> Cli RemoteProject
ProjectUtils.expectRemoteProjectById RemoteProjectId
remoteProjectId ProjectName
remoteProjectName
              ProjectUtils.expectLatestReleaseBranchName remoteProject
        remoteProjectBranch <-
          ProjectUtils.expectRemoteProjectBranchByName
            includeSquashed
            (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
        pure (ReadShare'ProjectBranch remoteProjectBranch)
      Maybe (RemoteProjectId, Maybe RemoteProjectBranchId)
Nothing -> do
        Output -> Cli (ReadRemoteNamespace RemoteProjectBranch)
forall a. Output -> Cli a
Cli.returnEarly (Output -> Cli (ReadRemoteNamespace RemoteProjectBranch))
-> Output -> Cli (ReadRemoteNamespace RemoteProjectBranch)
forall a b. (a -> b) -> a -> b
$
          URI -> ProjectAndBranch ProjectName ProjectBranchName -> Output
Output.NoAssociatedRemoteProject URI
Share.hardCodedUri (ProjectAndBranch Project ProjectBranch
-> ProjectAndBranch ProjectName ProjectBranchName
ProjectUtils.justTheNames ProjectAndBranch Project ProjectBranch
localProjectAndBranch)
  ReadShare'ProjectBranch (These ProjectName
projectName ProjectBranchNameOrLatestRelease
branchNameOrLatestRelease) -> do
    remoteProject <- ProjectName -> Cli RemoteProject
ProjectUtils.expectRemoteProjectByName ProjectName
projectName
    let remoteProjectId = RemoteProject
remoteProject.projectId
    branchName <-
      case branchNameOrLatestRelease of
        ProjectBranchNameOrLatestRelease'Name ProjectBranchName
name -> ProjectBranchName -> Cli ProjectBranchName
forall a. a -> Cli a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ProjectBranchName
name
        ProjectBranchNameOrLatestRelease
ProjectBranchNameOrLatestRelease'LatestRelease -> RemoteProject -> Cli ProjectBranchName
ProjectUtils.expectLatestReleaseBranchName RemoteProject
remoteProject
    remoteProjectBranch <-
      ProjectUtils.expectRemoteProjectBranchByName
        includeSquashed
        (ProjectAndBranch (remoteProjectId, projectName) branchName)
    pure (ReadShare'ProjectBranch remoteProjectBranch)

resolveImplicitTarget :: Cli (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch)
resolveImplicitTarget :: Cli (ProjectAndBranch Project ProjectBranch)
resolveImplicitTarget = do
  ProjectPath -> ProjectAndBranch Project ProjectBranch
forall p b. ProjectPathG p b -> ProjectAndBranch p b
PP.toProjectAndBranch (ProjectPath -> ProjectAndBranch Project ProjectBranch)
-> Cli ProjectPath -> Cli (ProjectAndBranch Project ProjectBranch)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Cli ProjectPath
Cli.getCurrentProjectPath