Merge pull request #4301 from unisonweb/cp/squashed-pull

Make `pull.without-history` work for Share project branches

unison-cli/src/Unison/Cli/ProjectUtils.hs

@@ -42,6 +42,7 @@ 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.Share.Projects (IncludeSquashedHead)
 import Unison.Cli.Share.Projects qualified as Share
 import Unison.Codebase.Editor.Input (LooseCodeOrProject)
 import Unison.Codebase.Editor.Output (Output (LocalProjectBranchDoesntExist))
@@ -192,10 +193,11 @@ expectRemoteProjectByName remoteProjectName = do
     Cli.returnEarly (Output.RemoteProjectDoesntExist Share.hardCodedUri remoteProjectName)
 
 expectRemoteProjectBranchById ::
+  IncludeSquashedHead ->
   ProjectAndBranch (RemoteProjectId, ProjectName) (RemoteProjectBranchId, ProjectBranchName) ->
   Cli Share.RemoteProjectBranch
-expectRemoteProjectBranchById projectAndBranch = do
-  Share.getProjectBranchById projectAndBranchIds >>= \case
+expectRemoteProjectBranchById includeSquashed projectAndBranch = do
+  Share.getProjectBranchById includeSquashed projectAndBranchIds >>= \case
     Share.GetProjectBranchResponseBranchNotFound -> remoteProjectBranchDoesntExist projectAndBranchNames
     Share.GetProjectBranchResponseProjectNotFound -> remoteProjectBranchDoesntExist projectAndBranchNames
     Share.GetProjectBranchResponseSuccess branch -> pure branch
@@ -204,19 +206,21 @@ expectRemoteProjectBranchById projectAndBranch = do
     projectAndBranchNames = projectAndBranch & over #project snd & over #branch snd
 
 loadRemoteProjectBranchByName ::
+  IncludeSquashedHead ->
   ProjectAndBranch RemoteProjectId ProjectBranchName ->
   Cli (Maybe Share.RemoteProjectBranch)
-loadRemoteProjectBranchByName projectAndBranch =
-  Share.getProjectBranchByName projectAndBranch <&> \case
+loadRemoteProjectBranchByName includeSquashed projectAndBranch =
+  Share.getProjectBranchByName includeSquashed projectAndBranch <&> \case
     Share.GetProjectBranchResponseBranchNotFound -> Nothing
     Share.GetProjectBranchResponseProjectNotFound -> Nothing
     Share.GetProjectBranchResponseSuccess branch -> Just branch
 
 expectRemoteProjectBranchByName ::
+  IncludeSquashedHead ->
   ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName ->
   Cli Share.RemoteProjectBranch
