Merge remote-tracking branch 'origin/arya/ooo-sync' into arya/ooo-sync

codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs

@@ -4,6 +4,8 @@ module U.Codebase.Sqlite.Operations
     loadRootCausalHash,
     expectRootCausalHash,
     expectRootCausal,
+    loadCausalHashAtPath,
+    expectCausalHashAtPath,
     saveBranch,
     loadCausalBranchByCausalHash,
     expectCausalBranchByCausalHash,
@@ -196,6 +198,40 @@ loadRootCausalHash =
   runMaybeT $
     lift . Q.expectCausalHash =<< MaybeT Q.loadNamespaceRoot
 
+-- | Load the causal hash at the given path from the root.
+--
+-- FIXME should we move some Path type here?
+loadCausalHashAtPath :: [Text] -> Transaction (Maybe CausalHash)
+loadCausalHashAtPath =
+  let go :: Db.CausalHashId -> [Text] -> MaybeT Transaction CausalHash
+      go hashId = \case
+        [] -> lift (Q.expectCausalHash hashId)
+        t : ts -> do
+          tid <- MaybeT (Q.loadTextId t)
+          S.Branch{children} <- MaybeT (loadDbBranchByCausalHashId hashId)
+          (_, hashId') <- MaybeT (pure (Map.lookup tid children))
+          go hashId' ts
+  in \path -> do
+    hashId <- Q.expectNamespaceRoot
+    runMaybeT (go hashId path)
+
+-- | Expect the causal hash at the given path from the root.
+--
+-- FIXME should we move some Path type here?
+expectCausalHashAtPath :: [Text] -> Transaction CausalHash
+expectCausalHashAtPath =
+  let go :: Db.CausalHashId -> [Text] -> Transaction CausalHash
+      go hashId = \case
+        [] -> Q.expectCausalHash hashId
+        t : ts -> do
+          tid <- Q.expectTextId t
+          S.Branch{children} <- expectDbBranchByCausalHashId hashId
+          let (_, hashId') = children Map.! tid
+          go hashId' ts
+  in \path -> do
+    hashId <- Q.expectNamespaceRoot
+    go hashId path
+
 -- * Reference transformations
 
 -- ** read existing references
@@ -946,6 +982,19 @@ expectBranchByCausalHashId id = do
   boId <- Q.expectBranchObjectIdByCausalHashId id
   expectBranch boId
 
+-- | Load a branch value given its causal hash id.
+loadDbBranchByCausalHashId :: Db.CausalHashId -> Transaction (Maybe S.DbBranch)
+loadDbBranchByCausalHashId causalHashId =
+  Q.loadBranchObjectIdByCausalHashId causalHashId >>= \case
+    Nothing -> pure Nothing
+    Just branchObjectId -> Just <$> expectDbBranch branchObjectId
+
+-- | Expect a branch value given its causal hash id.
+expectDbBranchByCausalHashId :: Db.CausalHashId -> Transaction S.DbBranch
+expectDbBranchByCausalHashId causalHashId = do
+  branchObjectId <- Q.expectBranchObjectIdByCausalHashId causalHashId
+  expectDbBranch branchObjectId
+
 expectDbBranch :: Db.BranchObjectId -> Transaction S.DbBranch
 expectDbBranch id =
   deserializeBranchObject id >>= \case

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

@@ -11,6 +11,7 @@ where
 import qualified Control.Error.Util as ErrorUtil
 import Control.Lens
 import Control.Monad.Except (ExceptT (..), runExceptT, throwError, withExceptT)
+import Control.Monad.Reader (ask)
 import Control.Monad.State (StateT)
 import qualified Control.Monad.State as State
 import Data.Bifunctor (first, second)
@@ -27,6 +28,8 @@ import qualified Data.Set.NonEmpty as NESet
 import qualified Data.Text as Text
 import Data.Tuple.Extra (uncurry3)
 import qualified Text.Megaparsec as P
+import U.Codebase.HashTags (CausalHash)
+import qualified U.Codebase.Sqlite.Operations as Ops
 import U.Util.Timing (unsafeTime)
 import qualified Unison.ABT as ABT
 import Unison.Auth.Types (Host (Host))
@@ -130,7 +133,14 @@ import qualified Unison.Share.Sync as Share
 import qualified Unison.ShortHash as SH
 import qualified Unison.Sqlite as Sqlite
 import Unison.Symbol (Symbol)
-import qualified Unison.Sync.Types as Share (RepoName (..), RepoPath (..), hashJWTHash)
+import qualified Unison.Sync.Types as Share
+  ( Hash,
+    HashMismatch (..),
+    RepoName (..),
+    RepoPath (..),
+    hashJWTHash,
+  )
+import qualified Unison.Sync.Types as Share.TypedHash (TypedHash (..))
 import Unison.Term (Term)
 import qualified Unison.Term as Term
 import Unison.Type (Type)
@@ -1693,6 +1703,18 @@ handleGist :: MonadUnliftIO m => GistInput -> Action' m v ()
 handleGist (GistInput repo) =
   doPushRemoteBranch repo Path.relativeEmpty' SyncMode.ShortCircuit Nothing
 
+handlePullFromUnisonShare :: MonadIO m => Text -> Path -> Action' m v ()
+handlePullFromUnisonShare remoteRepo remotePath = do
+  let repoPath = Share.RepoPath (Share.RepoName remoteRepo) (coerce @[NameSegment] @[Text] (Path.toList remotePath))
+
+  LoopState.Env {authHTTPClient, codebase = Codebase {connection}, unisonShareUrl} <- ask
+
+  liftIO (Share.pull authHTTPClient unisonShareUrl connection repoPath) >>= \case
+    Left (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission _)) -> undefined
+    Right Nothing -> undefined
+    Right (Just causalHash) -> do
+      undefined
+
 -- | Handle a @push@ command.
 handlePushRemoteBranch ::
   forall m v.
@@ -1764,29 +1786,37 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do
 handlePushToUnisonShare :: MonadIO m => Text -> Path -> Action' m v ()
 handlePushToUnisonShare remoteRepo remotePath = do
   let repoPath = Share.RepoPath (Share.RepoName remoteRepo) (coerce @[NameSegment] @[Text] (Path.toList remotePath))
-  Codebase {connection} <- LoopState.askCodebase
 
-  liftIO (Share.getCausalHashByPath httpClient unisonShareUrl repoPath) >>= \case
-    Left err -> undefined
-    Right causalHashJwt -> do
-      localCausalHash <- do
-        localPath <- use LoopState.currentPath
-        Sqlite.runTransaction connection (undefined (Path.toList (Path.unabsolute localPath)))
-      liftIO
-        ( Share.push
-            httpClient
-            unisonShareUrl
-            connection
-            repoPath
-            (Share.hashJWTHash <$> causalHashJwt)
-            localCausalHash
-        )
-        >>= \case
-          Left pushError -> undefined
+  LoopState.Env {authHTTPClient, codebase = Codebase {connection}, unisonShareUrl} <- ask
+
+  -- First, get the remote causal's hash at the requested path. This effectively gives `push.share` force-push
+  -- semantics, as the user doesn't provide the expected remote hash themselves, ala `git push --force-with-lease`.
+  -- Then, with our trusty remote causal hash, do the push.
+
+  localCausalHash <- do
+    localPath <- use LoopState.currentPath
+    Sqlite.runTransaction connection do
+      Ops.expectCausalHashAtPath (coerce @[NameSegment] @[Text] (Path.toList (Path.unabsolute localPath)))
+
+  let doPush :: Maybe Share.Hash -> IO ()
+      doPush expectedHash =
+        Share.push authHTTPClient unisonShareUrl connection repoPath expectedHash localCausalHash >>= \case
+          Left pushError ->
+            case pushError of
+              -- Race condition: inbetween getting the remote causal hash and attempting to overwrite it, it changed.
+              -- So, because this push has force-push semantics anyway, just loop again with the latest known remote
+              -- causal hash and attempt the push again.
+              Share.PushErrorHashMismatch Share.HashMismatch {actualHash} ->
+                doPush (Share.TypedHash.hash <$> actualHash)
+              Share.PushErrorNoWritePermission _ -> undefined
+              -- Meh; bug in client or server? Even though we (thought we) pushed all of the entities we were supposed
+              -- to, the server still said it was missing some when we tried to set the remote causal hash.
+              Share.PushErrorServerMissingDependencies missingDependencies -> undefined
           Right () -> pure ()
-  where
-    httpClient = undefined
-    unisonShareUrl = undefined
+
+  liftIO (Share.getCausalHashByPath authHTTPClient unisonShareUrl repoPath) >>= \case
+    Left (Share.GetCausalHashByPathErrorNoReadPermission _) -> undefined
+    Right causalHashJwt -> liftIO (doPush (Share.hashJWTHash <$> causalHashJwt))
 
 -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`.
 handleShowDefinition ::