From 422ee31a2916dd45d378127a8077bd4a18c5dffa Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 29 Apr 2022 16:15:15 -0400 Subject: [PATCH 1/3] write loadCausalHashAtPath --- .../U/Codebase/Sqlite/Operations.hs | 25 +++++++++++++++++++ 1 file changed, 25 insertions(+) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index b48790bfe..5a370cd68 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -4,6 +4,7 @@ module U.Codebase.Sqlite.Operations loadRootCausalHash, expectRootCausalHash, expectRootCausal, + loadCausalHashAtPath, saveBranch, loadCausalBranchByCausalHash, expectCausalBranchByCausalHash, @@ -196,6 +197,23 @@ 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) + -- * Reference transformations -- ** read existing references @@ -946,6 +964,13 @@ 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 + expectDbBranch :: Db.BranchObjectId -> Transaction S.DbBranch expectDbBranch id = deserializeBranchObject id >>= \case From e1bb80722afcf3c7ea4936dc4d0d2c08ec6eb622 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Sat, 30 Apr 2022 13:03:53 -0400 Subject: [PATCH 2/3] more push.share work --- .../U/Codebase/Sqlite/Operations.hs | 24 +++++++++++++++++++ .../src/Unison/Codebase/Editor/HandleInput.hs | 20 ++++++++++------ 2 files changed, 37 insertions(+), 7 deletions(-) diff --git a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs index 5a370cd68..e741143ab 100644 --- a/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs +++ b/codebase2/codebase-sqlite/U/Codebase/Sqlite/Operations.hs @@ -5,6 +5,7 @@ module U.Codebase.Sqlite.Operations expectRootCausalHash, expectRootCausal, loadCausalHashAtPath, + expectCausalHashAtPath, saveBranch, loadCausalBranchByCausalHash, expectCausalBranchByCausalHash, @@ -214,6 +215,23 @@ loadCausalHashAtPath = 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 @@ -971,6 +989,12 @@ loadDbBranchByCausalHashId causalHashId = 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 diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 207c058dd..36f34b940 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/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,11 +28,13 @@ 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 U.Util.Timing (unsafeTime) import qualified Unison.ABT as ABT import Unison.Auth.Types (Host (Host)) import qualified Unison.Builtin as Builtin import qualified Unison.Builtin.Decls as DD +import qualified U.Codebase.Sqlite.Operations as Ops import qualified Unison.Builtin.Terms as Builtin import Unison.Codebase (Preprocessing (..), PushGitBranchOpts (..)) import Unison.Codebase.Branch (Branch (..), Branch0 (..)) @@ -1764,17 +1767,23 @@ 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 + 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. + + liftIO (Share.getCausalHashByPath authHTTPClient unisonShareUrl repoPath) >>= \case Left err -> undefined Right causalHashJwt -> do localCausalHash <- do localPath <- use LoopState.currentPath - Sqlite.runTransaction connection (undefined (Path.toList (Path.unabsolute localPath))) + Sqlite.runTransaction connection do + Ops.expectCausalHashAtPath (coerce @[NameSegment] @[Text] (Path.toList (Path.unabsolute localPath))) liftIO ( Share.push - httpClient + authHTTPClient unisonShareUrl connection repoPath @@ -1784,9 +1793,6 @@ handlePushToUnisonShare remoteRepo remotePath = do >>= \case Left pushError -> undefined Right () -> pure () - where - httpClient = undefined - unisonShareUrl = undefined -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`. handleShowDefinition :: From ca006c6f7c4209fc011de014373dca15d3ad2f31 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Sat, 30 Apr 2022 18:31:59 -0400 Subject: [PATCH 3/3] push/pull work --- .../src/Unison/Codebase/Editor/HandleInput.hs | 64 +++++++++++++------ 1 file changed, 44 insertions(+), 20 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 36f34b940..68b43ff01 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -29,12 +29,12 @@ 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)) import qualified Unison.Builtin as Builtin import qualified Unison.Builtin.Decls as DD -import qualified U.Codebase.Sqlite.Operations as Ops import qualified Unison.Builtin.Terms as Builtin import Unison.Codebase (Preprocessing (..), PushGitBranchOpts (..)) import Unison.Codebase.Branch (Branch (..), Branch0 (..)) @@ -133,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) @@ -1696,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. @@ -1774,26 +1793,31 @@ handlePushToUnisonShare remoteRepo remotePath = do -- 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. - liftIO (Share.getCausalHashByPath authHTTPClient unisonShareUrl repoPath) >>= \case - Left err -> undefined - Right causalHashJwt -> do - localCausalHash <- do - localPath <- use LoopState.currentPath - Sqlite.runTransaction connection do - Ops.expectCausalHashAtPath (coerce @[NameSegment] @[Text] (Path.toList (Path.unabsolute localPath))) - liftIO - ( Share.push - authHTTPClient - unisonShareUrl - connection - repoPath - (Share.hashJWTHash <$> causalHashJwt) - localCausalHash - ) - >>= \case - Left pushError -> undefined + 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 () + 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 :: forall m v.