-expectRemoteProjectBranchByName projectAndBranch =
-  Share.getProjectBranchByName (projectAndBranch & over #project fst) >>= \case
+expectRemoteProjectBranchByName includeSquashed projectAndBranch =
+  Share.getProjectBranchByName includeSquashed (projectAndBranch & over #project fst) >>= \case
     Share.GetProjectBranchResponseBranchNotFound -> doesntExist
     Share.GetProjectBranchResponseProjectNotFound -> doesntExist
     Share.GetProjectBranchResponseSuccess branch -> pure branch
@@ -225,19 +229,21 @@ expectRemoteProjectBranchByName projectAndBranch =
       remoteProjectBranchDoesntExist (projectAndBranch & over #project snd)
 
 loadRemoteProjectBranchByNames ::
+  IncludeSquashedHead ->
   ProjectAndBranch ProjectName ProjectBranchName ->
   Cli (Maybe Share.RemoteProjectBranch)
-loadRemoteProjectBranchByNames (ProjectAndBranch projectName branchName) =
+loadRemoteProjectBranchByNames includeSquashed (ProjectAndBranch projectName branchName) =
   runMaybeT do
     project <- MaybeT (Share.getProjectByName projectName)
-    MaybeT (loadRemoteProjectBranchByName (ProjectAndBranch (project ^. #projectId) branchName))
+    MaybeT (loadRemoteProjectBranchByName includeSquashed (ProjectAndBranch (project ^. #projectId) branchName))
 
 expectRemoteProjectBranchByNames ::
+  IncludeSquashedHead ->
   ProjectAndBranch ProjectName ProjectBranchName ->
   Cli Share.RemoteProjectBranch
-expectRemoteProjectBranchByNames (ProjectAndBranch projectName branchName) = do
+expectRemoteProjectBranchByNames includeSquashed (ProjectAndBranch projectName branchName) = do
   project <- expectRemoteProjectByName projectName
-  expectRemoteProjectBranchByName (ProjectAndBranch (project ^. #projectId, project ^. #projectName) branchName)
+  expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (project ^. #projectId, project ^. #projectName) branchName)
 
 -- Expect a remote project branch by a "these names".
 --
@@ -247,21 +253,21 @@ expectRemoteProjectBranchByNames (ProjectAndBranch projectName branchName) = do
 --
 --   If only a branch name is provided, use the current branch's remote mapping (falling back to its parent, etc) to get
 --   the project.
-expectRemoteProjectBranchByTheseNames :: These ProjectName ProjectBranchName -> Cli Share.RemoteProjectBranch
-expectRemoteProjectBranchByTheseNames = \case
+expectRemoteProjectBranchByTheseNames :: IncludeSquashedHead -> These ProjectName ProjectBranchName -> Cli Share.RemoteProjectBranch
+expectRemoteProjectBranchByTheseNames includeSquashed = \case
   This remoteProjectName -> do
     remoteProject <- expectRemoteProjectByName remoteProjectName
     let remoteProjectId = remoteProject ^. #projectId
     let remoteBranchName = unsafeFrom @Text "main"
-    expectRemoteProjectBranchByName (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
+    expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
   That branchName -> do
     (ProjectAndBranch localProject localBranch, _restPath) <- expectCurrentProjectBranch
     let localProjectId = localProject ^. #projectId
     let localBranchId = localBranch ^. #branchId
     Cli.runTransaction (Queries.loadRemoteProjectBranch localProjectId Share.hardCodedUri localBranchId) >>= \case
       Just (remoteProjectId, _maybeProjectBranchId) -> do
         remoteProjectName <- Cli.runTransaction (Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri)
-        expectRemoteProjectBranchByName (ProjectAndBranch (remoteProjectId, remoteProjectName) branchName)
+        expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) branchName)
       Nothing -> do
         Cli.returnEarly $
           Output.NoAssociatedRemoteProject
@@ -270,7 +276,7 @@ expectRemoteProjectBranchByTheseNames = \case
   These projectName branchName -> do
     remoteProject <- expectRemoteProjectByName projectName
     let remoteProjectId = remoteProject ^. #projectId
-    expectRemoteProjectBranchByName (ProjectAndBranch (remoteProjectId, projectName) branchName)
+    expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, projectName) branchName)
 
 remoteProjectBranchDoesntExist :: ProjectAndBranch ProjectName ProjectBranchName -> Cli void
 remoteProjectBranchDoesntExist projectAndBranch =

unison-cli/src/Unison/Cli/Share/Projects.hs

@@ -17,6 +17,7 @@ module Unison.Cli.Share.Projects
     getProjectByName',
     createProject,
     GetProjectBranchResponse (..),
+    IncludeSquashedHead (..),
     getProjectBranchById,
     getProjectBranchByName,
     getProjectBranchByName',
@@ -91,30 +92,39 @@ data GetProjectBranchResponse
   | GetProjectBranchResponseProjectNotFound
   | GetProjectBranchResponseSuccess !RemoteProjectBranch
 
+data IncludeSquashedHead
+  = IncludeSquashedHead
+  | NoSquashedHead
+  deriving (Show, Eq)
+
 -- | Get a project branch by id.
 --
 -- On success, update the `remote_project_branch` table.
-getProjectBranchById :: ProjectAndBranch RemoteProjectId RemoteProjectBranchId -> Cli GetProjectBranchResponse
-getProjectBranchById (ProjectAndBranch (RemoteProjectId projectId) (RemoteProjectBranchId branchId)) = do
-  response <- servantClientToCli (getProjectBranch0 projectId (Just branchId) Nothing) & onLeftM servantClientError
+getProjectBranchById :: IncludeSquashedHead -> ProjectAndBranch RemoteProjectId RemoteProjectBranchId -> Cli GetProjectBranchResponse
+getProjectBranchById includeSquashed (ProjectAndBranch (RemoteProjectId projectId) (RemoteProjectBranchId branchId)) = do
+  let squashed = includeSquashed == IncludeSquashedHead
+  response <- servantClientToCli (getProjectBranch0 projectId (Just branchId) Nothing squashed) & onLeftM servantClientError
   onGetProjectBranchResponse response
 
 -- | Get a project branch by name.
 --
 -- On success, update the `remote_project_branch` table.
-getProjectBranchByName :: ProjectAndBranch RemoteProjectId ProjectBranchName -> Cli GetProjectBranchResponse
-getProjectBranchByName (ProjectAndBranch (RemoteProjectId projectId) branchName) = do
+getProjectBranchByName :: IncludeSquashedHead -> ProjectAndBranch RemoteProjectId ProjectBranchName -> Cli GetProjectBranchResponse
+getProjectBranchByName includeSquashed (ProjectAndBranch (RemoteProjectId projectId) branchName) = do
+  let squashed = includeSquashed == IncludeSquashedHead
   response <-
-    servantClientToCli (getProjectBranch0 projectId Nothing (Just (into @Text branchName)))
+    servantClientToCli (getProjectBranch0 projectId Nothing (Just (into @Text branchName)) squashed)
       & onLeftM servantClientError
   onGetProjectBranchResponse response
 
 -- | Variant of 'getProjectBranchByName' that returns servant client errors.
 getProjectBranchByName' ::
+  IncludeSquashedHead ->
   ProjectAndBranch RemoteProjectId ProjectBranchName ->
   Cli (Either Servant.ClientError GetProjectBranchResponse)
-getProjectBranchByName' (ProjectAndBranch (RemoteProjectId projectId) branchName) = do
-  servantClientToCli (getProjectBranch0 projectId Nothing (Just (into @Text branchName))) >>= \case
+getProjectBranchByName' includeSquashed (ProjectAndBranch (RemoteProjectId projectId) branchName) = do
+  let squashed = includeSquashed == IncludeSquashedHead
+  servantClientToCli (getProjectBranch0 projectId Nothing (Just (into @Text branchName)) squashed) >>= \case
     Left err -> pure (Left err)
     Right response -> Right <$> onGetProjectBranchResponse response
 
@@ -197,7 +207,8 @@ onGotProjectBranch branch = do
         projectName,
         branchId,
         branchName,
-        branchHead = branch ^. #branchHead
+        branchHead = branch ^. #branchHead,
+        squashedBranchHead = branch ^. #squashedBranchHead
       }
 
 validateProjectName :: Text -> Cli ProjectName
@@ -250,7 +261,7 @@ servantClientToCli action = do
 
 getProject0 :: Maybe Text -> Maybe Text -> ClientM Share.API.GetProjectResponse
 createProject0 :: Share.API.CreateProjectRequest -> ClientM Share.API.CreateProjectResponse
-getProjectBranch0 :: Text -> Maybe Text -> Maybe Text -> ClientM Share.API.GetProjectBranchResponse
+getProjectBranch0 :: Text -> Maybe Text -> Maybe Text -> Bool -> ClientM Share.API.GetProjectBranchResponse
 createProjectBranch0 :: Share.API.CreateProjectBranchRequest -> ClientM Share.API.CreateProjectBranchResponse
 setProjectBranchHead0 :: Share.API.SetProjectBranchHeadRequest -> ClientM Share.API.SetProjectBranchHeadResponse
 ( getProject0

unison-cli/src/Unison/Cli/Share/Projects/Types.hs

@@ -26,6 +26,8 @@ data RemoteProjectBranch = RemoteProjectBranch
     projectName :: ProjectName,
     branchId :: RemoteProjectBranchId,
     branchName :: ProjectBranchName,
-    branchHead :: Share.API.HashJWT
+    branchHead :: Share.API.HashJWT,
+    -- The hash of the squashed version of the branch head, if it was requested.
+    squashedBranchHead :: Maybe Share.API.HashJWT
   }
   deriving stock (Eq, Show, Generic)

unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs

@@ -45,7 +45,7 @@ data RemoteProjectKey
 handleClone :: ProjectAndBranchNames -> Maybe ProjectAndBranchNames -> Cli ()
 handleClone remoteNames0 maybeLocalNames0 = do
   maybeCurrentProjectBranch <- ProjectUtils.getCurrentProjectBranch
-  resolvedRemoteNames <- resolveRemoteNames maybeCurrentProjectBranch remoteNames0
+  resolvedRemoteNames <- resolveRemoteNames Share.NoSquashedHead maybeCurrentProjectBranch remoteNames0
   localNames1 <- resolveLocalNames maybeCurrentProjectBranch resolvedRemoteNames maybeLocalNames0
   cloneInto localNames1 (resolvedRemoteNames ^. #branch)
 
@@ -82,10 +82,11 @@ data ResolvedRemoteNamesFrom
 --                              project in question, and the "@runar/topic" project does not exist), we'll do that,
 --                              otherwise abort
 resolveRemoteNames ::
+  Share.IncludeSquashedHead ->
   Maybe (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch, Path) ->
   ProjectAndBranchNames ->
   Cli ResolvedRemoteNames
-resolveRemoteNames maybeCurrentProjectBranch = \case
+resolveRemoteNames includeSquashed maybeCurrentProjectBranch = \case
   ProjectAndBranchNames'Ambiguous remoteProjectName remoteBranchName ->
     case maybeCurrentProjectBranch of
       Nothing -> resolveP remoteProjectName
@@ -99,7 +100,7 @@ resolveRemoteNames maybeCurrentProjectBranch = \case
                 -- Fetching these in parallel would be an improvement
                 maybeRemoteProject <- Share.getProjectByName remoteProjectName
                 maybeRemoteBranch <-
-                  Share.getProjectBranchByName (ProjectAndBranch remoteBranchProjectId remoteBranchName) <&> \case
+                  Share.getProjectBranchByName includeSquashed (ProjectAndBranch remoteBranchProjectId remoteBranchName) <&> \case
                     Share.GetProjectBranchResponseBranchNotFound -> Nothing
                     Share.GetProjectBranchResponseProjectNotFound -> Nothing
                     Share.GetProjectBranchResponseSuccess remoteBranch -> Just remoteBranch
@@ -110,6 +111,7 @@ resolveRemoteNames maybeCurrentProjectBranch = \case
                     let remoteBranchName = unsafeFrom @Text "main"
                     remoteBranch <-
                       ProjectUtils.expectRemoteProjectBranchByName
+                        includeSquashed
                         (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
                     pure
                       ResolvedRemoteNames
@@ -158,9 +160,9 @@ resolveRemoteNames maybeCurrentProjectBranch = \case
       case remoteProjectKey of
         RemoteProjectKey'Id remoteProjectId -> do
           remoteProjectName <- Cli.runTransaction (Queries.expectRemoteProjectName remoteProjectId Share.hardCodedUri)
-          ProjectUtils.expectRemoteProjectBranchByName (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
+          ProjectUtils.expectRemoteProjectBranchByName includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName)
         RemoteProjectKey'Name remoteProjectName ->
-          ProjectUtils.expectRemoteProjectBranchByNames (ProjectAndBranch remoteProjectName remoteBranchName)
+          ProjectUtils.expectRemoteProjectBranchByNames includeSquashed (ProjectAndBranch remoteProjectName remoteBranchName)
 
 -- Resolve the local names to an actual local project (which may not exist yet), aborting on nonsense
 -- inputs:

unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs

@@ -108,14 +108,15 @@ projectCreate tryDownloadingBase maybeProjectName = do
             let baseProjectId = baseProject ^. #projectId
             let baseLatestReleaseBranchName = unsafeFrom @Text ("releases/" <> into @Text ver)
             response <-
-              Share.getProjectBranchByName' (ProjectAndBranch baseProjectId baseLatestReleaseBranchName)
+              Share.getProjectBranchByName' Share.NoSquashedHead (ProjectAndBranch baseProjectId baseLatestReleaseBranchName)
                 & onLeftM \_err -> done Nothing
             baseLatestReleaseBranch <-
               case response of
                 Share.GetProjectBranchResponseBranchNotFound -> done Nothing
                 Share.GetProjectBranchResponseProjectNotFound -> done Nothing
                 Share.GetProjectBranchResponseSuccess branch -> pure branch
-            Pull.downloadShareProjectBranch baseLatestReleaseBranch
+            let useSquashed = False
+            Pull.downloadShareProjectBranch useSquashed baseLatestReleaseBranch
             Cli.Env {codebase} <- ask
             baseLatestReleaseBranchObject <-
               liftIO $