diff --git a/unison-cli/src/Unison/Cli/ProjectUtils.hs b/unison-cli/src/Unison/Cli/ProjectUtils.hs index f2bbc38bfc..aa2c839efe 100644 --- a/unison-cli/src/Unison/Cli/ProjectUtils.hs +++ b/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,13 +253,13 @@ 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 @@ -261,7 +267,7 @@ expectRemoteProjectBranchByTheseNames = \case 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 = diff --git a/unison-cli/src/Unison/Cli/Share/Projects.hs b/unison-cli/src/Unison/Cli/Share/Projects.hs index fd000bf36a..0318e30824 100644 --- a/unison-cli/src/Unison/Cli/Share/Projects.hs +++ b/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 diff --git a/unison-cli/src/Unison/Cli/Share/Projects/Types.hs b/unison-cli/src/Unison/Cli/Share/Projects/Types.hs index 6992004139..3d2bd7e074 100644 --- a/unison-cli/src/Unison/Cli/Share/Projects/Types.hs +++ b/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) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs index 56d6f605c1..dc6733ae65 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs +++ b/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: diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs index 3fbf7ba554..094234e73b 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs +++ b/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 $ diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index fc08e10be4..4ca8abfb5c 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -53,6 +53,7 @@ import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName)) import Unison.NameSegment (NameSegment (..)) import Unison.Prelude import Unison.Project (ProjectAndBranch (..), ProjectBranchNameOrLatestRelease (..), ProjectName) +import Unison.Share.API.Hash (HashJWT) import Unison.Share.API.Hash qualified as Share import Unison.Share.Codeserver qualified as Codeserver import Unison.Share.Sync qualified as Share @@ -64,7 +65,10 @@ import Witch (unsafeFrom) doPullRemoteBranch :: PullSourceTarget -> SyncMode.SyncMode -> PullMode -> Verbosity.Verbosity -> Cli () doPullRemoteBranch unresolvedSourceAndTarget syncMode pullMode verbosity = do - (source, target) <- resolveSourceAndTarget unresolvedSourceAndTarget + let includeSquashed = case pullMode of + Input.PullWithHistory -> Share.NoSquashedHead + Input.PullWithoutHistory -> Share.IncludeSquashedHead + (source, target) <- resolveSourceAndTarget includeSquashed unresolvedSourceAndTarget remoteBranchObject <- loadRemoteNamespaceIntoMemory syncMode pullMode source when (Branch.isEmpty0 (Branch.head remoteBranchObject)) do Cli.respond (PulledEmptyBranch source) @@ -112,19 +116,20 @@ doPullRemoteBranch unresolvedSourceAndTarget syncMode pullMode verbosity = do else PullAlreadyUpToDate source target resolveSourceAndTarget :: + Share.IncludeSquashedHead -> PullSourceTarget -> Cli ( ReadRemoteNamespace Share.RemoteProjectBranch, Either Path' (ProjectAndBranch Sqlite.Project Sqlite.ProjectBranch) ) -resolveSourceAndTarget = \case - Input.PullSourceTarget0 -> liftA2 (,) resolveImplicitSource resolveImplicitTarget - Input.PullSourceTarget1 source -> liftA2 (,) (resolveExplicitSource source) resolveImplicitTarget +resolveSourceAndTarget includeSquashed = \case + Input.PullSourceTarget0 -> liftA2 (,) (resolveImplicitSource includeSquashed) resolveImplicitTarget + Input.PullSourceTarget1 source -> liftA2 (,) (resolveExplicitSource includeSquashed source) resolveImplicitTarget Input.PullSourceTarget2 source target -> - liftA2 (,) (resolveExplicitSource source) (ProjectUtils.expectLooseCodeOrProjectBranch target) + liftA2 (,) (resolveExplicitSource includeSquashed source) (ProjectUtils.expectLooseCodeOrProjectBranch target) -resolveImplicitSource :: Cli (ReadRemoteNamespace Share.RemoteProjectBranch) -resolveImplicitSource = +resolveImplicitSource :: Share.IncludeSquashedHead -> Cli (ReadRemoteNamespace Share.RemoteProjectBranch) +resolveImplicitSource includeSquashed = ProjectUtils.getCurrentProjectBranch >>= \case Nothing -> RemoteRepo.writeNamespaceToRead <$> resolveConfiguredUrl PushPull.Pull Path.currentPath Just (localProjectAndBranch, _restPath) -> do @@ -146,16 +151,17 @@ resolveImplicitSource = Left $ Output.NoAssociatedRemoteProjectBranch Share.hardCodedUri localProjectAndBranch remoteBranch <- - ProjectUtils.expectRemoteProjectBranchById $ + ProjectUtils.expectRemoteProjectBranchById includeSquashed $ ProjectAndBranch (remoteProjectId, remoteProjectName) (remoteBranchId, remoteBranchName) pure (ReadShare'ProjectBranch remoteBranch) resolveExplicitSource :: + Share.IncludeSquashedHead -> ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease) -> Cli (ReadRemoteNamespace Share.RemoteProjectBranch) -resolveExplicitSource = \case +resolveExplicitSource includeSquashed = \case ReadRemoteNamespaceGit namespace -> pure (ReadRemoteNamespaceGit namespace) ReadShare'LooseCode namespace -> pure (ReadShare'LooseCode namespace) ReadShare'ProjectBranch (This remoteProjectName) -> do @@ -164,6 +170,7 @@ resolveExplicitSource = \case let remoteBranchName = unsafeFrom @Text "main" remoteProjectBranch <- ProjectUtils.expectRemoteProjectBranchByName + includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) pure (ReadShare'ProjectBranch remoteProjectBranch) ReadShare'ProjectBranch (That branchNameOrLatestRelease) -> do @@ -176,6 +183,7 @@ resolveExplicitSource = \case remoteBranchName <- resolveRemoteBranchName remoteProjectName branchNameOrLatestRelease remoteProjectBranch <- ProjectUtils.expectRemoteProjectBranchByName + includeSquashed (ProjectAndBranch (remoteProjectId, remoteProjectName) remoteBranchName) pure (ReadShare'ProjectBranch remoteProjectBranch) Nothing -> do @@ -189,6 +197,7 @@ resolveExplicitSource = \case branchName <- resolveRemoteBranchName projectName branchNameOrLatestRelease remoteProjectBranch <- ProjectUtils.expectRemoteProjectBranchByName + includeSquashed (ProjectAndBranch (remoteProjectId, projectName) branchName) pure (ReadShare'ProjectBranch remoteProjectBranch) where @@ -223,16 +232,21 @@ loadRemoteNamespaceIntoMemory syncMode pullMode remoteNamespace = do Cli.returnEarly (Output.GitError err) ReadShare'LooseCode repo -> loadShareLooseCodeIntoMemory repo ReadShare'ProjectBranch remoteBranch -> do - downloadShareProjectBranch remoteBranch - let causalHash = Common.hash32ToCausalHash (Share.hashJWTHash (remoteBranch ^. #branchHead)) + projectBranchCausalHashJWT <- downloadShareProjectBranch (pullMode == Input.PullWithoutHistory) remoteBranch + let causalHash = Common.hash32ToCausalHash (Share.hashJWTHash projectBranchCausalHashJWT) liftIO (Codebase.expectBranchForHash codebase causalHash) -- | @downloadShareProjectBranch branch@ downloads the given branch. -downloadShareProjectBranch :: Share.RemoteProjectBranch -> Cli () -downloadShareProjectBranch branch = do +downloadShareProjectBranch :: HasCallStack => Bool -> Share.RemoteProjectBranch -> Cli HashJWT +downloadShareProjectBranch useSquashedIfAvailable branch = do + let remoteProjectBranchName = branch ^. #branchName let repoInfo = Share.RepoInfo (into @Text (ProjectAndBranch (branch ^. #projectName) remoteProjectBranchName)) - causalHashJwt = branch ^. #branchHead - remoteProjectBranchName = branch ^. #branchName + causalHashJwt <- + if useSquashedIfAvailable + then case (branch ^. #squashedBranchHead) of + Nothing -> Cli.returnEarly (Output.ShareError ShareExpectedSquashedHead) + Just squashedHead -> pure squashedHead + else pure (branch ^. #branchHead) exists <- Cli.runTransaction (Queries.causalExistsByHash32 (Share.hashJWTHash causalHashJwt)) when (not exists) do (result, numDownloaded) <- @@ -245,6 +259,7 @@ downloadShareProjectBranch branch = do Share.SyncError err -> Output.ShareErrorDownloadEntities err Share.TransportError err -> Output.ShareErrorTransport err Cli.respond (Output.DownloadedEntities numDownloaded) + pure causalHashJwt loadShareLooseCodeIntoMemory :: ReadShareLooseCode -> Cli (Branch IO) loadShareLooseCodeIntoMemory rrn@(ReadShareLooseCode {server, repo, path}) = do diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs index 6fce387a15..9c617de223 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Push.hs @@ -422,7 +422,7 @@ pushProjectBranchToProjectBranch'InferredProject force localProjectAndBranch loc Output.RemoteProjectBranchDoesntExist Share.hardCodedUri (ProjectAndBranch remoteProjectName remoteBranchName) - Share.getProjectBranchById (ProjectAndBranch remoteProjectId remoteBranchId) >>= \case + Share.getProjectBranchById Share.NoSquashedHead (ProjectAndBranch remoteProjectId remoteBranchId) >>= \case Share.GetProjectBranchResponseBranchNotFound -> remoteProjectBranchDoesntExist Share.GetProjectBranchResponseProjectNotFound -> remoteProjectBranchDoesntExist Share.GetProjectBranchResponseSuccess remoteBranch -> do @@ -546,7 +546,7 @@ pushToProjectBranch0 force pushing localBranchHead remoteProjectAndBranch = do } Just remoteProject -> do let remoteProjectId = remoteProject ^. #projectId - Share.getProjectBranchByName (remoteProjectAndBranch & #project .~ remoteProjectId) >>= \case + Share.getProjectBranchByName Share.NoSquashedHead (remoteProjectAndBranch & #project .~ remoteProjectId) >>= \case Share.GetProjectBranchResponseBranchNotFound -> do pure UploadPlan @@ -579,7 +579,7 @@ pushToProjectBranch1 :: ProjectAndBranch (RemoteProjectId, ProjectName) ProjectBranchName -> Cli UploadPlan pushToProjectBranch1 force localProjectAndBranch localBranchHead remoteProjectAndBranch = do - Share.getProjectBranchByName (over #project fst remoteProjectAndBranch) >>= \case + Share.getProjectBranchByName Share.NoSquashedHead (over #project fst remoteProjectAndBranch) >>= \case Share.GetProjectBranchResponseBranchNotFound -> do pure UploadPlan diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index fc18b788ec..8016dd9bb8 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -417,6 +417,7 @@ data ShareError | ShareErrorPull Sync.PullError | ShareErrorTransport Sync.CodeserverTransportError | ShareErrorUploadEntities Share.UploadEntitiesError + | ShareExpectedSquashedHead data HistoryTail = EndOfLog CausalHash diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index c60f8a473d..d47281a4ec 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -2197,6 +2197,7 @@ prettyShareError = ShareErrorPull err -> prettyPullError err ShareErrorTransport err -> prettyTransportError err ShareErrorUploadEntities err -> prettyUploadEntitiesError err + ShareExpectedSquashedHead -> "The server failed to provide a squashed branch head when requested. Please report this as a bug to the Unison team." prettyCheckAndSetPushError :: Share.CheckAndSetPushError -> Pretty prettyCheckAndSetPushError = \case @@ -2786,7 +2787,7 @@ renderEditConflicts ppe Patch {..} = do then "deprecated and also replaced with" else "replaced with" ) - `P.hang` P.lines replacements + `P.hang` P.lines replacements formatTermEdits :: (Reference.TermReference, Set TermEdit.TermEdit) -> Numbered Pretty @@ -2801,7 +2802,7 @@ renderEditConflicts ppe Patch {..} = do then "deprecated and also replaced with" else "replaced with" ) - `P.hang` P.lines replacements + `P.hang` P.lines replacements formatConflict :: Either (Reference, Set TypeEdit.TypeEdit) diff --git a/unison-share-api/src/Unison/Server/Doc/Markdown/Types.hs b/unison-share-api/src/Unison/Server/Doc/Markdown/Types.hs index 435377097c..13856831c9 100644 --- a/unison-share-api/src/Unison/Server/Doc/Markdown/Types.hs +++ b/unison-share-api/src/Unison/Server/Doc/Markdown/Types.hs @@ -4,7 +4,6 @@ import Control.Lens (imap) import Data.Char qualified as Char import Data.Char qualified as Text import Data.Text qualified as Text -import Unison.Debug qualified as Debug import Unison.Prelude -- | Custom type for converting Docs into Markdown. @@ -40,7 +39,7 @@ toText = toText' . Paragraph where toText' :: Markdown -> Text toText' = - Debug.debug Debug.Temp "Markdown" >>> \case + \case ThematicBreak -> "\n---" Paragraph m -> flattenParagraph m BlockQuote m -> "> " <> flattenParagraph m diff --git a/unison-share-projects-api/src/Unison/Share/API/Projects.hs b/unison-share-projects-api/src/Unison/Share/API/Projects.hs index 649e95af23..86dae3cf35 100644 --- a/unison-share-projects-api/src/Unison/Share/API/Projects.hs +++ b/unison-share-projects-api/src/Unison/Share/API/Projects.hs @@ -150,6 +150,7 @@ type GetProjectBranchAPI = :> QueryParam' '[Required, Strict] "projectId" Text :> QueryParam "branchId" Text :> QueryParam "branchName" Text + :> QueryFlag "includeSquashed" -- If set, include the squashed branch head in the response :> Verb 'GET 200 '[JSON] GetProjectBranchResponse -- | @GET /project-branch@ response. @@ -364,7 +365,8 @@ data ProjectBranch = ProjectBranch projectName :: Text, branchId :: Text, branchName :: Text, - branchHead :: HashJWT + branchHead :: HashJWT, + squashedBranchHead :: Maybe HashJWT } deriving stock (Eq, Show, Generic) @@ -376,16 +378,18 @@ instance FromJSON ProjectBranch where branchId <- parseField o "branch-id" branchName <- parseField o "branch-name" branchHead <- parseField o "branch-head" + squashedBranchHead <- o .:? "squashed-branch-head" pure ProjectBranch {..} instance ToJSON ProjectBranch where - toJSON (ProjectBranch projectId projectName branchId branchName branchHead) = + toJSON (ProjectBranch projectId projectName branchId branchName branchHead squashedBranchHead) = object [ "project-id" .= projectId, "project-name" .= projectName, "branch-id" .= branchId, "branch-name" .= branchName, - "branch-head" .= branchHead + "branch-head" .= branchHead, + "squashed-branch-head" .= squashedBranchHead ] -- | A project id and branch id.