From d75f173ab76c533d5a86275e26d663ad7c481f03 Mon Sep 17 00:00:00 2001 From: Chris Penner Date: Tue, 14 Jan 2025 15:43:02 -0800 Subject: [PATCH] Sync to/from file --- .gitignore | 1 + .../U/Codebase/Sqlite/Branch/Format.hs | 3 +- .../U/Codebase/Sqlite/Causal.hs | 1 + .../U/Codebase/Sqlite/Decl/Format.hs | 2 + .../U/Codebase/Sqlite/Entity.hs | 1 + .../U/Codebase/Sqlite/LocalIds.hs | 2 +- .../U/Codebase/Sqlite/Patch/Format.hs | 2 + .../U/Codebase/Sqlite/Term/Format.hs | 2 + .../unison-codebase-sqlite.cabal | 2 +- hie.yaml | 3 + lib/unison-sqlite/src/Unison/Sqlite.hs | 1 + .../src/Unison/Sqlite/Transaction.hs | 9 + parser-typechecker/src/Unison/Codebase.hs | 10 + unison-cli/package.yaml | 6 + unison-cli/src/Unison/Cli/DownloadUtils.hs | 46 +- unison-cli/src/Unison/Cli/MonadUtils.hs | 8 + .../src/Unison/Codebase/Editor/HandleInput.hs | 19 +- .../Codebase/Editor/HandleInput/InstallLib.hs | 2 +- .../Editor/HandleInput/ProjectClone.hs | 4 +- .../Editor/HandleInput/ProjectCreate.hs | 4 +- .../Codebase/Editor/HandleInput/Pull.hs | 1 + .../Codebase/Editor/HandleInput/SyncV2.hs | 76 +++ .../src/Unison/Codebase/Editor/Input.hs | 3 + .../src/Unison/Codebase/Editor/Output.hs | 3 + .../src/Unison/CommandLine/InputPatterns.hs | 118 +++++ .../src/Unison/CommandLine/OutputMessages.hs | 8 + unison-cli/src/Unison/Share/Sync/Types.hs | 2 + unison-cli/src/Unison/Share/SyncV2.hs | 491 ++++++++++++++++++ unison-cli/unison-cli.cabal | 8 + unison-share-api/package.yaml | 16 + unison-share-api/src/Unison/Server/Orphans.hs | 127 +++++ unison-share-api/src/Unison/Sync/Types.hs | 92 +++- unison-share-api/tests/Main.hs | 23 + .../tests/Unison/Test/Sync/Gen.hs | 93 ++++ .../tests/Unison/Test/Sync/Roundtrip.hs | 29 ++ unison-share-api/unison-share-api.cabal | 109 +++- 36 files changed, 1283 insertions(+), 44 deletions(-) create mode 100644 unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs create mode 100644 unison-cli/src/Unison/Share/SyncV2.hs create mode 100644 unison-share-api/tests/Main.hs create mode 100644 unison-share-api/tests/Unison/Test/Sync/Gen.hs create mode 100644 unison-share-api/tests/Unison/Test/Sync/Roundtrip.hs diff --git a/.gitignore b/.gitignore index 9af3e43c04..a2fb3975a1 100644 --- a/.gitignore +++ b/.gitignore @@ -27,6 +27,7 @@ dist-newstyle *.prof.html *.hp *.ps +*.profiterole.* /.direnv/ /.envrc diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Format.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Format.hs index ce07a487fb..2a2300329f 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Format.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Branch/Format.hs @@ -101,7 +101,7 @@ data BranchLocalIds' t d p c = LocalIds branchPatchLookup :: Vector p, branchChildLookup :: Vector c } - deriving (Show) + deriving (Show, Eq) -- | Bytes encoding a LocalBranch newtype LocalBranchBytes = LocalBranchBytes ByteString @@ -110,6 +110,7 @@ newtype LocalBranchBytes = LocalBranchBytes ByteString data SyncBranchFormat' parent text defn patch child = SyncFull (BranchLocalIds' text defn patch child) LocalBranchBytes | SyncDiff parent (BranchLocalIds' text defn patch child) LocalBranchBytes + deriving (Eq, Show) type SyncBranchFormat = SyncBranchFormat' BranchObjectId TextId ObjectId PatchObjectId (BranchObjectId, CausalHashId) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Causal.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Causal.hs index 582bfc65a3..87f532bf25 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Causal.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Causal.hs @@ -22,5 +22,6 @@ data SyncCausalFormat' causalHash valueHash = SyncCausalFormat { valueHash :: valueHash, parents :: Vector causalHash } + deriving stock (Eq, Show) type SyncCausalFormat = SyncCausalFormat' CausalHashId BranchHashId diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs index 5a6f401964..5752d2dd87 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Decl/Format.hs @@ -36,9 +36,11 @@ type SyncDeclFormat = data SyncDeclFormat' t d = SyncDecl (SyncLocallyIndexedComponent' t d) + deriving stock (Eq, Show) newtype SyncLocallyIndexedComponent' t d = SyncLocallyIndexedComponent (Vector (LocalIds' t d, ByteString)) + deriving stock (Eq, Show) -- [OldDecl] ==map==> [NewDecl] ==number==> [(NewDecl, Int)] ==sort==> [(NewDecl, Int)] ==> permutation is map snd of that diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Entity.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Entity.hs index 3b93fd4b16..92cbb58828 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Entity.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Entity.hs @@ -24,6 +24,7 @@ data SyncEntity' text hash defn patch branchh branch causal | N (Namespace.SyncBranchFormat' branch text defn patch (branch, causal)) | P (Patch.SyncPatchFormat' patch text hash defn) | C (Causal.SyncCausalFormat' causal branchh) + deriving stock (Eq, Show) entityType :: SyncEntity' text hash defn patch branchh branch causal -> TempEntityType entityType = \case diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalIds.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalIds.hs index d8645b81ae..f68016de78 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalIds.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/LocalIds.hs @@ -15,7 +15,7 @@ data LocalIds' t h = LocalIds { textLookup :: Vector t, defnLookup :: Vector h } - deriving (Functor, Show) + deriving stock (Functor, Show, Eq) type LocalIds = LocalIds' TextId ObjectId diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs index 7defa50234..452df27904 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs @@ -40,6 +40,7 @@ data PatchLocalIds' t h d = LocalIds patchHashLookup :: Vector h, patchDefnLookup :: Vector d } + deriving stock (Eq, Show) type SyncPatchFormat = SyncPatchFormat' PatchObjectId TextId HashId ObjectId @@ -47,6 +48,7 @@ data SyncPatchFormat' parent text hash defn = SyncFull (PatchLocalIds' text hash defn) ByteString | -- | p is the identity of the thing that the diff is relative to SyncDiff parent (PatchLocalIds' text hash defn) ByteString + deriving stock (Eq, Show) -- | Apply a list of patch diffs to a patch, left to right. applyPatchDiffs :: Patch -> [PatchDiff] -> Patch diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs index e50d215ecf..f06fc70ec3 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Term/Format.hs @@ -49,6 +49,7 @@ newtype LocallyIndexedComponent' t d = LocallyIndexedComponent newtype SyncLocallyIndexedComponent' t d = SyncLocallyIndexedComponent (Vector (LocalIds' t d, ByteString)) + deriving stock (Eq, Show) {- message = "hello, world" -> ABT { ... { Term.F.Text "hello, world" } } -> hashes to (#abc, 0) @@ -127,6 +128,7 @@ data TermFormat' t d = Term (LocallyIndexedComponent' t d) type SyncTermFormat = SyncTermFormat' TextId ObjectId data SyncTermFormat' t d = SyncTerm (SyncLocallyIndexedComponent' t d) + deriving stock (Eq, Show) data WatchResultFormat = WatchResult WatchLocalIds Term diff --git a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal index 2641df87cd..48431ee573 100644 --- a/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal +++ b/codebase2/codebase-sqlite/unison-codebase-sqlite.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack diff --git a/hie.yaml b/hie.yaml index 811a7099ff..6b28f83ee0 100644 --- a/hie.yaml +++ b/hie.yaml @@ -140,6 +140,9 @@ cradle: - path: "unison-share-api/src" component: "unison-share-api:lib" + - path: "unison-share-api/tests" + component: "unison-share-api:test:unison-share-api-tests" + - path: "unison-share-projects-api/src" component: "unison-share-projects-api:lib" diff --git a/lib/unison-sqlite/src/Unison/Sqlite.hs b/lib/unison-sqlite/src/Unison/Sqlite.hs index eec974d6ed..a94fceae40 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite.hs @@ -19,6 +19,7 @@ module Unison.Sqlite Transaction, runTransaction, runTransactionWithRollback, + runTransactionExceptT, runReadOnlyTransaction, runWriteTransaction, cacheTransaction, diff --git a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs index b44a04b0fa..5bf735b917 100644 --- a/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs +++ b/lib/unison-sqlite/src/Unison/Sqlite/Transaction.hs @@ -3,6 +3,7 @@ module Unison.Sqlite.Transaction Transaction, runTransaction, runTransactionWithRollback, + runTransactionExceptT, runReadOnlyTransaction, runWriteTransaction, cacheTransaction, @@ -44,6 +45,7 @@ where import Control.Concurrent (threadDelay) import Control.Exception (Exception (fromException), onException, throwIO) +import Control.Monad.Trans.Except (ExceptT, runExceptT) import Control.Monad.Trans.Reader (ReaderT (..)) import Data.Text qualified as Text import Data.Unique (Unique, newUnique) @@ -130,6 +132,13 @@ runTransactionWithRollback conn transaction = liftIO do Right x -> pure x {-# SPECIALIZE runTransactionWithRollback :: Connection -> ((forall void. a -> Transaction void) -> Transaction a) -> IO a #-} +-- | Run a transaction wrapped in an 'ExceptT'. If the ExceptT fails, the transaction is rolled back. +runTransactionExceptT :: (MonadIO m, HasCallStack) => Connection -> ExceptT e Transaction a -> m (Either e a) +runTransactionExceptT conn transaction = runTransactionWithRollback conn \rollback -> do + runExceptT transaction >>= \case + Left e -> rollback (Left e) + Right a -> pure (Right a) + -- | Run a transaction that is known to only perform reads. -- -- The action is provided a function that peels off the 'Transaction' newtype without sending the corresponding diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index 1fcb0e5c7c..e8cb24e84e 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -99,6 +99,7 @@ module Unison.Codebase -- * Direct codebase access runTransaction, runTransactionWithRollback, + runTransactionExceptT, withConnection, withConnectionIO, @@ -112,6 +113,7 @@ module Unison.Codebase ) where +import Control.Monad.Except (ExceptT) import Data.Map qualified as Map import Data.Set qualified as Set import U.Codebase.Branch qualified as V2Branch @@ -174,6 +176,14 @@ runTransactionWithRollback :: runTransactionWithRollback Codebase {withConnection} action = withConnection \conn -> Sqlite.runTransactionWithRollback conn action +runTransactionExceptT :: + (MonadIO m) => + Codebase m v a -> + ExceptT e Sqlite.Transaction b -> + m (Either e b) +runTransactionExceptT Codebase {withConnection} action = + withConnection \conn -> Sqlite.runTransactionExceptT conn action + getShallowCausalAtPathFromRootHash :: -- Causal to start at, if Nothing use the codebase's root branch. CausalHash -> diff --git a/unison-cli/package.yaml b/unison-cli/package.yaml index 098c48f302..d3d48f2c8a 100644 --- a/unison-cli/package.yaml +++ b/unison-cli/package.yaml @@ -20,6 +20,7 @@ library: - condition: "!os(windows)" dependencies: unix dependencies: + - attoparsec - Diff - IntervalMap - ListLike @@ -32,7 +33,10 @@ library: - co-log-core - code-page - concurrent-output + - conduit - containers >= 0.6.3 + - conduit + - conduit-extra - cryptonite - either - errors @@ -65,8 +69,10 @@ library: - recover-rtti - regex-tdfa - semialign + - serialise - servant - servant-client + - servant-conduit - stm - temporary - text-ansi diff --git a/unison-cli/src/Unison/Cli/DownloadUtils.hs b/unison-cli/src/Unison/Cli/DownloadUtils.hs index 343ebfeeb5..fb53a84176 100644 --- a/unison-cli/src/Unison/Cli/DownloadUtils.hs +++ b/unison-cli/src/Unison/Cli/DownloadUtils.hs @@ -4,12 +4,14 @@ module Unison.Cli.DownloadUtils ( downloadProjectBranchFromShare, downloadLooseCodeFromShare, + SyncVersion (..), ) where import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TVar (modifyTVar', newTVarIO, readTVar, readTVarIO) import Data.List.NonEmpty (pattern (:|)) +import Data.Set qualified as Set import System.Console.Regions qualified as Console.Regions import U.Codebase.HashTags (CausalHash) import U.Codebase.Sqlite.Queries qualified as Queries @@ -28,20 +30,24 @@ import Unison.Share.API.Hash qualified as Share 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.SyncV2 qualified as SyncV2 import Unison.Share.Types (codeserverBaseURL) import Unison.Sync.Common qualified as Sync.Common import Unison.Sync.Types qualified as Share +import Unison.SyncV2.Types qualified as SyncV2 + +data SyncVersion = SyncV1 | SyncV2 -- | Download a project/branch from Share. downloadProjectBranchFromShare :: (HasCallStack) => + SyncVersion -> Share.IncludeSquashedHead -> Share.RemoteProjectBranch -> Cli (Either Output.ShareError CausalHash) -downloadProjectBranchFromShare useSquashed branch = +downloadProjectBranchFromShare syncVersion useSquashed branch = Cli.labelE \done -> do let remoteProjectBranchName = branch.branchName - let repoInfo = Share.RepoInfo (into @Text (ProjectAndBranch branch.projectName remoteProjectBranchName)) causalHashJwt <- case (useSquashed, branch.squashedBranchHead) of (Share.IncludeSquashedHead, Nothing) -> done Output.ShareExpectedSquashedHead @@ -49,16 +55,32 @@ downloadProjectBranchFromShare useSquashed branch = (Share.NoSquashedHead, _) -> pure branch.branchHead exists <- Cli.runTransaction (Queries.causalExistsByHash32 (Share.hashJWTHash causalHashJwt)) when (not exists) do - (result, numDownloaded) <- - Cli.with withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do - result <- Share.downloadEntities Share.hardCodedBaseUrl repoInfo causalHashJwt downloadedCallback - numDownloaded <- liftIO getNumDownloaded - pure (result, numDownloaded) - result & onLeft \err0 -> do - done case err0 of - Share.SyncError err -> Output.ShareErrorDownloadEntities err - Share.TransportError err -> Output.ShareErrorTransport err - Cli.respond (Output.DownloadedEntities numDownloaded) + case syncVersion of + SyncV1 -> do + let repoInfo = Share.RepoInfo (into @Text (ProjectAndBranch branch.projectName remoteProjectBranchName)) + Cli.with withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do + result <- Share.downloadEntities Share.hardCodedBaseUrl repoInfo causalHashJwt downloadedCallback + numDownloaded <- liftIO getNumDownloaded + result & onLeft \err0 -> do + done case err0 of + Share.SyncError err -> Output.ShareErrorDownloadEntities err + Share.TransportError err -> Output.ShareErrorTransport err + Cli.respond (Output.DownloadedEntities numDownloaded) + SyncV2 -> do + -- Cli.with withEntitiesDownloadedProgressCallback \(downloadedCallback, getNumDownloaded) -> do + let branchRef = SyncV2.BranchRef (into @Text (ProjectAndBranch branch.projectName remoteProjectBranchName)) + -- TODO: Fill this in. + let knownHashes = Set.empty + let downloadedCallback = \_ -> pure () + let shouldValidate = not $ Codeserver.isCustomCodeserver Codeserver.defaultCodeserver + result <- SyncV2.syncFromCodeserver shouldValidate Share.hardCodedBaseUrl branchRef causalHashJwt knownHashes downloadedCallback + result & onLeft \err0 -> do + done case err0 of + Share.SyncError err -> + -- TODO: Fix this + error (show err) + -- Output.ShareErrorDownloadEntities err + Share.TransportError err -> Output.ShareErrorTransport err pure (Sync.Common.hash32ToCausalHash (Share.hashJWTHash causalHashJwt)) -- | Download loose code from Share. diff --git a/unison-cli/src/Unison/Cli/MonadUtils.hs b/unison-cli/src/Unison/Cli/MonadUtils.hs index 242ee77635..94f01b098b 100644 --- a/unison-cli/src/Unison/Cli/MonadUtils.hs +++ b/unison-cli/src/Unison/Cli/MonadUtils.hs @@ -49,6 +49,7 @@ module Unison.Cli.MonadUtils stepManyAtM, updateProjectBranchRoot, updateProjectBranchRoot_, + setProjectBranchRootToCausalHash, updateAtM, updateAt, updateAndStepAt, @@ -447,6 +448,13 @@ updateProjectBranchRoot projectBranch reason f = do Q.setProjectBranchHead reason (projectBranch ^. #projectId) (projectBranch ^. #branchId) causalHashId pure result +setProjectBranchRootToCausalHash :: ProjectBranch -> Text -> CausalHash -> Cli () +setProjectBranchRootToCausalHash projectBranch reason targetCH = do + Cli.time "setProjectBranchRootToCausalHash" do + Cli.runTransaction $ do + targetCHID <- Q.expectCausalHashIdByCausalHash targetCH + Q.setProjectBranchHead reason (projectBranch ^. #projectId) (projectBranch ^. #branchId) targetCHID + updateProjectBranchRoot_ :: ProjectBranch -> Text -> (Branch IO -> Branch IO) -> Cli () updateProjectBranchRoot_ projectBranch reason f = do updateProjectBranchRoot projectBranch reason (\b -> pure (f b, ())) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 4967878424..e3e78c6575 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -59,8 +59,8 @@ import Unison.Codebase.Editor.HandleInput.DeleteBranch (handleDeleteBranch) import Unison.Codebase.Editor.HandleInput.DeleteNamespace (getEndangeredDependents, handleDeleteNamespace) import Unison.Codebase.Editor.HandleInput.DeleteProject (handleDeleteProject) import Unison.Codebase.Editor.HandleInput.Dependents (handleDependents) -import Unison.Codebase.Editor.HandleInput.EditNamespace (handleEditNamespace) import Unison.Codebase.Editor.HandleInput.EditDependents (handleEditDependents) +import Unison.Codebase.Editor.HandleInput.EditNamespace (handleEditNamespace) import Unison.Codebase.Editor.HandleInput.FindAndReplace (handleStructuredFindI, handleStructuredFindReplaceI, handleTextFindI) import Unison.Codebase.Editor.HandleInput.FormatFile qualified as Format import Unison.Codebase.Editor.HandleInput.Global qualified as Global @@ -87,6 +87,7 @@ import Unison.Codebase.Editor.HandleInput.ReleaseDraft (handleReleaseDraft) import Unison.Codebase.Editor.HandleInput.Run (handleRun) import Unison.Codebase.Editor.HandleInput.RuntimeUtils qualified as RuntimeUtils import Unison.Codebase.Editor.HandleInput.ShowDefinition (handleShowDefinition) +import Unison.Codebase.Editor.HandleInput.SyncV2 qualified as SyncV2 import Unison.Codebase.Editor.HandleInput.TermResolution (resolveMainRef) import Unison.Codebase.Editor.HandleInput.Tests qualified as Tests import Unison.Codebase.Editor.HandleInput.Todo (handleTodo) @@ -688,6 +689,17 @@ loop e = do Cli.respond Success PullI sourceTarget pullMode -> handlePull sourceTarget pullMode PushRemoteBranchI pushRemoteBranchInput -> handlePushRemoteBranch pushRemoteBranchInput + SyncToFileI syncFileDest projectBranchName -> SyncV2.handleSyncToFile syncFileDest projectBranchName + SyncFromFileI syncFileSrc projectBranchName -> do + description <- inputDescription input + SyncV2.handleSyncFromFile description syncFileSrc projectBranchName + SyncFromCodebaseI srcCodebasePath srcBranch destBranch -> do + description <- inputDescription input + let srcBranch' = + srcBranch & over #project \case + Nothing -> error "todo" + Just proj -> proj + SyncV2.handleSyncFromCodebase description srcCodebasePath srcBranch' destBranch ListDependentsI hq -> handleDependents hq ListDependenciesI hq -> handleDependencies hq NamespaceDependenciesI path -> handleNamespaceDependencies path @@ -1012,6 +1024,11 @@ inputDescription input = ProjectsI -> wat PullI {} -> wat PushRemoteBranchI {} -> wat + SyncToFileI {} -> wat + SyncFromFileI fp pab -> + pure $ "sync.from-file " <> into @Text fp <> " " <> into @Text pab + SyncFromCodebaseI fp srcBranch destBranch -> do + pure $ "sync.from-file " <> into @Text fp <> " " <> into @Text srcBranch <> " " <> into @Text destBranch QuitI {} -> wat ReleaseDraftI {} -> wat ShowDefinitionI {} -> wat diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs index 52e70188c8..299f30ba47 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/InstallLib.hs @@ -60,7 +60,7 @@ handleInstallLib remind (ProjectAndBranch libdepProjectName unresolvedLibdepBran Cli.Env {codebase} <- ask causalHash <- - downloadProjectBranchFromShare Share.IncludeSquashedHead libdepProjectBranch + downloadProjectBranchFromShare SyncV1 Share.IncludeSquashedHead libdepProjectBranch & onLeftM (Cli.returnEarly . Output.ShareError) remoteBranchObject <- liftIO (Codebase.expectBranchForHash codebase causalHash) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs index 8a872d18b8..670a730b5e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectClone.hs @@ -13,7 +13,7 @@ import U.Codebase.Sqlite.Project qualified as Sqlite (Project (..)) import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite import U.Codebase.Sqlite.Queries qualified as Q import U.Codebase.Sqlite.Queries qualified as Queries -import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare) +import Unison.Cli.DownloadUtils (SyncVersion (..), downloadProjectBranchFromShare) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.MonadUtils qualified as Cli (getCurrentProjectAndBranch) @@ -225,7 +225,7 @@ cloneInto localProjectBranch remoteProjectBranch = do let remoteProjectBranchNames = ProjectAndBranch remoteProjectName remoteBranchName branchHead <- - downloadProjectBranchFromShare Share.NoSquashedHead remoteProjectBranch + downloadProjectBranchFromShare SyncV1 Share.NoSquashedHead remoteProjectBranch & onLeftM (Cli.returnEarly . Output.ShareError) localProjectAndBranch <- diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs index e9f6e99e95..0096a91d8d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/ProjectCreate.hs @@ -13,7 +13,7 @@ import U.Codebase.Sqlite.Project (Project (..)) import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..)) import U.Codebase.Sqlite.Queries (expectCausalHashIdByCausalHash) import U.Codebase.Sqlite.Queries qualified as Queries -import Unison.Cli.DownloadUtils (downloadProjectBranchFromShare) +import Unison.Cli.DownloadUtils (SyncVersion (..), downloadProjectBranchFromShare) import Unison.Cli.Monad (Cli) import Unison.Cli.Monad qualified as Cli import Unison.Cli.Share.Projects qualified as Share @@ -108,7 +108,7 @@ projectCreate tryDownloadingBase maybeProjectName = do Share.GetProjectBranchResponseBranchNotFound -> done Nothing Share.GetProjectBranchResponseProjectNotFound -> done Nothing Share.GetProjectBranchResponseSuccess branch -> pure branch - downloadProjectBranchFromShare Share.NoSquashedHead baseLatestReleaseBranch + downloadProjectBranchFromShare SyncV1 Share.NoSquashedHead baseLatestReleaseBranch & onLeftM (Cli.returnEarly . Output.ShareError) Cli.Env {codebase} <- ask baseLatestReleaseBranchObject <- diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs index 3ff7012220..42aebf0299 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/Pull.hs @@ -59,6 +59,7 @@ handlePull unresolvedSourceAndTarget pullMode = do ReadShare'LooseCode repo -> downloadLooseCodeFromShare repo & onLeftM (Cli.returnEarly . Output.ShareError) ReadShare'ProjectBranch remoteBranch -> downloadProjectBranchFromShare + SyncV1 ( case pullMode of Input.PullWithHistory -> Share.NoSquashedHead Input.PullWithoutHistory -> Share.IncludeSquashedHead diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs new file mode 100644 index 0000000000..6bcf1b7aa1 --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/SyncV2.hs @@ -0,0 +1,76 @@ +module Unison.Codebase.Editor.HandleInput.SyncV2 + ( handleSyncToFile, + handleSyncFromFile, + handleSyncFromCodebase, + handleSyncFromCodeserver, + ) +where + +import Control.Lens +import Control.Monad.Reader (MonadReader (..)) +import U.Codebase.HashTags (CausalHash) +import U.Codebase.Sqlite.Queries qualified as Q +import Unison.Cli.DownloadUtils (SyncVersion, downloadProjectBranchFromShare) +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 Project +import Unison.Cli.Share.Projects qualified as Projects +import Unison.Codebase (CodebasePath) +import Unison.Codebase qualified as Codebase +import Unison.Codebase.Editor.Output qualified as Output +import Unison.Codebase.Init qualified as Init +import Unison.Codebase.SqliteCodebase qualified as SqliteCodebase +import Unison.Prelude +import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName) +import Unison.Share.SyncV2 qualified as SyncV2 +import Unison.SyncV2.Types (BranchRef) + +handleSyncToFile :: FilePath -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) -> Cli () +handleSyncToFile destSyncFile branchToSync = do + pp <- Cli.getCurrentProjectPath + projectBranch <- Project.resolveProjectBranchInProject (pp ^. #project) branchToSync + causalHash <- Cli.runTransaction $ Project.getProjectBranchCausalHash (projectBranch ^. #branch) + let branchRef = into @BranchRef $ ProjectAndBranch (projectBranch ^. #project . #name) (projectBranch ^. #branch . #name) + Cli.Env {codebase} <- ask + liftIO (SyncV2.syncToFile codebase causalHash (Just branchRef) destSyncFile) >>= \case + Left err -> Cli.respond (Output.SyncPullError err) + Right _ -> pure () + +handleSyncFromFile :: Text -> FilePath -> ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () +handleSyncFromFile description srcSyncFile branchToSync = do + pp <- Cli.getCurrentProjectPath + projectBranch <- Project.resolveProjectBranchInProject (pp ^. #project) (over #branch Just branchToSync) + let shouldValidate = True + SyncV2.syncFromFile shouldValidate srcSyncFile >>= \case + Left err -> Cli.respond (Output.SyncPullError err) + Right causalHash -> do + Cli.setProjectBranchRootToCausalHash (projectBranch ^. #branch) description causalHash + +handleSyncFromCodebase :: Text -> CodebasePath -> ProjectAndBranch ProjectName ProjectBranchName -> ProjectAndBranch (Maybe ProjectName) ProjectBranchName -> Cli () +handleSyncFromCodebase description srcCodebasePath srcBranch destBranch = do + Cli.Env {codebase} <- ask + pp <- Cli.getCurrentProjectPath + projectBranch <- Project.resolveProjectBranchInProject (pp ^. #project) (over #branch Just destBranch) + r <- liftIO $ Init.withOpenCodebase SqliteCodebase.init "sync-src" srcCodebasePath Init.DontLock (Init.MigrateAfterPrompt Init.Backup Init.Vacuum) \srcCodebase -> do + Codebase.withConnection srcCodebase \srcConn -> do + maySrcCausalHash <- Codebase.runTransaction srcCodebase $ do + let ProjectAndBranch srcProjName srcBranchName = srcBranch + runMaybeT do + project <- MaybeT (Q.loadProjectByName srcProjName) + branch <- MaybeT (Q.loadProjectBranchByName (project ^. #projectId) srcBranchName) + lift $ Project.getProjectBranchCausalHash branch + case maySrcCausalHash of + Nothing -> pure $ Left (error "Todo proper error") + Just srcCausalHash -> do + let shouldValidate = True + fmap (const srcCausalHash) <$> liftIO (SyncV2.syncFromCodebase shouldValidate srcConn codebase srcCausalHash) + + case r of + Left _err -> pure $ error "Todo proper error" + Right (Left syncErr) -> Cli.respond (Output.SyncPullError syncErr) + Right (Right causalHash) -> do + Cli.setProjectBranchRootToCausalHash (projectBranch ^. #branch) description causalHash + +handleSyncFromCodeserver :: SyncVersion -> Projects.IncludeSquashedHead -> Projects.RemoteProjectBranch -> Cli (Either Output.ShareError CausalHash) +handleSyncFromCodeserver = downloadProjectBranchFromShare diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index da06a5fb8e..684a5ac1ea 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -126,6 +126,9 @@ data Input | DiffNamespaceI BranchId2 BranchId2 -- old new | PullI !PullSourceTarget !PullMode | PushRemoteBranchI PushRemoteBranchInput + | SyncToFileI FilePath (ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)) + | SyncFromFileI FilePath UnresolvedProjectBranch + | SyncFromCodebaseI FilePath UnresolvedProjectBranch UnresolvedProjectBranch | ResetI (BranchId2 {- namespace to reset it to -}) (Maybe UnresolvedProjectBranch {- ProjectBranch to reset -}) | -- | used in Welcome module to give directions to user -- diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 7ebf9ad299..13c0a076cc 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -80,6 +80,7 @@ import Unison.Share.Sync.Types qualified as Sync import Unison.ShortHash (ShortHash) import Unison.Symbol (Symbol) import Unison.Sync.Types qualified as Share (DownloadEntitiesError, UploadEntitiesError) +import Unison.SyncV2.Types qualified as SyncV2 import Unison.Syntax.Parser qualified as Parser import Unison.Term (Term) import Unison.Type (Type) @@ -440,6 +441,7 @@ data Output | -- | A literal output message. Use this if it's too cumbersome to create a new Output constructor, e.g. for -- ephemeral progress messages that are just simple strings like "Loading branch..." Literal !(P.Pretty P.ColorText) + | SyncPullError (Sync.SyncError SyncV2.PullError) data MoreEntriesThanShown = MoreEntriesThanShown | AllEntriesShown deriving (Eq, Show) @@ -678,6 +680,7 @@ isFailure o = case o of IncoherentDeclDuringMerge {} -> True IncoherentDeclDuringUpdate {} -> True Literal _ -> False + SyncPullError {} -> True isNumberedFailure :: NumberedOutput -> Bool isNumberedFailure = \case diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 87597a8653..f2fc24cf7d 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -97,6 +97,9 @@ module Unison.CommandLine.InputPatterns pushCreate, pushExhaustive, pushForce, + syncToFile, + syncFromFile, + syncFromCodebase, quit, releaseDraft, renameBranch, @@ -738,6 +741,38 @@ handleProjectAndBranchNamesArg = SA.ProjectBranch (ProjectAndBranch mproj branch) -> pure $ maybe That These mproj branch otherNumArg -> Left $ wrongStructuredArgument "a project or branch" otherNumArg +handleOptionalProjectAndBranch :: I.Argument -> Either (P.Pretty CT.ColorText) (ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName)) +handleOptionalProjectAndBranch = + either + (\str -> fmap intoProjectAndBranch . first (const $ expectedButActually' "a project or branch" str) . tryInto @(These ProjectName ProjectBranchName) $ Text.pack str) + $ \case + SA.Project project -> pure $ ProjectAndBranch (Just project) Nothing + SA.ProjectBranch (ProjectAndBranch mproj branch) -> pure $ ProjectAndBranch mproj (Just branch) + otherNumArg -> Left $ wrongStructuredArgument "a project or branch" otherNumArg + where + intoProjectAndBranch :: These ProjectName ProjectBranchName -> ProjectAndBranch (Maybe ProjectName) (Maybe ProjectBranchName) + intoProjectAndBranch = \case + This project -> ProjectAndBranch (Just project) Nothing + That branch -> ProjectAndBranch Nothing (Just branch) + These project branch -> ProjectAndBranch (Just project) (Just branch) + +handleBranchWithOptionalProject :: I.Argument -> Either (P.Pretty CT.ColorText) (ProjectAndBranch (Maybe ProjectName) ProjectBranchName) +handleBranchWithOptionalProject = + either + ( \str -> + Text.pack str + & tryInto @(These ProjectName ProjectBranchName) + & first (const $ expectedButActually' "a project branch" str) + >>= \case + These project branch -> pure $ ProjectAndBranch (Just project) branch + That branch -> pure $ ProjectAndBranch Nothing branch + This _project -> Left $ expectedButActually' "a project branch" str + ) + ( \case + SA.ProjectBranch (ProjectAndBranch mproj branch) -> pure $ ProjectAndBranch mproj branch + otherNumArg -> Left $ wrongStructuredArgument "a project branch" otherNumArg + ) + mergeBuiltins :: InputPattern mergeBuiltins = InputPattern @@ -2088,6 +2123,86 @@ pushExhaustive = branchInclusion = AllBranches } +syncToFile :: InputPattern +syncToFile = + InputPattern + { patternName = "sync.to-file", + aliases = [], + visibility = I.Hidden, + args = [("file-path", Required, filePathArg), ("branch", Optional, projectAndBranchNamesArg suggestionsConfig)], + help = + ( P.wrapColumn2 + [ ( makeExample syncToFile ["./branch.usync"], + "saves the current branch to the file `foo.u`." + ), + ( makeExample syncToFile ["./main.usync", "/main"], + "saves the main branch to the file `main.usync`." + ) + ] + ), + parse = \case + [filePath, branch] -> Input.SyncToFileI <$> unsupportedStructuredArgument makeStandalone "a file name" filePath <*> handleOptionalProjectAndBranch branch + [filePath] -> Input.SyncToFileI <$> unsupportedStructuredArgument makeStandalone "a file name" filePath <*> pure (ProjectAndBranch Nothing Nothing) + args -> wrongArgsLength "one or two arguments" args + } + where + suggestionsConfig = + ProjectBranchSuggestionsConfig + { showProjectCompletions = True, + projectInclusion = AllProjects, + branchInclusion = AllBranches + } + +syncFromFile :: InputPattern +syncFromFile = + InputPattern + { patternName = "sync.from-file", + aliases = [], + visibility = I.Hidden, + args = [("file-path", Required, filePathArg), ("destination branch", Required, projectAndBranchNamesArg suggestionsConfig)], + help = + ( P.wrapColumn2 + [ ( makeExample syncFromFile ["./feature.usync", "/feature"], + "Sets the /feature branch to the contents of the file `main.usync`." + ) + ] + ), + parse = \case + [filePath, branch] -> Input.SyncFromFileI <$> unsupportedStructuredArgument makeStandalone "a file name" filePath <*> handleBranchWithOptionalProject branch + args -> wrongArgsLength "one or two arguments" args + } + where + suggestionsConfig = + ProjectBranchSuggestionsConfig + { showProjectCompletions = True, + projectInclusion = AllProjects, + branchInclusion = AllBranches + } + +syncFromCodebase :: InputPattern +syncFromCodebase = + InputPattern + { patternName = "sync.from-codebase", + aliases = [], + visibility = I.Hidden, + args = [("codebase-location", Required, filePathArg), ("branch-to-sync", Required, projectAndBranchNamesArg suggestionsConfig), ("destination-branch", Optional, projectAndBranchNamesArg suggestionsConfig)], + help = + ( P.wrapColumn2 + [ (makeExample syncFromCodebase ["./codebase", "/feature", "/main"], "Sets the /feature branch to the contents of the codebase at ./codebase.") + ] + ), + parse = \case + [codebaseLocation, branchToSync, destinationBranch] -> Input.SyncFromCodebaseI <$> unsupportedStructuredArgument makeStandalone "a file name" codebaseLocation <*> handleBranchWithOptionalProject branchToSync <*> handleBranchWithOptionalProject destinationBranch + args -> wrongArgsLength "three arguments" args + } + where + suggestionsConfig = + ProjectBranchSuggestionsConfig + { showProjectCompletions = True, + projectInclusion = AllProjects, + branchInclusion = AllBranches + } + mergeOldSquashInputPattern :: InputPattern mergeOldSquashInputPattern = InputPattern @@ -3666,6 +3781,9 @@ validInputs = pushCreate, pushExhaustive, pushForce, + syncToFile, + syncFromFile, + syncFromCodebase, quit, releaseDraft, renameBranch, diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index f2d1ab61c0..385a9aa6c0 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -2258,6 +2258,9 @@ notifyUser dir = \case <> "it. Then try the update again." ] Literal message -> pure message + SyncPullError syncErr -> + -- TODO: Better error message + pure (P.shown syncErr) prettyShareError :: ShareError -> Pretty prettyShareError = @@ -2363,6 +2366,11 @@ prettyTransportError = \case Share.Timeout -> "The code server timed-out when responding to your request. Please try again later or report an issue if the problem persists." Share.UnexpectedResponse resp -> unexpectedServerResponse resp + Share.StreamingError err -> + P.lines + [ ( "We encountered an error while streaming data from the code server: " <> P.text err), + P.red (P.text err) + ] unexpectedServerResponse :: Servant.ResponseF LazyByteString.ByteString -> P.Pretty Unison.Util.ColorText.ColorText unexpectedServerResponse resp = diff --git a/unison-cli/src/Unison/Share/Sync/Types.hs b/unison-cli/src/Unison/Share/Sync/Types.hs index a53d14acbb..1d7066688c 100644 --- a/unison-cli/src/Unison/Share/Sync/Types.hs +++ b/unison-cli/src/Unison/Share/Sync/Types.hs @@ -39,6 +39,8 @@ data CodeserverTransportError | Unauthenticated Servant.BaseUrl | UnexpectedResponse Servant.Response | UnreachableCodeserver Servant.BaseUrl + | -- I wish Servant gave us more detail, but it's just Text. I don't think we ever hit these errors though. + StreamingError Text deriving stock (Show) deriving anyclass (Exception) diff --git a/unison-cli/src/Unison/Share/SyncV2.hs b/unison-cli/src/Unison/Share/SyncV2.hs new file mode 100644 index 0000000000..d0a9c7483a --- /dev/null +++ b/unison-cli/src/Unison/Share/SyncV2.hs @@ -0,0 +1,491 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeOperators #-} + +module Unison.Share.SyncV2 + ( syncFromCodeserver, + syncFromFile, + syncToFile, + syncFromCodebase, + ) +where + +import Codec.Serialise qualified as CBOR +import Conduit (ConduitT) +import Conduit qualified as C +import Control.Lens +import Control.Monad.Except +import Control.Monad.Reader (ask) +import Control.Monad.ST (ST, stToIO) +import Control.Monad.State +import Data.Attoparsec.ByteString qualified as A +import Data.Attoparsec.ByteString.Char8 qualified as A8 +import Data.ByteString qualified as BS +import Data.ByteString.Lazy qualified as BL +import Data.Conduit.Attoparsec qualified as C +import Data.Conduit.List qualified as C +import Data.Conduit.Zlib qualified as C +import Data.Graph qualified as Graph +import Data.Map qualified as Map +import Data.Proxy +import Data.Set qualified as Set +import Data.Text.Lazy qualified as Text.Lazy +import Data.Text.Lazy.Encoding qualified as Text.Lazy +import Network.HTTP.Client qualified as Http.Client +import Network.HTTP.Types qualified as HTTP +import Servant.API qualified as Servant +import Servant.Client.Streaming qualified as Servant +import Servant.Conduit () +import Servant.Types.SourceT qualified as Servant +import System.Console.Regions qualified as Console.Regions +import U.Codebase.HashTags (CausalHash) +import U.Codebase.Sqlite.Queries qualified as Q +import U.Codebase.Sqlite.TempEntity (TempEntity) +import U.Codebase.Sqlite.V2.HashHandle (v2HashHandle) +import Unison.Auth.HTTPClient qualified as Auth +import Unison.Cli.Monad (Cli) +import Unison.Cli.Monad qualified as Cli +import Unison.Codebase qualified as Codebase +import Unison.Debug qualified as Debug +import Unison.Hash32 (Hash32) +import Unison.Prelude +import Unison.Share.API.Hash qualified as Share +import Unison.Share.ExpectedHashMismatches (expectedCausalHashMismatches, expectedComponentHashMismatches) +import Unison.Share.Sync.Types +import Unison.Sqlite qualified as Sqlite +import Unison.Sync.Common (causalHashToHash32, hash32ToCausalHash, tempEntityToEntity) +import Unison.Sync.Common qualified as Sync +import Unison.Sync.EntityValidation qualified as EV +import Unison.Sync.Types qualified as Share +import Unison.Sync.Types qualified as Sync +import Unison.SyncV2.API (Routes (downloadEntitiesStream)) +import Unison.SyncV2.API qualified as SyncV2 +import Unison.SyncV2.Types (CBORBytes) +import Unison.SyncV2.Types qualified as SyncV2 +import Unison.Util.Servant.CBOR qualified as CBOR +import Unison.Util.Timing qualified as Timing +import UnliftIO qualified as IO + +type Stream i o = ConduitT i o StreamM () + +type SyncErr = SyncError SyncV2.PullError + +type StreamM = (ExceptT SyncErr (C.ResourceT IO)) + +batchSize :: Int +batchSize = 5000 + +------------------------------------------------------------------------------------------------------------------------ +-- Download entities + +validateAndSave :: Bool -> (Codebase.Codebase IO v a) -> [(Hash32, TempEntity)] -> StreamM () +validateAndSave shouldValidate codebase entities = do + let validateEntities = + runExceptT $ when shouldValidate (batchValidateEntities entities) + -- Validation is slow, run it in parallel with insertion, but don't commit the transaction until we're done + -- validation. + ExceptT . liftIO $ IO.withAsync validateEntities \validationTask -> do + Timing.time "Inserting entities" $ Codebase.runTransactionExceptT codebase do + for_ entities \(hash, entity) -> do + void . lift $ Q.saveTempEntityInMain v2HashHandle hash entity + lift (Sqlite.unsafeIO (IO.wait validationTask)) >>= \case + Left err -> throwError err + Right _ -> pure () + +-- | Syncs a stream which could send entities in any order. +syncUnsortedStream :: + Bool -> + (Codebase.Codebase IO v a) -> + Stream () SyncV2.EntityChunk -> + StreamM () +syncUnsortedStream shouldValidate codebase stream = do + Debug.debugLogM Debug.Temp $ "Syncing unsorted stream" + allResults <- C.runConduit $ stream C..| C.sinkList + allEntities <- ExceptT $ Timing.time "Unpacking chunks" $ liftIO $ Codebase.runTransactionExceptT codebase $ do unpackChunks allResults + let sortedEntities = sortDependencyFirst allEntities + validateAndSave shouldValidate codebase sortedEntities + +-- | Syncs a stream which sends entities which are already sorted in dependency order. +syncSortedStream :: + Bool -> + (Codebase.Codebase IO v a) -> + Stream () SyncV2.EntityChunk -> + StreamM () +syncSortedStream shouldValidate codebase stream = do + Debug.debugLogM Debug.Temp $ "Syncing sorted stream" + let handler :: Stream [SyncV2.EntityChunk] o + handler = C.mapM_C \chunkBatch -> do + entityBatch <- mapExceptT lift . ExceptT $ Codebase.runTransactionExceptT codebase do for chunkBatch unpackChunk + validateAndSave shouldValidate codebase (catMaybes entityBatch) + C.runConduit $ stream C..| C.chunksOf batchSize C..| handler + +unpackChunk :: SyncV2.EntityChunk -> ExceptT SyncErr Sqlite.Transaction (Maybe (Hash32, TempEntity)) +unpackChunk = \case + SyncV2.EntityChunk {hash, entityCBOR = entityBytes} -> do + -- Only want entities we don't already have + lift (Q.entityLocation hash) >>= \case + Just Q.EntityInMainStorage -> pure Nothing + _ -> do + (Just . (hash,)) <$> unpackEntity entityBytes + where + unpackEntity :: (CBORBytes TempEntity) -> ExceptT SyncErr Sqlite.Transaction TempEntity + unpackEntity entityBytes = do + case CBOR.deserialiseOrFailCBORBytes entityBytes of + Left err -> do throwError $ (SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorDeserializationFailure err) + Right entity -> pure entity + +unpackChunks :: [SyncV2.EntityChunk] -> ExceptT SyncErr Sqlite.Transaction [(Hash32, TempEntity)] +unpackChunks xs = do + for xs unpackChunk + <&> catMaybes + +batchValidateEntities :: [(Hash32, TempEntity)] -> ExceptT SyncErr IO () +batchValidateEntities entities = do + mismatches <- fmap catMaybes $ liftIO $ IO.pooledForConcurrently entities \(hash, entity) -> do + IO.evaluate $ EV.validateTempEntity hash entity + for_ mismatches \case + err@(Share.EntityHashMismatch et (Share.HashMismatchForEntity {supplied, computed})) -> + let expectedMismatches = case et of + Share.TermComponentType -> expectedComponentHashMismatches + Share.DeclComponentType -> expectedComponentHashMismatches + Share.CausalType -> expectedCausalHashMismatches + _ -> mempty + in case Map.lookup supplied expectedMismatches of + Just expected + | expected == computed -> pure () + _ -> do + throwError . SyncError . SyncV2.PullError'DownloadEntities . SyncV2.DownloadEntitiesEntityValidationFailure $ err + err -> do + throwError . SyncError . SyncV2.PullError'DownloadEntities . SyncV2.DownloadEntitiesEntityValidationFailure $ err + +syncFromCodeserver :: + Bool -> + -- | The Unison Share URL. + Servant.BaseUrl -> + -- | The branch to download from. + SyncV2.BranchRef -> + -- | The hash to download. + Share.HashJWT -> + Set Hash32 -> + -- | Callback that's given a number of entities we just downloaded. + (Int -> IO ()) -> + Cli (Either (SyncError SyncV2.PullError) ()) +syncFromCodeserver shouldValidate unisonShareUrl branchRef hashJwt knownHashes _downloadedCallback = do + Cli.Env {authHTTPClient, codebase} <- ask + runExceptT do + let hash = Share.hashJWTHash hashJwt + ExceptT $ do + (Cli.runTransaction (Q.entityLocation hash)) >>= \case + Just Q.EntityInMainStorage -> pure $ Right () + _ -> do + Debug.debugLogM Debug.Temp $ "Kicking off sync request" + Timing.time "Entity Download" $ do + liftIO . C.runResourceT . runExceptT $ httpStreamEntities + authHTTPClient + unisonShareUrl + SyncV2.DownloadEntitiesRequest {branchRef, causalHash = hashJwt, knownHashes} + \header stream -> do + streamIntoCodebase shouldValidate codebase header stream + mapExceptT liftIO (afterSyncChecks codebase hash) + +streamIntoCodebase :: Bool -> Codebase.Codebase IO v a -> SyncV2.StreamInitInfo -> Stream () SyncV2.EntityChunk -> StreamM () +streamIntoCodebase shouldValidate codebase SyncV2.StreamInitInfo {version, entitySorting, numEntities = numEntities} stream = ExceptT do + withStreamProgressCallback (fromIntegral <$> numEntities) \countC -> runExceptT do + let stream' = stream C..| countC + case version of + (SyncV2.Version 1) -> pure () + v -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorUnsupportedVersion v + + case entitySorting of + SyncV2.DependenciesFirst -> syncSortedStream shouldValidate codebase stream' + SyncV2.Unsorted -> syncUnsortedStream shouldValidate codebase stream' + +afterSyncChecks :: Codebase.Codebase IO v a -> Hash32 -> ExceptT (SyncError SyncV2.PullError) IO () +afterSyncChecks codebase hash = do + lift (didCausalSuccessfullyImport codebase hash) >>= \case + False -> do + throwError (SyncError (SyncV2.PullError'Sync . SyncV2.SyncErrorExpectedResultNotInMain . hash32ToCausalHash $ hash)) + True -> pure () + void $ liftIO (Codebase.withConnection codebase Sqlite.vacuum) + where + -- Verify that the expected hash made it into main storage. + didCausalSuccessfullyImport :: Codebase.Codebase IO v a -> Hash32 -> IO Bool + didCausalSuccessfullyImport codebase hash = do + let expectedHash = hash32ToCausalHash hash + isJust <$> (Codebase.runTransaction codebase $ Q.loadCausalByCausalHash expectedHash) + +-- | Topologically sort entities based on their dependencies. +sortDependencyFirst :: [(Hash32, TempEntity)] -> [(Hash32, TempEntity)] +sortDependencyFirst entities = do + let adjList = entities <&> \(hash32, entity) -> ((hash32, entity), hash32, Set.toList $ Share.entityDependencies (tempEntityToEntity entity)) + (graph, vertexInfo, _vertexForKey) = Graph.graphFromEdges adjList + in Graph.reverseTopSort graph <&> \v -> (view _1 $ vertexInfo v) + +syncFromFile :: + Bool -> + -- | Location of the sync-file + FilePath -> + Cli (Either (SyncError SyncV2.PullError) CausalHash) +syncFromFile shouldValidate syncFilePath = do + Cli.Env {codebase} <- ask + runExceptT do + Debug.debugLogM Debug.Temp $ "Kicking off sync" + mapExceptT liftIO $ Timing.time "File Sync" $ do + header <- mapExceptT C.runResourceT $ do + let stream = C.sourceFile syncFilePath C..| C.ungzip C..| decodeUnframedEntities + (header, rest) <- initializeStream stream + streamIntoCodebase shouldValidate codebase header rest + pure header + afterSyncChecks codebase (SyncV2.rootCausalHash header) + pure . hash32ToCausalHash $ SyncV2.rootCausalHash header + +syncFromCodebase :: + Bool -> + -- | The codebase to sync from. + Sqlite.Connection -> + (Codebase.Codebase IO v a) -> + -- | The hash to sync. + CausalHash -> + IO (Either (SyncError SyncV2.PullError) ()) +syncFromCodebase shouldValidate srcConn destCodebase causalHash = do + liftIO . C.runResourceT . runExceptT $ withEntityStream srcConn causalHash Nothing \_total entityStream -> do + (header, rest) <- initializeStream entityStream + streamIntoCodebase shouldValidate destCodebase header rest + mapExceptT liftIO (afterSyncChecks destCodebase (causalHashToHash32 causalHash)) + +withEntityStream :: + (MonadIO m) => + Sqlite.Connection -> + CausalHash -> + Maybe SyncV2.BranchRef -> + (Int -> Stream () SyncV2.DownloadEntitiesChunk -> m r) -> + m r +withEntityStream conn rootHash mayBranchRef callback = do + entities <- liftIO $ Sqlite.runTransaction conn (depsForCausal rootHash) + let totalEntities = fromIntegral $ Map.size entities + let initialChunk = + SyncV2.InitialC + ( SyncV2.StreamInitInfo + { rootCausalHash = causalHashToHash32 rootHash, + version = SyncV2.Version 1, + entitySorting = SyncV2.DependenciesFirst, + numEntities = Just $ fromIntegral totalEntities, + rootBranchRef = mayBranchRef + } + ) + let contents = + entities + & fmap (Sync.entityToTempEntity id) + & Map.toList + & sortDependencyFirst + & ( fmap \(hash, entity) -> + let entityCBOR = (CBOR.serialiseCBORBytes entity) + in SyncV2.EntityC (SyncV2.EntityChunk {hash, entityCBOR}) + ) + & (initialChunk :) + let stream = C.yieldMany contents + callback totalEntities stream + +syncToFile :: + Codebase.Codebase IO v a -> + CausalHash -> + Maybe SyncV2.BranchRef -> + FilePath -> + IO (Either SyncErr ()) +syncToFile codebase rootHash mayBranchRef destFilePath = do + liftIO $ Codebase.withConnection codebase \conn -> do + C.runResourceT $ + withEntityStream conn rootHash mayBranchRef \mayTotal stream -> do + withStreamProgressCallback (Just mayTotal) \countC -> runExceptT do + C.runConduit $ stream C..| countC C..| C.map (BL.toStrict . CBOR.serialise) C..| C.transPipe liftIO C.gzip C..| C.sinkFile destFilePath + +-- | Collect all dependencies of a given causal hash. +depsForCausal :: CausalHash -> Sqlite.Transaction (Map Hash32 (Sync.Entity Text Hash32 Hash32)) +depsForCausal causalHash = do + flip execStateT mempty $ expandEntities (causalHashToHash32 causalHash) + where + expandEntities :: Hash32 -> ((StateT (Map Hash32 (Sync.Entity Text Hash32 Hash32)) Sqlite.Transaction)) () + expandEntities hash32 = do + gets (Map.member hash32) >>= \case + True -> pure () + False -> do + entity <- lift $ Sync.expectEntity hash32 + modify (Map.insert hash32 entity) + traverseOf_ Sync.entityHashes_ expandEntities entity + +-- | Gets the framed chunks from a NetString framed stream. +_unNetString :: ConduitT ByteString ByteString StreamM () +_unNetString = do + bs <- C.sinkParser $ do + len <- A8.decimal + _ <- A8.char ':' + bs <- A.take len + _ <- A8.char ',' + pure bs + C.yield bs + +_decodeFramedEntity :: ByteString -> StreamM SyncV2.DownloadEntitiesChunk +_decodeFramedEntity bs = do + case CBOR.deserialiseOrFail (BL.fromStrict bs) of + Left err -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorDeserializationFailure err + Right chunk -> pure chunk + +-- Expects a stream of tightly-packed CBOR entities without any framing/separators. +decodeUnframedEntities :: ConduitT ByteString SyncV2.DownloadEntitiesChunk StreamM () +decodeUnframedEntities = C.transPipe (mapExceptT (lift . stToIO)) $ do + C.await >>= \case + Nothing -> pure () + Just bs -> do + d <- newDecoder + loop bs d + where + newDecoder :: ConduitT ByteString SyncV2.DownloadEntitiesChunk (ExceptT SyncErr (ST s)) (Maybe ByteString -> ST s (CBOR.IDecode s (SyncV2.DownloadEntitiesChunk))) + newDecoder = do + (lift . lift) CBOR.deserialiseIncremental >>= \case + CBOR.Done _ _ _ -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorStreamFailure "Invalid initial decoder" + CBOR.Fail _ _ err -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorDeserializationFailure err + CBOR.Partial k -> pure k + loop :: ByteString -> (Maybe ByteString -> ST s (CBOR.IDecode s (SyncV2.DownloadEntitiesChunk))) -> ConduitT ByteString SyncV2.DownloadEntitiesChunk (ExceptT SyncErr (ST s)) () + loop bs k = do + (lift . lift) (k (Just bs)) >>= \case + CBOR.Fail _ _ err -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorDeserializationFailure err + CBOR.Partial k' -> do + -- We need more input, try to get some + nextBS <- C.await + case nextBS of + Nothing -> do + -- No more input, try to finish up the decoder. + (lift . lift) (k' Nothing) >>= \case + CBOR.Done _ _ a -> C.yield a + CBOR.Fail _ _ err -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorDeserializationFailure err + CBOR.Partial _ -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorStreamFailure "Unexpected end of input" + Just bs' -> + -- Have some input, keep going. + loop bs' k' + CBOR.Done rem _ a -> do + C.yield a + if BS.null rem + then do + -- If we had no leftovers, we can check if there's any input left. + C.await >>= \case + Nothing -> pure () + Just bs'' -> do + -- If we have input left, start up a new decoder. + k <- newDecoder + loop bs'' k + else do + -- We have leftovers, start a new decoder and use those. + k <- newDecoder + loop rem k + +------------------------------------------------------------------------------------------------------------------------ +-- Servant stuff + +type SyncAPI = ("ucm" Servant.:> "v2" Servant.:> "sync" Servant.:> SyncV2.API) + +syncAPI :: Proxy SyncAPI +syncAPI = Proxy @SyncAPI + +downloadEntitiesStreamClientM :: SyncV2.DownloadEntitiesRequest -> Servant.ClientM (Servant.SourceT IO SyncV2.DownloadEntitiesChunk) +SyncV2.Routes + { downloadEntitiesStream = downloadEntitiesStreamClientM + } = Servant.client syncAPI + +-- -- | Helper for running clientM that returns a stream of entities. +-- -- You MUST consume the stream within the callback, it will be closed when the callback returns. +-- handleStream :: forall m o. (MonadUnliftIO m) => Servant.ClientEnv -> (o -> m ()) -> Servant.ClientM (Servant.SourceIO o) -> m (Either CodeserverTransportError ()) +-- handleStream clientEnv callback clientM = do +-- handleSourceT clientEnv (SourceT.foreach (throwError . StreamingError . Text.pack) callback) clientM + +-- | Helper for running clientM that returns a stream of entities. +-- You MUST consume the stream within the callback, it will be closed when the callback returns. +withConduit :: forall r. Servant.ClientEnv -> (Stream () SyncV2.DownloadEntitiesChunk -> StreamM r) -> Servant.ClientM (Servant.SourceIO SyncV2.DownloadEntitiesChunk) -> StreamM r +withConduit clientEnv callback clientM = do + Debug.debugLogM Debug.Temp $ "Running clientM" + ExceptT $ withRunInIO \runInIO -> do + Servant.withClientM clientM clientEnv $ \case + Left err -> pure . Left . TransportError $ (handleClientError clientEnv err) + Right sourceT -> do + Debug.debugLogM Debug.Temp $ "Converting sourceIO to conduit" + conduit <- liftIO $ Servant.fromSourceIO sourceT + (runInIO . runExceptT $ callback conduit) + +handleClientError :: Servant.ClientEnv -> Servant.ClientError -> CodeserverTransportError +handleClientError clientEnv err = + case err of + Servant.FailureResponse _req resp -> + case HTTP.statusCode $ Servant.responseStatusCode resp of + 401 -> Unauthenticated (Servant.baseUrl clientEnv) + -- The server should provide semantically relevant permission-denied messages + -- when possible, but this should catch any we miss. + 403 -> PermissionDenied (Text.Lazy.toStrict . Text.Lazy.decodeUtf8 $ Servant.responseBody resp) + 408 -> Timeout + 429 -> RateLimitExceeded + 504 -> Timeout + _ -> UnexpectedResponse resp + Servant.DecodeFailure msg resp -> DecodeFailure msg resp + Servant.UnsupportedContentType _ct resp -> UnexpectedResponse resp + Servant.InvalidContentTypeHeader resp -> UnexpectedResponse resp + Servant.ConnectionError _ -> UnreachableCodeserver (Servant.baseUrl clientEnv) + +httpStreamEntities :: + forall. + Auth.AuthenticatedHttpClient -> + Servant.BaseUrl -> + SyncV2.DownloadEntitiesRequest -> + (SyncV2.StreamInitInfo -> Stream () SyncV2.EntityChunk -> StreamM ()) -> + StreamM () +httpStreamEntities (Auth.AuthenticatedHttpClient httpClient) unisonShareUrl req callback = do + let clientEnv = + (Servant.mkClientEnv httpClient unisonShareUrl) + { Servant.makeClientRequest = \url request -> + -- Disable client-side timeouts + (Servant.defaultMakeClientRequest url request) + <&> \r -> + r + { Http.Client.responseTimeout = Http.Client.responseTimeoutNone + } + } + (downloadEntitiesStreamClientM req) & withConduit clientEnv \stream -> do + (init, entityStream) <- initializeStream stream + callback init entityStream + +-- | Peel the header off the stream and parse the remaining entity chunks. +initializeStream :: Stream () SyncV2.DownloadEntitiesChunk -> StreamM (SyncV2.StreamInitInfo, Stream () SyncV2.EntityChunk) +initializeStream stream = do + (streamRemainder, init) <- stream C.$$+ C.headC + Debug.debugM Debug.Temp "Got initial chunk: " init + case init of + Nothing -> throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorMissingInitialChunk + Just chunk -> do + case chunk of + SyncV2.InitialC info -> do + let entityStream = C.unsealConduitT streamRemainder C..| C.mapM parseEntity + pure $ (info, entityStream) + SyncV2.EntityC _ -> do + Debug.debugLogM Debug.Temp $ "Got unexpected entity chunk" + throwError . SyncError . SyncV2.PullError'Sync $ SyncV2.SyncErrorMissingInitialChunk + SyncV2.ErrorC (SyncV2.ErrorChunk err) -> throwError . SyncError . SyncV2.PullError'DownloadEntities $ err + where + parseEntity :: SyncV2.DownloadEntitiesChunk -> StreamM SyncV2.EntityChunk + parseEntity = \case + SyncV2.EntityC chunk -> pure chunk + SyncV2.ErrorC (SyncV2.ErrorChunk err) -> throwError . SyncError $ SyncV2.PullError'DownloadEntities err + SyncV2.InitialC {} -> throwError . SyncError $ SyncV2.PullError'Sync SyncV2.SyncErrorMisplacedInitialChunk + +-- Provide the given action a callback that display to the terminal. +withStreamProgressCallback :: (MonadIO m, MonadUnliftIO n) => Maybe Int -> (ConduitT i i m () -> n a) -> n a +withStreamProgressCallback total action = do + entitiesDownloadedVar <- IO.newTVarIO (0 :: Int) + IO.withRunInIO \toIO -> do + Console.Regions.displayConsoleRegions do + Console.Regions.withConsoleRegion Console.Regions.Linear \region -> do + Console.Regions.setConsoleRegion region do + entitiesDownloaded <- IO.readTVar entitiesDownloadedVar + pure $ + "\n Processed " + <> tShow entitiesDownloaded + <> maybe "" (\total -> " / " <> tShow total) total + <> " entities...\n\n" + toIO $ action $ C.awaitForever \i -> do + liftIO $ IO.atomically (IO.modifyTVar' entitiesDownloadedVar (+ 1)) + C.yield i diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index ab8d4ecc07..dbdc009a7a 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -88,6 +88,7 @@ library Unison.Codebase.Editor.HandleInput.Run Unison.Codebase.Editor.HandleInput.RuntimeUtils Unison.Codebase.Editor.HandleInput.ShowDefinition + Unison.Codebase.Editor.HandleInput.SyncV2 Unison.Codebase.Editor.HandleInput.TermResolution Unison.Codebase.Editor.HandleInput.Tests Unison.Codebase.Editor.HandleInput.Todo @@ -151,6 +152,8 @@ library Unison.Share.ExpectedHashMismatches Unison.Share.Sync Unison.Share.Sync.Types + Unison.Share.Sync.Util + Unison.Share.SyncV2 Unison.Util.HTTP Unison.Version hs-source-dirs: @@ -198,12 +201,15 @@ library , aeson-pretty , ansi-terminal , async + , attoparsec , base , bytestring , cmark , co-log-core , code-page , concurrent-output + , conduit + , conduit-extra , containers >=0.6.3 , cryptonite , directory @@ -239,8 +245,10 @@ library , recover-rtti , regex-tdfa , semialign + , serialise , servant , servant-client + , servant-conduit , stm , temporary , text diff --git a/unison-share-api/package.yaml b/unison-share-api/package.yaml index 8ed217cf4d..cae9acde7a 100644 --- a/unison-share-api/package.yaml +++ b/unison-share-api/package.yaml @@ -8,6 +8,19 @@ library: - condition: false other-modules: Paths_unison_share_api +tests: + unison-share-api-tests: + when: + - condition: false + other-modules: Paths_unison_share_api + dependencies: + - code-page + - easytest + - hedgehog + - unison-share-api + main: Main.hs + source-dirs: tests + dependencies: - aeson >= 2.0.0.0 - async @@ -15,6 +28,7 @@ dependencies: - binary - bytes - bytestring + - cborg - containers - Diff - directory @@ -31,6 +45,7 @@ dependencies: - nonempty-containers - openapi3 - regex-tdfa + - serialise - servant - servant-docs - servant-openapi3 @@ -50,6 +65,7 @@ dependencies: - unison-pretty-printer - unison-runtime - unison-util-relation + - unison-util-base32hex - unison-share-projects-api - unison-sqlite - unison-syntax diff --git a/unison-share-api/src/Unison/Server/Orphans.hs b/unison-share-api/src/Unison/Server/Orphans.hs index bab2d26fef..003e6d1675 100644 --- a/unison-share-api/src/Unison/Server/Orphans.hs +++ b/unison-share-api/src/Unison/Server/Orphans.hs @@ -1,8 +1,14 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} {-# OPTIONS_GHC -Wno-orphans #-} module Unison.Server.Orphans where +import Codec.CBOR.Decoding qualified as CBOR +import Codec.CBOR.Encoding qualified as CBOR +import Codec.Serialise (Serialise (..)) +import Codec.Serialise qualified as CBOR +import Codec.Serialise.Class qualified as CBOR import Control.Lens import Data.Aeson import Data.Aeson qualified as Aeson @@ -12,9 +18,20 @@ import Data.List.NonEmpty (NonEmpty (..)) import Data.OpenApi import Data.Proxy import Data.Text qualified as Text +import Data.Vector (Vector) +import Data.Vector qualified as Vector import Servant import Servant.Docs (DocCapture (DocCapture), DocQueryParam (..), ParamKind (..), ToCapture (..), ToParam (..)) import U.Codebase.HashTags +import U.Codebase.Sqlite.Branch.Format qualified as BranchFormat +import U.Codebase.Sqlite.Causal qualified as SqliteCausal +import U.Codebase.Sqlite.Decl.Format qualified as DeclFormat +import U.Codebase.Sqlite.Entity qualified as Entity +import U.Codebase.Sqlite.LocalIds qualified as LocalIds +import U.Codebase.Sqlite.Patch.Format qualified as PatchFormat +import U.Codebase.Sqlite.TempEntity (TempEntity) +import U.Codebase.Sqlite.Term.Format qualified as TermFormat +import U.Util.Base32Hex (Base32Hex (..)) import Unison.Codebase.Editor.DisplayObject import Unison.Codebase.Path qualified as Path import Unison.Codebase.Path.Parse qualified as Path @@ -25,6 +42,7 @@ import Unison.ConstructorType qualified as CT import Unison.Core.Project (ProjectBranchName (..), ProjectName (..)) import Unison.Hash (Hash (..)) import Unison.Hash qualified as Hash +import Unison.Hash32 (Hash32 (..)) import Unison.HashQualified qualified as HQ import Unison.HashQualifiedPrime qualified as HQ' import Unison.Name (Name) @@ -34,6 +52,7 @@ import Unison.Prelude import Unison.Project import Unison.Reference qualified as Reference import Unison.Referent qualified as Referent +import Unison.Share.API.Hash (HashJWT (..)) import Unison.ShortHash (ShortHash) import Unison.ShortHash qualified as SH import Unison.Syntax.HashQualified qualified as HQ (parseText) @@ -424,3 +443,111 @@ instance ToCapture (Capture "branch-name" ProjectBranchName) where "The name of a branch in a project. E.g. @handle/name" deriving via Text instance ToJSON ProjectBranchName + +-- CBOR encodings + +deriving via Text instance Serialise Hash32 + +deriving via Text instance Serialise HashJWT + +data SyncTag + = TermComponentTag + | DeclComponentTag + | PatchTag + | NamespaceTag + | CausalTag + deriving (Eq, Show) + +instance Serialise SyncTag where + encode = \case + TermComponentTag -> CBOR.encodeWord 0 + DeclComponentTag -> CBOR.encodeWord 1 + PatchTag -> CBOR.encodeWord 2 + NamespaceTag -> CBOR.encodeWord 3 + CausalTag -> CBOR.encodeWord 4 + + decode = do + tag <- CBOR.decodeWord + case tag of + 0 -> pure TermComponentTag + 1 -> pure DeclComponentTag + 2 -> pure PatchTag + 3 -> pure NamespaceTag + 4 -> pure CausalTag + _ -> fail $ "Unknown tag: " <> show tag + +newtype ComponentBody t d = ComponentBody {unComponentBody :: (LocalIds.LocalIds' t d, ByteString)} + +instance (Serialise t, Serialise d) => Serialise (ComponentBody t d) where + encode (ComponentBody (LocalIds.LocalIds {textLookup, defnLookup}, bytes)) = + CBOR.encodeVector textLookup + <> CBOR.encodeVector defnLookup + <> CBOR.encodeBytes bytes + + decode = do + textLookup <- CBOR.decodeVector + defnLookup <- CBOR.decodeVector + bytes <- CBOR.decodeBytes + pure $ ComponentBody (LocalIds.LocalIds {textLookup, defnLookup}, bytes) + +instance Serialise TempEntity where + encode = \case + Entity.TC (TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent elements)) -> + CBOR.encode TermComponentTag + <> CBOR.encodeVector (coerce @(Vector (LocalIds.LocalIds' Text Hash32, ByteString)) @(Vector (ComponentBody Text Hash32)) elements) + Entity.DC (DeclFormat.SyncDecl (DeclFormat.SyncLocallyIndexedComponent elements)) -> + CBOR.encode DeclComponentTag + <> CBOR.encodeVector (coerce @(Vector (LocalIds.LocalIds' Text Hash32, ByteString)) @(Vector (ComponentBody Text Hash32)) elements) + Entity.P (PatchFormat.SyncDiff {}) -> error "Serializing Diffs are not supported" + Entity.P (PatchFormat.SyncFull (PatchFormat.LocalIds {patchTextLookup, patchHashLookup, patchDefnLookup}) bytes) -> + CBOR.encode PatchTag + <> CBOR.encodeVector patchTextLookup + <> CBOR.encodeVector patchHashLookup + <> CBOR.encodeVector patchDefnLookup + <> CBOR.encodeBytes bytes + Entity.N (BranchFormat.SyncDiff {}) -> error "Serializing Diffs are not supported" + Entity.N (BranchFormat.SyncFull (BranchFormat.LocalIds {branchTextLookup, branchDefnLookup, branchPatchLookup, branchChildLookup}) (BranchFormat.LocalBranchBytes bytes)) -> + CBOR.encode NamespaceTag + <> CBOR.encodeVector branchTextLookup + <> CBOR.encodeVector branchDefnLookup + <> CBOR.encodeVector branchPatchLookup + <> CBOR.encodeVector branchChildLookup + <> CBOR.encodeBytes bytes + Entity.C (SqliteCausal.SyncCausalFormat {valueHash, parents}) -> + CBOR.encode CausalTag + <> CBOR.encode valueHash + <> CBOR.encodeVector parents + + decode = do + CBOR.decode >>= \case + TermComponentTag -> do + elements <- coerce @(Vector (ComponentBody Text Hash32)) @(Vector (LocalIds.LocalIds' Text Hash32, ByteString)) <$> CBOR.decodeVector + pure $ Entity.TC (TermFormat.SyncTerm (TermFormat.SyncLocallyIndexedComponent elements)) + DeclComponentTag -> do + elements <- coerce @(Vector (ComponentBody Text Hash32)) @(Vector (LocalIds.LocalIds' Text Hash32, ByteString)) <$> CBOR.decodeVector + pure $ Entity.DC (DeclFormat.SyncDecl (DeclFormat.SyncLocallyIndexedComponent elements)) + PatchTag -> do + patchTextLookup <- CBOR.decodeVector + patchHashLookup <- CBOR.decodeVector + patchDefnLookup <- CBOR.decodeVector + bytes <- CBOR.decodeBytes + pure $ Entity.P (PatchFormat.SyncFull (PatchFormat.LocalIds {patchTextLookup, patchHashLookup, patchDefnLookup}) bytes) + NamespaceTag -> do + branchTextLookup <- CBOR.decodeVector + branchDefnLookup <- CBOR.decodeVector + branchPatchLookup <- CBOR.decodeVector + branchChildLookup <- CBOR.decodeVector + bytes <- CBOR.decodeBytes + pure $ Entity.N (BranchFormat.SyncFull (BranchFormat.LocalIds {branchTextLookup, branchDefnLookup, branchPatchLookup, branchChildLookup}) (BranchFormat.LocalBranchBytes bytes)) + CausalTag -> do + valueHash <- CBOR.decode + parents <- CBOR.decodeVector + pure $ Entity.C (SqliteCausal.SyncCausalFormat {valueHash, parents}) + +encodeVectorWith :: (a -> CBOR.Encoding) -> Vector.Vector a -> CBOR.Encoding +encodeVectorWith f xs = + CBOR.encodeListLen (fromIntegral $ Vector.length xs) + <> (foldr (\a b -> f a <> b) mempty xs) + +instance Ord CBOR.DeserialiseFailure where + compare (CBOR.DeserialiseFailure o s) (CBOR.DeserialiseFailure o' s') = compare (o, s) (o', s') diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 35d7030cc8..51a1dd4538 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -56,7 +56,11 @@ module Unison.Sync.Types ) where -import Control.Lens (both, traverseOf) +import Codec.CBOR.Decoding qualified as CBOR +import Codec.CBOR.Encoding qualified as CBOR +import Codec.Serialise +import Codec.Serialise qualified as CBOR +import Control.Lens (both, foldMapOf, traverseOf) import Data.Aeson import Data.Aeson qualified as Aeson import Data.Aeson.Types qualified as Aeson @@ -73,6 +77,7 @@ import U.Codebase.Sqlite.Branch.Format (LocalBranchBytes (..)) import Unison.Hash32 (Hash32) import Unison.Hash32.Orphans.Aeson () import Unison.Prelude +import Unison.Server.Orphans () import Unison.Share.API.Hash (HashJWT) import Unison.Util.Set qualified as Set @@ -91,6 +96,7 @@ instance FromJSON Base64Bytes where newtype RepoInfo = RepoInfo {unRepoInfo :: Text} deriving newtype (Show, Eq, Ord, ToJSON, FromJSON) + deriving (Serialise) via Text data Path = Path { -- This is a nonempty list, where we require the first segment to be the repo name / user name / whatever, @@ -168,28 +174,8 @@ entityHashes_ f = \case C causal -> C <$> causalHashes_ f causal -- | Get the direct dependencies of an entity (which are actually sync'd). --- --- FIXME use generic-lens here? (typed @hash) entityDependencies :: (Ord hash) => Entity text noSyncHash hash -> Set hash -entityDependencies = \case - TC (TermComponent terms) -> flip foldMap terms \(LocalIds {hashes}, _term) -> Set.fromList hashes - DC (DeclComponent decls) -> flip foldMap decls \(LocalIds {hashes}, _decl) -> Set.fromList hashes - P Patch {newHashLookup} -> Set.fromList newHashLookup - PD PatchDiff {parent, newHashLookup} -> Set.insert parent (Set.fromList newHashLookup) - N Namespace {defnLookup, patchLookup, childLookup} -> - Set.unions - [ Set.fromList defnLookup, - Set.fromList patchLookup, - foldMap (\(namespaceHash, causalHash) -> Set.fromList [namespaceHash, causalHash]) childLookup - ] - ND NamespaceDiff {parent, defnLookup, patchLookup, childLookup} -> - Set.unions - [ Set.singleton parent, - Set.fromList defnLookup, - Set.fromList patchLookup, - foldMap (\(namespaceHash, causalHash) -> Set.fromList [namespaceHash, causalHash]) childLookup - ] - C Causal {namespaceHash, parents} -> Set.insert namespaceHash parents +entityDependencies = foldMapOf entityHashes_ Set.singleton data TermComponent text hash = TermComponent [(LocalIds text hash, ByteString)] deriving stock (Show, Eq, Functor, Ord) @@ -482,6 +468,27 @@ data EntityType | CausalType deriving stock (Eq, Ord, Show) +instance Serialise EntityType where + encode = \case + TermComponentType -> CBOR.encodeWord8 0 + DeclComponentType -> CBOR.encodeWord8 1 + PatchType -> CBOR.encodeWord8 2 + PatchDiffType -> CBOR.encodeWord8 3 + NamespaceType -> CBOR.encodeWord8 4 + NamespaceDiffType -> CBOR.encodeWord8 5 + CausalType -> CBOR.encodeWord8 6 + decode = do + tag <- CBOR.decodeWord8 + case tag of + 0 -> pure TermComponentType + 1 -> pure DeclComponentType + 2 -> pure PatchType + 3 -> pure PatchDiffType + 4 -> pure NamespaceType + 5 -> pure NamespaceDiffType + 6 -> pure CausalType + _ -> fail "invalid tag" + instance ToJSON EntityType where toJSON = String . \case @@ -618,6 +625,43 @@ data EntityValidationError deriving stock (Show, Eq, Ord) deriving anyclass (Exception) +data EntityValidationErrorTag + = HashMismatchTag + | UnsupportedTypeTag + | InvalidByteEncodingTag + | HashResolutionFailureTag + deriving stock (Eq, Show) + +instance Serialise EntityValidationErrorTag where + encode = \case + HashMismatchTag -> CBOR.encodeWord8 0 + UnsupportedTypeTag -> CBOR.encodeWord8 1 + InvalidByteEncodingTag -> CBOR.encodeWord8 2 + HashResolutionFailureTag -> CBOR.encodeWord8 3 + decode = do + tag <- CBOR.decodeWord8 + case tag of + 0 -> pure HashMismatchTag + 1 -> pure UnsupportedTypeTag + 2 -> pure InvalidByteEncodingTag + 3 -> pure HashResolutionFailureTag + _ -> fail "invalid tag" + +instance Serialise EntityValidationError where + encode = \case + EntityHashMismatch typ mismatch -> CBOR.encode HashMismatchTag <> CBOR.encode typ <> CBOR.encode mismatch + UnsupportedEntityType hash typ -> CBOR.encode UnsupportedTypeTag <> CBOR.encode hash <> CBOR.encode typ + InvalidByteEncoding hash typ errMsg -> CBOR.encode InvalidByteEncodingTag <> CBOR.encode hash <> CBOR.encode typ <> CBOR.encode errMsg + HashResolutionFailure hash -> CBOR.encode HashResolutionFailureTag <> CBOR.encode hash + + decode = do + tag <- CBOR.decode + case tag of + HashMismatchTag -> EntityHashMismatch <$> CBOR.decode <*> CBOR.decode + UnsupportedTypeTag -> UnsupportedEntityType <$> CBOR.decode <*> CBOR.decode + InvalidByteEncodingTag -> InvalidByteEncoding <$> CBOR.decode <*> CBOR.decode <*> CBOR.decode + HashResolutionFailureTag -> HashResolutionFailure <$> CBOR.decode + instance ToJSON EntityValidationError where toJSON = \case EntityHashMismatch typ mismatch -> jsonUnion "mismatched_hash" (object ["type" .= typ, "mismatch" .= mismatch]) @@ -693,6 +737,10 @@ data HashMismatchForEntity = HashMismatchForEntity } deriving stock (Show, Eq, Ord) +instance Serialise HashMismatchForEntity where + encode (HashMismatchForEntity supplied computed) = CBOR.encode supplied <> CBOR.encode computed + decode = HashMismatchForEntity <$> CBOR.decode <*> CBOR.decode + instance ToJSON UploadEntitiesResponse where toJSON = \case UploadEntitiesSuccess -> jsonUnion "success" (Object mempty) diff --git a/unison-share-api/tests/Main.hs b/unison-share-api/tests/Main.hs new file mode 100644 index 0000000000..232452d79b --- /dev/null +++ b/unison-share-api/tests/Main.hs @@ -0,0 +1,23 @@ +module Main where + +import EasyTest +import System.Environment (getArgs) +import System.IO +import System.IO.CodePage (withCP65001) +import Unison.Test.Sync.Roundtrip qualified as SyncRoundtrip + +test :: Test () +test = + tests + [ SyncRoundtrip.test + ] + +main :: IO () +main = withCP65001 do + args <- getArgs + mapM_ (`hSetEncoding` utf8) [stdout, stdin, stderr] + case args of + [] -> runOnly "" test + [prefix] -> runOnly prefix test + [seed, prefix] -> rerunOnly (read seed) prefix test + _ -> error "expected no args, a prefix, or a seed and a prefix" diff --git a/unison-share-api/tests/Unison/Test/Sync/Gen.hs b/unison-share-api/tests/Unison/Test/Sync/Gen.hs new file mode 100644 index 0000000000..8e45bc1445 --- /dev/null +++ b/unison-share-api/tests/Unison/Test/Sync/Gen.hs @@ -0,0 +1,93 @@ +-- | Hedghog generators for Sync types. +module Unison.Test.Sync.Gen + ( genTempEntity, + ) +where + +import Data.ByteString (ByteString) +import Data.ByteString.Short qualified as BShort +import Data.Text (Text) +import Data.Vector qualified as Vector +import Hedgehog +import Hedgehog.Gen qualified as Gen +import Hedgehog.Range qualified as Range +import U.Codebase.Sqlite.Branch.Format qualified as BranchFormat +import U.Codebase.Sqlite.Causal qualified as CausalFormat +import U.Codebase.Sqlite.Decl.Format qualified as DeclFormat +import U.Codebase.Sqlite.Entity qualified as Entity +import U.Codebase.Sqlite.LocalIds qualified as LocalIds +import U.Codebase.Sqlite.Patch.Format qualified as PatchFormat +import U.Codebase.Sqlite.TempEntity (TempEntity) +import U.Codebase.Sqlite.Term.Format qualified as TermFormat +import Unison.Hash (Hash (..)) +import Unison.Hash32 (Hash32) +import Unison.Hash32 qualified as Hash32 + +genTempEntity :: Gen TempEntity +genTempEntity = do + Gen.choice + [ Entity.TC <$> genSyncTermFormat, + Entity.DC <$> genSyncDeclFormat, + Entity.P <$> genPatchFormat, + Entity.N <$> genNamespaceFormat, + Entity.C <$> genCausalFormat + ] + +genSyncTermFormat :: Gen (TermFormat.SyncTermFormat' Text Hash32) +genSyncTermFormat = do + elems <- Gen.list (Range.linear 1 4) do + localIds <- genLocalIds + term <- genBodyBytes + pure (localIds, term) + pure $ TermFormat.SyncTerm $ TermFormat.SyncLocallyIndexedComponent $ Vector.fromList elems + +genSyncDeclFormat :: Gen (DeclFormat.SyncDeclFormat' Text Hash32) +genSyncDeclFormat = do + elems <- Gen.list (Range.linear 1 4) do + localIds <- genLocalIds + decl <- genBodyBytes + pure (localIds, decl) + pure $ DeclFormat.SyncDecl $ DeclFormat.SyncLocallyIndexedComponent $ Vector.fromList elems + +genPatchFormat :: Gen (PatchFormat.SyncPatchFormat' Hash32 Text Hash32 Hash32) +genPatchFormat = do + patchTextLookup <- Vector.fromList <$> Gen.list (Range.linear 0 5) genTextLiteral + patchHashLookup <- Vector.fromList <$> Gen.list (Range.linear 0 5) genHash32 + patchDefnLookup <- Vector.fromList <$> Gen.list (Range.linear 0 5) genHash32 + let localIds = PatchFormat.LocalIds {patchTextLookup, patchHashLookup, patchDefnLookup} + body <- genBodyBytes + pure $ PatchFormat.SyncFull localIds body + +genNamespaceFormat :: Gen (BranchFormat.SyncBranchFormat' Hash32 Text Hash32 Hash32 (Hash32, Hash32)) +genNamespaceFormat = do + branchTextLookup <- Vector.fromList <$> Gen.list (Range.linear 0 5) genTextLiteral + branchDefnLookup <- Vector.fromList <$> Gen.list (Range.linear 0 5) genHash32 + branchPatchLookup <- Vector.fromList <$> Gen.list (Range.linear 0 5) genHash32 + branchChildLookup <- Vector.fromList <$> Gen.list (Range.linear 0 5) ((,) <$> genHash32 <*> genHash32) + let branchLocalIds = BranchFormat.LocalIds {branchTextLookup, branchDefnLookup, branchPatchLookup, branchChildLookup} + body <- BranchFormat.LocalBranchBytes <$> genBodyBytes + pure $ BranchFormat.SyncFull branchLocalIds body + +genCausalFormat :: Gen (CausalFormat.SyncCausalFormat' Hash32 Hash32) +genCausalFormat = do + valueHash <- genHash32 + parents <- Vector.fromList <$> Gen.list (Range.linear 0 5) genHash32 + pure $ CausalFormat.SyncCausalFormat {valueHash, parents} + +genBodyBytes :: Gen ByteString +genBodyBytes = Gen.bytes (Range.linear 0 100) + +genLocalIds :: Gen (LocalIds.LocalIds' Text Hash32) +genLocalIds = do + textLookup <- Vector.fromList <$> Gen.list (Range.linear 0 10) genTextLiteral + defnLookup <- Vector.fromList <$> Gen.list (Range.linear 0 10) genHash32 + pure $ LocalIds.LocalIds {textLookup, defnLookup} + +genHash32 :: Gen Hash32 +genHash32 = Hash32.fromHash <$> genHash + +genHash :: Gen Hash +genHash = Hash . BShort.toShort <$> Gen.bytes (Range.singleton 64) + +genTextLiteral :: Gen Text +genTextLiteral = Gen.text (Range.linear 0 100) Gen.unicodeAll diff --git a/unison-share-api/tests/Unison/Test/Sync/Roundtrip.hs b/unison-share-api/tests/Unison/Test/Sync/Roundtrip.hs new file mode 100644 index 0000000000..fb83748817 --- /dev/null +++ b/unison-share-api/tests/Unison/Test/Sync/Roundtrip.hs @@ -0,0 +1,29 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Roundtrip tests for types used in sync. +module Unison.Test.Sync.Roundtrip (Unison.Test.Sync.Roundtrip.test) where + +import Codec.Serialise qualified as Serialise +import EasyTest qualified as EasyTest +import Hedgehog hiding (Test, test) +import Unison.Prelude +import Unison.Server.Orphans () +import Unison.Test.Sync.Gen qualified as Gen + +test :: EasyTest.Test () +test = + void . EasyTest.scope "syncv2.roundtrip" $ do + success <- + EasyTest.io $ + checkParallel $ + Group + "syncv2.roundtrip" + [ ("termComponentRoundtrip", termComponentRoundtrip) + ] + EasyTest.expect success + +termComponentRoundtrip :: Property +termComponentRoundtrip = + property $ do + te <- forAll $ Gen.genTempEntity + (Serialise.deserialise . Serialise.serialise $ te) === te diff --git a/unison-share-api/unison-share-api.cabal b/unison-share-api/unison-share-api.cabal index 52cb824d14..5013cc64d2 100644 --- a/unison-share-api/unison-share-api.cabal +++ b/unison-share-api/unison-share-api.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.37.0. -- -- see: https://github.com/sol/hpack @@ -48,7 +48,10 @@ library Unison.Sync.Common Unison.Sync.EntityValidation Unison.Sync.Types + Unison.SyncV2.API + Unison.SyncV2.Types Unison.Util.Find + Unison.Util.Servant.CBOR hs-source-dirs: src default-extensions: @@ -90,6 +93,7 @@ library , binary , bytes , bytestring + , cborg , containers , directory , errors @@ -105,6 +109,7 @@ library , nonempty-containers , openapi3 , regex-tdfa + , serialise , servant , servant-docs , servant-openapi3 @@ -126,6 +131,108 @@ library , unison-share-projects-api , unison-sqlite , unison-syntax + , unison-util-base32hex + , unison-util-relation + , unliftio + , uri-encode + , utf8-string + , vector + , wai + , wai-cors + , warp + , yaml + default-language: Haskell2010 + +test-suite unison-share-api-tests + type: exitcode-stdio-1.0 + main-is: Main.hs + other-modules: + Unison.Test.Sync.Gen + Unison.Test.Sync.Roundtrip + hs-source-dirs: + tests + default-extensions: + BlockArguments + ConstraintKinds + DeriveAnyClass + DeriveFunctor + DeriveGeneric + DerivingStrategies + DerivingVia + DoAndIfThenElse + DuplicateRecordFields + FlexibleContexts + FlexibleInstances + GADTs + GeneralizedNewtypeDeriving + KindSignatures + ImportQualifiedPost + LambdaCase + MultiParamTypeClasses + NamedFieldPuns + NumericUnderscores + OverloadedStrings + PatternSynonyms + RankNTypes + ScopedTypeVariables + StandaloneDeriving + TupleSections + TypeApplications + TypeOperators + ViewPatterns + ImportQualifiedPost + ghc-options: -Wall + build-depends: + Diff + , aeson >=2.0.0.0 + , async + , base + , binary + , bytes + , bytestring + , cborg + , code-page + , containers + , directory + , easytest + , errors + , extra + , filepath + , fuzzyfind + , hedgehog + , http-media + , http-types + , lens + , lucid + , memory + , mtl + , nonempty-containers + , openapi3 + , regex-tdfa + , serialise + , servant + , servant-docs + , servant-openapi3 + , servant-server + , text + , transformers + , unison-codebase + , unison-codebase-sqlite + , unison-codebase-sqlite-hashing-v2 + , unison-core + , unison-core1 + , unison-hash + , unison-hash-orphans-aeson + , unison-hashing-v2 + , unison-parser-typechecker + , unison-prelude + , unison-pretty-printer + , unison-runtime + , unison-share-api + , unison-share-projects-api + , unison-sqlite + , unison-syntax + , unison-util-base32hex , unison-util-relation , unliftio , uri-encode