Merge pull request #5543 from unisonweb/syncv2/file-sync

Allow syncing to/from a local file

Author: aryairani

.gitignore

@@ -27,6 +27,7 @@ dist-newstyle
 *.prof.html
 *.hp
 *.ps
+*.profiterole.*
 /.direnv/
 /.envrc
 

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)
 

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

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
 

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

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
 

codebase2/codebase-sqlite/U/Codebase/Sqlite/Patch/Format.hs

@@ -40,13 +40,15 @@ data PatchLocalIds' t h d = LocalIds
     patchHashLookup :: Vector h,
     patchDefnLookup :: Vector d
   }
+  deriving stock (Eq, Show)
 
 type SyncPatchFormat = SyncPatchFormat' PatchObjectId TextId HashId ObjectId
 
 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

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

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
 

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"
 

lib/unison-sqlite/src/Unison/Sqlite.hs

@@ -19,6 +19,7 @@ module Unison.Sqlite
     Transaction,
     runTransaction,
     runTransactionWithRollback,
+    runTransactionExceptT,
     runReadOnlyTransaction,
     runWriteTransaction,
     cacheTransaction,

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

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 ->

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

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

@@ -49,6 +49,7 @@ module Unison.Cli.MonadUtils
     stepManyAtM,
     updateProjectBranchRoot,
     updateProjectBranchRoot_,
+    setProjectBranchRootToCausalHash,
     updateAtM,
     updateAt,
     updateAndStepAt,
@@ -454,6 +455,13 @@ updateProjectBranchRoot projectBranch reason f = do
         liftIO (env.lspCheckForChanges projectPathIds)
     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, ()))

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

@@ -88,6 +88,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)
@@ -668,6 +669,13 @@ 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
+              SyncV2.handleSyncFromCodebase description srcCodebasePath srcBranch destBranch
             ListDependentsI hq -> handleDependents hq
             ListDependenciesI hq -> handleDependencies hq
             NamespaceDependenciesI path -> handleNamespaceDependencies path
@@ -992,6 +1000,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

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

@@ -0,0 +1,71 @@
+module Unison.Codebase.Editor.HandleInput.SyncV2
+  ( handleSyncToFile,
+    handleSyncFromFile,
+    handleSyncFromCodebase,
+  )
+where
+
+import Control.Lens
+import Control.Monad.Reader (MonadReader (..))
+import U.Codebase.Sqlite.Queries qualified as Q
+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.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 (Output.SyncFromCodebaseMissingProjectBranch srcBranch)
+        Just srcCausalHash -> do
+          let shouldValidate = True
+          Right . fmap (const srcCausalHash) <$> liftIO (SyncV2.syncFromCodebase shouldValidate srcConn codebase srcCausalHash)
+
+  case r of
+    Left openCodebaseErr -> Cli.respond (Output.OpenCodebaseError srcCodebasePath openCodebaseErr)
+    Right (Left errOutput) -> Cli.respond errOutput
+    Right (Right (Right causalHash)) -> do
+      Cli.setProjectBranchRootToCausalHash (projectBranch ^. #branch) description causalHash
+    Right (Right (Left syncErr)) -> do
+      Cli.respond (Output.SyncPullError syncErr)

unison-cli/src/Unison/Codebase/Editor/Input.hs

@@ -136,6 +136,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 (ProjectAndBranch ProjectName ProjectBranchName) UnresolvedProjectBranch
   | ResetI (BranchId2 {- namespace to reset it to -}) (Maybe UnresolvedProjectBranch {- ProjectBranch to reset -})
   | -- | used in Welcome module to give directions to user
     --

unison-cli/src/Unison/Codebase/Editor/Output.hs

@@ -35,6 +35,7 @@ import U.Codebase.Sqlite.ProjectReflog qualified as ProjectReflog
 import Unison.Auth.Types (CredentialFailure)
 import Unison.Cli.MergeTypes (MergeSourceAndTarget, MergeSourceOrTarget)
 import Unison.Cli.Share.Projects.Types qualified as Share
+import Unison.Codebase (CodebasePath)
 import Unison.Codebase.Editor.Input
 import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput)
 import Unison.Codebase.Editor.Output.BranchDiff qualified as BD
@@ -43,6 +44,7 @@ import Unison.Codebase.Editor.RemoteRepo
 import Unison.Codebase.Editor.SlurpResult (SlurpResult (..))
 import Unison.Codebase.Editor.SlurpResult qualified as SR
 import Unison.Codebase.Editor.StructuredArgument (StructuredArgument)
+import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError)
 import Unison.Codebase.IntegrityCheck (IntegrityResult (..))
 import Unison.Codebase.Path (Path')
 import Unison.Codebase.Path qualified as Path
@@ -80,6 +82,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)
@@ -442,6 +445,9 @@ 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)
+  | SyncFromCodebaseMissingProjectBranch (ProjectAndBranch ProjectName ProjectBranchName)
+  | OpenCodebaseError CodebasePath OpenCodebaseError
 
 data MoreEntriesThanShown = MoreEntriesThanShown | AllEntriesShown
   deriving (Eq, Show)
@@ -680,6 +686,9 @@ isFailure o = case o of
   IncoherentDeclDuringMerge {} -> True
   IncoherentDeclDuringUpdate {} -> True
   Literal _ -> False
+  SyncPullError {} -> True
+  SyncFromCodebaseMissingProjectBranch {} -> True
+  OpenCodebaseError {} -> True
 
 isNumberedFailure :: NumberedOutput -> Bool
 isNumberedFailure = \case