From 83192412ad8dc9c8cf84c07a963735a5d6fa20db Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Mon, 9 May 2022 17:32:41 -0400 Subject: [PATCH 01/19] initial work on making ReadRepo a sum type --- .../src/Unison/Codebase/Editor/Git.hs | 6 ++-- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 32 +++++++++++++++---- .../src/Unison/Codebase/GitError.hs | 24 +++++++------- .../src/Unison/Codebase/SqliteCodebase.hs | 22 +++++++++---- .../Codebase/SqliteCodebase/GitError.hs | 8 ++--- .../src/Unison/Codebase/Type.hs | 8 ++--- 6 files changed, 64 insertions(+), 36 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs index a11ccbd14..1fabb1cbd 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/Git.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/Git.hs @@ -28,7 +28,7 @@ import Shellmet (($?), ($^), ($|)) import System.Exit (ExitCode (ExitSuccess)) import System.FilePath (()) import System.IO.Unsafe (unsafePerformIO) -import Unison.Codebase.Editor.RemoteRepo (ReadRepo (..)) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo(..)) import Unison.Codebase.GitError (GitProtocolError) import qualified Unison.Codebase.GitError as GitError import Unison.Prelude @@ -136,7 +136,7 @@ data GitBranchBehavior withRepo :: forall m a. (MonadUnliftIO m) => - ReadRepo -> + ReadGitRepo -> GitBranchBehavior -> (GitRepo -> m a) -> m (Either GitProtocolError a) @@ -209,7 +209,7 @@ withRepo repo@(ReadGitRepo {url = uri, ref = mayGitRef}) branchBehavior action = pure succeeded -- | Do a `git clone` (for a not-previously-cached repo). -cloneIfMissing :: (MonadIO m, MonadError GitProtocolError m) => ReadRepo -> FilePath -> m GitRepo +cloneIfMissing :: (MonadIO m, MonadError GitProtocolError m) => ReadGitRepo -> FilePath -> m GitRepo cloneIfMissing repo@(ReadGitRepo {url = uri}) localPath = do doesDirectoryExist localPath >>= \case True -> diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 67e572e6d..c9e23adfe 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -11,21 +11,37 @@ import Unison.Codebase.ShortBranchHash (ShortBranchHash) import qualified Unison.Codebase.ShortBranchHash as SBH import Unison.Prelude -data ReadRepo = ReadGitRepo {url :: Text, ref :: Maybe Text} deriving (Eq, Ord, Show) +data ReadRepo + = ReadRepoGit ReadGitRepo + deriving (Show) -data WriteRepo = WriteGitRepo {url' :: Text, branch :: Maybe Text} deriving (Eq, Ord, Show) +data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text} + deriving (Show) + +data WriteRepo = WriteRepoGit WriteGitRepo + deriving (Show) + +data WriteGitRepo = WriteGitRepo {url' :: Text, branch :: Maybe Text} + deriving (Show) writeToRead :: WriteRepo -> ReadRepo -writeToRead (WriteGitRepo {url', branch}) = ReadGitRepo {url = url', ref = branch} +writeToRead = \case + WriteRepoGit repo -> ReadRepoGit (writeToReadGit repo) + +writeToReadGit :: WriteGitRepo -> ReadGitRepo +writeToReadGit = \case + WriteGitRepo {url', branch} -> ReadGitRepo {url = url', ref = branch} writePathToRead :: WriteRemotePath -> ReadRemoteNamespace writePathToRead (w, p) = (writeToRead w, Nothing, p) printReadRepo :: ReadRepo -> Text -printReadRepo ReadGitRepo {url, ref} = url <> Monoid.fromMaybe (Text.cons ':' <$> ref) +printReadRepo = \case + ReadRepoGit ReadGitRepo {url, ref} -> url <> Monoid.fromMaybe (Text.cons ':' <$> ref) printWriteRepo :: WriteRepo -> Text -printWriteRepo WriteGitRepo {url', branch} = url' <> Monoid.fromMaybe (Text.cons ':' <$> branch) +printWriteRepo = \case + WriteRepoGit WriteGitRepo {url', branch} -> url' <> Monoid.fromMaybe (Text.cons ':' <$> branch) printNamespace :: ReadRepo -> Maybe ShortBranchHash -> Path -> Text printNamespace repo sbh path = @@ -45,6 +61,10 @@ printHead repo path = printWriteRepo repo <> if path == Path.empty then mempty else ":." <> Path.toText path -type ReadRemoteNamespace = (ReadRepo, Maybe ShortBranchHash, Path) +type GReadRemoteNamespace a = (a, Maybe ShortBranchHash, Path) + +type ReadRemoteNamespace = GReadRemoteNamespace ReadRepo + +type ReadGitRemoteNamespace = GReadRemoteNamespace ReadGitRepo type WriteRemotePath = (WriteRepo, Path) diff --git a/parser-typechecker/src/Unison/Codebase/GitError.hs b/parser-typechecker/src/Unison/Codebase/GitError.hs index 8cccd2819..728449350 100644 --- a/parser-typechecker/src/Unison/Codebase/GitError.hs +++ b/parser-typechecker/src/Unison/Codebase/GitError.hs @@ -2,7 +2,7 @@ module Unison.Codebase.GitError where -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo, WriteRepo) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadGitRepo, WriteGitRepo) import Unison.Codebase.Path import Unison.Codebase.ShortBranchHash (ShortBranchHash) import Unison.Prelude @@ -11,15 +11,15 @@ type CodebasePath = FilePath data GitProtocolError = NoGit - | UnrecognizableCacheDir ReadRepo CodebasePath - | UnrecognizableCheckoutDir ReadRepo CodebasePath + | UnrecognizableCacheDir ReadGitRepo CodebasePath + | UnrecognizableCheckoutDir ReadGitRepo CodebasePath | -- srcPath destPath error-description CopyException FilePath FilePath String - | CloneException ReadRepo String - | PushException WriteRepo String - | PushNoOp WriteRepo + | CloneException ReadGitRepo String + | PushException WriteGitRepo String + | PushNoOp WriteGitRepo | -- url commit Diff of what would change on merge with remote - PushDestinationHasNewStuff WriteRepo + PushDestinationHasNewStuff WriteGitRepo | CleanupError SomeException | -- Thrown when a commit, tag, or branch isn't found in a repo. -- repo ref @@ -28,10 +28,10 @@ data GitProtocolError deriving anyclass (Exception) data GitCodebaseError h - = NoRemoteNamespaceWithHash ReadRepo ShortBranchHash - | RemoteNamespaceHashAmbiguous ReadRepo ShortBranchHash (Set h) - | CouldntLoadRootBranch ReadRepo h - | CouldntParseRemoteBranch ReadRepo String + = NoRemoteNamespaceWithHash ReadGitRepo ShortBranchHash + | RemoteNamespaceHashAmbiguous ReadGitRepo ShortBranchHash (Set h) + | CouldntLoadRootBranch ReadGitRepo h + | CouldntParseRemoteBranch ReadGitRepo String | CouldntLoadSyncedBranch ReadRemoteNamespace h - | CouldntFindRemoteBranch ReadRepo Path + | CouldntFindRemoteBranch ReadGitRepo Path deriving (Show) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 7f04dc590..828f2ac7c 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -45,7 +45,14 @@ import qualified Unison.Codebase.Branch.Names as Branch import qualified Unison.Codebase.Causal.Type as Causal import Unison.Codebase.Editor.Git (gitIn, gitInCaptured, gitTextIn, withRepo) import qualified Unison.Codebase.Editor.Git as Git -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo, WriteRepo (..), printWriteRepo, writeToRead) +import Unison.Codebase.Editor.RemoteRepo + ( ReadGitRemoteNamespace, + ReadGitRepo, + WriteGitRepo (..), + WriteRepo (..), + printWriteRepo, + writeToReadGit, + ) import qualified Unison.Codebase.GitError as GitError import qualified Unison.Codebase.Init as Codebase import qualified Unison.Codebase.Init.CreateCodebaseError as Codebase1 @@ -676,10 +683,11 @@ syncProgress progressStateRef = Sync.Progress (liftIO . need) (liftIO . done) (l where v = const () +-- FIXME(mitchell) seems like this should have "git" in its name viewRemoteBranch' :: forall m r. (MonadUnliftIO m) => - ReadRemoteNamespace -> + ReadGitRemoteNamespace -> Git.GitBranchBehavior -> ((Branch m, CodebasePath) -> m r) -> m (Either C.GitError r) @@ -728,7 +736,7 @@ pushGitBranch :: forall m e. (MonadUnliftIO m) => Sqlite.Connection -> - WriteRepo -> + WriteGitRepo -> PushGitBranchOpts -> -- An action which accepts the current root branch on the remote and computes a new branch. (Branch m -> m (Either e (Branch m))) -> @@ -764,8 +772,8 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift for newBranchOrErr $ push pushStaging repo pure newBranchOrErr where - readRepo :: ReadRepo - readRepo = writeToRead repo + readRepo :: ReadGitRepo + readRepo = writeToReadGit repo doSync :: CodebaseStatus -> FilePath -> Sqlite.Connection -> Branch m -> m () doSync codebaseStatus remotePath destConn newBranch = do progressStateRef <- liftIO (newIORef emptySyncProgressState) @@ -802,7 +810,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift Just True -> pure () CreatedCodebase -> pure () run (setRepoRoot newBranchHash) - repoString = Text.unpack $ printWriteRepo repo + repoString = Text.unpack $ printWriteRepo (WriteRepoGit repo) setRepoRoot :: Branch.Hash -> Sqlite.Transaction () setRepoRoot h = do let h2 = Cv.causalHash1to2 h @@ -854,7 +862,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift hasDeleteShm = any isShmDelete statusLines -- Commit our changes - push :: forall n. MonadIO n => Git.GitRepo -> WriteRepo -> Branch m -> n Bool -- withIOError needs IO + push :: forall n. MonadIO n => Git.GitRepo -> WriteGitRepo -> Branch m -> n Bool -- withIOError needs IO push remotePath repo@(WriteGitRepo {url' = url, branch = mayGitBranch}) newRootBranch = time "SqliteCodebase.pushGitRootBranch.push" $ do -- has anything changed? -- note: -uall recursively shows status for all files in untracked directories diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs index 262628db0..6494cc96f 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs @@ -1,11 +1,11 @@ module Unison.Codebase.SqliteCodebase.GitError where import U.Codebase.Sqlite.DbId (SchemaVersion) -import Unison.Codebase.Editor.RemoteRepo (ReadRepo) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo) import Unison.CodebasePath (CodebasePath) data GitSqliteCodebaseError - = GitCouldntParseRootBranchHash ReadRepo String - | NoDatabaseFile ReadRepo CodebasePath - | UnrecognizedSchemaVersion ReadRepo CodebasePath SchemaVersion + = GitCouldntParseRootBranchHash ReadGitRepo String + | NoDatabaseFile ReadGitRepo CodebasePath + | UnrecognizedSchemaVersion ReadGitRepo CodebasePath SchemaVersion deriving (Show) diff --git a/parser-typechecker/src/Unison/Codebase/Type.hs b/parser-typechecker/src/Unison/Codebase/Type.hs index 86e661c36..045e826cd 100644 --- a/parser-typechecker/src/Unison/Codebase/Type.hs +++ b/parser-typechecker/src/Unison/Codebase/Type.hs @@ -17,7 +17,7 @@ import qualified U.Codebase.Reference as V2 import Unison.Codebase.Branch (Branch) import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Editor.Git as Git -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo, WriteRepo) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadGitRepo, WriteGitRepo) import Unison.Codebase.GitError (GitCodebaseError, GitProtocolError) import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..)) import Unison.Codebase.Patch (Patch) @@ -111,9 +111,9 @@ data Codebase m v a = Codebase syncFromDirectory :: CodebasePath -> SyncMode -> Branch m -> m (), -- | Copy a branch and all of its dependencies from this codebase into the given codebase. syncToDirectory :: CodebasePath -> SyncMode -> Branch m -> m (), - viewRemoteBranch' :: forall r. ReadRemoteNamespace -> Git.GitBranchBehavior -> ((Branch m, CodebasePath) -> m r) -> m (Either GitError r), + viewRemoteBranch' :: forall r. ReadGitRemoteNamespace -> Git.GitBranchBehavior -> ((Branch m, CodebasePath) -> m r) -> m (Either GitError r), -- | Push the given branch to the given repo, and optionally set it as the root branch. - pushGitBranch :: forall e. WriteRepo -> PushGitBranchOpts -> (Branch m -> m (Either e (Branch m))) -> m (Either GitError (Either e (Branch m))), + pushGitBranch :: forall e. WriteGitRepo -> PushGitBranchOpts -> (Branch m -> m (Either e (Branch m))) -> m (Either GitError (Either e (Branch m))), -- | @watches k@ returns all of the references @r@ that were previously put by a @putWatch k r t@. @t@ can be -- retrieved by @getWatch k r@. watches :: WK.WatchKind -> m [Reference.Id], @@ -204,7 +204,7 @@ data GitError instance Exception GitError -gitErrorFromOpenCodebaseError :: CodebasePath -> ReadRepo -> OpenCodebaseError -> GitSqliteCodebaseError +gitErrorFromOpenCodebaseError :: CodebasePath -> ReadGitRepo -> OpenCodebaseError -> GitSqliteCodebaseError gitErrorFromOpenCodebaseError path repo = \case OpenCodebaseDoesntExist -> NoDatabaseFile repo path OpenCodebaseUnknownSchemaVersion v -> From 00355fd8bd905c8688676cdb93f9fbe4020d2a5b Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 10 May 2022 17:04:28 -0400 Subject: [PATCH 02/19] now compiles --- parser-typechecker/src/Unison/Codebase.hs | 8 +- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 8 +- .../src/Unison/Codebase/GitError.hs | 4 +- .../src/Unison/Codebase/Editor/Command.hs | 16 +-- .../Unison/Codebase/Editor/HandleCommand.hs | 6 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 100 ++++++++++-------- .../src/Unison/Codebase/Editor/Input.hs | 2 +- .../src/Unison/Codebase/Editor/UriParser.hs | 6 +- .../src/Unison/CommandLine/OutputMessages.hs | 36 +++---- unison-cli/src/Unison/Share/Sync.hs | 7 +- 10 files changed, 100 insertions(+), 93 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase.hs b/parser-typechecker/src/Unison/Codebase.hs index b4c44955a..e519dc9bb 100644 --- a/parser-typechecker/src/Unison/Codebase.hs +++ b/parser-typechecker/src/Unison/Codebase.hs @@ -117,7 +117,7 @@ import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (builtinAnnotation)) import qualified Unison.Codebase.CodeLookup as CL import Unison.Codebase.Editor.Git (withStatus) import qualified Unison.Codebase.Editor.Git as Git -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace) import qualified Unison.Codebase.GitError as GitError import Unison.Codebase.Path import qualified Unison.Codebase.Path as Path @@ -378,14 +378,14 @@ data Preprocessing m = Unmodified | Preprocessed (Branch m -> m (Branch m)) --- | Sync elements as needed from a remote codebase into the local one. +-- | Sync elements as needed from a remote git codebase into the local one. -- If `sbh` is supplied, we try to load the specified branch hash; -- otherwise we try to load the root branch. importRemoteBranch :: forall m v a. MonadUnliftIO m => Codebase m v a -> - ReadRemoteNamespace -> + ReadGitRemoteNamespace -> SyncMode -> Preprocessing m -> m (Either GitError (Branch m)) @@ -411,7 +411,7 @@ importRemoteBranch codebase ns mode preprocess = runExceptT $ do viewRemoteBranch :: MonadIO m => Codebase m v a -> - ReadRemoteNamespace -> + ReadGitRemoteNamespace -> Git.GitBranchBehavior -> (Branch m -> m r) -> m (Either GitError r) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index c9e23adfe..524e821dd 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -13,16 +13,16 @@ import Unison.Prelude data ReadRepo = ReadRepoGit ReadGitRepo - deriving (Show) + deriving (Eq, Show) data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text} - deriving (Show) + deriving (Eq, Show) data WriteRepo = WriteRepoGit WriteGitRepo - deriving (Show) + deriving (Eq, Show) data WriteGitRepo = WriteGitRepo {url' :: Text, branch :: Maybe Text} - deriving (Show) + deriving (Eq, Show) writeToRead :: WriteRepo -> ReadRepo writeToRead = \case diff --git a/parser-typechecker/src/Unison/Codebase/GitError.hs b/parser-typechecker/src/Unison/Codebase/GitError.hs index 728449350..b0131e137 100644 --- a/parser-typechecker/src/Unison/Codebase/GitError.hs +++ b/parser-typechecker/src/Unison/Codebase/GitError.hs @@ -2,7 +2,7 @@ module Unison.Codebase.GitError where -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadGitRepo, WriteGitRepo) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadGitRepo, WriteGitRepo) import Unison.Codebase.Path import Unison.Codebase.ShortBranchHash (ShortBranchHash) import Unison.Prelude @@ -32,6 +32,6 @@ data GitCodebaseError h | RemoteNamespaceHashAmbiguous ReadGitRepo ShortBranchHash (Set h) | CouldntLoadRootBranch ReadGitRepo h | CouldntParseRemoteBranch ReadGitRepo String - | CouldntLoadSyncedBranch ReadRemoteNamespace h + | CouldntLoadSyncedBranch ReadGitRemoteNamespace h | CouldntFindRemoteBranch ReadGitRepo Path deriving (Show) diff --git a/unison-cli/src/Unison/Codebase/Editor/Command.hs b/unison-cli/src/Unison/Codebase/Editor/Command.hs index 168e377b6..499b8b82f 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Command.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Command.hs @@ -197,16 +197,16 @@ data LoadLocalBranch :: Branch.Hash -> Command m i v (Branch m) -- Merge two branches, using the codebase for the LCA calculation where possible. Merge :: Branch.MergeMode -> Branch m -> Branch m -> Command m i v (Branch m) - ViewRemoteBranch :: - ReadRemoteNamespace -> + ViewRemoteGitBranch :: + ReadGitRemoteNamespace -> Git.GitBranchBehavior -> (Branch m -> (Free (Command m i v) r)) -> Command m i v (Either GitError r) -- we want to import as little as possible, so we pass the SBH/path as part -- of the `RemoteNamespace`. The Branch that's returned should be fully -- imported and not retain any resources from the remote codebase - ImportRemoteBranch :: - ReadRemoteNamespace -> + ImportRemoteGitBranch :: + ReadGitRemoteNamespace -> SyncMode -> -- | A preprocessing step to perform on the branch before it's imported. -- This is sometimes useful for minimizing the number of definitions to sync. @@ -217,7 +217,7 @@ data -- Any definitions in the head of the supplied branch that aren't in the target -- codebase are copied there. SyncLocalRootBranch :: Branch m -> Command m i v () - SyncRemoteBranch :: WriteRepo -> PushGitBranchOpts -> (Branch m -> m (Either e (Branch m))) -> Command m i v (Either GitError (Either e (Branch m))) + SyncRemoteGitBranch :: WriteGitRepo -> PushGitBranchOpts -> (Branch m -> m (Either e (Branch m))) -> Command m i v (Either GitError (Either e (Branch m))) AppendToReflog :: Text -> Branch m -> Branch m -> Command m i v () -- load the reflog in file (chronological) order LoadReflog :: Command m i v [Reflog.Entry Branch.Hash] @@ -316,10 +316,10 @@ commandName = \case LoadLocalRootBranch -> "LoadLocalRootBranch" LoadLocalBranch {} -> "LoadLocalBranch" Merge {} -> "Merge" - ViewRemoteBranch {} -> "ViewRemoteBranch" - ImportRemoteBranch {} -> "ImportRemoteBranch" + ViewRemoteGitBranch {} -> "ViewRemoteGitBranch" + ImportRemoteGitBranch {} -> "ImportRemoteGitBranch" SyncLocalRootBranch {} -> "SyncLocalRootBranch" - SyncRemoteBranch {} -> "SyncRemoteBranch" + SyncRemoteGitBranch {} -> "SyncRemoteGitBranch" AppendToReflog {} -> "AppendToReflog" LoadReflog -> "LoadReflog" LoadTerm {} -> "LoadTerm" diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs index 0419d1c27..03ea15a88 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs @@ -151,14 +151,14 @@ commandLine config awaitInput setBranchRef rt notifyUser notifyNumbered loadSour SyncLocalRootBranch branch -> lift $ do setBranchRef branch Codebase.putRootBranch codebase branch - ViewRemoteBranch ns gitBranchBehavior action -> do + ViewRemoteGitBranch ns gitBranchBehavior action -> do -- TODO: We probably won'd need to unlift anything once we remove the Command -- abstraction. toIO <- UnliftIO.askRunInIO lift $ Codebase.viewRemoteBranch codebase ns gitBranchBehavior (toIO . Free.fold go . action) - ImportRemoteBranch ns syncMode preprocess -> + ImportRemoteGitBranch ns syncMode preprocess -> lift $ Codebase.importRemoteBranch codebase ns syncMode preprocess - SyncRemoteBranch repo opts action -> + SyncRemoteGitBranch repo opts action -> lift $ Codebase.pushGitBranch codebase repo opts action LoadTerm r -> lift $ Codebase.getTerm codebase r LoadTypeOfTerm r -> lift $ Codebase.getTypeOfTerm codebase r diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 3d0e555be..e1c96d367 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -28,7 +28,6 @@ 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 @@ -59,7 +58,7 @@ import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBranchDiff import qualified Unison.Codebase.Editor.Output.DumpNamespace as Output.DN import qualified Unison.Codebase.Editor.Propagate as Propagate -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemotePath, WriteRepo, printNamespace, writePathToRead) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadRepo (ReadRepoGit), WriteGitRepo, WriteRemotePath, WriteRepo (WriteRepoGit), printNamespace, writePathToRead) import qualified Unison.Codebase.Editor.Slurp as Slurp import Unison.Codebase.Editor.SlurpComponent (SlurpComponent (..)) import qualified Unison.Codebase.Editor.SlurpComponent as SC @@ -134,11 +133,8 @@ import qualified Unison.ShortHash as SH import qualified Unison.Sqlite as Sqlite import Unison.Symbol (Symbol) import qualified Unison.Sync.Types as Share - ( Hash, - HashMismatch (..), - RepoName (..), + ( RepoName (..), RepoPath (..), - hashJWTHash, ) import Unison.Term (Term) import qualified Unison.Term as Term @@ -499,8 +495,8 @@ loop = do Action m i v1 Bool updateAtM = Unison.Codebase.Editor.HandleInput.updateAtM inputDescription unlessGitError = unlessError' Output.GitError - importRemoteBranch ns mode preprocess = - ExceptT . eval $ ImportRemoteBranch ns mode preprocess + importRemoteGitBranch ns mode preprocess = + ExceptT . eval $ ImportRemoteGitBranch ns mode preprocess loadSearchResults = eval . LoadSearchResults saveAndApplyPatch patchPath'' patchName patch' = do stepAtM @@ -657,9 +653,11 @@ loop = do ppe outputDiff CreatePullRequestI baseRepo headRepo -> do + let viewRemoteBranch repo callback = case repo of + (ReadRepoGit r, sbh, path) -> viewRemoteGitBranch (r, sbh, path) Git.RequireExistingBranch callback result <- - join @(Either GitError) <$> viewRemoteBranch baseRepo Git.RequireExistingBranch \baseBranch -> do - viewRemoteBranch headRepo Git.RequireExistingBranch \headBranch -> do + join @(Either GitError) <$> viewRemoteBranch baseRepo \baseBranch -> do + viewRemoteBranch headRepo \headBranch -> do merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) pure $ ShowDiffAfterCreatePR baseRepo headRepo ppe diff @@ -672,8 +670,12 @@ loop = do destb <- getAt desta if Branch.isEmpty0 (Branch.head destb) then unlessGitError do - baseb <- importRemoteBranch baseRepo SyncMode.ShortCircuit Unmodified - headb <- importRemoteBranch headRepo SyncMode.ShortCircuit Unmodified + baseb <- case baseRepo of + (ReadRepoGit r, sbh, path) -> + importRemoteGitBranch (r, sbh, path) SyncMode.ShortCircuit Unmodified + headb <- case headRepo of + (ReadRepoGit r, sbh, path) -> + importRemoteGitBranch (r, sbh, path) SyncMode.ShortCircuit Unmodified lift $ do mergedb <- eval $ Merge Branch.RegularMerge baseb headb squashedb <- eval $ Merge Branch.SquashMerge headb baseb @@ -1507,9 +1509,11 @@ loop = do let preprocess = case pullMode of Input.PullWithHistory -> Unmodified Input.PullWithoutHistory -> Preprocessed $ pure . Branch.discardHistory - ns <- maybe (writePathToRead <$> resolveConfiguredGitUrl Pull path) pure mayRepo + ns <- maybe (writePathToRead <$> resolveConfiguredUrl Pull path) pure mayRepo lift $ unlessGitError do - remoteBranch <- importRemoteBranch ns syncMode preprocess + remoteBranch <- case ns of + (ReadRepoGit r, sbh, path) -> + importRemoteGitBranch (r, sbh, path) syncMode preprocess let unchangedMsg = PullAlreadyUpToDate ns path let destAbs = resolveToAbsolute path let printDiffPath = if Verbosity.isSilent verbosity then Nothing else Just path @@ -1714,8 +1718,8 @@ handlePullFromUnisonShare remoteRepo remotePath = do liftIO (Share.pull authHTTPClient unisonShareUrl connection repoPath) >>= \case Left (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission _)) -> undefined - Right Nothing -> undefined - Right (Just causalHash) -> do + Left (Share.PullErrorNoHistoryAtPath repoPath) -> undefined + Right causalHash -> do undefined -- | Handle a @push@ command. @@ -1732,7 +1736,7 @@ handlePushRemoteBranch :: Action' m v () handlePushRemoteBranch mayRepo path pushBehavior syncMode = do unlessError do - (repo, remotePath) <- maybe (resolveConfiguredGitUrl Push path) pure mayRepo + (repo, remotePath) <- maybe (resolveConfiguredUrl Push path) pure mayRepo lift (doPushRemoteBranch repo path syncMode (Just (remotePath, pushBehavior))) -- Internal helper that implements pushing to a remote repo, which generalizes @gist@ and @push@. @@ -1754,26 +1758,28 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do getAt (Path.resolve currentPath' localPath) unlessError do - withExceptT Output.GitError $ do - case remoteTarget of - Nothing -> do - let opts = PushGitBranchOpts {setRoot = False, syncMode} - syncRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch)) - sbhLength <- (eval BranchHashLength) - respond (GistCreated sbhLength repo (Branch.headHash sourceBranch)) - Just (remotePath, pushBehavior) -> do - let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m)) - withRemoteRoot remoteRoot = do - let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if this - -- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already. - f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing - Branch.modifyAtM remotePath f remoteRoot & \case - Nothing -> pure (Left $ RefusedToPush pushBehavior) - Just newRemoteRoot -> pure (Right newRemoteRoot) - let opts = PushGitBranchOpts {setRoot = True, syncMode} - syncRemoteBranch repo opts withRemoteRoot >>= \case - Left output -> respond output - Right _branch -> respond Success + case repo of + WriteRepoGit repo -> + withExceptT Output.GitError $ do + case remoteTarget of + Nothing -> do + let opts = PushGitBranchOpts {setRoot = False, syncMode} + syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch)) + sbhLength <- (eval BranchHashLength) + respond (GistCreated sbhLength (WriteRepoGit repo) (Branch.headHash sourceBranch)) + Just (remotePath, pushBehavior) -> do + let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m)) + withRemoteRoot remoteRoot = do + let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if this + -- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already. + f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing + Branch.modifyAtM remotePath f remoteRoot & \case + Nothing -> pure (Left $ RefusedToPush pushBehavior) + Just newRemoteRoot -> pure (Right newRemoteRoot) + let opts = PushGitBranchOpts {setRoot = True, syncMode} + syncGitRemoteBranch repo opts withRemoteRoot >>= \case + Left output -> respond output + Right _branch -> respond Success where -- Per `pushBehavior`, we are either: -- @@ -2147,11 +2153,11 @@ manageLinks silent srcs mdValues op = do -- Takes a maybe (namespace address triple); returns it as-is if `Just`; -- otherwise, tries to load a value from .unisonConfig, and complains -- if needed. -resolveConfiguredGitUrl :: +resolveConfiguredUrl :: PushPull -> Path' -> ExceptT (Output v) (Action m i v) WriteRemotePath -resolveConfiguredGitUrl pushPull destPath' = ExceptT do +resolveConfiguredUrl pushPull destPath' = ExceptT do currentPath' <- use LoopState.currentPath let destPath = Path.resolve currentPath' destPath' let configKey = gitUrlKey destPath @@ -2177,26 +2183,26 @@ configKey k p = NameSegment.toText (Path.toSeq $ Path.unabsolute p) -viewRemoteBranch :: +viewRemoteGitBranch :: (MonadCommand n m i v, MonadUnliftIO m) => - ReadRemoteNamespace -> + ReadGitRemoteNamespace -> Git.GitBranchBehavior -> (Branch m -> Free (Command m i v) r) -> n (Either GitError r) -viewRemoteBranch ns gitBranchBehavior action = do - eval $ ViewRemoteBranch ns gitBranchBehavior action +viewRemoteGitBranch ns gitBranchBehavior action = do + eval $ ViewRemoteGitBranch ns gitBranchBehavior action -- | Given the current root branch of a remote -- (or an empty branch if no root branch exists) -- compute a new branch, which will then be synced and pushed. -syncRemoteBranch :: +syncGitRemoteBranch :: MonadCommand n m i v => - WriteRepo -> + WriteGitRepo -> PushGitBranchOpts -> (Branch m -> m (Either e (Branch m))) -> ExceptT GitError n (Either e (Branch m)) -syncRemoteBranch repo opts action = - ExceptT . eval $ SyncRemoteBranch repo opts action +syncGitRemoteBranch repo opts action = + ExceptT . eval $ SyncRemoteGitBranch repo opts action -- todo: compare to `getHQTerms` / `getHQTypes`. Is one universally better? resolveHQToLabeledDependencies :: Functor m => HQ.HashQualified Name -> Action' m v (Set LabeledDependency) diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index 96bb1effc..b9e19d273 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -189,7 +189,7 @@ data Input | VersionI deriving (Eq, Show) --- | @"gist repo"@ pushes the contents of the current namespace to @repo@. +-- | @"push.gist repo"@ pushes the contents of the current namespace to @repo@. data GistInput = GistInput { repo :: WriteRepo } diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 0dde3d667..888d961d4 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -9,7 +9,7 @@ import Data.Void import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as C import qualified Text.Megaparsec.Char.Lexer as L -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo (..), WriteRemotePath, WriteRepo (..)) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo (..), ReadRemoteNamespace, ReadRepo (..), WriteGitRepo (..), WriteRemotePath, WriteRepo (..)) import Unison.Codebase.Path (Path (..)) import qualified Unison.Codebase.Path as Path import Unison.Codebase.ShortBranchHash (ShortBranchHash (..)) @@ -42,7 +42,7 @@ repoPath :: P ReadRemoteNamespace repoPath = P.label "generic git repo" $ do protocol <- parseProtocol treeish <- P.optional treeishSuffix - let repo = ReadGitRepo {url = printProtocol protocol, ref = treeish} + let repo = (ReadRepoGit ReadGitRepo {url = printProtocol protocol, ref = treeish}) nshashPath <- P.optional (C.char ':' *> namespaceHashPath) case nshashPath of Nothing -> pure (repo, Nothing, Path.empty) @@ -52,7 +52,7 @@ writeRepo :: P WriteRepo writeRepo = P.label "repo root for writing" $ do uri <- parseProtocol treeish <- P.optional treeishSuffix - pure WriteGitRepo {url' = printProtocol uri, branch = treeish} + pure (WriteRepoGit WriteGitRepo {url' = printProtocol uri, branch = treeish}) writeRepoPath :: P WriteRemotePath writeRepoPath = P.label "generic git repo" $ do diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index c5675f190..4fa9c5368 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -44,7 +44,7 @@ import Unison.Codebase.Editor.Output import qualified Unison.Codebase.Editor.Output as E import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBD -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo, WriteRepo) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo (ReadRepoGit), WriteRepo (WriteRepoGit)) import qualified Unison.Codebase.Editor.RemoteRepo as RemoteRepo import qualified Unison.Codebase.Editor.SlurpResult as SlurpResult import qualified Unison.Codebase.Editor.TodoOutput as TO @@ -1045,14 +1045,14 @@ notifyUser dir o = case o of NoDatabaseFile repo localPath -> P.wrap $ "I didn't find a codebase in the repository at" - <> prettyReadRepo repo + <> prettyReadRepo (ReadRepoGit repo) <> "in the cache directory at" <> P.backticked' (P.string localPath) "." UnrecognizedSchemaVersion repo localPath (SchemaVersion v) -> P.wrap $ "I don't know how to interpret schema version " <> P.shown v <> "in the repository at" - <> prettyReadRepo repo + <> prettyReadRepo (ReadRepoGit repo) <> "in the cache directory at" <> P.backticked' (P.string localPath) "." GitCouldntParseRootBranchHash repo s -> @@ -1060,7 +1060,7 @@ notifyUser dir o = case o of "I couldn't parse the string" <> P.red (P.string s) <> "into a namespace hash, when opening the repository at" - <> P.group (prettyReadRepo repo <> ".") + <> P.group (prettyReadRepo (ReadRepoGit repo) <> ".") GitProtocolError e -> case e of NoGit -> P.wrap $ @@ -1071,7 +1071,7 @@ notifyUser dir o = case o of <> P.group (P.shown e) CloneException repo msg -> P.wrap $ - "I couldn't clone the repository at" <> prettyReadRepo repo <> ";" + "I couldn't clone the repository at" <> prettyReadRepo (ReadRepoGit repo) <> ";" <> "the error was:" <> (P.indentNAfterNewline 2 . P.group . P.string) msg CopyException srcRepoPath destPath msg -> @@ -1081,10 +1081,10 @@ notifyUser dir o = case o of <> (P.indentNAfterNewline 2 . P.group . P.string) msg PushNoOp repo -> P.wrap $ - "The repository at" <> prettyWriteRepo repo <> "is already up-to-date." + "The repository at" <> prettyWriteRepo (WriteRepoGit repo) <> "is already up-to-date." PushException repo msg -> P.wrap $ - "I couldn't push to the repository at" <> prettyWriteRepo repo <> ";" + "I couldn't push to the repository at" <> prettyWriteRepo (WriteRepoGit repo) <> ";" <> "the error was:" <> (P.indentNAfterNewline 2 . P.group . P.string) msg RemoteRefNotFound repo ref -> @@ -1093,7 +1093,7 @@ notifyUser dir o = case o of UnrecognizableCacheDir uri localPath -> P.wrap $ "A cache directory for" - <> P.backticked (P.text $ RemoteRepo.printReadRepo uri) + <> P.backticked (P.text $ RemoteRepo.printReadRepo (ReadRepoGit uri)) <> "already exists at" <> P.backticked' (P.string localPath) "," <> "but it doesn't seem to" @@ -1101,7 +1101,7 @@ notifyUser dir o = case o of UnrecognizableCheckoutDir uri localPath -> P.wrap $ "I tried to clone" - <> P.backticked (P.text $ RemoteRepo.printReadRepo uri) + <> P.backticked (P.text $ RemoteRepo.printReadRepo (ReadRepoGit uri)) <> "into a cache directory at" <> P.backticked' (P.string localPath) "," <> "but I can't recognize the" @@ -1109,7 +1109,7 @@ notifyUser dir o = case o of PushDestinationHasNewStuff repo -> P.callout "⏸" . P.lines $ [ P.wrap $ - "The repository at" <> prettyWriteRepo repo + "The repository at" <> prettyWriteRepo (WriteRepoGit repo) <> "has some changes I don't know about.", "", P.wrap $ "Try" <> pull <> "to merge these changes locally, then" <> push <> "again." @@ -1123,28 +1123,28 @@ notifyUser dir o = case o of "I couldn't decode the root branch " <> P.string s <> "from the repository at" - <> prettyReadRepo repo + <> prettyReadRepo (ReadRepoGit repo) CouldntLoadRootBranch repo hash -> P.wrap $ "I couldn't load the designated root hash" <> P.group ("(" <> P.text (Hash.base32Hex $ Causal.unRawHash hash) <> ")") <> "from the repository at" - <> prettyReadRepo repo + <> prettyReadRepo (ReadRepoGit repo) CouldntLoadSyncedBranch ns h -> P.wrap $ "I just finished importing the branch" <> P.red (P.shown h) <> "from" - <> P.red (prettyRemoteNamespace ns) + <> P.red (prettyRemoteNamespace (over _1 ReadRepoGit ns)) <> "but now I can't find it." CouldntFindRemoteBranch repo path -> P.wrap $ "I couldn't find the remote branch at" <> P.shown path <> "in the repository at" - <> prettyReadRepo repo + <> prettyReadRepo (ReadRepoGit repo) NoRemoteNamespaceWithHash repo sbh -> P.wrap $ - "The repository at" <> prettyReadRepo repo + "The repository at" <> prettyReadRepo (ReadRepoGit repo) <> "doesn't contain a namespace with the hash prefix" <> (P.blue . P.text . SBH.toText) sbh RemoteNamespaceHashAmbiguous repo sbh hashes -> @@ -1152,7 +1152,7 @@ notifyUser dir o = case o of [ P.wrap $ "The namespace hash" <> prettySBH sbh <> "at" - <> prettyReadRepo repo + <> prettyReadRepo (ReadRepoGit repo) <> "is ambiguous." <> "Did you mean one of these hashes?", "", @@ -2821,10 +2821,10 @@ prettyTypeName ppe r = prettyHashQualified (PPE.typeName ppe r) prettyReadRepo :: ReadRepo -> Pretty -prettyReadRepo (RemoteRepo.ReadGitRepo {url}) = P.blue (P.text url) +prettyReadRepo (RemoteRepo.ReadRepoGit RemoteRepo.ReadGitRepo {url}) = P.blue (P.text url) prettyWriteRepo :: WriteRepo -> Pretty -prettyWriteRepo (RemoteRepo.WriteGitRepo {url'}) = P.blue (P.text url') +prettyWriteRepo (RemoteRepo.WriteRepoGit RemoteRepo.WriteGitRepo {url'}) = P.blue (P.text url') isTestOk :: Term v Ann -> Bool isTestOk tm = case tm of diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index aa7ad56df..b82a98843 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -279,6 +279,7 @@ dagbfs goal children = data PullError = -- | An error occurred while resolving a repo+path to a causal hash. PullErrorGetCausalHashByPath GetCausalHashByPathError + | PullErrorNoHistoryAtPath Share.RepoPath.RepoPath pull :: -- | The HTTP client to use for Unison Share requests. @@ -289,19 +290,19 @@ pull :: Sqlite.Connection -> -- | The repo+path to pull from. Share.RepoPath -> - IO (Either PullError (Maybe CausalHash)) + IO (Either PullError CausalHash) pull httpClient unisonShareUrl conn repoPath = do getCausalHashByPath httpClient unisonShareUrl repoPath >>= \case Left err -> pure (Left (PullErrorGetCausalHashByPath err)) -- There's nothing at the remote path, so there's no causal to pull. - Right Nothing -> pure (Right Nothing) + Right Nothing -> pure (Left (PullErrorNoHistoryAtPath repoPath)) Right (Just hashJwt) -> do let hash = Share.hashJWTHash hashJwt Sqlite.runTransaction conn (entityLocation hash) >>= \case EntityInMainStorage -> pure () EntityInTempStorage missingDependencies -> doDownload missingDependencies EntityNotStored -> doDownload (NESet.singleton hashJwt) - pure (Right (Just (CausalHash (Hash.fromBase32Hex (Share.toBase32Hex hash))))) + pure (Right (CausalHash (Hash.fromBase32Hex (Share.toBase32Hex hash)))) where doDownload :: NESet Share.HashJWT -> IO () doDownload = From fc39e2e24ef6517577c88a3d485d790348e4131e Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Tue, 10 May 2022 17:55:12 -0400 Subject: [PATCH 03/19] started adding ShareRepo constructors --- parser-typechecker/package.yaml | 1 + .../src/Unison/Codebase/Editor/RemoteRepo.hs | 19 +++++++++++++++---- .../src/Unison/Codebase/SqliteCodebase.hs | 2 +- .../unison-parser-typechecker.cabal | 2 ++ .../src/Unison/Codebase/Editor/HandleInput.hs | 18 +++++++++++++----- .../src/Unison/Codebase/Editor/UriParser.hs | 2 +- .../src/Unison/CommandLine/OutputMessages.hs | 8 ++++++-- 7 files changed, 39 insertions(+), 13 deletions(-) diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 2b4b6e81e..4a2e8eb01 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -173,6 +173,7 @@ default-extensions: - DerivingStrategies - DerivingVia - DoAndIfThenElse + - DuplicateRecordFields - FlexibleContexts - FlexibleInstances - GeneralizedNewtypeDeriving diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 524e821dd..0e69bf0a4 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -13,24 +13,31 @@ import Unison.Prelude data ReadRepo = ReadRepoGit ReadGitRepo + | ReadRepoShare ShareRepo deriving (Eq, Show) data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text} deriving (Eq, Show) -data WriteRepo = WriteRepoGit WriteGitRepo +newtype ShareRepo = ShareRepo {url :: Text} deriving (Eq, Show) -data WriteGitRepo = WriteGitRepo {url' :: Text, branch :: Maybe Text} +data WriteRepo + = WriteRepoGit WriteGitRepo + | WriteRepoShare ShareRepo + deriving (Eq, Show) + +data WriteGitRepo = WriteGitRepo {url :: Text, branch :: Maybe Text} deriving (Eq, Show) writeToRead :: WriteRepo -> ReadRepo writeToRead = \case WriteRepoGit repo -> ReadRepoGit (writeToReadGit repo) + WriteRepoShare repo -> ReadRepoShare repo writeToReadGit :: WriteGitRepo -> ReadGitRepo writeToReadGit = \case - WriteGitRepo {url', branch} -> ReadGitRepo {url = url', ref = branch} + WriteGitRepo {url, branch} -> ReadGitRepo {url = url, ref = branch} writePathToRead :: WriteRemotePath -> ReadRemoteNamespace writePathToRead (w, p) = (writeToRead w, Nothing, p) @@ -38,11 +45,14 @@ writePathToRead (w, p) = (writeToRead w, Nothing, p) printReadRepo :: ReadRepo -> Text printReadRepo = \case ReadRepoGit ReadGitRepo {url, ref} -> url <> Monoid.fromMaybe (Text.cons ':' <$> ref) + ReadRepoShare ShareRepo {url} -> url printWriteRepo :: WriteRepo -> Text printWriteRepo = \case - WriteRepoGit WriteGitRepo {url', branch} -> url' <> Monoid.fromMaybe (Text.cons ':' <$> branch) + WriteRepoGit WriteGitRepo {url, branch} -> url <> Monoid.fromMaybe (Text.cons ':' <$> branch) + WriteRepoShare ShareRepo {url} -> url +-- | print remote namespace printNamespace :: ReadRepo -> Maybe ShortBranchHash -> Path -> Text printNamespace repo sbh path = printReadRepo repo <> case sbh of @@ -56,6 +66,7 @@ printNamespace repo sbh path = then mempty else "." <> Path.toText path +-- | print remote path printHead :: WriteRepo -> Path -> Text printHead repo path = printWriteRepo repo diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index 828f2ac7c..fca896b4e 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -863,7 +863,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift -- Commit our changes push :: forall n. MonadIO n => Git.GitRepo -> WriteGitRepo -> Branch m -> n Bool -- withIOError needs IO - push remotePath repo@(WriteGitRepo {url' = url, branch = mayGitBranch}) newRootBranch = time "SqliteCodebase.pushGitRootBranch.push" $ do + push remotePath repo@(WriteGitRepo {url, branch = mayGitBranch}) newRootBranch = time "SqliteCodebase.pushGitRootBranch.push" $ do -- has anything changed? -- note: -uall recursively shows status for all files in untracked directories -- we want this so that we see diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index e42169e52..b659960ba 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -178,6 +178,7 @@ library DerivingStrategies DerivingVia DoAndIfThenElse + DuplicateRecordFields FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving @@ -349,6 +350,7 @@ test-suite parser-typechecker-tests DerivingStrategies DerivingVia DoAndIfThenElse + DuplicateRecordFields FlexibleContexts FlexibleInstances GeneralizedNewtypeDeriving diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index e1c96d367..a07bcdef3 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -58,7 +58,7 @@ import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBranchDiff import qualified Unison.Codebase.Editor.Output.DumpNamespace as Output.DN import qualified Unison.Codebase.Editor.Propagate as Propagate -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadRepo (ReadRepoGit), WriteGitRepo, WriteRemotePath, WriteRepo (WriteRepoGit), printNamespace, writePathToRead) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadRepo (ReadRepoGit), WriteGitRepo, WriteRemotePath, WriteRepo (WriteRepoGit, WriteRepoShare), printNamespace, writePathToRead) import qualified Unison.Codebase.Editor.Slurp as Slurp import Unison.Codebase.Editor.SlurpComponent (SlurpComponent (..)) import qualified Unison.Codebase.Editor.SlurpComponent as SC @@ -1757,10 +1757,10 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do currentPath' <- use LoopState.currentPath getAt (Path.resolve currentPath' localPath) - unlessError do - case repo of - WriteRepoGit repo -> - withExceptT Output.GitError $ do + case repo of + WriteRepoGit repo -> + unlessError do + withExceptT Output.GitError do case remoteTarget of Nothing -> do let opts = PushGitBranchOpts {setRoot = False, syncMode} @@ -1780,6 +1780,14 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do syncGitRemoteBranch repo opts withRemoteRoot >>= \case Left output -> respond output Right _branch -> respond Success + WriteRepoShare repo -> do + case remoteTarget of + Nothing -> + -- do a gist + error "don't do a gist" + Just (remotePath, pushBehavior) -> + -- let (userSegment :| pathSegments) = undefined + handlePushToUnisonShare _userSegment _pathSegments _localPath pushBehavior where -- Per `pushBehavior`, we are either: -- diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 888d961d4..52e7b2e4a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -52,7 +52,7 @@ writeRepo :: P WriteRepo writeRepo = P.label "repo root for writing" $ do uri <- parseProtocol treeish <- P.optional treeishSuffix - pure (WriteRepoGit WriteGitRepo {url' = printProtocol uri, branch = treeish}) + pure (WriteRepoGit WriteGitRepo {url = printProtocol uri, branch = treeish}) writeRepoPath :: P WriteRemotePath writeRepoPath = P.label "generic git repo" $ do diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 4fa9c5368..d2f6a3470 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -2821,10 +2821,14 @@ prettyTypeName ppe r = prettyHashQualified (PPE.typeName ppe r) prettyReadRepo :: ReadRepo -> Pretty -prettyReadRepo (RemoteRepo.ReadRepoGit RemoteRepo.ReadGitRepo {url}) = P.blue (P.text url) +prettyReadRepo = \case + RemoteRepo.ReadRepoGit RemoteRepo.ReadGitRepo {url} -> P.blue (P.text url) + RemoteRepo.ReadRepoShare RemoteRepo.ShareRepo {url} -> P.blue (P.text url) prettyWriteRepo :: WriteRepo -> Pretty -prettyWriteRepo (RemoteRepo.WriteRepoGit RemoteRepo.WriteGitRepo {url'}) = P.blue (P.text url') +prettyWriteRepo = \case + RemoteRepo.WriteRepoGit RemoteRepo.WriteGitRepo {url} -> P.blue (P.text url) + RemoteRepo.WriteRepoShare RemoteRepo.ShareRepo {url} -> P.blue (P.text url) isTestOk :: Term v Ann -> Bool isTestOk tm = case tm of From 5d5e425b326e4db42bf0c008d3b38a0823f2f358 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Wed, 11 May 2022 10:29:46 -0400 Subject: [PATCH 04/19] refactored RepoPath into a non-empty Path --- .../src/Unison/Codebase/Editor/HandleInput.hs | 16 ++--- unison-cli/src/Unison/Share/Sync.hs | 54 +++++++-------- unison-share-api/src/Unison/Sync/Types.hs | 65 ++++++++++--------- 3 files changed, 70 insertions(+), 65 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index a07bcdef3..96d7cc197 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -132,10 +132,7 @@ 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 (..), - ) +import qualified Unison.Sync.Types as Share (Path (..)) import Unison.Term (Term) import qualified Unison.Term as Term import Unison.Type (Type) @@ -654,7 +651,8 @@ loop = do outputDiff CreatePullRequestI baseRepo headRepo -> do let viewRemoteBranch repo callback = case repo of - (ReadRepoGit r, sbh, path) -> viewRemoteGitBranch (r, sbh, path) Git.RequireExistingBranch callback + (ReadRepoGit r, sbh, path) -> + viewRemoteGitBranch (r, sbh, path) Git.RequireExistingBranch callback result <- join @(Either GitError) <$> viewRemoteBranch baseRepo \baseBranch -> do viewRemoteBranch headRepo \headBranch -> do @@ -1712,11 +1710,11 @@ handleGist (GistInput repo) = 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)) + let path = Share.Path (remoteRepo Nel.:| coerce @[NameSegment] @[Text] (Path.toList remotePath)) LoopState.Env {authHTTPClient, codebase = Codebase {connection}, unisonShareUrl} <- ask - liftIO (Share.pull authHTTPClient unisonShareUrl connection repoPath) >>= \case + liftIO (Share.pull authHTTPClient unisonShareUrl connection path) >>= \case Left (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission _)) -> undefined Left (Share.PullErrorNoHistoryAtPath repoPath) -> undefined Right causalHash -> do @@ -1787,7 +1785,7 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do error "don't do a gist" Just (remotePath, pushBehavior) -> -- let (userSegment :| pathSegments) = undefined - handlePushToUnisonShare _userSegment _pathSegments _localPath pushBehavior + error "handlePushToUnisonShare _userSegment _pathSegments _localPath pushBehavior" where -- Per `pushBehavior`, we are either: -- @@ -1801,7 +1799,7 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do handlePushToUnisonShare :: MonadIO m => Text -> Path -> Path.Absolute -> PushBehavior -> Action' m v () handlePushToUnisonShare remoteRepo remotePath localPath behavior = do - let repoPath = Share.RepoPath (Share.RepoName remoteRepo) (coerce @[NameSegment] @[Text] (Path.toList remotePath)) + let repoPath = Share.Path (remoteRepo Nel.:| coerce @[NameSegment] @[Text] (Path.toList remotePath)) LoopState.Env {authHTTPClient, codebase = Codebase {connection}, unisonShareUrl} <- ask diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index b82a98843..f407bb45c 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -65,7 +65,7 @@ import qualified Unison.Sync.HTTP as Share uploadEntitiesHandler, ) import qualified Unison.Sync.Types as Share -import qualified Unison.Sync.Types as Share.RepoPath (RepoPath (..)) +import qualified Unison.Sync.Types as Share.Path (Path (..)) import Unison.Util.Monoid (foldMapM) import qualified Unison.Util.Set as Set @@ -75,7 +75,7 @@ import qualified Unison.Util.Set as Set -- | An error occurred while pushing code to Unison Share. data CheckAndSetPushError = CheckAndSetPushErrorHashMismatch Share.HashMismatch - | CheckAndSetPushErrorNoWritePermission Share.RepoPath + | CheckAndSetPushErrorNoWritePermission Share.Path | CheckAndSetPushErrorServerMissingDependencies (NESet Share.Hash) -- | Push a causal to Unison Share. @@ -88,14 +88,14 @@ checkAndSetPush :: -- | SQLite connection, for reading entities to push. Sqlite.Connection -> -- | The repo+path to push to. - Share.RepoPath -> + Share.Path -> -- | The hash that we expect this repo+path to be at on Unison Share. If not, we'll get back a hash mismatch error. -- This prevents accidentally pushing over data that we didn't know was there. Maybe Share.Hash -> -- | The hash of our local causal to push. CausalHash -> IO (Either CheckAndSetPushError ()) -checkAndSetPush httpClient unisonShareUrl conn repoPath expectedHash causalHash = do +checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash = do -- Maybe the server already has this causal; try just setting its remote path. Commonly, it will respond that it needs -- this causal (UpdatePathMissingDependencies). updatePath >>= \case @@ -103,8 +103,8 @@ checkAndSetPush httpClient unisonShareUrl conn repoPath expectedHash causalHash Share.UpdatePathHashMismatch mismatch -> pure (Left (CheckAndSetPushErrorHashMismatch mismatch)) Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> do -- Upload the causal and all of its dependencies. - uploadEntities httpClient unisonShareUrl conn (Share.RepoPath.repoName repoPath) dependencies >>= \case - False -> pure (Left (CheckAndSetPushErrorNoWritePermission repoPath)) + uploadEntities httpClient unisonShareUrl conn (Share.pathRepoName path) dependencies >>= \case + False -> pure (Left (CheckAndSetPushErrorNoWritePermission path)) True -> -- After uploading the causal and all of its dependencies, try setting the remote path again. updatePath <&> \case @@ -117,8 +117,8 @@ checkAndSetPush httpClient unisonShareUrl conn repoPath expectedHash causalHash -- upload some dependency? Who knows. Share.UpdatePathMissingDependencies (Share.NeedDependencies dependencies) -> Left (CheckAndSetPushErrorServerMissingDependencies dependencies) - Share.UpdatePathNoWritePermission _ -> Left (CheckAndSetPushErrorNoWritePermission repoPath) - Share.UpdatePathNoWritePermission _ -> pure (Left (CheckAndSetPushErrorNoWritePermission repoPath)) + Share.UpdatePathNoWritePermission _ -> Left (CheckAndSetPushErrorNoWritePermission path) + Share.UpdatePathNoWritePermission _ -> pure (Left (CheckAndSetPushErrorNoWritePermission path)) where updatePath :: IO Share.UpdatePathResponse updatePath = @@ -126,17 +126,17 @@ checkAndSetPush httpClient unisonShareUrl conn repoPath expectedHash causalHash httpClient unisonShareUrl Share.UpdatePathRequest - { path = repoPath, + { path, expectedHash, newHash = causalHashToHash causalHash } -- | An error occurred while fast-forward pushing code to Unison Share. data FastForwardPushError - = FastForwardPushErrorNoHistory Share.RepoPath - | FastForwardPushErrorNoReadPermission Share.RepoPath + = FastForwardPushErrorNoHistory Share.Path + | FastForwardPushErrorNoReadPermission Share.Path | FastForwardPushErrorNotFastForward - | FastForwardPushErrorNoWritePermission Share.RepoPath + | FastForwardPushErrorNoWritePermission Share.Path | FastForwardPushErrorServerMissingDependencies (NESet Share.Hash) -- | Push a causal to Unison Share. @@ -149,14 +149,14 @@ fastForwardPush :: -- | SQLite connection, for reading entities to push. Sqlite.Connection -> -- | The repo+path to push to. - Share.RepoPath -> + Share.Path -> -- | The hash of our local causal to push. CausalHash -> IO (Either FastForwardPushError ()) -fastForwardPush httpClient unisonShareUrl conn repoPath localHeadHash = - getCausalHashByPath httpClient unisonShareUrl repoPath >>= \case - Left (GetCausalHashByPathErrorNoReadPermission _) -> pure (Left (FastForwardPushErrorNoReadPermission repoPath)) - Right Nothing -> pure (Left (FastForwardPushErrorNoHistory repoPath)) +fastForwardPush httpClient unisonShareUrl conn path localHeadHash = + getCausalHashByPath httpClient unisonShareUrl path >>= \case + Left (GetCausalHashByPathErrorNoReadPermission _) -> pure (Left (FastForwardPushErrorNoReadPermission path)) + Right Nothing -> pure (Left (FastForwardPushErrorNoHistory path)) Right (Just (Share.hashJWTHash -> remoteHeadHash)) -> Sqlite.runTransaction conn (fancyBfs localHeadHash remoteHeadHash) >>= \case -- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a @@ -164,7 +164,7 @@ fastForwardPush httpClient unisonShareUrl conn repoPath localHeadHash = Nothing -> pure (Left FastForwardPushErrorNotFastForward) Just localTailHashes -> doUpload (localHeadHash :| localTailHashes) >>= \case - False -> pure (Left (FastForwardPushErrorNoWritePermission repoPath)) + False -> pure (Left (FastForwardPushErrorNoWritePermission path)) True -> doFastForwardPath (localHeadHash : localTailHashes) <&> \case Share.FastForwardPathSuccess -> Right () @@ -172,8 +172,8 @@ fastForwardPush httpClient unisonShareUrl conn repoPath localHeadHash = Left (FastForwardPushErrorServerMissingDependencies dependencies) -- Weird: someone must have force-pushed no history here, or something. We observed a history at this -- path but moments ago! - Share.FastForwardPathNoHistory -> Left (FastForwardPushErrorNoHistory repoPath) - Share.FastForwardPathNoWritePermission _ -> Left (FastForwardPushErrorNoWritePermission repoPath) + Share.FastForwardPathNoHistory -> Left (FastForwardPushErrorNoHistory path) + Share.FastForwardPathNoWritePermission _ -> Left (FastForwardPushErrorNoWritePermission path) Share.FastForwardPathNotFastForward _ -> Left FastForwardPushErrorNotFastForward where doUpload :: List.NonEmpty CausalHash -> IO Bool @@ -185,7 +185,7 @@ fastForwardPush httpClient unisonShareUrl conn repoPath localHeadHash = httpClient unisonShareUrl conn - (Share.RepoPath.repoName repoPath) + (Share.pathRepoName path) (NESet.singleton (causalHashToHash headHash)) doFastForwardPath :: [CausalHash] -> IO Share.FastForwardPathResponse @@ -195,7 +195,7 @@ fastForwardPush httpClient unisonShareUrl conn repoPath localHeadHash = unisonShareUrl Share.FastForwardPathRequest { hashes = map causalHashToHash causalSpine, - path = repoPath + path = path } -- Return a list from newest to oldest of the ancestors between (excluding) the latest local and the current remote hash. @@ -279,7 +279,7 @@ dagbfs goal children = data PullError = -- | An error occurred while resolving a repo+path to a causal hash. PullErrorGetCausalHashByPath GetCausalHashByPathError - | PullErrorNoHistoryAtPath Share.RepoPath.RepoPath + | PullErrorNoHistoryAtPath Share.Path pull :: -- | The HTTP client to use for Unison Share requests. @@ -289,7 +289,7 @@ pull :: -- | SQLite connection, for writing entities we pull. Sqlite.Connection -> -- | The repo+path to pull from. - Share.RepoPath -> + Share.Path -> IO (Either PullError CausalHash) pull httpClient unisonShareUrl conn repoPath = do getCausalHashByPath httpClient unisonShareUrl repoPath >>= \case @@ -306,7 +306,7 @@ pull httpClient unisonShareUrl conn repoPath = do where doDownload :: NESet Share.HashJWT -> IO () doDownload = - downloadEntities httpClient unisonShareUrl conn (Share.RepoPath.repoName repoPath) + downloadEntities httpClient unisonShareUrl conn (Share.pathRepoName repoPath) ------------------------------------------------------------------------------------------------------------------------ -- Get causal hash by path @@ -314,7 +314,7 @@ pull httpClient unisonShareUrl conn repoPath = do -- | An error occurred when getting causal hash by path. data GetCausalHashByPathError = -- | The user does not have permission to read this path. - GetCausalHashByPathErrorNoReadPermission Share.RepoPath + GetCausalHashByPathErrorNoReadPermission Share.Path -- | Get the causal hash of a path hosted on Unison Share. getCausalHashByPath :: @@ -322,7 +322,7 @@ getCausalHashByPath :: AuthorizedHttpClient -> -- | The Unison Share URL. BaseUrl -> - Share.RepoPath -> + Share.Path -> IO (Either GetCausalHashByPathError (Maybe Share.HashJWT)) getCausalHashByPath httpClient unisonShareUrl repoPath = Share.getPathHandler httpClient unisonShareUrl (Share.GetCausalHashByPathRequest repoPath) <&> \case diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 1b9b17d3e..0a1ba93b0 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -4,7 +4,8 @@ module Unison.Sync.Types ( -- * Misc. types Base64Bytes (..), RepoName (..), - RepoPath (..), + Path (..), + pathRepoName, -- ** Hash types Hash (..), @@ -65,6 +66,7 @@ import Data.Bifunctor import Data.Bitraversable import Data.ByteArray.Encoding (Base (Base64), convertFromBase, convertToBase) import qualified Data.HashMap.Strict as HashMap +import Data.List.NonEmpty (NonEmpty ((:|))) import Data.Map.NonEmpty (NEMap) import qualified Data.Map.Strict as Map import qualified Data.Set as Set @@ -91,24 +93,29 @@ instance FromJSON Base64Bytes where newtype RepoName = RepoName Text deriving newtype (Show, Eq, Ord, ToJSON, FromJSON) -data RepoPath = RepoPath - { repoName :: RepoName, - pathSegments :: [Text] +data Path = Path + { -- This is a nonempty list, where we require the first segment to be the repo name / user name / whatever, + -- which we need on the server side as an implementation detail of how we're representing different users' codebases. + + -- This could be relaxed in some other share implementation that allows access to the "root" of the shared codebase. + -- Our share implementation doesn't have a root, just a collection of sub-roots, one per user or (eventually) organization. + pathSegments :: NonEmpty Text } deriving stock (Show, Eq, Ord) -instance ToJSON RepoPath where - toJSON (RepoPath name segments) = +pathRepoName :: Path -> RepoName +pathRepoName (Path (p :| _)) = RepoName p + +instance ToJSON Path where + toJSON (Path segments) = object - [ "repo_name" .= name, - "path" .= segments + [ "path" .= segments ] -instance FromJSON RepoPath where - parseJSON = Aeson.withObject "RepoPath" \obj -> do - repoName <- obj .: "repo_name" +instance FromJSON Path where + parseJSON = Aeson.withObject "Path" \obj -> do pathSegments <- obj .: "path" - pure RepoPath {..} + pure Path {..} ------------------------------------------------------------------------------------------------------------------------ -- Hash types @@ -534,30 +541,30 @@ instance FromJSON EntityType where -- Get causal hash by path newtype GetCausalHashByPathRequest = GetCausalHashByPathRequest - { repoPath :: RepoPath + { path :: Path } deriving stock (Show, Eq, Ord) instance ToJSON GetCausalHashByPathRequest where - toJSON (GetCausalHashByPathRequest repoPath) = + toJSON (GetCausalHashByPathRequest path) = object - [ "repo_path" .= repoPath + [ "path" .= path ] instance FromJSON GetCausalHashByPathRequest where parseJSON = Aeson.withObject "GetCausalHashByPathRequest" \obj -> do - repoPath <- obj .: "repo_path" + path <- obj .: "path" pure GetCausalHashByPathRequest {..} data GetCausalHashByPathResponse = GetCausalHashByPathSuccess (Maybe HashJWT) - | GetCausalHashByPathNoReadPermission RepoPath + | GetCausalHashByPathNoReadPermission Path deriving stock (Show, Eq, Ord) instance ToJSON GetCausalHashByPathResponse where toJSON = \case GetCausalHashByPathSuccess hashJWT -> jsonUnion "success" hashJWT - GetCausalHashByPathNoReadPermission repoPath -> jsonUnion "no_read_permission" repoPath + GetCausalHashByPathNoReadPermission path -> jsonUnion "no_read_permission" path instance FromJSON GetCausalHashByPathResponse where parseJSON = Aeson.withObject "GetCausalHashByPathResponse" \obj -> do @@ -675,8 +682,8 @@ instance FromJSON UploadEntitiesResponse where data FastForwardPathRequest = FastForwardPathRequest { -- TODO non-empty hashes :: [Hash], - -- | The repo + path to fast-forward. - path :: RepoPath + -- | The path to fast-forward. + path :: Path } deriving stock (Show) @@ -697,7 +704,7 @@ instance FromJSON FastForwardPathRequest where data FastForwardPathResponse = FastForwardPathSuccess | FastForwardPathMissingDependencies (NeedDependencies Hash) - | FastForwardPathNoWritePermission RepoPath + | FastForwardPathNoWritePermission Path | -- | This wasn't a fast-forward. Here's a JWT to download the causal head, if you want it. FastForwardPathNotFastForward HashJWT | -- | There was no history at this path; the client should use the "update path" endpoint instead. @@ -708,7 +715,7 @@ instance ToJSON FastForwardPathResponse where toJSON = \case FastForwardPathSuccess -> jsonUnion "success" (Object mempty) FastForwardPathMissingDependencies deps -> jsonUnion "missing_dependencies" deps - FastForwardPathNoWritePermission repoPath -> jsonUnion "no_write_permission" repoPath + FastForwardPathNoWritePermission path -> jsonUnion "no_write_permission" path FastForwardPathNotFastForward hashJwt -> jsonUnion "not_fast_forward" hashJwt FastForwardPathNoHistory -> jsonUnion "no_history" (Object mempty) @@ -727,7 +734,7 @@ instance FromJSON FastForwardPathResponse where -- Update path data UpdatePathRequest = UpdatePathRequest - { path :: RepoPath, + { path :: Path, expectedHash :: Maybe Hash, -- Nothing requires empty history at destination newHash :: Hash } @@ -752,7 +759,7 @@ data UpdatePathResponse = UpdatePathSuccess | UpdatePathHashMismatch HashMismatch | UpdatePathMissingDependencies (NeedDependencies Hash) - | UpdatePathNoWritePermission RepoPath + | UpdatePathNoWritePermission Path deriving stock (Show, Eq, Ord) instance ToJSON UpdatePathResponse where @@ -760,7 +767,7 @@ instance ToJSON UpdatePathResponse where UpdatePathSuccess -> jsonUnion "success" (Object mempty) UpdatePathHashMismatch hm -> jsonUnion "hash_mismatch" hm UpdatePathMissingDependencies md -> jsonUnion "missing_dependencies" md - UpdatePathNoWritePermission repoPath -> jsonUnion "no_write_permission" repoPath + UpdatePathNoWritePermission path -> jsonUnion "no_write_permission" path instance FromJSON UpdatePathResponse where parseJSON v = @@ -773,23 +780,23 @@ instance FromJSON UpdatePathResponse where t -> failText $ "Unexpected UpdatePathResponse type: " <> t data HashMismatch = HashMismatch - { repoPath :: RepoPath, + { path :: Path, expectedHash :: Maybe Hash, actualHash :: Maybe Hash } deriving stock (Show, Eq, Ord) instance ToJSON HashMismatch where - toJSON (HashMismatch repoPath expectedHash actualHash) = + toJSON (HashMismatch path expectedHash actualHash) = object - [ "repo_path" .= repoPath, + [ "path" .= path, "expected_hash" .= expectedHash, "actual_hash" .= actualHash ] instance FromJSON HashMismatch where parseJSON = Aeson.withObject "HashMismatch" \obj -> do - repoPath <- obj .: "repo_path" + path <- obj .: "path" expectedHash <- obj .: "expected_hash" actualHash <- obj .: "actual_hash" pure HashMismatch {..} From 06e9089c12f23248280dfce7fbf1f92d74c3fc13 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Wed, 11 May 2022 13:08:12 -0400 Subject: [PATCH 05/19] fix ShareRepo related missing case warnings --- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 9 +++-- .../src/Unison/Codebase/Editor/HandleInput.hs | 38 ++++++++++++------- .../Codebase/Editor/HandleInput/LoopState.hs | 5 +-- .../Unison/Codebase/Editor/VersionParser.hs | 17 +++++---- .../src/Unison/Codebase/TranscriptParser.hs | 3 +- unison-cli/src/Unison/CommandLine/Main.hs | 3 +- .../src/Unison/CommandLine/OutputMessages.hs | 4 +- unison-cli/src/Unison/Share/Sync.hs | 1 - 8 files changed, 44 insertions(+), 36 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 0e69bf0a4..117f5e4b8 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -19,7 +19,7 @@ data ReadRepo data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text} deriving (Eq, Show) -newtype ShareRepo = ShareRepo {url :: Text} +data ShareRepo = ShareRepo deriving (Eq, Show) data WriteRepo @@ -45,12 +45,15 @@ writePathToRead (w, p) = (writeToRead w, Nothing, p) printReadRepo :: ReadRepo -> Text printReadRepo = \case ReadRepoGit ReadGitRepo {url, ref} -> url <> Monoid.fromMaybe (Text.cons ':' <$> ref) - ReadRepoShare ShareRepo {url} -> url + ReadRepoShare s -> printShareRepo s + +printShareRepo :: ShareRepo -> Text +printShareRepo = const "PLACEHOLDER" printWriteRepo :: WriteRepo -> Text printWriteRepo = \case WriteRepoGit WriteGitRepo {url, branch} -> url <> Monoid.fromMaybe (Text.cons ':' <$> branch) - WriteRepoShare ShareRepo {url} -> url + WriteRepoShare s -> printShareRepo s -- | print remote namespace printNamespace :: ReadRepo -> Maybe ShortBranchHash -> Path -> Text diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 96d7cc197..b30fd79f5 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -27,6 +27,7 @@ import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import qualified Data.Text as Text import Data.Tuple.Extra (uncurry3) +import qualified Servant.Client as Servant import qualified Text.Megaparsec as P import qualified U.Codebase.Sqlite.Operations as Ops import U.Util.Timing (unsafeTime) @@ -58,7 +59,7 @@ import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBranchDiff import qualified Unison.Codebase.Editor.Output.DumpNamespace as Output.DN import qualified Unison.Codebase.Editor.Propagate as Propagate -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadRepo (ReadRepoGit), WriteGitRepo, WriteRemotePath, WriteRepo (WriteRepoGit, WriteRepoShare), printNamespace, writePathToRead) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadRepo (ReadRepoGit), ShareRepo (ShareRepo), WriteGitRepo, WriteRemotePath, WriteRepo (WriteRepoGit, WriteRepoShare), printNamespace, writePathToRead) import qualified Unison.Codebase.Editor.Slurp as Slurp import Unison.Codebase.Editor.SlurpComponent (SlurpComponent (..)) import qualified Unison.Codebase.Editor.SlurpComponent as SC @@ -1709,16 +1710,17 @@ handleGist (GistInput repo) = doPushRemoteBranch repo Path.relativeEmpty' SyncMode.ShortCircuit Nothing handlePullFromUnisonShare :: MonadIO m => Text -> Path -> Action' m v () -handlePullFromUnisonShare remoteRepo remotePath = do - let path = Share.Path (remoteRepo Nel.:| coerce @[NameSegment] @[Text] (Path.toList remotePath)) +handlePullFromUnisonShare remoteRepo remotePath = undefined - LoopState.Env {authHTTPClient, codebase = Codebase {connection}, unisonShareUrl} <- ask +-- let path = Share.Path (remoteRepo Nel.:| coerce @[NameSegment] @[Text] (Path.toList remotePath)) - liftIO (Share.pull authHTTPClient unisonShareUrl connection path) >>= \case - Left (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission _)) -> undefined - Left (Share.PullErrorNoHistoryAtPath repoPath) -> undefined - Right causalHash -> do - undefined +-- LoopState.Env {authHTTPClient, codebase = Codebase {connection}} <- ask + +-- liftIO (Share.pull authHTTPClient unisonShareUrl connection path) >>= \case +-- Left (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission _)) -> undefined +-- Left (Share.PullErrorNoHistoryAtPath repoPath) -> undefined +-- Right causalHash -> do +-- undefined -- | Handle a @push@ command. handlePushRemoteBranch :: @@ -1797,11 +1799,14 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do PushBehavior.RequireEmpty -> Branch.isEmpty0 (Branch.head remoteBranch) PushBehavior.RequireNonEmpty -> not (Branch.isEmpty0 (Branch.head remoteBranch)) -handlePushToUnisonShare :: MonadIO m => Text -> Path -> Path.Absolute -> PushBehavior -> Action' m v () -handlePushToUnisonShare remoteRepo remotePath localPath behavior = do +shareRepoToBaseURL :: ShareRepo -> Servant.BaseUrl +shareRepoToBaseURL ShareRepo = Servant.BaseUrl Servant.Https "share.unison.cloud" 443 "" + +handlePushToUnisonShare :: MonadIO m => ShareRepo -> Text -> Path -> Path.Absolute -> PushBehavior -> Action' m v () +handlePushToUnisonShare shareRepo remoteRepo remotePath localPath behavior = do let repoPath = Share.Path (remoteRepo Nel.:| coerce @[NameSegment] @[Text] (Path.toList remotePath)) - LoopState.Env {authHTTPClient, codebase = Codebase {connection}, unisonShareUrl} <- ask + LoopState.Env {authHTTPClient, codebase = Codebase {connection}} <- ask -- doesn't handle the case where a non-existent path is supplied Sqlite.runTransaction @@ -1812,7 +1817,7 @@ handlePushToUnisonShare remoteRepo remotePath localPath behavior = do Just localCausalHash -> case behavior of PushBehavior.RequireEmpty -> - liftIO (Share.checkAndSetPush authHTTPClient unisonShareUrl connection repoPath Nothing localCausalHash) >>= \case + liftIO (Share.checkAndSetPush authHTTPClient (shareRepoToBaseURL shareRepo) connection repoPath Nothing localCausalHash) >>= \case Left err -> case err of Share.CheckAndSetPushErrorHashMismatch _mismatch -> error "remote not empty" @@ -1820,7 +1825,7 @@ handlePushToUnisonShare remoteRepo remotePath localPath behavior = do Share.CheckAndSetPushErrorServerMissingDependencies deps -> errServerMissingDependencies deps Right () -> pure () PushBehavior.RequireNonEmpty -> - liftIO (Share.fastForwardPush authHTTPClient unisonShareUrl connection repoPath localCausalHash) >>= \case + liftIO (Share.fastForwardPush authHTTPClient (shareRepoToBaseURL shareRepo) connection repoPath localCausalHash) >>= \case Left err -> case err of Share.FastForwardPushErrorNoHistory _repoPath -> error "no history" @@ -2198,6 +2203,11 @@ viewRemoteGitBranch :: viewRemoteGitBranch ns gitBranchBehavior action = do eval $ ViewRemoteGitBranch ns gitBranchBehavior action +-- todo: support the full ReadShareRemoteNamespace eventually, in place of (ShareRepo, Text, Path) +importRemoteShareBranch :: + ShareRepo -> Text -> Path -> (Branch m -> Action' m v ()) -> Action' m v () +importRemoteShareBranch url repoName path action = undefined + -- | Given the current root branch of a remote -- (or an empty branch if no root branch exists) -- compute a new branch, which will then be synced and pushed. diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs index b023c7add..372b8bbb4 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs @@ -11,7 +11,6 @@ import Control.Monad.State import Data.Configurator () import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as Nel -import Servant.Client (BaseUrl) import Unison.Auth.CredentialManager (CredentialManager) import Unison.Auth.HTTPClient (AuthorizedHttpClient) import Unison.Codebase (Codebase) @@ -33,9 +32,7 @@ type F m i v = Free (Command m i v) data Env m v = Env { authHTTPClient :: AuthorizedHttpClient, codebase :: Codebase m v Ann, - credentialManager :: CredentialManager, - -- | The URL to Unison Share - unisonShareUrl :: BaseUrl + credentialManager :: CredentialManager } newtype Action m i v a = Action {unAction :: MaybeT (ReaderT (Env m v) (StateT (LoopState m v) (F m i v))) a} diff --git a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs index 4dc9ca87c..ccafb831a 100644 --- a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs @@ -25,14 +25,15 @@ defaultBaseLib = fmap makeNS $ latest <|> release Text.pack <$> some (alphaNumChar <|> ('_' <$ oneOf ['.', '_', '-'])) makeNS :: Text -> ReadRemoteNamespace makeNS t = - ( ReadGitRepo - { url = "https://github.com/unisonweb/base", - -- Use the 'v3' branch of base for now. - -- We can revert back to the main branch once enough people have upgraded ucm and - -- we're okay with pushing the v3 base codebase to main (perhaps by the next ucm - -- release). - ref = Just "v3" - }, + ( ReadRepoGit + ReadGitRepo + { url = "https://github.com/unisonweb/base", + -- Use the 'v3' branch of base for now. + -- We can revert back to the main branch once enough people have upgraded ucm and + -- we're okay with pushing the v3 base codebase to main (perhaps by the next ucm + -- release). + ref = Just "v3" + }, Nothing, Path.fromText t ) diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index 2c2690f90..2ab95649c 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -425,8 +425,7 @@ run dir stanzas codebase runtime config ucmVersion baseURL = UnliftIO.try $ do LoopState.Env { LoopState.authHTTPClient = error "Error: No access to authorized requests from transcripts.", LoopState.codebase = codebase, - LoopState.credentialManager = error "Error: No access to credentials from transcripts.", - LoopState.unisonShareUrl = error "Error: No access to Unison Share from transcripts." + LoopState.credentialManager = error "Error: No access to credentials from transcripts." } let free = LoopState.runAction env state $ HandleInput.loop rng i = pure $ Random.drgNewSeed (Random.seedFromInteger (fromIntegral i)) diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 480b29778..70d51fcb0 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -197,8 +197,7 @@ main dir welcome initialPath (config, cancelConfig) initialInputs runtime codeba LoopState.Env { LoopState.authHTTPClient = authorizedHTTPClient, LoopState.codebase = codebase, - LoopState.credentialManager = credMan, - LoopState.unisonShareUrl = error "TODO: wire in Unison Share URL" + LoopState.credentialManager = credMan } let free = LoopState.runAction env state HandleInput.loop let handleCommand = diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index d2f6a3470..5f1fe73bd 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -2823,12 +2823,12 @@ prettyTypeName ppe r = prettyReadRepo :: ReadRepo -> Pretty prettyReadRepo = \case RemoteRepo.ReadRepoGit RemoteRepo.ReadGitRepo {url} -> P.blue (P.text url) - RemoteRepo.ReadRepoShare RemoteRepo.ShareRepo {url} -> P.blue (P.text url) + RemoteRepo.ReadRepoShare s -> P.blue (P.text (RemoteRepo.printShareRepo s)) prettyWriteRepo :: WriteRepo -> Pretty prettyWriteRepo = \case RemoteRepo.WriteRepoGit RemoteRepo.WriteGitRepo {url} -> P.blue (P.text url) - RemoteRepo.WriteRepoShare RemoteRepo.ShareRepo {url} -> P.blue (P.text url) + RemoteRepo.WriteRepoShare s -> P.blue (P.text (RemoteRepo.printShareRepo s)) isTestOk :: Term v Ann -> Bool isTestOk tm = case tm of diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index f407bb45c..af664f294 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -65,7 +65,6 @@ import qualified Unison.Sync.HTTP as Share uploadEntitiesHandler, ) import qualified Unison.Sync.Types as Share -import qualified Unison.Sync.Types as Share.Path (Path (..)) import Unison.Util.Monoid (foldMapM) import qualified Unison.Util.Set as Set From 51d5e73b923efe56be24949bf4ee0bbb7b2c2a21 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 11 May 2022 15:29:53 -0400 Subject: [PATCH 06/19] pull handleCreatePullRequest out to the top level --- .../src/Unison/Codebase/Editor/HandleInput.hs | 55 ++++++++++--------- 1 file changed, 30 insertions(+), 25 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index b30fd79f5..a41bfeccc 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -59,7 +59,7 @@ import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBranchDiff import qualified Unison.Codebase.Editor.Output.DumpNamespace as Output.DN import qualified Unison.Codebase.Editor.Propagate as Propagate -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadRepo (ReadRepoGit), ShareRepo (ShareRepo), WriteGitRepo, WriteRemotePath, WriteRepo (WriteRepoGit, WriteRepoShare), printNamespace, writePathToRead) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadRemoteNamespace, ReadRepo (ReadRepoGit), ShareRepo (ShareRepo), WriteGitRepo, WriteRemotePath, WriteRepo (WriteRepoGit, WriteRepoShare), printNamespace, writePathToRead) import qualified Unison.Codebase.Editor.Slurp as Slurp import Unison.Codebase.Editor.SlurpComponent (SlurpComponent (..)) import qualified Unison.Codebase.Editor.SlurpComponent as SC @@ -650,19 +650,7 @@ loop = do (resolveToAbsolute <$> after) ppe outputDiff - CreatePullRequestI baseRepo headRepo -> do - let viewRemoteBranch repo callback = case repo of - (ReadRepoGit r, sbh, path) -> - viewRemoteGitBranch (r, sbh, path) Git.RequireExistingBranch callback - result <- - join @(Either GitError) <$> viewRemoteBranch baseRepo \baseBranch -> do - viewRemoteBranch headRepo \headBranch -> do - merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch - (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) - pure $ ShowDiffAfterCreatePR baseRepo headRepo ppe diff - case result of - Left gitErr -> respond (Output.GitError gitErr) - Right diff -> respondNumbered diff + CreatePullRequestI baseRepo headRepo -> handleCreatePullRequest baseRepo headRepo LoadPullRequestI baseRepo headRepo dest0 -> do let desta = resolveToAbsolute dest0 let dest = Path.unabsolute desta @@ -714,8 +702,8 @@ loop = do case getAtSplit' dest of Just existingDest | not (Branch.isEmpty0 (Branch.head existingDest)) -> do - -- Branch exists and isn't empty, print an error - throwError (BranchAlreadyExists (Path.unsplit' dest)) + -- Branch exists and isn't empty, print an error + throwError (BranchAlreadyExists (Path.unsplit' dest)) _ -> pure () -- allow rewriting history to ensure we move the branch's history too. lift $ @@ -1408,11 +1396,11 @@ loop = do case filtered of [(Referent.Ref ref, ty)] | Typechecker.isSubtype ty mainType -> - eval (MakeStandalone ppe ref output) >>= \case - Just err -> respond $ EvaluationFailure err - Nothing -> pure () + eval (MakeStandalone ppe ref output) >>= \case + Just err -> respond $ EvaluationFailure err + Nothing -> pure () | otherwise -> - respond $ BadMainFunction smain ty ppe [mainType] + respond $ BadMainFunction smain ty ppe [mainType] _ -> respond $ NoMainFunction smain ppe [mainType] IOTestI main -> do -- todo - allow this to run tests from scratch file, using addRunMain @@ -1668,6 +1656,23 @@ loop = do Right input -> LoopState.lastInput .= Just input _ -> pure () +handleCreatePullRequest :: MonadUnliftIO m => ReadRemoteNamespace -> ReadRemoteNamespace -> Action' m v () +handleCreatePullRequest baseRepo headRepo = do + root' <- use LoopState.root + currentPath' <- use LoopState.currentPath + let viewRemoteBranch repo callback = case repo of + (ReadRepoGit r, sbh, path) -> + viewRemoteGitBranch (r, sbh, path) Git.RequireExistingBranch callback + result <- + join @(Either GitError) <$> viewRemoteBranch baseRepo \baseBranch -> do + viewRemoteBranch headRepo \headBranch -> do + merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch + (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) + pure $ ShowDiffAfterCreatePR baseRepo headRepo ppe diff + case result of + Left gitErr -> respond (Output.GitError gitErr) + Right diff -> respondNumbered diff + handleDependents :: Monad m => HQ.HashQualified Name -> Action' m v () handleDependents hq = do hqLength <- eval CodebaseHashLength @@ -2497,10 +2502,10 @@ searchBranchScored names0 score queries = pair qn HQ.HashQualified qn h | h `SH.isPrefixOf` Referent.toShortHash ref -> - pair qn + pair qn HQ.HashOnly h | h `SH.isPrefixOf` Referent.toShortHash ref -> - Set.singleton (Nothing, result) + Set.singleton (Nothing, result) _ -> mempty where result = SR.termSearchResult names0 name ref @@ -2517,10 +2522,10 @@ searchBranchScored names0 score queries = pair qn HQ.HashQualified qn h | h `SH.isPrefixOf` Reference.toShortHash ref -> - pair qn + pair qn HQ.HashOnly h | h `SH.isPrefixOf` Reference.toShortHash ref -> - Set.singleton (Nothing, result) + Set.singleton (Nothing, result) _ -> mempty where result = SR.typeSearchResult names0 name ref @@ -2913,7 +2918,7 @@ docsI srcLoc prettyPrintNames src = do | Set.size s == 1 -> displayI prettyPrintNames ConsoleLocation dotDoc | Set.size s == 0 -> respond $ ListOfLinks mempty [] | otherwise -> -- todo: return a list of links here too - respond $ ListOfLinks mempty [] + respond $ ListOfLinks mempty [] filterBySlurpResult :: Ord v => From d719276508137b0bdd31c6afd58397d93396708b Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 11 May 2022 17:30:21 -0400 Subject: [PATCH 07/19] broken partial propagation of more structured read/write repo types --- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 68 +++++++++++---- .../src/Unison/Codebase/SqliteCodebase.hs | 4 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 82 +++++++++++++------ .../src/Unison/Codebase/Editor/Output.hs | 4 +- .../src/Unison/Codebase/Editor/UriParser.hs | 26 ++++-- .../Unison/Codebase/Editor/VersionParser.hs | 26 +++--- .../src/Unison/CommandLine/InputPatterns.hs | 12 +-- .../src/Unison/CommandLine/OutputMessages.hs | 15 ++-- unison-cli/src/Unison/CommandLine/Welcome.hs | 20 +++-- 9 files changed, 168 insertions(+), 89 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 117f5e4b8..96f1abcec 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -19,6 +19,7 @@ data ReadRepo data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text} deriving (Eq, Show) +-- FIXME rename to ShareServer data ShareRepo = ShareRepo deriving (Eq, Show) @@ -40,7 +41,11 @@ writeToReadGit = \case WriteGitRepo {url, branch} -> ReadGitRepo {url = url, ref = branch} writePathToRead :: WriteRemotePath -> ReadRemoteNamespace -writePathToRead (w, p) = (writeToRead w, Nothing, p) +writePathToRead = \case + WriteRemotePathGit WriteGitRemotePath {repo, path} -> + ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo = writeToReadGit repo, sbh = Nothing, path} + WriteRemotePathShare WriteShareRemotePath {server, repo, path} -> + ReadRemoteNamespaceShare ReadShareRemoteNamespace {server, repo, path} printReadRepo :: ReadRepo -> Text printReadRepo = \case @@ -56,18 +61,19 @@ printWriteRepo = \case WriteRepoShare s -> printShareRepo s -- | print remote namespace -printNamespace :: ReadRepo -> Maybe ShortBranchHash -> Path -> Text -printNamespace repo sbh path = - printReadRepo repo <> case sbh of - Nothing -> - if path == Path.empty - then mempty - else ":." <> Path.toText path - Just sbh -> - ":#" <> SBH.toText sbh - <> if path == Path.empty +printNamespace :: ReadRemoteNamespace -> Text +printNamespace = \case + ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo, sbh, path} -> + printReadRepo (ReadRepoGit repo) <> case sbh of + Nothing -> + if path == Path.empty then mempty - else "." <> Path.toText path + else ":." <> Path.toText path + Just sbh -> + ":#" <> SBH.toText sbh + <> if path == Path.empty + then mempty + else "." <> Path.toText path -- | print remote path printHead :: WriteRepo -> Path -> Text @@ -75,10 +81,40 @@ printHead repo path = printWriteRepo repo <> if path == Path.empty then mempty else ":." <> Path.toText path -type GReadRemoteNamespace a = (a, Maybe ShortBranchHash, Path) +data ReadRemoteNamespace + = ReadRemoteNamespaceGit ReadGitRemoteNamespace + | ReadRemoteNamespaceShare ReadShareRemoteNamespace + deriving stock (Eq, Show) -type ReadRemoteNamespace = GReadRemoteNamespace ReadRepo +data ReadGitRemoteNamespace = ReadGitRemoteNamespace + { repo :: ReadGitRepo, + sbh :: Maybe ShortBranchHash, + path :: Path + } + deriving stock (Eq, Show) -type ReadGitRemoteNamespace = GReadRemoteNamespace ReadGitRepo +data ReadShareRemoteNamespace = ReadShareRemoteNamespace + { server :: ShareRepo, + repo :: Text, + -- sbh :: Maybe ShortBranchHash, -- maybe later + path :: Path + } + deriving stock (Eq, Show) -type WriteRemotePath = (WriteRepo, Path) +data WriteRemotePath + = WriteRemotePathGit WriteGitRemotePath + | WriteRemotePathShare WriteShareRemotePath + deriving stock (Eq, Show) + +data WriteGitRemotePath = WriteGitRemotePath + { repo :: WriteGitRepo, + path :: Path + } + deriving stock (Eq, Show) + +data WriteShareRemotePath = WriteShareRemotePath + { server :: ShareRepo, + repo :: Text, + path :: Path + } + deriving stock (Eq, Show) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index fca896b4e..f789099d8 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -46,7 +46,7 @@ import qualified Unison.Codebase.Causal.Type as Causal import Unison.Codebase.Editor.Git (gitIn, gitInCaptured, gitTextIn, withRepo) import qualified Unison.Codebase.Editor.Git as Git import Unison.Codebase.Editor.RemoteRepo - ( ReadGitRemoteNamespace, + ( ReadGitRemoteNamespace (..), ReadGitRepo, WriteGitRepo (..), WriteRepo (..), @@ -691,7 +691,7 @@ viewRemoteBranch' :: Git.GitBranchBehavior -> ((Branch m, CodebasePath) -> m r) -> m (Either C.GitError r) -viewRemoteBranch' (repo, sbh, path) gitBranchBehavior action = UnliftIO.try $ do +viewRemoteBranch' ReadGitRemoteNamespace {repo, sbh, path} gitBranchBehavior action = UnliftIO.try $ do -- set up the cache dir time "Git fetch" $ throwEitherMWith C.GitProtocolError . withRepo repo gitBranchBehavior $ \remoteRepo -> do diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index a41bfeccc..b9548594f 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -59,7 +59,20 @@ import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBranchDiff import qualified Unison.Codebase.Editor.Output.DumpNamespace as Output.DN import qualified Unison.Codebase.Editor.Propagate as Propagate -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadRemoteNamespace, ReadRepo (ReadRepoGit), ShareRepo (ShareRepo), WriteGitRepo, WriteRemotePath, WriteRepo (WriteRepoGit, WriteRepoShare), printNamespace, writePathToRead) +import Unison.Codebase.Editor.RemoteRepo + ( ReadGitRemoteNamespace, + ReadRemoteNamespace (..), + ReadRepo (ReadRepoGit), + ShareRepo (ShareRepo), + WriteGitRepo, + WriteRemotePath, + WriteRepo (WriteRepoGit, WriteRepoShare), + printNamespace, + writePathToRead, + pattern ReadGitRemoteNamespace, + pattern ReadShareRemoteNamespace, + ) +import qualified Unison.Codebase.Editor.RemoteRepo as ReadGitRemoteNamespace (ReadGitRemoteNamespace (..)) import qualified Unison.Codebase.Editor.Slurp as Slurp import Unison.Codebase.Editor.SlurpComponent (SlurpComponent (..)) import qualified Unison.Codebase.Editor.SlurpComponent as SC @@ -416,7 +429,7 @@ loop = do -- todo: show the actual config-loaded namespace <> maybe "(remote namespace from .unisonConfig)" - (uncurry3 printNamespace) + printNamespace orepo <> " " <> p' dest @@ -428,9 +441,9 @@ loop = do CreatePullRequestI {} -> wat LoadPullRequestI base head dest -> "pr.load " - <> uncurry3 printNamespace base + <> printNamespace base <> " " - <> uncurry3 printNamespace head + <> printNamespace head <> " " <> p' dest PushRemoteBranchI {} -> wat @@ -658,11 +671,9 @@ loop = do if Branch.isEmpty0 (Branch.head destb) then unlessGitError do baseb <- case baseRepo of - (ReadRepoGit r, sbh, path) -> - importRemoteGitBranch (r, sbh, path) SyncMode.ShortCircuit Unmodified + ReadRemoteNamespaceGit repo -> importRemoteGitBranch repo SyncMode.ShortCircuit Unmodified headb <- case headRepo of - (ReadRepoGit r, sbh, path) -> - importRemoteGitBranch (r, sbh, path) SyncMode.ShortCircuit Unmodified + ReadRemoteNamespaceGit repo -> importRemoteGitBranch repo SyncMode.ShortCircuit Unmodified lift $ do mergedb <- eval $ Merge Branch.RegularMerge baseb headb squashedb <- eval $ Merge Branch.SquashMerge headb baseb @@ -1499,8 +1510,7 @@ loop = do ns <- maybe (writePathToRead <$> resolveConfiguredUrl Pull path) pure mayRepo lift $ unlessGitError do remoteBranch <- case ns of - (ReadRepoGit r, sbh, path) -> - importRemoteGitBranch (r, sbh, path) syncMode preprocess + ReadRemoteNamespaceGit repo -> importRemoteGitBranch repo syncMode preprocess let unchangedMsg = PullAlreadyUpToDate ns path let destAbs = resolveToAbsolute path let printDiffPath = if Verbosity.isSilent verbosity then Nothing else Just path @@ -1657,21 +1667,32 @@ loop = do _ -> pure () handleCreatePullRequest :: MonadUnliftIO m => ReadRemoteNamespace -> ReadRemoteNamespace -> Action' m v () -handleCreatePullRequest baseRepo headRepo = do +handleCreatePullRequest baseRepo0 headRepo0 = do root' <- use LoopState.root currentPath' <- use LoopState.currentPath - let viewRemoteBranch repo callback = case repo of - (ReadRepoGit r, sbh, path) -> - viewRemoteGitBranch (r, sbh, path) Git.RequireExistingBranch callback - result <- - join @(Either GitError) <$> viewRemoteBranch baseRepo \baseBranch -> do - viewRemoteBranch headRepo \headBranch -> do - merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch - (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) - pure $ ShowDiffAfterCreatePR baseRepo headRepo ppe diff - case result of - Left gitErr -> respond (Output.GitError gitErr) - Right diff -> respondNumbered diff + case (baseRepo0, headRepo0) of + (ReadRemoteNamespaceGit baseRepo, ReadRemoteNamespaceGit headRepo) -> do + result <- + viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> do + viewRemoteGitBranch headRepo Git.RequireExistingBranch \headBranch -> do + merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch + (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) + pure $ ShowDiffAfterCreatePR baseRepo0 headRepo0 ppe diff + case join result of + Left gitErr -> respond (Output.GitError gitErr) + Right diff -> respondNumbered diff + -- (ReadGitRemoteNamespace baseRepo, ReadShareRemoteNamespace headRepo@(headRepo', _, _)) -> do + -- importRemoteShareBranch headRepo' undefined undefined >>= \case + -- Left () -> respond (error "bad pull") + -- Right headBranch -> do + -- result <- + -- viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> do + -- merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch + -- (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) + -- pure $ ShowDiffAfterCreatePR baseRepo0 headRepo0 ppe diff + -- case result of + -- Left gitErr -> respond (Output.GitError gitErr) + -- Right diff -> respondNumbered diff handleDependents :: Monad m => HQ.HashQualified Name -> Action' m v () handleDependents hq = do @@ -1771,7 +1792,16 @@ doPushRemoteBranch repo localPath syncMode remoteTarget = do let opts = PushGitBranchOpts {setRoot = False, syncMode} syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch)) sbhLength <- (eval BranchHashLength) - respond (GistCreated sbhLength (WriteRepoGit repo) (Branch.headHash sourceBranch)) + respond + ( GistCreated + ( ReadRemoteNamespaceGit + ReadGitRemoteNamespace + { repo, + ReadGitRemoteNamespace.sbh = Just (SBH.fromHash sbhLength (Branch.headHash sourceBranch)), + ReadGitRemoteNamespace.path = Path.empty + } + ) + ) Just (remotePath, pushBehavior) -> do let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m)) withRemoteRoot remoteRoot = do @@ -2210,8 +2240,8 @@ viewRemoteGitBranch ns gitBranchBehavior action = do -- todo: support the full ReadShareRemoteNamespace eventually, in place of (ShareRepo, Text, Path) importRemoteShareBranch :: - ShareRepo -> Text -> Path -> (Branch m -> Action' m v ()) -> Action' m v () -importRemoteShareBranch url repoName path action = undefined + ShareRepo -> Text -> Path -> Action' m v (Either () (Branch m)) +importRemoteShareBranch url repoName path = undefined -- | Given the current root branch of a remote -- (or an empty branch if no root branch exists) diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index ca0251f1e..500f467ca 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -248,8 +248,8 @@ data Output v | NoOp | -- Refused to push, either because a `push` targeted an empty namespace, or a `push.create` targeted a non-empty namespace. RefusedToPush PushBehavior - | -- | @GistCreated repo hash@ means causal @hash@ was just published to @repo@. - GistCreated Int WriteRepo Branch.Hash + | -- | @GistCreated repo@ means a causal was just published to @repo@. + GistCreated ReadRemoteNamespace | -- | Directs the user to URI to begin an authorization flow. InitiateAuthFlow URI | UnknownCodeServer Text diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 52e7b2e4a..87b676a18 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -9,7 +9,7 @@ import Data.Void import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as C import qualified Text.Megaparsec.Char.Lexer as L -import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo (..), ReadRemoteNamespace, ReadRepo (..), WriteGitRepo (..), WriteRemotePath, WriteRepo (..)) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace (..), ReadGitRepo (..), ReadRemoteNamespace (..), WriteGitRemotePath (..), WriteGitRepo (..), WriteRemotePath (..), WriteRepo (..)) import Unison.Codebase.Path (Path (..)) import qualified Unison.Codebase.Path as Path import Unison.Codebase.ShortBranchHash (ShortBranchHash (..)) @@ -42,11 +42,13 @@ repoPath :: P ReadRemoteNamespace repoPath = P.label "generic git repo" $ do protocol <- parseProtocol treeish <- P.optional treeishSuffix - let repo = (ReadRepoGit ReadGitRepo {url = printProtocol protocol, ref = treeish}) + let repo = ReadGitRepo {url = printProtocol protocol, ref = treeish} nshashPath <- P.optional (C.char ':' *> namespaceHashPath) - case nshashPath of - Nothing -> pure (repo, Nothing, Path.empty) - Just (sbh, p) -> pure (repo, sbh, p) + pure do + ReadRemoteNamespaceGit do + case nshashPath of + Nothing -> ReadGitRemoteNamespace {repo, sbh = Nothing, path = Path.empty} + Just (sbh, path) -> ReadGitRemoteNamespace {repo, sbh, path} writeRepo :: P WriteRepo writeRepo = P.label "repo root for writing" $ do @@ -55,10 +57,18 @@ writeRepo = P.label "repo root for writing" $ do pure (WriteRepoGit WriteGitRepo {url = printProtocol uri, branch = treeish}) writeRepoPath :: P WriteRemotePath -writeRepoPath = P.label "generic git repo" $ do +writeRepoPath = P.label "generic write repo" $ do repo <- writeRepo - path <- P.optional (C.char ':' *> absolutePath) - pure (repo, fromMaybe Path.empty path) + case repo of + WriteRepoGit repo -> do + path <- P.optional (C.char ':' *> absolutePath) + pure (WriteRemotePathGit WriteGitRemotePath {repo, path = fromMaybe Path.empty path}) + {- + WriteRepoShare server -> do + repo <- undefined + path <- undefined + pure (WriteRemotePathShare WriteShareRemotePath {server, repo, path}) + -} -- does this not exist somewhere in megaparsec? yes in 7.0 symbol :: Text -> P Text diff --git a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs index ccafb831a..1e161c4cb 100644 --- a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs @@ -25,15 +25,17 @@ defaultBaseLib = fmap makeNS $ latest <|> release Text.pack <$> some (alphaNumChar <|> ('_' <$ oneOf ['.', '_', '-'])) makeNS :: Text -> ReadRemoteNamespace makeNS t = - ( ReadRepoGit - ReadGitRepo - { url = "https://github.com/unisonweb/base", - -- Use the 'v3' branch of base for now. - -- We can revert back to the main branch once enough people have upgraded ucm and - -- we're okay with pushing the v3 base codebase to main (perhaps by the next ucm - -- release). - ref = Just "v3" - }, - Nothing, - Path.fromText t - ) + ReadRemoteNamespaceGit + ReadGitRemoteNamespace + { repo = + ReadGitRepo + { url = "https://github.com/unisonweb/base", + -- Use the 'v3' branch of base for now. + -- We can revert back to the main branch once enough people have upgraded ucm and + -- we're okay with pushing the v3 base codebase to main (perhaps by the next ucm + -- release). + ref = Just "v3" + }, + sbh = Nothing, + path = Path.fromText t + } diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 3cd2b042c..6c1220072 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1086,12 +1086,12 @@ push = [] -> Right $ Input.PushRemoteBranchI Nothing Path.relativeEmpty' PushBehavior.RequireNonEmpty SyncMode.ShortCircuit url : rest -> do - (repo, path) <- parsePushPath "url" url + pushPath <- parsePushPath "url" url p <- case rest of [] -> Right Path.relativeEmpty' [path] -> first fromString $ Path.parsePath' path _ -> Left (I.help push) - Right $ Input.PushRemoteBranchI (Just (repo, path)) p PushBehavior.RequireNonEmpty SyncMode.ShortCircuit + Right $ Input.PushRemoteBranchI (Just pushPath) p PushBehavior.RequireNonEmpty SyncMode.ShortCircuit ) pushCreate :: InputPattern @@ -1127,12 +1127,12 @@ pushCreate = [] -> Right $ Input.PushRemoteBranchI Nothing Path.relativeEmpty' PushBehavior.RequireEmpty SyncMode.ShortCircuit url : rest -> do - (repo, path) <- parsePushPath "url" url + pushPath <- parsePushPath "url" url p <- case rest of [] -> Right Path.relativeEmpty' [path] -> first fromString $ Path.parsePath' path _ -> Left (I.help push) - Right $ Input.PushRemoteBranchI (Just (repo, path)) p PushBehavior.RequireEmpty SyncMode.ShortCircuit + Right $ Input.PushRemoteBranchI (Just pushPath) p PushBehavior.RequireEmpty SyncMode.ShortCircuit ) pushExhaustive :: InputPattern @@ -1155,12 +1155,12 @@ pushExhaustive = [] -> Right $ Input.PushRemoteBranchI Nothing Path.relativeEmpty' PushBehavior.RequireNonEmpty SyncMode.Complete url : rest -> do - (repo, path) <- parsePushPath "url" url + pushPath <- parsePushPath "url" url p <- case rest of [] -> Right Path.relativeEmpty' [path] -> first fromString $ Path.parsePath' path _ -> Left (I.help push) - Right $ Input.PushRemoteBranchI (Just (repo, path)) p PushBehavior.RequireNonEmpty SyncMode.Complete + Right $ Input.PushRemoteBranchI (Just pushPath) p PushBehavior.RequireNonEmpty SyncMode.Complete ) createPullRequest :: InputPattern diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 5f1fe73bd..11a1d70e5 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -23,7 +23,7 @@ import qualified Data.Set as Set import Data.Set.NonEmpty (NESet) import qualified Data.Text as Text import Data.Tuple (swap) -import Data.Tuple.Extra (dupe, uncurry3) +import Data.Tuple.Extra (dupe) import Network.URI (URI) import System.Directory ( canonicalizePath, @@ -506,11 +506,9 @@ showListEdits patch ppe = prettyURI :: URI -> Pretty prettyURI = P.bold . P.blue . P.shown -prettyRemoteNamespace :: - ReadRemoteNamespace -> - Pretty +prettyRemoteNamespace :: ReadRemoteNamespace -> Pretty prettyRemoteNamespace = - P.group . P.blue . P.text . uncurry3 RemoteRepo.printNamespace + P.group . P.blue . P.text . RemoteRepo.printNamespace notifyUser :: forall v. Var v => FilePath -> Output v -> IO Pretty notifyUser dir o = case o of @@ -1134,7 +1132,7 @@ notifyUser dir o = case o of P.wrap $ "I just finished importing the branch" <> P.red (P.shown h) <> "from" - <> P.red (prettyRemoteNamespace (over _1 ReadRepoGit ns)) + <> P.red (prettyRemoteNamespace (RemoteRepo.ReadRemoteNamespaceGit ns)) <> "but now I can't find it." CouldntFindRemoteBranch repo path -> P.wrap $ @@ -1525,16 +1523,13 @@ notifyUser dir o = case o of "", "Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?" ] - GistCreated hqLength repo hash -> + GistCreated remoteNamespace -> pure $ P.lines [ "Gist created. Pull via:", "", P.indentN 2 (IP.patternName IP.pull <> " " <> prettyRemoteNamespace remoteNamespace) ] - where - remoteNamespace = - (RemoteRepo.writeToRead repo, Just (SBH.fromHash hqLength hash), Path.empty) InitiateAuthFlow authURI -> do pure $ P.wrap $ diff --git a/unison-cli/src/Unison/CommandLine/Welcome.hs b/unison-cli/src/Unison/CommandLine/Welcome.hs index 4f3447071..59b9b10b9 100644 --- a/unison-cli/src/Unison/CommandLine/Welcome.hs +++ b/unison-cli/src/Unison/CommandLine/Welcome.hs @@ -7,7 +7,7 @@ import System.Random (randomRIO) import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import Unison.Codebase.Editor.Input -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace (..), ReadRemoteNamespace (..)) import Unison.Codebase.Path (Path) import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.SyncMode as SyncMode @@ -25,7 +25,7 @@ data Welcome = Welcome } data DownloadBase - = DownloadBase ReadRemoteNamespace + = DownloadBase ReadGitRemoteNamespace | DontDownloadBase -- Previously Created is different from Previously Onboarded because a user can @@ -38,7 +38,7 @@ data CodebaseInitStatus data Onboarding = Init CodebaseInitStatus -- Can transition to [DownloadingBase, Author, Finished, PreviouslyOnboarded] - | DownloadingBase ReadRemoteNamespace -- Can transition to [Author, Finished] + | DownloadingBase ReadGitRemoteNamespace -- Can transition to [Author, Finished] | Author -- Can transition to [Finished] -- End States | Finished @@ -48,12 +48,18 @@ welcome :: CodebaseInitStatus -> DownloadBase -> FilePath -> Text -> Welcome welcome initStatus downloadBase filePath unisonVersion = Welcome (Init initStatus) downloadBase filePath unisonVersion -pullBase :: ReadRemoteNamespace -> Either Event Input +pullBase :: ReadGitRemoteNamespace -> Either Event Input pullBase ns = let seg = NameSegment "base" rootPath = Path.Path {Path.toSeq = singleton seg} abs = Path.Absolute {Path.unabsolute = rootPath} - pullRemote = PullRemoteBranchI (Just ns) (Path.Path' {Path.unPath' = Left abs}) SyncMode.Complete PullWithHistory Verbosity.Silent + pullRemote = + PullRemoteBranchI + (Just (ReadRemoteNamespaceGit ns)) + (Path.Path' {Path.unPath' = Left abs}) + SyncMode.Complete + PullWithHistory + Verbosity.Silent in Right pullRemote run :: Codebase IO v a -> Welcome -> IO [Either Event Input] @@ -71,7 +77,7 @@ run codebase Welcome {onboarding = onboarding, downloadBase = downloadBase, watc go PreviouslyOnboarded (headerMsg : acc) where headerMsg = toInput (header version) - DownloadingBase ns@(_, _, path) -> + DownloadingBase ns@ReadGitRemoteNamespace {path} -> go Author ([pullBaseInput, downloadMsg] ++ acc) where downloadMsg = Right $ CreateMessage (downloading path) @@ -98,7 +104,7 @@ determineFirstStep downloadBase codebase = do case downloadBase of DownloadBase ns | isEmptyCodebase -> - pure $ DownloadingBase ns + pure $ DownloadingBase ns _ -> pure PreviouslyOnboarded From d2940e1fa932b456d1d0fdb990840a52bb95e54b Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Wed, 11 May 2022 20:23:05 -0400 Subject: [PATCH 08/19] more busted work --- .../src/Unison/Codebase/Editor/HandleInput.hs | 144 ++++++++++-------- .../src/Unison/Codebase/Editor/UriParser.hs | 32 ++-- 2 files changed, 95 insertions(+), 81 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index b9548594f..f93121da4 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -64,11 +64,14 @@ import Unison.Codebase.Editor.RemoteRepo ReadRemoteNamespace (..), ReadRepo (ReadRepoGit), ShareRepo (ShareRepo), + WriteGitRemotePath (..), WriteGitRepo, - WriteRemotePath, + WriteRemotePath (..), WriteRepo (WriteRepoGit, WriteRepoShare), + WriteShareRemotePath (..), printNamespace, writePathToRead, + writeToReadGit, pattern ReadGitRemoteNamespace, pattern ReadShareRemoteNamespace, ) @@ -1681,18 +1684,19 @@ handleCreatePullRequest baseRepo0 headRepo0 = do case join result of Left gitErr -> respond (Output.GitError gitErr) Right diff -> respondNumbered diff - -- (ReadGitRemoteNamespace baseRepo, ReadShareRemoteNamespace headRepo@(headRepo', _, _)) -> do - -- importRemoteShareBranch headRepo' undefined undefined >>= \case - -- Left () -> respond (error "bad pull") - -- Right headBranch -> do - -- result <- - -- viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> do - -- merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch - -- (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) - -- pure $ ShowDiffAfterCreatePR baseRepo0 headRepo0 ppe diff - -- case result of - -- Left gitErr -> respond (Output.GitError gitErr) - -- Right diff -> respondNumbered diff + +-- (ReadGitRemoteNamespace baseRepo, ReadShareRemoteNamespace headRepo@(headRepo', _, _)) -> do +-- importRemoteShareBranch headRepo' undefined undefined >>= \case +-- Left () -> respond (error "bad pull") +-- Right headBranch -> do +-- result <- +-- viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> do +-- merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch +-- (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) +-- pure $ ShowDiffAfterCreatePR baseRepo0 headRepo0 ppe diff +-- case result of +-- Left gitErr -> respond (Output.GitError gitErr) +-- Right diff -> respondNumbered diff handleDependents :: Monad m => HQ.HashQualified Name -> Action' m v () handleDependents hq = do @@ -1748,81 +1752,89 @@ handlePullFromUnisonShare remoteRepo remotePath = undefined -- Right causalHash -> do -- undefined +-- | Either perform a "normal" push (updating a remote path), which takes a 'PushBehavior' (to control whether creating +-- a new namespace is allowed), or perform a "gisty" push, which doesn't update any paths (and also is currently only +-- uploaded for remote git repos, not remote Share repos). +data PushFlavor f + = NormalPush (f WriteRemotePath) PushBehavior + | GistyPush (f WriteGitRepo) + -- | Handle a @push@ command. handlePushRemoteBranch :: forall m v. MonadUnliftIO m => -- | The repo to push to. If missing, it is looked up in `.unisonConfig`. - Maybe WriteRemotePath -> + PushFlavor Maybe -> -- | The local path to push. If relative, it's resolved relative to the current path (`cd`). Path' -> - -- | The push behavior (whether the remote branch is required to be empty or non-empty). - PushBehavior -> SyncMode.SyncMode -> Action' m v () -handlePushRemoteBranch mayRepo path pushBehavior syncMode = do - unlessError do - (repo, remotePath) <- maybe (resolveConfiguredUrl Push path) pure mayRepo - lift (doPushRemoteBranch repo path syncMode (Just (remotePath, pushBehavior))) +handlePushRemoteBranch pushFlavor0 path syncMode = do + resolvePushFlavor path pushFlavor0 >>= \case + Left output -> respond output + Right pushFlavor -> doPushRemoteBranch pushFlavor path syncMode + +resolvePushFlavor :: Path' -> PushFlavor Maybe -> Action' m v (Either (Output v) (PushFlavor Identity)) +resolvePushFlavor localPath = \case + NormalPush Nothing pushBehavior -> + runExceptT do + remotePath <- resolveConfiguredUrl Push localPath + pure (NormalPush (Identity (WriteRemotePathGit remotePath)) pushBehavior) + NormalPush (Just repo) pushBehavior -> pure (Right (NormalPush (Identity repo) pushBehavior)) + GistyPush Nothing -> + runExceptT do + WriteGitRemotePath {repo} <- resolveConfiguredUrl Push localPath + pure (GistyPush (Identity repo)) + GistyPush (Just repo) -> pure (Right (GistyPush (Identity repo))) -- Internal helper that implements pushing to a remote repo, which generalizes @gist@ and @push@. doPushRemoteBranch :: forall m v. MonadUnliftIO m => -- | The repo to push to. - WriteRepo -> + PushFlavor Identity -> -- | The local path to push. If relative, it's resolved relative to the current path (`cd`). Path' -> SyncMode.SyncMode -> - -- | The remote target. If missing, the given branch contents should be pushed to the remote repo without updating the - -- root namespace (a gist). - Maybe (Path, PushBehavior) -> Action' m v () -doPushRemoteBranch repo localPath syncMode remoteTarget = do +doPushRemoteBranch pushFlavor localPath syncMode = do sourceBranch <- do currentPath' <- use LoopState.currentPath getAt (Path.resolve currentPath' localPath) - case repo of - WriteRepoGit repo -> + case pushFlavor of + NormalPush (Identity (WriteRemotePathGit WriteGitRemotePath {repo, path = remotePath})) pushBehavior -> unlessError do - withExceptT Output.GitError do - case remoteTarget of - Nothing -> do - let opts = PushGitBranchOpts {setRoot = False, syncMode} - syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch)) - sbhLength <- (eval BranchHashLength) - respond - ( GistCreated - ( ReadRemoteNamespaceGit - ReadGitRemoteNamespace - { repo, - ReadGitRemoteNamespace.sbh = Just (SBH.fromHash sbhLength (Branch.headHash sourceBranch)), - ReadGitRemoteNamespace.path = Path.empty - } - ) - ) - Just (remotePath, pushBehavior) -> do - let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m)) - withRemoteRoot remoteRoot = do - let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if this - -- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already. - f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing - Branch.modifyAtM remotePath f remoteRoot & \case - Nothing -> pure (Left $ RefusedToPush pushBehavior) - Just newRemoteRoot -> pure (Right newRemoteRoot) - let opts = PushGitBranchOpts {setRoot = True, syncMode} - syncGitRemoteBranch repo opts withRemoteRoot >>= \case - Left output -> respond output - Right _branch -> respond Success - WriteRepoShare repo -> do - case remoteTarget of - Nothing -> - -- do a gist - error "don't do a gist" - Just (remotePath, pushBehavior) -> - -- let (userSegment :| pathSegments) = undefined - error "handlePushToUnisonShare _userSegment _pathSegments _localPath pushBehavior" + let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m)) + withRemoteRoot remoteRoot = do + let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if this + -- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already. + f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing + Branch.modifyAtM remotePath f remoteRoot & \case + Nothing -> pure (Left $ RefusedToPush pushBehavior) + Just newRemoteRoot -> pure (Right newRemoteRoot) + let opts = PushGitBranchOpts {setRoot = True, syncMode} + withExceptT Output.GitError (syncGitRemoteBranch repo opts withRemoteRoot) >>= \case + Left output -> respond output + Right _branch -> respond Success + NormalPush (Identity (WriteRemotePathShare WriteShareRemotePath {server, repo, path = remotePath})) pushBehavior -> + -- let (userSegment :| pathSegments) = undefined + error "handlePushToUnisonShare _userSegment _pathSegments _localPath pushBehavior" + GistyPush (Identity repo) -> do + unlessError do + let opts = PushGitBranchOpts {setRoot = False, syncMode} + withExceptT Output.GitError (syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch))) + sbhLength <- eval BranchHashLength + respond + ( GistCreated + ( ReadRemoteNamespaceGit + ReadGitRemoteNamespace + { repo = writeToReadGit repo, + ReadGitRemoteNamespace.sbh = Just (SBH.fromHash sbhLength (Branch.headHash sourceBranch)), + ReadGitRemoteNamespace.path = Path.empty + } + ) + ) where -- Per `pushBehavior`, we are either: -- @@ -2202,14 +2214,14 @@ manageLinks silent srcs mdValues op = do resolveConfiguredUrl :: PushPull -> Path' -> - ExceptT (Output v) (Action m i v) WriteRemotePath + ExceptT (Output v) (Action m i v) WriteGitRemotePath resolveConfiguredUrl pushPull destPath' = ExceptT do currentPath' <- use LoopState.currentPath let destPath = Path.resolve currentPath' destPath' let configKey = gitUrlKey destPath (eval . ConfigLookup) configKey >>= \case Just url -> - case P.parse UriParser.writeRepoPath (Text.unpack configKey) url of + case P.parse UriParser.writeGitRepoPath (Text.unpack configKey) url of Left e -> pure . Left $ ConfiguredGitUrlParseError pushPull destPath' url (show e) diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 87b676a18..7fbda71e5 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Unison.Codebase.Editor.UriParser (repoPath, writeRepo, writeRepoPath) where +module Unison.Codebase.Editor.UriParser (repoPath, writeRepo, writeRepoPath, writeGitRepoPath) where import Data.Char (isAlphaNum, isDigit, isSpace) import Data.Sequence as Seq @@ -51,24 +51,26 @@ repoPath = P.label "generic git repo" $ do Just (sbh, path) -> ReadGitRemoteNamespace {repo, sbh, path} writeRepo :: P WriteRepo -writeRepo = P.label "repo root for writing" $ do +writeRepo = + -- FIXME parse share paths too + WriteRepoGit <$> writeGitRepo + +writeGitRepo :: P WriteGitRepo +writeGitRepo = P.label "repo root for writing" $ do uri <- parseProtocol treeish <- P.optional treeishSuffix - pure (WriteRepoGit WriteGitRepo {url = printProtocol uri, branch = treeish}) + pure WriteGitRepo {url = printProtocol uri, branch = treeish} writeRepoPath :: P WriteRemotePath -writeRepoPath = P.label "generic write repo" $ do - repo <- writeRepo - case repo of - WriteRepoGit repo -> do - path <- P.optional (C.char ':' *> absolutePath) - pure (WriteRemotePathGit WriteGitRemotePath {repo, path = fromMaybe Path.empty path}) - {- - WriteRepoShare server -> do - repo <- undefined - path <- undefined - pure (WriteRemotePathShare WriteShareRemotePath {server, repo, path}) - -} +writeRepoPath = + -- FIXME parse share paths too + WriteRemotePathGit <$> writeGitRepoPath + +writeGitRepoPath :: P WriteGitRemotePath +writeGitRepoPath = P.label "generic write repo" $ do + repo <- writeGitRepo + path <- P.optional (C.char ':' *> absolutePath) + pure WriteGitRemotePath {repo, path = fromMaybe Path.empty path} -- does this not exist somewhere in megaparsec? yes in 7.0 symbol :: Text -> P Text From 1304f3e3e8e3ff88771c4cc5abc23fdf4a80a6ab Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 12 May 2022 09:51:26 -0400 Subject: [PATCH 09/19] fix a few compiler errors and make a better push type --- .../src/Unison/Codebase/Editor/HandleInput.hs | 57 +++++++++---------- .../src/Unison/Codebase/Editor/Input.hs | 2 +- .../src/Unison/Codebase/Editor/UriParser.hs | 20 ++++++- .../Unison/Codebase/Editor/VersionParser.hs | 31 +++++----- .../src/Unison/CommandLine/InputPatterns.hs | 10 ++-- unison-cli/unison/Main.hs | 4 +- 6 files changed, 66 insertions(+), 58 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index f93121da4..cb2c7d805 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1737,7 +1737,7 @@ handleDependents hq = do -- | Handle a @gist@ command. handleGist :: MonadUnliftIO m => GistInput -> Action' m v () handleGist (GistInput repo) = - doPushRemoteBranch repo Path.relativeEmpty' SyncMode.ShortCircuit Nothing + doPushRemoteBranch (GistyPush repo) Path.relativeEmpty' SyncMode.ShortCircuit handlePullFromUnisonShare :: MonadIO m => Text -> Path -> Action' m v () handlePullFromUnisonShare remoteRepo remotePath = undefined @@ -1752,47 +1752,42 @@ handlePullFromUnisonShare remoteRepo remotePath = undefined -- Right causalHash -> do -- undefined --- | Either perform a "normal" push (updating a remote path), which takes a 'PushBehavior' (to control whether creating --- a new namespace is allowed), or perform a "gisty" push, which doesn't update any paths (and also is currently only --- uploaded for remote git repos, not remote Share repos). -data PushFlavor f - = NormalPush (f WriteRemotePath) PushBehavior - | GistyPush (f WriteGitRepo) - -- | Handle a @push@ command. handlePushRemoteBranch :: forall m v. MonadUnliftIO m => -- | The repo to push to. If missing, it is looked up in `.unisonConfig`. - PushFlavor Maybe -> + Maybe WriteRemotePath -> -- | The local path to push. If relative, it's resolved relative to the current path (`cd`). Path' -> + -- | The push behavior (whether the remote branch is required to be empty or non-empty). + PushBehavior -> SyncMode.SyncMode -> Action' m v () -handlePushRemoteBranch pushFlavor0 path syncMode = do - resolvePushFlavor path pushFlavor0 >>= \case - Left output -> respond output - Right pushFlavor -> doPushRemoteBranch pushFlavor path syncMode +handlePushRemoteBranch mayRepo path pushBehavior syncMode = + case mayRepo of + Nothing -> + runExceptT (resolveConfiguredUrl Push path) >>= \case + Left output -> respond output + Right repo -> push repo + Just repo -> push repo + where + push repo = + doPushRemoteBranch (NormalPush repo pushBehavior) path syncMode -resolvePushFlavor :: Path' -> PushFlavor Maybe -> Action' m v (Either (Output v) (PushFlavor Identity)) -resolvePushFlavor localPath = \case - NormalPush Nothing pushBehavior -> - runExceptT do - remotePath <- resolveConfiguredUrl Push localPath - pure (NormalPush (Identity (WriteRemotePathGit remotePath)) pushBehavior) - NormalPush (Just repo) pushBehavior -> pure (Right (NormalPush (Identity repo) pushBehavior)) - GistyPush Nothing -> - runExceptT do - WriteGitRemotePath {repo} <- resolveConfiguredUrl Push localPath - pure (GistyPush (Identity repo)) - GistyPush (Just repo) -> pure (Right (GistyPush (Identity repo))) +-- | Either perform a "normal" push (updating a remote path), which takes a 'PushBehavior' (to control whether creating +-- a new namespace is allowed), or perform a "gisty" push, which doesn't update any paths (and also is currently only +-- uploaded for remote git repos, not remote Share repos). +data PushFlavor + = NormalPush WriteRemotePath PushBehavior + | GistyPush WriteGitRepo -- Internal helper that implements pushing to a remote repo, which generalizes @gist@ and @push@. doPushRemoteBranch :: forall m v. MonadUnliftIO m => -- | The repo to push to. - PushFlavor Identity -> + PushFlavor -> -- | The local path to push. If relative, it's resolved relative to the current path (`cd`). Path' -> SyncMode.SyncMode -> @@ -1803,7 +1798,7 @@ doPushRemoteBranch pushFlavor localPath syncMode = do getAt (Path.resolve currentPath' localPath) case pushFlavor of - NormalPush (Identity (WriteRemotePathGit WriteGitRemotePath {repo, path = remotePath})) pushBehavior -> + NormalPush (WriteRemotePathGit WriteGitRemotePath {repo, path = remotePath}) pushBehavior -> unlessError do let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m)) withRemoteRoot remoteRoot = do @@ -1817,10 +1812,10 @@ doPushRemoteBranch pushFlavor localPath syncMode = do withExceptT Output.GitError (syncGitRemoteBranch repo opts withRemoteRoot) >>= \case Left output -> respond output Right _branch -> respond Success - NormalPush (Identity (WriteRemotePathShare WriteShareRemotePath {server, repo, path = remotePath})) pushBehavior -> + NormalPush (WriteRemotePathShare WriteShareRemotePath {server, repo, path = remotePath}) pushBehavior -> -- let (userSegment :| pathSegments) = undefined error "handlePushToUnisonShare _userSegment _pathSegments _localPath pushBehavior" - GistyPush (Identity repo) -> do + GistyPush repo -> do unlessError do let opts = PushGitBranchOpts {setRoot = False, syncMode} withExceptT Output.GitError (syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch))) @@ -2214,14 +2209,14 @@ manageLinks silent srcs mdValues op = do resolveConfiguredUrl :: PushPull -> Path' -> - ExceptT (Output v) (Action m i v) WriteGitRemotePath + ExceptT (Output v) (Action m i v) WriteRemotePath resolveConfiguredUrl pushPull destPath' = ExceptT do currentPath' <- use LoopState.currentPath let destPath = Path.resolve currentPath' destPath' let configKey = gitUrlKey destPath (eval . ConfigLookup) configKey >>= \case Just url -> - case P.parse UriParser.writeGitRepoPath (Text.unpack configKey) url of + case P.parse UriParser.writeRepoPath (Text.unpack configKey) url of Left e -> pure . Left $ ConfiguredGitUrlParseError pushPull destPath' url (show e) diff --git a/unison-cli/src/Unison/Codebase/Editor/Input.hs b/unison-cli/src/Unison/Codebase/Editor/Input.hs index b9e19d273..4071bb458 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Input.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Input.hs @@ -191,7 +191,7 @@ data Input -- | @"push.gist repo"@ pushes the contents of the current namespace to @repo@. data GistInput = GistInput - { repo :: WriteRepo + { repo :: WriteGitRepo } deriving stock (Eq, Show) diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 7fbda71e5..55d1b2c3c 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -1,6 +1,12 @@ {-# LANGUAGE OverloadedStrings #-} -module Unison.Codebase.Editor.UriParser (repoPath, writeRepo, writeRepoPath, writeGitRepoPath) where +module Unison.Codebase.Editor.UriParser + ( repoPath, + writeGitRepo, + writeRepo, + writeRepoPath, + ) +where import Data.Char (isAlphaNum, isDigit, isSpace) import Data.Sequence as Seq @@ -9,7 +15,15 @@ import Data.Void import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as C import qualified Text.Megaparsec.Char.Lexer as L -import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace (..), ReadGitRepo (..), ReadRemoteNamespace (..), WriteGitRemotePath (..), WriteGitRepo (..), WriteRemotePath (..), WriteRepo (..)) +import Unison.Codebase.Editor.RemoteRepo + ( ReadGitRemoteNamespace (..), + ReadGitRepo (..), + ReadRemoteNamespace (..), + WriteGitRemotePath (..), + WriteGitRepo (..), + WriteRemotePath (..), + WriteRepo (..), + ) import Unison.Codebase.Path (Path (..)) import qualified Unison.Codebase.Path as Path import Unison.Codebase.ShortBranchHash (ShortBranchHash (..)) @@ -50,9 +64,9 @@ repoPath = P.label "generic git repo" $ do Nothing -> ReadGitRemoteNamespace {repo, sbh = Nothing, path = Path.empty} Just (sbh, path) -> ReadGitRemoteNamespace {repo, sbh, path} +-- FIXME parse share paths too writeRepo :: P WriteRepo writeRepo = - -- FIXME parse share paths too WriteRepoGit <$> writeGitRepo writeGitRepo :: P WriteGitRepo diff --git a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs index 1e161c4cb..24a1f42b5 100644 --- a/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/VersionParser.hs @@ -15,7 +15,7 @@ import qualified Unison.Codebase.Path as Path -- "release/M1j" -> "releases._M1j" -- "release/M1j.2" -> "releases._M1j_2" -- "latest-*" -> "trunk" -defaultBaseLib :: Parsec Void Text ReadRemoteNamespace +defaultBaseLib :: Parsec Void Text ReadGitRemoteNamespace defaultBaseLib = fmap makeNS $ latest <|> release where latest, release, version :: Parsec Void Text Text @@ -23,19 +23,18 @@ defaultBaseLib = fmap makeNS $ latest <|> release release = fmap ("releases._" <>) $ "release/" *> version <* eof version = do Text.pack <$> some (alphaNumChar <|> ('_' <$ oneOf ['.', '_', '-'])) - makeNS :: Text -> ReadRemoteNamespace + makeNS :: Text -> ReadGitRemoteNamespace makeNS t = - ReadRemoteNamespaceGit - ReadGitRemoteNamespace - { repo = - ReadGitRepo - { url = "https://github.com/unisonweb/base", - -- Use the 'v3' branch of base for now. - -- We can revert back to the main branch once enough people have upgraded ucm and - -- we're okay with pushing the v3 base codebase to main (perhaps by the next ucm - -- release). - ref = Just "v3" - }, - sbh = Nothing, - path = Path.fromText t - } + ReadGitRemoteNamespace + { repo = + ReadGitRepo + { url = "https://github.com/unisonweb/base", + -- Use the 'v3' branch of base for now. + -- We can revert back to the main branch once enough people have upgraded ucm and + -- we're okay with pushing the v3 base codebase to main (perhaps by the next ucm + -- release). + ref = Just "v3" + }, + sbh = Nothing, + path = Path.fromText t + } diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 6c1220072..4ecc2fdc1 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -21,7 +21,7 @@ import qualified Unison.Codebase.Branch.Merge as Branch import qualified Unison.Codebase.Branch.Names as Branch import Unison.Codebase.Editor.Input (Input) import qualified Unison.Codebase.Editor.Input as Input -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemotePath, WriteRepo) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemotePath) import qualified Unison.Codebase.Editor.SlurpResult as SR import qualified Unison.Codebase.Editor.UriParser as UriParser import qualified Unison.Codebase.Path as Path @@ -1263,11 +1263,11 @@ prettyPrintParseError input = \case message = [expected] <> catMaybes [found] in P.oxfordCommasWith "." message -parseWriteRepo :: String -> String -> Either (P.Pretty P.ColorText) WriteRepo -parseWriteRepo label input = do +parseWriteGitRepo :: String -> String -> Either (P.Pretty P.ColorText) WriteGitRepo +parseWriteGitRepo label input = do first (fromString . show) -- turn any parsing errors into a Pretty. - (P.parse UriParser.writeRepo label (Text.pack input)) + (P.parse UriParser.writeGitRepo label (Text.pack input)) parsePushPath :: String -> String -> Either (P.Pretty P.ColorText) WriteRemotePath parsePushPath label input = do @@ -2002,7 +2002,7 @@ gist = ) ( \case [repoString] -> do - repo <- parseWriteRepo "repo" repoString + repo <- parseWriteGitRepo "repo" repoString pure (Input.GistI (Input.GistInput repo)) _ -> Left (showPatternHelp gist) ) diff --git a/unison-cli/unison/Main.hs b/unison-cli/unison/Main.hs index 2dfabfb76..6df256e56 100644 --- a/unison-cli/unison/Main.hs +++ b/unison-cli/unison/Main.hs @@ -50,7 +50,7 @@ import Text.Pretty.Simple (pHPrint) import Unison.Codebase (Codebase, CodebasePath) import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Editor.Input as Input -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace) +import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace) import qualified Unison.Codebase.Editor.VersionParser as VP import Unison.Codebase.Execute (execute) import Unison.Codebase.Init (CodebaseInitOptions (..), InitError (..), InitResult (..), SpecifiedCodebase (..)) @@ -418,7 +418,7 @@ isFlag f arg = arg == f || arg == "-" ++ f || arg == "--" ++ f getConfigFilePath :: Maybe FilePath -> IO FilePath getConfigFilePath mcodepath = (FP. ".unisonConfig") <$> Codebase.getCodebaseDir mcodepath -defaultBaseLib :: Maybe ReadRemoteNamespace +defaultBaseLib :: Maybe ReadGitRemoteNamespace defaultBaseLib = rightMay $ runParser VP.defaultBaseLib "version" gitRef From 79618e75781f5c8cb7133254f141723c7284712c Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 12 May 2022 10:08:44 -0400 Subject: [PATCH 10/19] pull git/share case --- .../src/Unison/Codebase/Editor/HandleInput.hs | 43 +++++++++---------- 1 file changed, 21 insertions(+), 22 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index cb2c7d805..a05cfdb63 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -60,9 +60,10 @@ import qualified Unison.Codebase.Editor.Output.BranchDiff as OBranchDiff import qualified Unison.Codebase.Editor.Output.DumpNamespace as Output.DN import qualified Unison.Codebase.Editor.Propagate as Propagate import Unison.Codebase.Editor.RemoteRepo - ( ReadGitRemoteNamespace, + ( ReadGitRemoteNamespace (..), ReadRemoteNamespace (..), ReadRepo (ReadRepoGit), + ReadShareRemoteNamespace (..), ShareRepo (ShareRepo), WriteGitRemotePath (..), WriteGitRepo, @@ -72,8 +73,6 @@ import Unison.Codebase.Editor.RemoteRepo printNamespace, writePathToRead, writeToReadGit, - pattern ReadGitRemoteNamespace, - pattern ReadShareRemoteNamespace, ) import qualified Unison.Codebase.Editor.RemoteRepo as ReadGitRemoteNamespace (ReadGitRemoteNamespace (..)) import qualified Unison.Codebase.Editor.Slurp as Slurp @@ -1673,30 +1672,31 @@ handleCreatePullRequest :: MonadUnliftIO m => ReadRemoteNamespace -> ReadRemoteN handleCreatePullRequest baseRepo0 headRepo0 = do root' <- use LoopState.root currentPath' <- use LoopState.currentPath + + let block baseBranch headBranch = do + merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch + (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) + pure $ ShowDiffAfterCreatePR baseRepo0 headRepo0 ppe diff + case (baseRepo0, headRepo0) of (ReadRemoteNamespaceGit baseRepo, ReadRemoteNamespaceGit headRepo) -> do result <- viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> do viewRemoteGitBranch headRepo Git.RequireExistingBranch \headBranch -> do - merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch - (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) - pure $ ShowDiffAfterCreatePR baseRepo0 headRepo0 ppe diff + block baseBranch headBranch case join result of Left gitErr -> respond (Output.GitError gitErr) Right diff -> respondNumbered diff - --- (ReadGitRemoteNamespace baseRepo, ReadShareRemoteNamespace headRepo@(headRepo', _, _)) -> do --- importRemoteShareBranch headRepo' undefined undefined >>= \case --- Left () -> respond (error "bad pull") --- Right headBranch -> do --- result <- --- viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> do --- merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch --- (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) --- pure $ ShowDiffAfterCreatePR baseRepo0 headRepo0 ppe diff --- case result of --- Left gitErr -> respond (Output.GitError gitErr) --- Right diff -> respondNumbered diff + (ReadRemoteNamespaceGit baseRepo, ReadRemoteNamespaceShare headRepo) -> do + importRemoteShareBranch headRepo >>= \case + Left () -> respond (error "bad pull") + Right headBranch -> do + result <- + viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> do + block baseBranch headBranch + case result of + Left gitErr -> respond (Output.GitError gitErr) + Right diff -> respondNumbered diff handleDependents :: Monad m => HQ.HashQualified Name -> Action' m v () handleDependents hq = do @@ -2246,9 +2246,8 @@ viewRemoteGitBranch ns gitBranchBehavior action = do eval $ ViewRemoteGitBranch ns gitBranchBehavior action -- todo: support the full ReadShareRemoteNamespace eventually, in place of (ShareRepo, Text, Path) -importRemoteShareBranch :: - ShareRepo -> Text -> Path -> Action' m v (Either () (Branch m)) -importRemoteShareBranch url repoName path = undefined +importRemoteShareBranch :: ReadShareRemoteNamespace -> Action' m v (Either () (Branch m)) +importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = undefined -- | Given the current root branch of a remote -- (or an empty branch if no root branch exists) From 05b5469e48b6511e8973b7284ea7a10a5b4c788f Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 12 May 2022 11:24:43 -0400 Subject: [PATCH 11/19] importRemoteShareBranch and handleCreatePullRequest --- .../src/Unison/Codebase/Editor/HandleInput.hs | 86 ++++++++++++------- 1 file changed, 56 insertions(+), 30 deletions(-) diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index a05cfdb63..0615666fa 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -29,6 +29,7 @@ import qualified Data.Text as Text import Data.Tuple.Extra (uncurry3) import qualified Servant.Client as Servant import qualified Text.Megaparsec as P +import U.Codebase.Causal (Causal (causalHash)) import qualified U.Codebase.Sqlite.Operations as Ops import U.Util.Timing (unsafeTime) import qualified Unison.ABT as ABT @@ -37,6 +38,7 @@ import qualified Unison.Builtin as Builtin import qualified Unison.Builtin.Decls as DD import qualified Unison.Builtin.Terms as Builtin import Unison.Codebase (Preprocessing (..), PushGitBranchOpts (..)) +import qualified Unison.Codebase as Codebase import Unison.Codebase.Branch (Branch (..), Branch0 (..)) import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Branch.Merge as Branch @@ -62,19 +64,16 @@ import qualified Unison.Codebase.Editor.Propagate as Propagate import Unison.Codebase.Editor.RemoteRepo ( ReadGitRemoteNamespace (..), ReadRemoteNamespace (..), - ReadRepo (ReadRepoGit), ReadShareRemoteNamespace (..), ShareRepo (ShareRepo), WriteGitRemotePath (..), WriteGitRepo, WriteRemotePath (..), - WriteRepo (WriteRepoGit, WriteRepoShare), WriteShareRemotePath (..), printNamespace, writePathToRead, writeToReadGit, ) -import qualified Unison.Codebase.Editor.RemoteRepo as ReadGitRemoteNamespace (ReadGitRemoteNamespace (..)) import qualified Unison.Codebase.Editor.Slurp as Slurp import Unison.Codebase.Editor.SlurpComponent (SlurpComponent (..)) import qualified Unison.Codebase.Editor.SlurpComponent as SC @@ -95,6 +94,7 @@ import qualified Unison.Codebase.PushBehavior as PushBehavior import qualified Unison.Codebase.Reflog as Reflog import Unison.Codebase.ShortBranchHash (ShortBranchHash) import qualified Unison.Codebase.ShortBranchHash as SBH +import qualified Unison.Codebase.SqliteCodebase.Conversions as Cv import qualified Unison.Codebase.SyncMode as SyncMode import Unison.Codebase.TermEdit (TermEdit (..)) import qualified Unison.Codebase.TermEdit as TermEdit @@ -1668,12 +1668,22 @@ loop = do Right input -> LoopState.lastInput .= Just input _ -> pure () -handleCreatePullRequest :: MonadUnliftIO m => ReadRemoteNamespace -> ReadRemoteNamespace -> Action' m v () +handleCreatePullRequest :: forall m v. MonadUnliftIO m => ReadRemoteNamespace -> ReadRemoteNamespace -> Action' m v () handleCreatePullRequest baseRepo0 headRepo0 = do root' <- use LoopState.root currentPath' <- use LoopState.currentPath - let block baseBranch headBranch = do + -- One of these needs a callback and the other doesn't. you might think you can get around that problem with + -- a helper function to unify the two cases, but we tried that and they were in such different monads that it + -- was hard to do. + -- viewRemoteBranch' :: forall r. ReadGitRemoteNamespace -> Git.GitBranchBehavior -> ((Branch m, CodebasePath) -> m r) -> m (Either GitError r), + -- because there's no MonadUnliftIO instance on Action. + -- We need `Command` to go away (the FreeT layer goes away), + -- We have the StateT layer goes away (can put it into an IORef in the environment), + -- We have the MaybeT layer that signals end of input (can just been an IORef bool that we check before looping), + -- and once all those things become IO, we can add a MonadUnliftIO instance on Action, and unify these cases. + let mergeAndDiff :: MonadCommand n m i v => Branch m -> Branch m -> n (NumberedOutput v) + mergeAndDiff baseBranch headBranch = do merged <- eval $ Merge Branch.RegularMerge baseBranch headBranch (ppe, diff) <- diffHelperCmd root' currentPath' (Branch.head baseBranch) (Branch.head merged) pure $ ShowDiffAfterCreatePR baseRepo0 headRepo0 ppe diff @@ -1681,22 +1691,41 @@ handleCreatePullRequest baseRepo0 headRepo0 = do case (baseRepo0, headRepo0) of (ReadRemoteNamespaceGit baseRepo, ReadRemoteNamespaceGit headRepo) -> do result <- - viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> do - viewRemoteGitBranch headRepo Git.RequireExistingBranch \headBranch -> do - block baseBranch headBranch + viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> + viewRemoteGitBranch headRepo Git.RequireExistingBranch \headBranch -> + mergeAndDiff baseBranch headBranch case join result of Left gitErr -> respond (Output.GitError gitErr) Right diff -> respondNumbered diff - (ReadRemoteNamespaceGit baseRepo, ReadRemoteNamespaceShare headRepo) -> do + (ReadRemoteNamespaceGit baseRepo, ReadRemoteNamespaceShare headRepo) -> importRemoteShareBranch headRepo >>= \case - Left () -> respond (error "bad pull") + Left () -> respond (error "bad pull because" headRepo) Right headBranch -> do result <- - viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> do - block baseBranch headBranch + viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> + mergeAndDiff baseBranch headBranch case result of Left gitErr -> respond (Output.GitError gitErr) Right diff -> respondNumbered diff + (ReadRemoteNamespaceShare baseRepo, ReadRemoteNamespaceGit headRepo) -> + importRemoteShareBranch baseRepo >>= \case + Left () -> respond (error "bad pull because" baseRepo) + Right baseBranch -> do + result <- + viewRemoteGitBranch headRepo Git.RequireExistingBranch \headBranch -> + mergeAndDiff baseBranch headBranch + case result of + Left gitErr -> respond (Output.GitError gitErr) + Right diff -> respondNumbered diff + (ReadRemoteNamespaceShare baseRepo, ReadRemoteNamespaceShare headRepo) -> + importRemoteShareBranch headRepo >>= \case + Left () -> respond (error "bad pull because" headRepo) + Right headBranch -> + importRemoteShareBranch baseRepo >>= \case + Left () -> respond (error "bad pull because" baseRepo) + Right baseBranch -> do + diff <- mergeAndDiff baseBranch headBranch + respondNumbered diff handleDependents :: Monad m => HQ.HashQualified Name -> Action' m v () handleDependents hq = do @@ -1739,19 +1768,6 @@ handleGist :: MonadUnliftIO m => GistInput -> Action' m v () handleGist (GistInput repo) = doPushRemoteBranch (GistyPush repo) Path.relativeEmpty' SyncMode.ShortCircuit -handlePullFromUnisonShare :: MonadIO m => Text -> Path -> Action' m v () -handlePullFromUnisonShare remoteRepo remotePath = undefined - --- let path = Share.Path (remoteRepo Nel.:| coerce @[NameSegment] @[Text] (Path.toList remotePath)) - --- LoopState.Env {authHTTPClient, codebase = Codebase {connection}} <- ask - --- liftIO (Share.pull authHTTPClient unisonShareUrl connection path) >>= \case --- Left (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission _)) -> undefined --- Left (Share.PullErrorNoHistoryAtPath repoPath) -> undefined --- Right causalHash -> do --- undefined - -- | Handle a @push@ command. handlePushRemoteBranch :: forall m v. @@ -1825,8 +1841,8 @@ doPushRemoteBranch pushFlavor localPath syncMode = do ( ReadRemoteNamespaceGit ReadGitRemoteNamespace { repo = writeToReadGit repo, - ReadGitRemoteNamespace.sbh = Just (SBH.fromHash sbhLength (Branch.headHash sourceBranch)), - ReadGitRemoteNamespace.path = Path.empty + sbh = Just (SBH.fromHash sbhLength (Branch.headHash sourceBranch)), + path = Path.empty } ) ) @@ -2245,9 +2261,19 @@ viewRemoteGitBranch :: viewRemoteGitBranch ns gitBranchBehavior action = do eval $ ViewRemoteGitBranch ns gitBranchBehavior action --- todo: support the full ReadShareRemoteNamespace eventually, in place of (ShareRepo, Text, Path) -importRemoteShareBranch :: ReadShareRemoteNamespace -> Action' m v (Either () (Branch m)) -importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = undefined +importRemoteShareBranch :: MonadIO m => ReadShareRemoteNamespace -> Action' m v (Either () (Branch m)) +importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = do + let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) + LoopState.Env {authHTTPClient, codebase = codebase@Codebase {connection}} <- ask + liftIO (Share.pull authHTTPClient (shareRepoToBaseURL server) connection shareFlavoredPath) >>= \case + Left (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission _)) -> + error "Share.GetCausalHashByPathErrorNoReadPermission" + Left (Share.PullErrorNoHistoryAtPath repoPath) -> + error "Share.PullErrorNoHistoryAtPath" + Right causalHash -> do + (eval . Eval) (Codebase.getBranchForHash codebase (Cv.branchHash2to1 causalHash)) >>= \case + Nothing -> error $ reportBug "E412939" "`pull` \"succeeded\", but I can't find the result in the codebase. (This is a bug.)" + Just branch -> pure (Right branch) -- | Given the current root branch of a remote -- (or an empty branch if no root branch exists) From a3856ba81d19d517949da7e5ef457d2017e630ac Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Thu, 12 May 2022 15:12:58 -0400 Subject: [PATCH 12/19] fill in call to push to unison share --- .../src/Unison/Codebase/SqliteCodebase.hs | 2 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 93 +++++++++++-------- 2 files changed, 54 insertions(+), 41 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index f789099d8..f49b40bb5 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -478,7 +478,7 @@ sqliteCodebase debugName root localOrRemote action = do syncFromDirectory = syncFromDirectory, syncToDirectory = syncToDirectory, viewRemoteBranch' = viewRemoteBranch', - pushGitBranch = (\r opts action -> pushGitBranch conn r opts action), + pushGitBranch = pushGitBranch conn, watches = watches, getWatch = getWatch, putWatch = putWatch, diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 0615666fa..f206753b5 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -1808,36 +1808,36 @@ doPushRemoteBranch :: Path' -> SyncMode.SyncMode -> Action' m v () -doPushRemoteBranch pushFlavor localPath syncMode = do - sourceBranch <- do - currentPath' <- use LoopState.currentPath - getAt (Path.resolve currentPath' localPath) +doPushRemoteBranch pushFlavor localPath0 syncMode = do + currentPath' <- use LoopState.currentPath + let localPath = Path.resolve currentPath' localPath0 case pushFlavor of - NormalPush (WriteRemotePathGit WriteGitRemotePath {repo, path = remotePath}) pushBehavior -> - unlessError do - let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m)) - withRemoteRoot remoteRoot = do - let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if this - -- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already. - f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing - Branch.modifyAtM remotePath f remoteRoot & \case - Nothing -> pure (Left $ RefusedToPush pushBehavior) - Just newRemoteRoot -> pure (Right newRemoteRoot) - let opts = PushGitBranchOpts {setRoot = True, syncMode} - withExceptT Output.GitError (syncGitRemoteBranch repo opts withRemoteRoot) >>= \case - Left output -> respond output - Right _branch -> respond Success - NormalPush (WriteRemotePathShare WriteShareRemotePath {server, repo, path = remotePath}) pushBehavior -> - -- let (userSegment :| pathSegments) = undefined - error "handlePushToUnisonShare _userSegment _pathSegments _localPath pushBehavior" + NormalPush (WriteRemotePathGit WriteGitRemotePath {repo, path = remotePath}) pushBehavior -> do + sourceBranch <- getAt localPath + let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m)) + withRemoteRoot remoteRoot = do + let -- We don't merge `sourceBranch` with `remoteBranch`, we just replace it. This push will be rejected if this + -- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already. + f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing + Branch.modifyAtM remotePath f remoteRoot & \case + Nothing -> pure (Left $ RefusedToPush pushBehavior) + Just newRemoteRoot -> pure (Right newRemoteRoot) + let opts = PushGitBranchOpts {setRoot = True, syncMode} + runExceptT (syncGitRemoteBranch repo opts withRemoteRoot) >>= \case + Left gitErr -> respond (Output.GitError gitErr) + Right _branch -> respond Success + NormalPush (WriteRemotePathShare sharePath) pushBehavior -> + handlePushToUnisonShare sharePath localPath pushBehavior GistyPush repo -> do - unlessError do - let opts = PushGitBranchOpts {setRoot = False, syncMode} - withExceptT Output.GitError (syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch))) - sbhLength <- eval BranchHashLength - respond - ( GistCreated + sourceBranch <- getAt localPath + let opts = PushGitBranchOpts {setRoot = False, syncMode} + runExceptT (syncGitRemoteBranch repo opts (\_remoteRoot -> pure (Right sourceBranch))) >>= \case + Left gitErr -> respond (Output.GitError gitErr) + Right _result -> do + sbhLength <- eval BranchHashLength + respond $ + GistCreated ( ReadRemoteNamespaceGit ReadGitRemoteNamespace { repo = writeToReadGit repo, @@ -1845,7 +1845,6 @@ doPushRemoteBranch pushFlavor localPath syncMode = do path = Path.empty } ) - ) where -- Per `pushBehavior`, we are either: -- @@ -1860,42 +1859,56 @@ doPushRemoteBranch pushFlavor localPath syncMode = do shareRepoToBaseURL :: ShareRepo -> Servant.BaseUrl shareRepoToBaseURL ShareRepo = Servant.BaseUrl Servant.Https "share.unison.cloud" 443 "" -handlePushToUnisonShare :: MonadIO m => ShareRepo -> Text -> Path -> Path.Absolute -> PushBehavior -> Action' m v () -handlePushToUnisonShare shareRepo remoteRepo remotePath localPath behavior = do - let repoPath = Share.Path (remoteRepo Nel.:| coerce @[NameSegment] @[Text] (Path.toList remotePath)) +handlePushToUnisonShare :: MonadIO m => WriteShareRemotePath -> Path.Absolute -> PushBehavior -> Action' m v () +handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} localPath behavior = do + let sharePath = Share.Path (repo Nel.:| pathToSegments remotePath) LoopState.Env {authHTTPClient, codebase = Codebase {connection}} <- ask -- doesn't handle the case where a non-existent path is supplied - Sqlite.runTransaction - connection - (Ops.loadCausalHashAtPath (coerce @[NameSegment] @[Text] (Path.toList (Path.unabsolute localPath)))) + Sqlite.runTransaction connection (Ops.loadCausalHashAtPath (pathToSegments (Path.unabsolute localPath))) >>= \case Nothing -> respond (error "you are bad") Just localCausalHash -> case behavior of - PushBehavior.RequireEmpty -> - liftIO (Share.checkAndSetPush authHTTPClient (shareRepoToBaseURL shareRepo) connection repoPath Nothing localCausalHash) >>= \case + PushBehavior.RequireEmpty -> do + let push :: IO (Either Share.CheckAndSetPushError ()) + push = + Share.checkAndSetPush + authHTTPClient + (shareRepoToBaseURL server) + connection + sharePath + Nothing + localCausalHash + liftIO push >>= \case Left err -> case err of Share.CheckAndSetPushErrorHashMismatch _mismatch -> error "remote not empty" - Share.CheckAndSetPushErrorNoWritePermission _repoPath -> errNoWritePermission repoPath + Share.CheckAndSetPushErrorNoWritePermission _repoPath -> errNoWritePermission sharePath Share.CheckAndSetPushErrorServerMissingDependencies deps -> errServerMissingDependencies deps Right () -> pure () - PushBehavior.RequireNonEmpty -> - liftIO (Share.fastForwardPush authHTTPClient (shareRepoToBaseURL shareRepo) connection repoPath localCausalHash) >>= \case + PushBehavior.RequireNonEmpty -> do + let push :: IO (Either Share.FastForwardPushError ()) + push = + Share.fastForwardPush authHTTPClient (shareRepoToBaseURL server) connection sharePath localCausalHash + liftIO push >>= \case Left err -> case err of Share.FastForwardPushErrorNoHistory _repoPath -> error "no history" Share.FastForwardPushErrorNoReadPermission _repoPath -> error "no read permission" Share.FastForwardPushErrorNotFastForward -> error "not fast-forward" - Share.FastForwardPushErrorNoWritePermission _repoPath -> errNoWritePermission repoPath + Share.FastForwardPushErrorNoWritePermission _repoPath -> errNoWritePermission sharePath Share.FastForwardPushErrorServerMissingDependencies deps -> errServerMissingDependencies deps Right () -> pure () where errNoWritePermission _repoPath = error "no write permission" errServerMissingDependencies _dependencies = error "server missing dependencies" + pathToSegments :: Path -> [Text] + pathToSegments = + coerce Path.toList + -- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`. handleShowDefinition :: forall m v. From f5103652903dffc07da1e1693e536d06531a9fca Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 12 May 2022 18:03:00 -0400 Subject: [PATCH 13/19] filled in a lot of things? --- lib/unison-prelude/src/Unison/Prelude.hs | 5 ++ unison-cli/src/Unison/Auth/HTTPClient.hs | 4 +- .../src/Unison/Codebase/Editor/Command.hs | 4 +- .../Unison/Codebase/Editor/HandleCommand.hs | 3 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 69 ++++++++----------- .../src/Unison/Codebase/Editor/Output.hs | 10 +++ .../src/Unison/Codebase/Editor/UCMVersion.hs | 5 ++ .../src/Unison/Codebase/TranscriptParser.hs | 3 +- unison-cli/src/Unison/CommandLine/Main.hs | 3 +- .../src/Unison/CommandLine/OutputMessages.hs | 8 ++- unison-cli/src/Unison/Util/HTTP.hs | 2 +- unison-cli/unison-cli.cabal | 3 +- 12 files changed, 65 insertions(+), 54 deletions(-) create mode 100644 unison-cli/src/Unison/Codebase/Editor/UCMVersion.hs diff --git a/lib/unison-prelude/src/Unison/Prelude.hs b/lib/unison-prelude/src/Unison/Prelude.hs index 97d3a0389..b3de550cd 100644 --- a/lib/unison-prelude/src/Unison/Prelude.hs +++ b/lib/unison-prelude/src/Unison/Prelude.hs @@ -7,6 +7,7 @@ module Unison.Prelude uncurry4, reportBug, tShow, + wundefined, -- * @Maybe@ control flow onNothing, @@ -165,3 +166,7 @@ reportBug bugId msg = "on the issue to let the team know you encountered it, and you can add", "any additional details you know of to the issue." ] + +{-# WARNING wundefined "You left this wundefined." #-} +wundefined :: a +wundefined = undefined diff --git a/unison-cli/src/Unison/Auth/HTTPClient.hs b/unison-cli/src/Unison/Auth/HTTPClient.hs index 26765332d..85ffb4d00 100644 --- a/unison-cli/src/Unison/Auth/HTTPClient.hs +++ b/unison-cli/src/Unison/Auth/HTTPClient.hs @@ -1,4 +1,4 @@ -module Unison.Auth.HTTPClient (newAuthorizedHTTPClient, AuthorizedHttpClient(..)) where +module Unison.Auth.HTTPClient (newAuthorizedHTTPClient, AuthorizedHttpClient (..)) where import qualified Data.Text.Encoding as Text import Network.HTTP.Client (Request) @@ -7,7 +7,7 @@ import qualified Network.HTTP.Client.TLS as HTTP import Unison.Auth.CredentialManager (CredentialManager) import Unison.Auth.Tokens (TokenProvider, newTokenProvider) import Unison.Auth.Types -import Unison.Codebase.Editor.Command (UCMVersion) +import Unison.Codebase.Editor.UCMVersion (UCMVersion) import Unison.Prelude import qualified Unison.Util.HTTP as HTTP diff --git a/unison-cli/src/Unison/Codebase/Editor/Command.hs b/unison-cli/src/Unison/Codebase/Editor/Command.hs index 499b8b82f..4647909d4 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Command.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Command.hs @@ -13,7 +13,6 @@ module Unison.Codebase.Editor.Command EvalResult, commandName, lookupEvalResult, - UCMVersion, ) where @@ -30,6 +29,7 @@ import Unison.Codebase.Editor.AuthorInfo (AuthorInfo) import qualified Unison.Codebase.Editor.Git as Git import Unison.Codebase.Editor.Output import Unison.Codebase.Editor.RemoteRepo +import Unison.Codebase.Editor.UCMVersion (UCMVersion) import Unison.Codebase.Path (Path) import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Reflog as Reflog @@ -94,8 +94,6 @@ type TypecheckingResult v = (Seq (Note v Ann)) (Either Names (UF.TypecheckedUnisonFile v Ann)) -type UCMVersion = Text - data Command m -- Command monad diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs index 03ea15a88..c71f05e82 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs @@ -22,8 +22,9 @@ import Unison.Codebase.Branch (Branch) import qualified Unison.Codebase.Branch as Branch import qualified Unison.Codebase.Branch.Merge as Branch import qualified Unison.Codebase.Editor.AuthorInfo as AuthorInfo -import Unison.Codebase.Editor.Command (Command (..), LexedSource, LoadSourceResult, SourceName, TypecheckingResult, UCMVersion, UseCache) +import Unison.Codebase.Editor.Command (Command (..), LexedSource, LoadSourceResult, SourceName, TypecheckingResult, UseCache) import Unison.Codebase.Editor.Output (NumberedArgs, NumberedOutput, Output (PrintMessage)) +import Unison.Codebase.Editor.UCMVersion (UCMVersion) import qualified Unison.Codebase.Path as Path import Unison.Codebase.Runtime (Runtime) import qualified Unison.Codebase.Runtime as Runtime diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index f206753b5..0ba6bba29 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -29,7 +29,6 @@ import qualified Data.Text as Text import Data.Tuple.Extra (uncurry3) import qualified Servant.Client as Servant import qualified Text.Megaparsec as P -import U.Codebase.Causal (Causal (causalHash)) import qualified U.Codebase.Sqlite.Operations as Ops import U.Util.Timing (unsafeTime) import qualified Unison.ABT as ABT @@ -507,7 +506,6 @@ loop = do (Branch m -> Action m i v1 (Branch m)) -> Action m i v1 Bool updateAtM = Unison.Codebase.Editor.HandleInput.updateAtM inputDescription - unlessGitError = unlessError' Output.GitError importRemoteGitBranch ns mode preprocess = ExceptT . eval $ ImportRemoteGitBranch ns mode preprocess loadSearchResults = eval . LoadSearchResults @@ -670,12 +668,15 @@ loop = do let desta = resolveToAbsolute dest0 let dest = Path.unabsolute desta destb <- getAt desta + let tryImportBranch = \case + ReadRemoteNamespaceGit repo -> + withExceptT Output.GitError (importRemoteGitBranch repo SyncMode.ShortCircuit Unmodified) + ReadRemoteNamespaceShare repo -> + ExceptT (importRemoteShareBranch repo) if Branch.isEmpty0 (Branch.head destb) - then unlessGitError do - baseb <- case baseRepo of - ReadRemoteNamespaceGit repo -> importRemoteGitBranch repo SyncMode.ShortCircuit Unmodified - headb <- case headRepo of - ReadRemoteNamespaceGit repo -> importRemoteGitBranch repo SyncMode.ShortCircuit Unmodified + then unlessError do + baseb <- tryImportBranch baseRepo + headb <- tryImportBranch headRepo lift $ do mergedb <- eval $ Merge Branch.RegularMerge baseb headb squashedb <- eval $ Merge Branch.SquashMerge headb baseb @@ -1510,9 +1511,10 @@ loop = do Input.PullWithHistory -> Unmodified Input.PullWithoutHistory -> Preprocessed $ pure . Branch.discardHistory ns <- maybe (writePathToRead <$> resolveConfiguredUrl Pull path) pure mayRepo - lift $ unlessGitError do + lift $ unlessError do remoteBranch <- case ns of - ReadRemoteNamespaceGit repo -> importRemoteGitBranch repo syncMode preprocess + ReadRemoteNamespaceGit repo -> withExceptT Output.GitError (importRemoteGitBranch repo syncMode preprocess) + ReadRemoteNamespaceShare repo -> ExceptT (importRemoteShareBranch repo) let unchangedMsg = PullAlreadyUpToDate ns path let destAbs = resolveToAbsolute path let printDiffPath = if Verbosity.isSilent verbosity then Nothing else Just path @@ -1699,7 +1701,7 @@ handleCreatePullRequest baseRepo0 headRepo0 = do Right diff -> respondNumbered diff (ReadRemoteNamespaceGit baseRepo, ReadRemoteNamespaceShare headRepo) -> importRemoteShareBranch headRepo >>= \case - Left () -> respond (error "bad pull because" headRepo) + Left err -> respond err Right headBranch -> do result <- viewRemoteGitBranch baseRepo Git.RequireExistingBranch \baseBranch -> @@ -1709,7 +1711,7 @@ handleCreatePullRequest baseRepo0 headRepo0 = do Right diff -> respondNumbered diff (ReadRemoteNamespaceShare baseRepo, ReadRemoteNamespaceGit headRepo) -> importRemoteShareBranch baseRepo >>= \case - Left () -> respond (error "bad pull because" baseRepo) + Left err -> respond err Right baseBranch -> do result <- viewRemoteGitBranch headRepo Git.RequireExistingBranch \headBranch -> @@ -1719,10 +1721,10 @@ handleCreatePullRequest baseRepo0 headRepo0 = do Right diff -> respondNumbered diff (ReadRemoteNamespaceShare baseRepo, ReadRemoteNamespaceShare headRepo) -> importRemoteShareBranch headRepo >>= \case - Left () -> respond (error "bad pull because" headRepo) + Left err -> respond err Right headBranch -> importRemoteShareBranch baseRepo >>= \case - Left () -> respond (error "bad pull because" baseRepo) + Left err -> respond err Right baseBranch -> do diff <- mergeAndDiff baseBranch headBranch respondNumbered diff @@ -1882,29 +1884,16 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l Nothing localCausalHash liftIO push >>= \case - Left err -> - case err of - Share.CheckAndSetPushErrorHashMismatch _mismatch -> error "remote not empty" - Share.CheckAndSetPushErrorNoWritePermission _repoPath -> errNoWritePermission sharePath - Share.CheckAndSetPushErrorServerMissingDependencies deps -> errServerMissingDependencies deps + Left err -> respond (Output.ShareError (ShareErrorCheckAndSetPush err)) Right () -> pure () PushBehavior.RequireNonEmpty -> do let push :: IO (Either Share.FastForwardPushError ()) push = Share.fastForwardPush authHTTPClient (shareRepoToBaseURL server) connection sharePath localCausalHash liftIO push >>= \case - Left err -> - case err of - Share.FastForwardPushErrorNoHistory _repoPath -> error "no history" - Share.FastForwardPushErrorNoReadPermission _repoPath -> error "no read permission" - Share.FastForwardPushErrorNotFastForward -> error "not fast-forward" - Share.FastForwardPushErrorNoWritePermission _repoPath -> errNoWritePermission sharePath - Share.FastForwardPushErrorServerMissingDependencies deps -> errServerMissingDependencies deps + Left err -> respond (Output.ShareError (ShareErrorFastForwardPush err)) Right () -> pure () where - errNoWritePermission _repoPath = error "no write permission" - errServerMissingDependencies _dependencies = error "server missing dependencies" - pathToSegments :: Path -> [Text] pathToSegments = coerce Path.toList @@ -2274,19 +2263,17 @@ viewRemoteGitBranch :: viewRemoteGitBranch ns gitBranchBehavior action = do eval $ ViewRemoteGitBranch ns gitBranchBehavior action -importRemoteShareBranch :: MonadIO m => ReadShareRemoteNamespace -> Action' m v (Either () (Branch m)) -importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = do - let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) - LoopState.Env {authHTTPClient, codebase = codebase@Codebase {connection}} <- ask - liftIO (Share.pull authHTTPClient (shareRepoToBaseURL server) connection shareFlavoredPath) >>= \case - Left (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission _)) -> - error "Share.GetCausalHashByPathErrorNoReadPermission" - Left (Share.PullErrorNoHistoryAtPath repoPath) -> - error "Share.PullErrorNoHistoryAtPath" - Right causalHash -> do - (eval . Eval) (Codebase.getBranchForHash codebase (Cv.branchHash2to1 causalHash)) >>= \case - Nothing -> error $ reportBug "E412939" "`pull` \"succeeded\", but I can't find the result in the codebase. (This is a bug.)" - Just branch -> pure (Right branch) +importRemoteShareBranch :: MonadIO m => ReadShareRemoteNamespace -> Action' m v (Either (Output v) (Branch m)) +importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = + mapLeft Output.ShareError <$> do + let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) + LoopState.Env {authHTTPClient, codebase = codebase@Codebase {connection}} <- ask + liftIO (Share.pull authHTTPClient (shareRepoToBaseURL server) connection shareFlavoredPath) >>= \case + Left e -> pure (Left (Output.ShareErrorPull e)) + Right causalHash -> do + (eval . Eval) (Codebase.getBranchForHash codebase (Cv.branchHash2to1 causalHash)) >>= \case + Nothing -> error $ reportBug "E412939" "`pull` \"succeeded\", but I can't find the result in the codebase. (This is a bug.)" + Just branch -> pure (Right branch) -- | Given the current root branch of a remote -- (or an empty branch if no root branch exists) diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index 500f467ca..a06daa80d 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -10,6 +10,7 @@ module Unison.Codebase.Editor.Output UndoFailureReason (..), PushPull (..), ReflogEntry (..), + ShareError (..), pushPull, isFailure, isNumberedFailure, @@ -56,6 +57,7 @@ import qualified Unison.Reference as Reference import Unison.Referent (Referent) import Unison.Server.Backend (ShallowListEntry (..)) import Unison.Server.SearchResult' (SearchResult') +import qualified Unison.Share.Sync as Sync import Unison.ShortHash (ShortHash) import Unison.Term (Term) import Unison.Type (Type) @@ -206,6 +208,7 @@ data Output v -- and a nicer render. BustedBuiltins (Set Reference) (Set Reference) | GitError GitError + | ShareError ShareError | ConfiguredMetadataParseError Path' String (P.Pretty P.ColorText) | NoConfiguredGitUrl PushPull Path' | ConfiguredGitUrlParseError PushPull Path' Text String @@ -256,6 +259,12 @@ data Output v | CredentialFailureMsg CredentialFailure | PrintVersion Text +data ShareError + = ShareErrorCheckAndSetPush Sync.CheckAndSetPushError + | ShareErrorFastForwardPush Sync.FastForwardPushError + | ShareErrorPull Sync.PullError + | ShareErrorGetCausalHashByPath Sync.GetCausalHashByPathError + data ReflogEntry = ReflogEntry {hash :: ShortBranchHash, reason :: Text} deriving (Show) @@ -381,6 +390,7 @@ isFailure o = case o of UnknownCodeServer {} -> True CredentialFailureMsg {} -> True PrintVersion {} -> False + ShareError {} -> True isNumberedFailure :: NumberedOutput v -> Bool isNumberedFailure = \case diff --git a/unison-cli/src/Unison/Codebase/Editor/UCMVersion.hs b/unison-cli/src/Unison/Codebase/Editor/UCMVersion.hs new file mode 100644 index 000000000..4e003e63e --- /dev/null +++ b/unison-cli/src/Unison/Codebase/Editor/UCMVersion.hs @@ -0,0 +1,5 @@ +module Unison.Codebase.Editor.UCMVersion where + +import Data.Text (Text) + +type UCMVersion = Text diff --git a/unison-cli/src/Unison/Codebase/TranscriptParser.hs b/unison-cli/src/Unison/Codebase/TranscriptParser.hs index 2ab95649c..54edbba95 100644 --- a/unison-cli/src/Unison/Codebase/TranscriptParser.hs +++ b/unison-cli/src/Unison/Codebase/TranscriptParser.hs @@ -40,12 +40,13 @@ import qualified Text.Megaparsec as P import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import qualified Unison.Codebase.Branch as Branch -import Unison.Codebase.Editor.Command (LoadSourceResult (..), UCMVersion) +import Unison.Codebase.Editor.Command (LoadSourceResult (..)) import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand import qualified Unison.Codebase.Editor.HandleInput as HandleInput import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState import Unison.Codebase.Editor.Input (Event (UnisonFileChanged), Input (..)) import qualified Unison.Codebase.Editor.Output as Output +import Unison.Codebase.Editor.UCMVersion (UCMVersion) import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Path.Parse as Path import qualified Unison.Codebase.Runtime as Runtime diff --git a/unison-cli/src/Unison/CommandLine/Main.hs b/unison-cli/src/Unison/CommandLine/Main.hs index 70d51fcb0..be44430ac 100644 --- a/unison-cli/src/Unison/CommandLine/Main.hs +++ b/unison-cli/src/Unison/CommandLine/Main.hs @@ -28,12 +28,13 @@ import Unison.Codebase (Codebase) import qualified Unison.Codebase as Codebase import Unison.Codebase.Branch (Branch) import qualified Unison.Codebase.Branch as Branch -import Unison.Codebase.Editor.Command (LoadSourceResult (..), UCMVersion) +import Unison.Codebase.Editor.Command (LoadSourceResult (..)) import qualified Unison.Codebase.Editor.HandleCommand as HandleCommand import qualified Unison.Codebase.Editor.HandleInput as HandleInput import qualified Unison.Codebase.Editor.HandleInput.LoopState as LoopState import Unison.Codebase.Editor.Input (Event, Input (..)) import Unison.Codebase.Editor.Output (Output) +import Unison.Codebase.Editor.UCMVersion (UCMVersion) import qualified Unison.Codebase.Path as Path import qualified Unison.Codebase.Runtime as Runtime import Unison.CommandLine diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 11a1d70e5..20f961009 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -622,8 +622,8 @@ notifyUser dir o = case o of CachedTests 0 _ -> pure . P.callout "😶" $ "No tests to run." CachedTests n n' | n == n' -> - pure $ - P.lines [cache, "", displayTestResults True ppe oks fails] + pure $ + P.lines [cache, "", displayTestResults True ppe oks fails] CachedTests _n m -> pure $ if m == 0 @@ -632,6 +632,7 @@ notifyUser dir o = case o of P.indentN 2 $ P.lines ["", cache, "", displayTestResults False ppe oks fails, "", "✅ "] where + NewlyComputed -> do clearCurrentLine pure $ @@ -1575,6 +1576,7 @@ notifyUser dir o = case o of "Host names should NOT include a schema or path." ] PrintVersion ucmVersion -> pure (P.text ucmVersion) + ShareError {} -> wundefined where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" @@ -2162,7 +2164,7 @@ showDiffNamespace :: (Pretty, NumberedArgs) showDiffNamespace _ _ _ _ diffOutput | OBD.isEmpty diffOutput = - ("The namespaces are identical.", mempty) + ("The namespaces are identical.", mempty) showDiffNamespace sn ppe oldPath newPath OBD.BranchDiffOutput {..} = (P.sepNonEmpty "\n\n" p, toList args) where diff --git a/unison-cli/src/Unison/Util/HTTP.hs b/unison-cli/src/Unison/Util/HTTP.hs index 940d681f4..8f0e6f577 100644 --- a/unison-cli/src/Unison/Util/HTTP.hs +++ b/unison-cli/src/Unison/Util/HTTP.hs @@ -2,7 +2,7 @@ module Unison.Util.HTTP (addRequestMiddleware, setUserAgent, ucmUserAgent) where import qualified Data.Text.Encoding as Text import qualified Network.HTTP.Client as HTTP -import Unison.Codebase.Editor.Command (UCMVersion) +import Unison.Codebase.Editor.UCMVersion (UCMVersion) import Unison.Prelude addRequestMiddleware :: (HTTP.Request -> IO HTTP.Request) -> HTTP.ManagerSettings -> HTTP.ManagerSettings diff --git a/unison-cli/unison-cli.cabal b/unison-cli/unison-cli.cabal index dc6fac3a2..7183af772 100644 --- a/unison-cli/unison-cli.cabal +++ b/unison-cli/unison-cli.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.34.4. +-- This file has been generated from package.yaml by hpack version 0.34.6. -- -- see: https://github.com/sol/hpack @@ -47,6 +47,7 @@ library Unison.Codebase.Editor.SlurpComponent Unison.Codebase.Editor.SlurpResult Unison.Codebase.Editor.TodoOutput + Unison.Codebase.Editor.UCMVersion Unison.Codebase.Editor.UriParser Unison.Codebase.Editor.VersionParser Unison.Codebase.TranscriptParser From bfadd5d06e20556af0d3c02b94fb2e532be5ded3 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Thu, 12 May 2022 18:45:54 -0400 Subject: [PATCH 14/19] started fleshing out OutputMessages --- .../src/Unison/CommandLine/OutputMessages.hs | 21 ++++++++++++++++++- 1 file changed, 20 insertions(+), 1 deletion(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 20f961009..5c2e69521 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -117,8 +117,10 @@ import qualified Unison.Referent' as Referent import qualified Unison.Result as Result import Unison.Server.Backend (ShallowListEntry (..), TermEntry (..), TypeEntry (..)) import qualified Unison.Server.SearchResult' as SR' +import qualified Unison.Share.Sync as Sync import qualified Unison.ShortHash as SH import qualified Unison.ShortHash as ShortHash +import qualified Unison.Sync.Types as Sync import Unison.Term (Term) import qualified Unison.Term as Term import qualified Unison.TermPrinter as TermPrinter @@ -1576,7 +1578,24 @@ notifyUser dir o = case o of "Host names should NOT include a schema or path." ] PrintVersion ucmVersion -> pure (P.text ucmVersion) - ShareError {} -> wundefined + ShareError x -> case x of + ShareErrorCheckAndSetPush e -> case e of + (Sync.CheckAndSetPushErrorHashMismatch Sync.HashMismatch {path, expectedHash, actualHash}) -> wundefined + (Sync.CheckAndSetPushErrorNoWritePermission sharePath) -> wundefined + (Sync.CheckAndSetPushErrorServerMissingDependencies hashes) -> wundefined + ShareErrorFastForwardPush e -> case e of + (Sync.FastForwardPushErrorNoHistory sharePath) -> wundefined + (Sync.FastForwardPushErrorNoReadPermission sharePath) -> wundefined + Sync.FastForwardPushErrorNotFastForward -> wundefined + (Sync.FastForwardPushErrorNoWritePermission sharePath) -> wundefined + (Sync.FastForwardPushErrorServerMissingDependencies hashes) -> wundefined + ShareErrorPull e -> case e of + (Sync.PullErrorGetCausalHashByPath (Sync.GetCausalHashByPathErrorNoReadPermission sharePath)) -> wundefined + (Sync.PullErrorNoHistoryAtPath sharePath) -> wundefined + ShareErrorGetCausalHashByPath gchbpe -> case gchbpe of + (Sync.GetCausalHashByPathErrorNoReadPermission sharePath) -> wundefined + where + y = () where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" From c7291c672cec6b52492749c86f5ac10852528786 Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Fri, 13 May 2022 11:01:09 -0400 Subject: [PATCH 15/19] working on OutputMessages --- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 5 + .../src/Unison/Codebase/Editor/Output.hs | 2 +- .../src/Unison/CommandLine/OutputMessages.hs | 91 +++++++++++++------ 3 files changed, 69 insertions(+), 29 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 96f1abcec..819dda188 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -75,6 +75,11 @@ printNamespace = \case then mempty else "." <> Path.toText path +printWriteRemotePath :: WriteRemotePath -> Text +printWriteRemotePath = \case + WriteRemotePathGit WriteGitRemotePath {repo, path} -> wundefined + WriteRemotePathShare WriteShareRemotePath {server, repo, path} -> wundefined + -- | print remote path printHead :: WriteRepo -> Path -> Text printHead repo path = diff --git a/unison-cli/src/Unison/Codebase/Editor/Output.hs b/unison-cli/src/Unison/Codebase/Editor/Output.hs index a06daa80d..786604f6b 100644 --- a/unison-cli/src/Unison/Codebase/Editor/Output.hs +++ b/unison-cli/src/Unison/Codebase/Editor/Output.hs @@ -250,7 +250,7 @@ data Output v | NamespaceEmpty (NonEmpty AbsBranchId) | NoOp | -- Refused to push, either because a `push` targeted an empty namespace, or a `push.create` targeted a non-empty namespace. - RefusedToPush PushBehavior + RefusedToPush PushBehavior WriteRemotePath | -- | @GistCreated repo@ means a causal was just published to @repo@. GistCreated ReadRemoteNamespace | -- | Directs the user to URI to begin an authorization flow. diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 5c2e69521..dfbb61956 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RankNTypes #-} @@ -31,6 +32,8 @@ import System.Directory getHomeDirectory, ) import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion)) +import U.Util.Base32Hex (Base32Hex) +import qualified U.Util.Base32Hex as Base32Hex import qualified U.Util.Hash as Hash import qualified U.Util.Monoid as Monoid import qualified Unison.ABT as ABT @@ -44,7 +47,7 @@ import Unison.Codebase.Editor.Output import qualified Unison.Codebase.Editor.Output as E import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBD -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo (ReadRepoGit), WriteRepo (WriteRepoGit)) +import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo (ReadRepoGit), WriteRemotePath, WriteRepo (WriteRepoGit)) import qualified Unison.Codebase.Editor.RemoteRepo as RemoteRepo import qualified Unison.Codebase.Editor.SlurpResult as SlurpResult import qualified Unison.Codebase.Editor.TodoOutput as TO @@ -117,10 +120,11 @@ import qualified Unison.Referent' as Referent import qualified Unison.Result as Result import Unison.Server.Backend (ShallowListEntry (..), TermEntry (..), TypeEntry (..)) import qualified Unison.Server.SearchResult' as SR' -import qualified Unison.Share.Sync as Sync +import qualified Unison.Share.Sync as Share import qualified Unison.ShortHash as SH import qualified Unison.ShortHash as ShortHash -import qualified Unison.Sync.Types as Sync +import qualified Unison.Sync.Types as Share +import qualified Unison.Sync.Types as Share.Hash (toBase32Hex) import Unison.Term (Term) import qualified Unison.Term as Term import qualified Unison.TermPrinter as TermPrinter @@ -508,10 +512,14 @@ showListEdits patch ppe = prettyURI :: URI -> Pretty prettyURI = P.bold . P.blue . P.shown -prettyRemoteNamespace :: ReadRemoteNamespace -> Pretty -prettyRemoteNamespace = +prettyReadRemoteNamespace :: ReadRemoteNamespace -> Pretty +prettyReadRemoteNamespace = P.group . P.blue . P.text . RemoteRepo.printNamespace +-- prettyWriteRemotePath :: WriteRemotePath -> Pretty +-- prettyWriteRemotePath = +-- P.group . P.blue . P.text . RemoteRepo.printWriteRemotePath + notifyUser :: forall v. Var v => FilePath -> Output v -> IO Pretty notifyUser dir o = case o of Success -> pure $ P.bold "Done." @@ -1514,18 +1522,15 @@ notifyUser dir o = case o of <> ( terms <&> \(n, r) -> prettyHashQualified' (HQ'.take hqLength . HQ'.fromNamedReference n $ Reference.DerivedId r) ) - RefusedToPush pushBehavior -> - (pure . P.warnCallout . P.lines) case pushBehavior of + RefusedToPush pushBehavior path -> + (pure . P.warnCallout) case pushBehavior of PushBehavior.RequireEmpty -> - [ "The remote namespace is not empty.", - "", - "Did you mean to use " <> IP.makeExample' IP.push <> " instead?" - ] - PushBehavior.RequireNonEmpty -> - [ "The remote namespace is empty.", - "", - "Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?" - ] + P.lines + [ "The remote namespace is not empty.", + "", + "Did you mean to use " <> IP.makeExample' IP.push <> " instead?" + ] + PushBehavior.RequireNonEmpty -> expectedNonEmptyPushDest path GistCreated remoteNamespace -> pure $ P.lines @@ -1578,26 +1583,44 @@ notifyUser dir o = case o of "Host names should NOT include a schema or path." ] PrintVersion ucmVersion -> pure (P.text ucmVersion) - ShareError x -> case x of + ShareError x -> (pure . P.warnCallout) case x of ShareErrorCheckAndSetPush e -> case e of - (Sync.CheckAndSetPushErrorHashMismatch Sync.HashMismatch {path, expectedHash, actualHash}) -> wundefined - (Sync.CheckAndSetPushErrorNoWritePermission sharePath) -> wundefined - (Sync.CheckAndSetPushErrorServerMissingDependencies hashes) -> wundefined + (Share.CheckAndSetPushErrorHashMismatch Share.HashMismatch {path = sharePath, expectedHash, actualHash}) -> + P.wrap $ P.text "It looks like someone modified" <> prettySharePath sharePath <> P.text "an instant before you. Pull and try again? 🤞" + (Share.CheckAndSetPushErrorNoWritePermission sharePath) -> + P.wrap $ P.text "The server said you don't have permission to write" <> prettySharePath sharePath + (Share.CheckAndSetPushErrorServerMissingDependencies hashes) -> + -- maybe todo: stuff in all the args to CheckAndSetPush + P.lines + [ P.wrap + ( P.text "The server was expecting to have received some stuff from UCM during that last command, but claims to have not received it." + <> P.text "(This is probably a bug in UCM.)" + ), + P.text "", + P.text "The hashes it expected are:\n" + <> P.indentN 2 (P.lines (map prettyShareHash (toList hashes))) + ] ShareErrorFastForwardPush e -> case e of - (Sync.FastForwardPushErrorNoHistory sharePath) -> wundefined - (Sync.FastForwardPushErrorNoReadPermission sharePath) -> wundefined - Sync.FastForwardPushErrorNotFastForward -> wundefined - (Sync.FastForwardPushErrorNoWritePermission sharePath) -> wundefined - (Sync.FastForwardPushErrorServerMissingDependencies hashes) -> wundefined + (Share.FastForwardPushErrorNoHistory _sharePath) -> expectedNonEmptyPushDest + (Share.FastForwardPushErrorNoReadPermission sharePath) -> wundefined + Share.FastForwardPushErrorNotFastForward -> wundefined + (Share.FastForwardPushErrorNoWritePermission sharePath) -> wundefined + (Share.FastForwardPushErrorServerMissingDependencies hashes) -> wundefined ShareErrorPull e -> case e of - (Sync.PullErrorGetCausalHashByPath (Sync.GetCausalHashByPathErrorNoReadPermission sharePath)) -> wundefined - (Sync.PullErrorNoHistoryAtPath sharePath) -> wundefined + (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission sharePath)) -> wundefined + (Share.PullErrorNoHistoryAtPath sharePath) -> wundefined ShareErrorGetCausalHashByPath gchbpe -> case gchbpe of - (Sync.GetCausalHashByPathErrorNoReadPermission sharePath) -> wundefined + (Share.GetCausalHashByPathErrorNoReadPermission sharePath) -> wundefined where y = () where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" + expectedNonEmptyPushDest writeRemotePath = + P.lines + [ "The remote namespace" <> prettyRemoteNamespace <> "is empty.", + "", + "Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?" + ] -- do -- when (not . Set.null $ E.changedSuccessfully r) . putPrettyLn . P.okCallout $ @@ -1653,6 +1676,18 @@ prettySBH hash = P.group $ "#" <> P.text (SBH.toText hash) prettyCausalHash :: IsString s => Causal.RawHash x -> P.Pretty s prettyCausalHash hash = P.group $ "#" <> P.text (Hash.toBase32HexText . Causal.unRawHash $ hash) +prettyBase32Hex :: IsString s => Base32Hex -> P.Pretty s +prettyBase32Hex = P.text . Base32Hex.toText + +prettyBase32Hex# :: IsString s => Base32Hex -> P.Pretty s +prettyBase32Hex# b = P.group $ "#" <> prettyBase32Hex b + +prettyHash :: IsString s => Hash.Hash -> P.Pretty s +prettyHash = prettyBase32Hex# . Hash.toBase32Hex + +prettyShareHash :: IsString s => Share.Hash -> P.Pretty s +prettyShareHash = prettyBase32Hex# . Share.Hash.toBase32Hex + formatMissingStuff :: (Show tm, Show typ) => [(HQ.HashQualified Name, tm)] -> From 9569907e88e43f05b17fa78ddd70b378ddeadb65 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 13 May 2022 11:36:34 -0400 Subject: [PATCH 16/19] prettyRemoteNamespace -> prettyReadRemoteNamespace --- .../src/Unison/CommandLine/OutputMessages.hs | 29 +++++++++---------- 1 file changed, 13 insertions(+), 16 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index dfbb61956..e2dc391b5 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1,9 +1,6 @@ {-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PartialTypeSignatures #-} -{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Unison.CommandLine.OutputMessages where @@ -273,9 +270,9 @@ notifyNumbered o = case o of then ( P.wrap $ "Looks like there's no difference between " - <> prettyRemoteNamespace baseRepo + <> prettyReadRemoteNamespace baseRepo <> "and" - <> prettyRemoteNamespace headRepo + <> prettyReadRemoteNamespace headRepo <> ".", mempty ) @@ -290,8 +287,8 @@ notifyNumbered o = case o of P.indentN 2 $ IP.makeExampleNoBackticks IP.loadPullRequest - [ (prettyRemoteNamespace baseRepo), - (prettyRemoteNamespace headRepo) + [ (prettyReadRemoteNamespace baseRepo), + (prettyReadRemoteNamespace headRepo) ], "", p @@ -590,8 +587,8 @@ notifyUser dir o = case o of LoadPullRequest baseNS headNS basePath headPath mergedPath squashedPath -> pure $ P.lines - [ P.wrap $ "I checked out" <> prettyRemoteNamespace baseNS <> "to" <> P.group (prettyPath' basePath <> "."), - P.wrap $ "I checked out" <> prettyRemoteNamespace headNS <> "to" <> P.group (prettyPath' headPath <> "."), + [ P.wrap $ "I checked out" <> prettyReadRemoteNamespace baseNS <> "to" <> P.group (prettyPath' basePath <> "."), + P.wrap $ "I checked out" <> prettyReadRemoteNamespace headNS <> "to" <> P.group (prettyPath' headPath <> "."), "", P.wrap $ "The merged result is in" <> P.group (prettyPath' mergedPath <> "."), P.wrap $ "The (squashed) merged result is in" <> P.group (prettyPath' squashedPath <> "."), @@ -617,11 +614,11 @@ notifyUser dir o = case o of "Use" <> IP.makeExample IP.push - [prettyRemoteNamespace baseNS, prettyPath' mergedPath] + [prettyReadRemoteNamespace baseNS, prettyPath' mergedPath] <> "or" <> IP.makeExample IP.push - [prettyRemoteNamespace baseNS, prettyPath' squashedPath] + [prettyReadRemoteNamespace baseNS, prettyPath' squashedPath] <> "to push the changes." ] DisplayDefinitions outputLoc ppe types terms -> @@ -1143,7 +1140,7 @@ notifyUser dir o = case o of P.wrap $ "I just finished importing the branch" <> P.red (P.shown h) <> "from" - <> P.red (prettyRemoteNamespace (RemoteRepo.ReadRemoteNamespaceGit ns)) + <> P.red (prettyReadRemoteNamespace (RemoteRepo.ReadRemoteNamespaceGit ns)) <> "but now I can't find it." CouldntFindRemoteBranch repo path -> P.wrap $ @@ -1387,12 +1384,12 @@ notifyUser dir o = case o of pure . P.callout "😶" $ P.wrap $ prettyPath' dest <> "was already up-to-date with" - <> P.group (prettyRemoteNamespace ns <> ".") + <> P.group (prettyReadRemoteNamespace ns <> ".") PullSuccessful ns dest -> pure . P.okCallout $ P.wrap $ "Successfully updated" <> prettyPath' dest <> "from" - <> P.group (prettyRemoteNamespace ns <> ".") + <> P.group (prettyReadRemoteNamespace ns <> ".") MergeOverEmpty dest -> pure . P.okCallout $ P.wrap $ @@ -1536,7 +1533,7 @@ notifyUser dir o = case o of P.lines [ "Gist created. Pull via:", "", - P.indentN 2 (IP.patternName IP.pull <> " " <> prettyRemoteNamespace remoteNamespace) + P.indentN 2 (IP.patternName IP.pull <> " " <> prettyReadRemoteNamespace remoteNamespace) ] InitiateAuthFlow authURI -> do pure $ @@ -1617,7 +1614,7 @@ notifyUser dir o = case o of _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" expectedNonEmptyPushDest writeRemotePath = P.lines - [ "The remote namespace" <> prettyRemoteNamespace <> "is empty.", + [ "The remote namespace" <> prettyReadRemoteNamespace <> "is empty.", "", "Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?" ] From bf2c6d6329ed940ef4bcc2b9f6dae121c0609ff0 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 13 May 2022 12:25:09 -0400 Subject: [PATCH 17/19] more pretty-printing work --- parser-typechecker/package.yaml | 1 + .../src/Unison/Codebase/Editor/RemoteRepo.hs | 5 +++ .../unison-parser-typechecker.cabal | 1 + .../src/Unison/Codebase/Editor/HandleInput.hs | 15 ++++----- .../src/Unison/CommandLine/OutputMessages.hs | 31 ++++++++++++++----- unison-share-api/src/Unison/Sync/Types.hs | 6 +++- 6 files changed, 42 insertions(+), 17 deletions(-) diff --git a/parser-typechecker/package.yaml b/parser-typechecker/package.yaml index 4a2e8eb01..b447556d6 100644 --- a/parser-typechecker/package.yaml +++ b/parser-typechecker/package.yaml @@ -77,6 +77,7 @@ library: - safe - safe-exceptions - semialign + - servant-client - mwc-random - NanoID - lucid diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index 819dda188..d27236945 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -4,6 +4,7 @@ module Unison.Codebase.Editor.RemoteRepo where import qualified Data.Text as Text +import qualified Servant.Client as Servant import qualified U.Util.Monoid as Monoid import Unison.Codebase.Path (Path) import qualified Unison.Codebase.Path as Path @@ -23,6 +24,9 @@ data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text} data ShareRepo = ShareRepo deriving (Eq, Show) +shareRepoToBaseUrl :: ShareRepo -> Servant.BaseUrl +shareRepoToBaseUrl ShareRepo = Servant.BaseUrl Servant.Https "share.unison.cloud" 443 "" + data WriteRepo = WriteRepoGit WriteGitRepo | WriteRepoShare ShareRepo @@ -75,6 +79,7 @@ printNamespace = \case then mempty else "." <> Path.toText path +-- | Render a 'WriteRemotePath' as text. printWriteRemotePath :: WriteRemotePath -> Text printWriteRemotePath = \case WriteRemotePathGit WriteGitRemotePath {repo, path} -> wundefined diff --git a/parser-typechecker/unison-parser-typechecker.cabal b/parser-typechecker/unison-parser-typechecker.cabal index b659960ba..15cb81e4b 100644 --- a/parser-typechecker/unison-parser-typechecker.cabal +++ b/parser-typechecker/unison-parser-typechecker.cabal @@ -260,6 +260,7 @@ library , safe-exceptions , semialign , servant + , servant-client , servant-docs , servant-openapi3 , servant-server diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 0ba6bba29..27808b85e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -27,7 +27,6 @@ import Data.Set.NonEmpty (NESet) import qualified Data.Set.NonEmpty as NESet import qualified Data.Text as Text import Data.Tuple.Extra (uncurry3) -import qualified Servant.Client as Servant import qualified Text.Megaparsec as P import qualified U.Codebase.Sqlite.Operations as Ops import U.Util.Timing (unsafeTime) @@ -70,6 +69,7 @@ import Unison.Codebase.Editor.RemoteRepo WriteRemotePath (..), WriteShareRemotePath (..), printNamespace, + shareRepoToBaseUrl, writePathToRead, writeToReadGit, ) @@ -1815,7 +1815,7 @@ doPushRemoteBranch pushFlavor localPath0 syncMode = do let localPath = Path.resolve currentPath' localPath0 case pushFlavor of - NormalPush (WriteRemotePathGit WriteGitRemotePath {repo, path = remotePath}) pushBehavior -> do + NormalPush (writeRemotePath@(WriteRemotePathGit WriteGitRemotePath {repo, path = remotePath})) pushBehavior -> do sourceBranch <- getAt localPath let withRemoteRoot :: Branch m -> m (Either (Output v) (Branch m)) withRemoteRoot remoteRoot = do @@ -1823,7 +1823,7 @@ doPushRemoteBranch pushFlavor localPath0 syncMode = do -- rewinds time or misses any new updates in the remote branch that aren't in `sourceBranch` already. f remoteBranch = if shouldPushTo pushBehavior remoteBranch then Just sourceBranch else Nothing Branch.modifyAtM remotePath f remoteRoot & \case - Nothing -> pure (Left $ RefusedToPush pushBehavior) + Nothing -> pure (Left $ RefusedToPush pushBehavior writeRemotePath) Just newRemoteRoot -> pure (Right newRemoteRoot) let opts = PushGitBranchOpts {setRoot = True, syncMode} runExceptT (syncGitRemoteBranch repo opts withRemoteRoot) >>= \case @@ -1858,9 +1858,6 @@ doPushRemoteBranch pushFlavor localPath0 syncMode = do PushBehavior.RequireEmpty -> Branch.isEmpty0 (Branch.head remoteBranch) PushBehavior.RequireNonEmpty -> not (Branch.isEmpty0 (Branch.head remoteBranch)) -shareRepoToBaseURL :: ShareRepo -> Servant.BaseUrl -shareRepoToBaseURL ShareRepo = Servant.BaseUrl Servant.Https "share.unison.cloud" 443 "" - handlePushToUnisonShare :: MonadIO m => WriteShareRemotePath -> Path.Absolute -> PushBehavior -> Action' m v () handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} localPath behavior = do let sharePath = Share.Path (repo Nel.:| pathToSegments remotePath) @@ -1878,7 +1875,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l push = Share.checkAndSetPush authHTTPClient - (shareRepoToBaseURL server) + (shareRepoToBaseUrl server) connection sharePath Nothing @@ -1889,7 +1886,7 @@ handlePushToUnisonShare WriteShareRemotePath {server, repo, path = remotePath} l PushBehavior.RequireNonEmpty -> do let push :: IO (Either Share.FastForwardPushError ()) push = - Share.fastForwardPush authHTTPClient (shareRepoToBaseURL server) connection sharePath localCausalHash + Share.fastForwardPush authHTTPClient (shareRepoToBaseUrl server) connection sharePath localCausalHash liftIO push >>= \case Left err -> respond (Output.ShareError (ShareErrorFastForwardPush err)) Right () -> pure () @@ -2268,7 +2265,7 @@ importRemoteShareBranch ReadShareRemoteNamespace {server, repo, path} = mapLeft Output.ShareError <$> do let shareFlavoredPath = Share.Path (repo Nel.:| coerce @[NameSegment] @[Text] (Path.toList path)) LoopState.Env {authHTTPClient, codebase = codebase@Codebase {connection}} <- ask - liftIO (Share.pull authHTTPClient (shareRepoToBaseURL server) connection shareFlavoredPath) >>= \case + liftIO (Share.pull authHTTPClient (shareRepoToBaseUrl server) connection shareFlavoredPath) >>= \case Left e -> pure (Left (Output.ShareErrorPull e)) Right causalHash -> do (eval . Eval) (Codebase.getBranchForHash codebase (Cv.branchHash2to1 causalHash)) >>= \case diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index e2dc391b5..808d7c050 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -44,7 +44,13 @@ import Unison.Codebase.Editor.Output import qualified Unison.Codebase.Editor.Output as E import qualified Unison.Codebase.Editor.Output as Output import qualified Unison.Codebase.Editor.Output.BranchDiff as OBD -import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo (ReadRepoGit), WriteRemotePath, WriteRepo (WriteRepoGit)) +import Unison.Codebase.Editor.RemoteRepo + ( ReadRemoteNamespace, + ReadRepo (..), + WriteRemotePath (..), + WriteRepo (..), + WriteShareRemotePath (..), + ) import qualified Unison.Codebase.Editor.RemoteRepo as RemoteRepo import qualified Unison.Codebase.Editor.SlurpResult as SlurpResult import qualified Unison.Codebase.Editor.TodoOutput as TO @@ -91,6 +97,7 @@ import Unison.NamePrinter styleHashQualified, styleHashQualified', ) +import Unison.NameSegment (NameSegment (..)) import Unison.Names (Names (..)) import qualified Unison.Names as Names import qualified Unison.NamesWithHistory as Names @@ -513,9 +520,9 @@ prettyReadRemoteNamespace :: ReadRemoteNamespace -> Pretty prettyReadRemoteNamespace = P.group . P.blue . P.text . RemoteRepo.printNamespace --- prettyWriteRemotePath :: WriteRemotePath -> Pretty --- prettyWriteRemotePath = --- P.group . P.blue . P.text . RemoteRepo.printWriteRemotePath +prettyWriteRemotePath :: WriteRemotePath -> Pretty +prettyWriteRemotePath = + P.group . P.blue . P.text . RemoteRepo.printWriteRemotePath notifyUser :: forall v. Var v => FilePath -> Output v -> IO Pretty notifyUser dir o = case o of @@ -1598,7 +1605,17 @@ notifyUser dir o = case o of <> P.indentN 2 (P.lines (map prettyShareHash (toList hashes))) ] ShareErrorFastForwardPush e -> case e of - (Share.FastForwardPushErrorNoHistory _sharePath) -> expectedNonEmptyPushDest + (Share.FastForwardPushErrorNoHistory sharePath) -> + expectedNonEmptyPushDest + -- Recover the original WriteRemotePath from the information in the error, which is thrown from generic share + -- client code that doesn't know about WriteRemotePath + ( WriteRemotePathShare + WriteShareRemotePath + { server = RemoteRepo.ShareRepo, + repo = Share.unRepoName (Share.pathRepoName sharePath), + path = Path.fromList (coerce @[Text] @[NameSegment] (Share.pathCodebasePath sharePath)) + } + ) (Share.FastForwardPushErrorNoReadPermission sharePath) -> wundefined Share.FastForwardPushErrorNotFastForward -> wundefined (Share.FastForwardPushErrorNoWritePermission sharePath) -> wundefined @@ -1609,12 +1626,12 @@ notifyUser dir o = case o of ShareErrorGetCausalHashByPath gchbpe -> case gchbpe of (Share.GetCausalHashByPathErrorNoReadPermission sharePath) -> wundefined where - y = () + prettySharePath = undefined where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" expectedNonEmptyPushDest writeRemotePath = P.lines - [ "The remote namespace" <> prettyReadRemoteNamespace <> "is empty.", + [ "The remote namespace" <> prettyWriteRemotePath writeRemotePath <> "is empty.", "", "Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?" ] diff --git a/unison-share-api/src/Unison/Sync/Types.hs b/unison-share-api/src/Unison/Sync/Types.hs index 0a1ba93b0..c5929d905 100644 --- a/unison-share-api/src/Unison/Sync/Types.hs +++ b/unison-share-api/src/Unison/Sync/Types.hs @@ -6,6 +6,7 @@ module Unison.Sync.Types RepoName (..), Path (..), pathRepoName, + pathCodebasePath, -- ** Hash types Hash (..), @@ -90,7 +91,7 @@ instance FromJSON Base64Bytes where parseJSON = Aeson.withText "Base64" \txt -> do either fail (pure . Base64Bytes) $ convertFromBase Base64 (Text.encodeUtf8 txt) -newtype RepoName = RepoName Text +newtype RepoName = RepoName {unRepoName :: Text} deriving newtype (Show, Eq, Ord, ToJSON, FromJSON) data Path = Path @@ -106,6 +107,9 @@ data Path = Path pathRepoName :: Path -> RepoName pathRepoName (Path (p :| _)) = RepoName p +pathCodebasePath :: Path -> [Text] +pathCodebasePath (Path (_ :| ps)) = ps + instance ToJSON Path where toJSON (Path segments) = object From 5ace0e1ee18de09d0cf885da3994387b63ffffe7 Mon Sep 17 00:00:00 2001 From: Mitchell Rosen Date: Fri, 13 May 2022 15:08:59 -0400 Subject: [PATCH 18/19] couple more output messages --- .../src/Unison/CommandLine/OutputMessages.hs | 20 +++++++++++-------- 1 file changed, 12 insertions(+), 8 deletions(-) diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index 808d7c050..d099ed599 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1591,8 +1591,7 @@ notifyUser dir o = case o of ShareErrorCheckAndSetPush e -> case e of (Share.CheckAndSetPushErrorHashMismatch Share.HashMismatch {path = sharePath, expectedHash, actualHash}) -> P.wrap $ P.text "It looks like someone modified" <> prettySharePath sharePath <> P.text "an instant before you. Pull and try again? 🤞" - (Share.CheckAndSetPushErrorNoWritePermission sharePath) -> - P.wrap $ P.text "The server said you don't have permission to write" <> prettySharePath sharePath + (Share.CheckAndSetPushErrorNoWritePermission sharePath) -> noWritePermission sharePath (Share.CheckAndSetPushErrorServerMissingDependencies hashes) -> -- maybe todo: stuff in all the args to CheckAndSetPush P.lines @@ -1616,17 +1615,22 @@ notifyUser dir o = case o of path = Path.fromList (coerce @[Text] @[NameSegment] (Share.pathCodebasePath sharePath)) } ) - (Share.FastForwardPushErrorNoReadPermission sharePath) -> wundefined + (Share.FastForwardPushErrorNoReadPermission sharePath) -> noReadPermission sharePath Share.FastForwardPushErrorNotFastForward -> wundefined - (Share.FastForwardPushErrorNoWritePermission sharePath) -> wundefined + (Share.FastForwardPushErrorNoWritePermission sharePath) -> noWritePermission sharePath (Share.FastForwardPushErrorServerMissingDependencies hashes) -> wundefined ShareErrorPull e -> case e of - (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission sharePath)) -> wundefined + (Share.PullErrorGetCausalHashByPath err) -> handleGetCausalHashByPathError err (Share.PullErrorNoHistoryAtPath sharePath) -> wundefined - ShareErrorGetCausalHashByPath gchbpe -> case gchbpe of - (Share.GetCausalHashByPathErrorNoReadPermission sharePath) -> wundefined + ShareErrorGetCausalHashByPath err -> handleGetCausalHashByPathError err where - prettySharePath = undefined + prettySharePath sharePath = undefined + handleGetCausalHashByPathError = \case + Share.GetCausalHashByPathErrorNoReadPermission sharePath -> noReadPermission sharePath + noReadPermission sharePath = + P.wrap $ P.text "The server said you don't have permission to read" <> prettySharePath sharePath + noWritePermission sharePath = + P.wrap $ P.text "The server said you don't have permission to write" <> prettySharePath sharePath where _nameChange _cmd _pastTenseCmd _oldName _newName _r = error "todo" expectedNonEmptyPushDest writeRemotePath = From 6cf9cd1f421b6c59fb388563a27f767d4bd706bc Mon Sep 17 00:00:00 2001 From: Arya Irani Date: Sun, 15 May 2022 17:10:18 -0400 Subject: [PATCH 19/19] implementing the new git and share remote syntaxes, and maybe other stuff --- .../src/Unison/Codebase/Editor/RemoteRepo.hs | 49 ++--- .../src/Unison/Codebase/SqliteCodebase.hs | 4 +- .../src/Unison/Codebase/Editor/HandleInput.hs | 3 +- .../src/Unison/Codebase/Editor/UriParser.hs | 191 +++++++++++++----- .../src/Unison/CommandLine/InputPatterns.hs | 2 +- .../src/Unison/CommandLine/OutputMessages.hs | 71 ++++--- unison-cli/src/Unison/Share/Sync.hs | 6 +- 7 files changed, 213 insertions(+), 113 deletions(-) diff --git a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs index d27236945..4eeed6055 100644 --- a/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs +++ b/parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs @@ -51,45 +51,38 @@ writePathToRead = \case WriteRemotePathShare WriteShareRemotePath {server, repo, path} -> ReadRemoteNamespaceShare ReadShareRemoteNamespace {server, repo, path} -printReadRepo :: ReadRepo -> Text -printReadRepo = \case - ReadRepoGit ReadGitRepo {url, ref} -> url <> Monoid.fromMaybe (Text.cons ':' <$> ref) - ReadRepoShare s -> printShareRepo s +printReadGitRepo :: ReadGitRepo -> Text +printReadGitRepo ReadGitRepo {url, ref} = + "git(" <> url <> Monoid.fromMaybe (Text.cons ':' <$> ref) <> ")" -printShareRepo :: ShareRepo -> Text -printShareRepo = const "PLACEHOLDER" - -printWriteRepo :: WriteRepo -> Text -printWriteRepo = \case - WriteRepoGit WriteGitRepo {url, branch} -> url <> Monoid.fromMaybe (Text.cons ':' <$> branch) - WriteRepoShare s -> printShareRepo s +printWriteGitRepo :: WriteGitRepo -> Text +printWriteGitRepo WriteGitRepo {url, branch} = "git(" <> url <> Monoid.fromMaybe (Text.cons ':' <$> branch) <> ")" -- | print remote namespace printNamespace :: ReadRemoteNamespace -> Text printNamespace = \case ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo, sbh, path} -> - printReadRepo (ReadRepoGit repo) <> case sbh of - Nothing -> - if path == Path.empty - then mempty - else ":." <> Path.toText path - Just sbh -> - ":#" <> SBH.toText sbh - <> if path == Path.empty - then mempty - else "." <> Path.toText path + printReadGitRepo repo <> maybePrintSBH sbh <> maybePrintPath path + where + maybePrintSBH = \case + Nothing -> mempty + Just sbh -> "#" <> SBH.toText sbh + ReadRemoteNamespaceShare ReadShareRemoteNamespace {server = ShareRepo, repo, path} -> + repo <> maybePrintPath path -- | Render a 'WriteRemotePath' as text. printWriteRemotePath :: WriteRemotePath -> Text printWriteRemotePath = \case - WriteRemotePathGit WriteGitRemotePath {repo, path} -> wundefined - WriteRemotePathShare WriteShareRemotePath {server, repo, path} -> wundefined + WriteRemotePathGit WriteGitRemotePath {repo, path} -> + printWriteGitRepo repo <> maybePrintPath path + WriteRemotePathShare WriteShareRemotePath {server = ShareRepo, repo, path} -> + repo <> maybePrintPath path --- | print remote path -printHead :: WriteRepo -> Path -> Text -printHead repo path = - printWriteRepo repo - <> if path == Path.empty then mempty else ":." <> Path.toText path +maybePrintPath :: Path -> Text +maybePrintPath path = + if path == Path.empty + then mempty + else "." <> Path.toText path data ReadRemoteNamespace = ReadRemoteNamespaceGit ReadGitRemoteNamespace diff --git a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs index f49b40bb5..4613f7594 100644 --- a/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs +++ b/parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs @@ -50,7 +50,7 @@ import Unison.Codebase.Editor.RemoteRepo ReadGitRepo, WriteGitRepo (..), WriteRepo (..), - printWriteRepo, + printWriteGitRepo, writeToReadGit, ) import qualified Unison.Codebase.GitError as GitError @@ -810,7 +810,7 @@ pushGitBranch srcConn repo (PushGitBranchOpts setRoot _syncMode) action = Unlift Just True -> pure () CreatedCodebase -> pure () run (setRepoRoot newBranchHash) - repoString = Text.unpack $ printWriteRepo (WriteRepoGit repo) + repoString = Text.unpack $ printWriteGitRepo repo setRepoRoot :: Branch.Hash -> Sqlite.Transaction () setRepoRoot h = do let h2 = Cv.causalHash1to2 h diff --git a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs index 27808b85e..b3760a95e 100644 --- a/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs +++ b/unison-cli/src/Unison/Codebase/Editor/HandleInput.hs @@ -63,7 +63,6 @@ import Unison.Codebase.Editor.RemoteRepo ( ReadGitRemoteNamespace (..), ReadRemoteNamespace (..), ReadShareRemoteNamespace (..), - ShareRepo (ShareRepo), WriteGitRemotePath (..), WriteGitRepo, WriteRemotePath (..), @@ -2231,7 +2230,7 @@ resolveConfiguredUrl pushPull destPath' = ExceptT do let configKey = gitUrlKey destPath (eval . ConfigLookup) configKey >>= \case Just url -> - case P.parse UriParser.writeRepoPath (Text.unpack configKey) url of + case P.parse UriParser.writeRemotePath (Text.unpack configKey) url of Left e -> pure . Left $ ConfiguredGitUrlParseError pushPull destPath' url (show e) diff --git a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs index 55d1b2c3c..f24e18ed1 100644 --- a/unison-cli/src/Unison/Codebase/Editor/UriParser.hs +++ b/unison-cli/src/Unison/Codebase/Editor/UriParser.hs @@ -3,8 +3,7 @@ module Unison.Codebase.Editor.UriParser ( repoPath, writeGitRepo, - writeRepo, - writeRepoPath, + writeRemotePath, ) where @@ -14,15 +13,17 @@ import Data.Text as Text import Data.Void import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as C -import qualified Text.Megaparsec.Char.Lexer as L +import qualified Text.Megaparsec.Char as P import Unison.Codebase.Editor.RemoteRepo ( ReadGitRemoteNamespace (..), ReadGitRepo (..), ReadRemoteNamespace (..), + ReadShareRemoteNamespace (..), + ShareRepo (..), WriteGitRemotePath (..), WriteGitRepo (..), WriteRemotePath (..), - WriteRepo (..), + WriteShareRemotePath (..), ) import Unison.Codebase.Path (Path (..)) import qualified Unison.Codebase.Path as Path @@ -30,6 +31,7 @@ import Unison.Codebase.ShortBranchHash (ShortBranchHash (..)) import qualified Unison.Hash as Hash import qualified Unison.Lexer import Unison.NameSegment (NameSegment (..)) +import qualified Unison.NameSegment as NameSegment import Unison.Prelude type P = P.Parsec Void Text.Text @@ -53,43 +55,108 @@ type P = P.Parsec Void Text.Text -- $ git clone [user@]server:project.git[:treeish][:[#hash][.path]] repoPath :: P ReadRemoteNamespace -repoPath = P.label "generic git repo" $ do - protocol <- parseProtocol - treeish <- P.optional treeishSuffix +repoPath = + P.label "generic repo" $ + fmap ReadRemoteNamespaceGit readGitRemoteNamespace + <|> fmap ReadRemoteNamespaceShare readShareRemoteNamespace + +-- >>> P.parseMaybe writeRemotePath "unisonweb.base._releases.M4" +-- >>> P.parseMaybe writeRemotePath "git(git@github.com:unisonweb/base:v3)._releases.M3" +-- Just (WriteRemotePathShare (WriteShareRemotePath {server = ShareRepo, repo = "unisonweb", path = base._releases.M4})) +-- Just (WriteRemotePathGit (WriteGitRemotePath {repo = WriteGitRepo {url = "git@github.com:unisonweb/base", branch = Just "v3"}, path = _releases.M3})) +writeRemotePath :: P WriteRemotePath +writeRemotePath = + (fmap WriteRemotePathGit writeGitRemotePath) + <|> fmap WriteRemotePathShare writeShareRemotePath + +-- >>> P.parseMaybe writeShareRemotePath "unisonweb.base._releases.M4" +-- Just (WriteShareRemotePath {server = ShareRepo, repo = "unisonweb", path = base._releases.M4}) +writeShareRemotePath :: P WriteShareRemotePath +writeShareRemotePath = + P.label "write share remote path" $ + WriteShareRemotePath + <$> pure ShareRepo + <*> (NameSegment.toText <$> nameSegment) + <*> (Path.fromList <$> P.many (C.char '.' *> nameSegment)) + +-- >>> P.parseMaybe readShareRemoteNamespace ".unisonweb.base._releases.M4" +-- >>> P.parseMaybe readShareRemoteNamespace "unisonweb.base._releases.M4" +-- Nothing +-- Just (ReadShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4}) +readShareRemoteNamespace :: P ReadShareRemoteNamespace +readShareRemoteNamespace = do + P.label "read share remote namespace" $ + ReadShareRemoteNamespace + <$> pure ShareRepo + -- <*> sbh <- P.optional shortBranchHash + <*> (NameSegment.toText <$> nameSegment) + <*> (Path.fromList <$> P.many (C.char '.' *> nameSegment)) + +-- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)#asdf.foo.bar" +-- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)#asdf" +-- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)#asdf." +-- >>> P.parseMaybe readGitRemoteNamespace "git(user@server:project.git:branch)" +-- >>> P.parseMaybe readGitRemoteNamespace "git(git@github.com:unisonweb/base:v3)._releases.M3" +-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = foo.bar}) +-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = }) +-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Just #asdf, path = }) +-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sbh = Nothing, path = }) +-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "git@github.com:unisonweb/base", ref = Just "v3"}, sbh = Nothing, path = _releases.M3}) +readGitRemoteNamespace :: P ReadGitRemoteNamespace +readGitRemoteNamespace = P.label "generic git repo" $ do + P.string "git(" + protocol <- parseGitProtocol + treeish <- P.optional gitTreeishSuffix let repo = ReadGitRepo {url = printProtocol protocol, ref = treeish} - nshashPath <- P.optional (C.char ':' *> namespaceHashPath) - pure do - ReadRemoteNamespaceGit do - case nshashPath of - Nothing -> ReadGitRemoteNamespace {repo, sbh = Nothing, path = Path.empty} - Just (sbh, path) -> ReadGitRemoteNamespace {repo, sbh, path} - --- FIXME parse share paths too -writeRepo :: P WriteRepo -writeRepo = - WriteRepoGit <$> writeGitRepo + P.string ")" + nshashPath <- P.optional namespaceHashPath + pure case nshashPath of + Nothing -> ReadGitRemoteNamespace {repo, sbh = Nothing, path = Path.empty} + Just (sbh, path) -> ReadGitRemoteNamespace {repo, sbh, path} +-- >>> P.parseMaybe writeGitRepo "git(/srv/git/project.git)" +-- >>> P.parseMaybe writeGitRepo "git(/srv/git/project.git:branch)" +-- Just (WriteGitRepo {url = "/srv/git/project.git", branch = Nothing}) +-- Just (WriteGitRepo {url = "/srv/git/project.git", branch = Just "branch"}) +-- +-- >>> P.parseMaybe writeGitRepo "git(file:///srv/git/project.git)" +-- >>> P.parseMaybe writeGitRepo "git(file:///srv/git/project.git:branch)" +-- Just (WriteGitRepo {url = "file:///srv/git/project.git", branch = Nothing}) +-- Just (WriteGitRepo {url = "file:///srv/git/project.git", branch = Just "branch"}) +-- +-- >>> P.parseMaybe writeGitRepo "git(https://example.com/gitproject.git)" +-- >>> P.parseMaybe writeGitRepo "git(https://example.com/gitproject.git:base)" +-- Just (WriteGitRepo {url = "https://example.com/gitproject.git", branch = Nothing}) +-- Just (WriteGitRepo {url = "https://example.com/gitproject.git", branch = Just "base"}) +-- +-- >>> P.parseMaybe writeGitRepo "git(ssh://user@server/project.git)" +-- >>> P.parseMaybe writeGitRepo "git(ssh://user@server/project.git:branch)" +-- >>> P.parseMaybe writeGitRepo "git(ssh://server/project.git)" +-- >>> P.parseMaybe writeGitRepo "git(ssh://server/project.git:branch)" +-- Just (WriteGitRepo {url = "ssh://user@server/project.git", branch = Nothing}) +-- Just (WriteGitRepo {url = "ssh://user@server/project.git", branch = Just "branch"}) +-- Just (WriteGitRepo {url = "ssh://server/project.git", branch = Nothing}) +-- Just (WriteGitRepo {url = "ssh://server/project.git", branch = Just "branch"}) +-- +-- >>> P.parseMaybe writeGitRepo "git(server:project)" +-- >>> P.parseMaybe writeGitRepo "git(user@server:project.git:branch)" +-- Just (WriteGitRepo {url = "server:project", branch = Nothing}) +-- Just (WriteGitRepo {url = "user@server:project.git", branch = Just "branch"}) writeGitRepo :: P WriteGitRepo writeGitRepo = P.label "repo root for writing" $ do - uri <- parseProtocol - treeish <- P.optional treeishSuffix + P.string "git(" + uri <- parseGitProtocol + treeish <- P.optional gitTreeishSuffix + P.string ")" pure WriteGitRepo {url = printProtocol uri, branch = treeish} -writeRepoPath :: P WriteRemotePath -writeRepoPath = - -- FIXME parse share paths too - WriteRemotePathGit <$> writeGitRepoPath - -writeGitRepoPath :: P WriteGitRemotePath -writeGitRepoPath = P.label "generic write repo" $ do +-- git(myrepo@git.com).foo.bar +writeGitRemotePath :: P WriteGitRemotePath +writeGitRemotePath = P.label "generic write repo" $ do repo <- writeGitRepo - path <- P.optional (C.char ':' *> absolutePath) + path <- P.optional absolutePath pure WriteGitRemotePath {repo, path = fromMaybe Path.empty path} --- does this not exist somewhere in megaparsec? yes in 7.0 -symbol :: Text -> P Text -symbol = L.symbol (pure ()) - data GitProtocol = HttpsProtocol (Maybe User) HostInfo UrlPath | SshProtocol (Maybe User) HostInfo UrlPath @@ -136,29 +203,29 @@ type Host = Text -- no port -- doesn't yet handle basic authentication like https://user:pass@server.com -- (does anyone even want that?) -- or handle ipv6 addresses (https://en.wikipedia.org/wiki/IPv6#Addressing) -parseProtocol :: P GitProtocol -parseProtocol = - P.label "parseProtocol" $ +parseGitProtocol :: P GitProtocol +parseGitProtocol = + P.label "parseGitProtocol" $ fileRepo <|> httpsRepo <|> sshRepo <|> scpRepo <|> localRepo where localRepo, fileRepo, httpsRepo, sshRepo, scpRepo :: P GitProtocol parsePath = P.takeWhile1P (Just "repo path character") - (\c -> not (isSpace c || c == ':')) + (\c -> not (isSpace c || c == ':' || c == ')')) localRepo = LocalProtocol <$> parsePath fileRepo = P.label "fileRepo" $ do - void $ symbol "file://" + void $ P.string "file://" FileProtocol <$> parsePath httpsRepo = P.label "httpsRepo" $ do - void $ symbol "https://" + void $ P.string "https://" HttpsProtocol <$> P.optional userInfo <*> parseHostInfo <*> parsePath sshRepo = P.label "sshRepo" $ do - void $ symbol "ssh://" + void $ P.string "ssh://" SshProtocol <$> P.optional userInfo <*> parseHostInfo <*> parsePath scpRepo = P.label "scpRepo" . P.try $ - ScpProtocol <$> P.optional userInfo <*> parseHost <* symbol ":" <*> parsePath + ScpProtocol <$> P.optional userInfo <*> parseHost <* P.string ":" <*> parsePath userInfo :: P User userInfo = P.label "userInfo" . P.try $ do username <- P.takeWhile1P (Just "username character") (/= '@') @@ -169,7 +236,7 @@ parseProtocol = P.label "parseHostInfo" $ HostInfo <$> parseHost <*> ( P.optional $ do - void $ symbol ":" + void $ P.string ":" P.takeWhile1P (Just "digits") isDigit ) @@ -190,29 +257,47 @@ parseProtocol = pure $ Text.pack $ o1 <> "." <> o2 <> "." <> o3 <> "." <> o4 decOctet = P.count' 1 3 C.digitChar --- #nshashabc.path.foo.bar or .path.foo.bar +-- >>> P.parseMaybe namespaceHashPath "#nshashabc.path.foo.bar" +-- Just (Just #nshashabc,path.foo.bar) +-- +-- >>> P.parseMaybe namespaceHashPath ".path.foo.bar" +-- Just (Nothing,path.foo.bar) +-- +-- >>> P.parseMaybe namespaceHashPath "#nshashabc" +-- Just (Just #nshashabc,) +-- +-- >>> P.parseMaybe namespaceHashPath "#nshashabc." +-- Just (Just #nshashabc,) +-- +-- >>> P.parseMaybe namespaceHashPath "." +-- Just (Nothing,) namespaceHashPath :: P (Maybe ShortBranchHash, Path) namespaceHashPath = do sbh <- P.optional shortBranchHash p <- P.optional absolutePath pure (sbh, fromMaybe Path.empty p) +-- >>> P.parseMaybe absolutePath "." +-- Just +-- +-- >>> P.parseMaybe absolutePath ".path.foo.bar" +-- Just path.foo.bar absolutePath :: P Path absolutePath = do void $ C.char '.' - Path . Seq.fromList . fmap (NameSegment . Text.pack) - <$> P.sepBy1 - ( (:) <$> C.satisfy Unison.Lexer.wordyIdStartChar - <*> P.many (C.satisfy Unison.Lexer.wordyIdChar) - ) - (C.char '.') + Path . Seq.fromList <$> P.sepBy nameSegment (C.char '.') -treeishSuffix :: P Text -treeishSuffix = P.label "git treeish" . P.try $ do +nameSegment :: P NameSegment +nameSegment = + NameSegment . Text.pack + <$> ( (:) <$> C.satisfy Unison.Lexer.wordyIdStartChar + <*> P.many (C.satisfy Unison.Lexer.wordyIdChar) + ) + +gitTreeishSuffix :: P Text +gitTreeishSuffix = P.label "git treeish" . P.try $ do void $ C.char ':' - notdothash <- C.noneOf @[] ".#:" - rest <- P.takeWhileP (Just "not colon") (/= ':') - pure $ Text.cons notdothash rest + P.takeWhile1P (Just "not close paren") (/= ')') shortBranchHash :: P ShortBranchHash shortBranchHash = P.label "short branch hash" $ do diff --git a/unison-cli/src/Unison/CommandLine/InputPatterns.hs b/unison-cli/src/Unison/CommandLine/InputPatterns.hs index 4ecc2fdc1..e73fcc93c 100644 --- a/unison-cli/src/Unison/CommandLine/InputPatterns.hs +++ b/unison-cli/src/Unison/CommandLine/InputPatterns.hs @@ -1273,7 +1273,7 @@ parsePushPath :: String -> String -> Either (P.Pretty P.ColorText) WriteRemotePa parsePushPath label input = do first (fromString . show) -- turn any parsing errors into a Pretty. - (P.parse UriParser.writeRepoPath label (Text.pack input)) + (P.parse UriParser.writeRemotePath label (Text.pack input)) squashMerge :: InputPattern squashMerge = diff --git a/unison-cli/src/Unison/CommandLine/OutputMessages.hs b/unison-cli/src/Unison/CommandLine/OutputMessages.hs index d099ed599..72c1c8aa4 100644 --- a/unison-cli/src/Unison/CommandLine/OutputMessages.hs +++ b/unison-cli/src/Unison/CommandLine/OutputMessages.hs @@ -1589,10 +1589,45 @@ notifyUser dir o = case o of PrintVersion ucmVersion -> pure (P.text ucmVersion) ShareError x -> (pure . P.warnCallout) case x of ShareErrorCheckAndSetPush e -> case e of - (Share.CheckAndSetPushErrorHashMismatch Share.HashMismatch {path = sharePath, expectedHash, actualHash}) -> + (Share.CheckAndSetPushErrorHashMismatch Share.HashMismatch {path = sharePath, expectedHash = _expectedHash, actualHash = _actualHash}) -> P.wrap $ P.text "It looks like someone modified" <> prettySharePath sharePath <> P.text "an instant before you. Pull and try again? 🤞" (Share.CheckAndSetPushErrorNoWritePermission sharePath) -> noWritePermission sharePath - (Share.CheckAndSetPushErrorServerMissingDependencies hashes) -> + (Share.CheckAndSetPushErrorServerMissingDependencies hashes) -> missingDependencies hashes + ShareErrorFastForwardPush e -> case e of + (Share.FastForwardPushErrorNoHistory sharePath) -> + expectedNonEmptyPushDest (sharePathToWriteRemotePathShare sharePath) + (Share.FastForwardPushErrorNoReadPermission sharePath) -> noReadPermission sharePath + Share.FastForwardPushErrorNotFastForward sharePath -> + P.lines $ + [ P.wrap $ + "There are some changes at" <> prettySharePath sharePath <> "that aren't in the history you pushed.", + "", + P.wrap $ + "If you're sure you got the right paths, try" + <> pull + <> "to merge these changes locally, then" + <> push + <> "again." + ] + where + push = P.group . P.backticked . IP.patternName $ IP.push + pull = P.group . P.backticked . IP.patternName $ IP.pull + (Share.FastForwardPushErrorNoWritePermission sharePath) -> noWritePermission sharePath + (Share.FastForwardPushErrorServerMissingDependencies hashes) -> missingDependencies hashes + ShareErrorPull e -> case e of + (Share.PullErrorGetCausalHashByPath err) -> handleGetCausalHashByPathError err + (Share.PullErrorNoHistoryAtPath sharePath) -> + P.wrap $ P.text "The server didn't find anything at" <> prettySharePath sharePath + ShareErrorGetCausalHashByPath err -> handleGetCausalHashByPathError err + where + prettySharePath = + prettyRelative + . Path.Relative + . Path.fromList + . coerce @[Text] @[NameSegment] + . toList + . Share.pathSegments + missingDependencies hashes = -- maybe todo: stuff in all the args to CheckAndSetPush P.lines [ P.wrap @@ -1603,28 +1638,6 @@ notifyUser dir o = case o of P.text "The hashes it expected are:\n" <> P.indentN 2 (P.lines (map prettyShareHash (toList hashes))) ] - ShareErrorFastForwardPush e -> case e of - (Share.FastForwardPushErrorNoHistory sharePath) -> - expectedNonEmptyPushDest - -- Recover the original WriteRemotePath from the information in the error, which is thrown from generic share - -- client code that doesn't know about WriteRemotePath - ( WriteRemotePathShare - WriteShareRemotePath - { server = RemoteRepo.ShareRepo, - repo = Share.unRepoName (Share.pathRepoName sharePath), - path = Path.fromList (coerce @[Text] @[NameSegment] (Share.pathCodebasePath sharePath)) - } - ) - (Share.FastForwardPushErrorNoReadPermission sharePath) -> noReadPermission sharePath - Share.FastForwardPushErrorNotFastForward -> wundefined - (Share.FastForwardPushErrorNoWritePermission sharePath) -> noWritePermission sharePath - (Share.FastForwardPushErrorServerMissingDependencies hashes) -> wundefined - ShareErrorPull e -> case e of - (Share.PullErrorGetCausalHashByPath err) -> handleGetCausalHashByPathError err - (Share.PullErrorNoHistoryAtPath sharePath) -> wundefined - ShareErrorGetCausalHashByPath err -> handleGetCausalHashByPathError err - where - prettySharePath sharePath = undefined handleGetCausalHashByPathError = \case Share.GetCausalHashByPathErrorNoReadPermission sharePath -> noReadPermission sharePath noReadPermission sharePath = @@ -1639,6 +1652,16 @@ notifyUser dir o = case o of "", "Did you mean to use " <> IP.makeExample' IP.pushCreate <> " instead?" ] + sharePathToWriteRemotePathShare sharePath = + -- Recover the original WriteRemotePath from the information in the error, which is thrown from generic share + -- client code that doesn't know about WriteRemotePath + ( WriteRemotePathShare + WriteShareRemotePath + { server = RemoteRepo.ShareRepo, + repo = Share.unRepoName (Share.pathRepoName sharePath), + path = Path.fromList (coerce @[Text] @[NameSegment] (Share.pathCodebasePath sharePath)) + } + ) -- do -- when (not . Set.null $ E.changedSuccessfully r) . putPrettyLn . P.okCallout $ diff --git a/unison-cli/src/Unison/Share/Sync.hs b/unison-cli/src/Unison/Share/Sync.hs index af664f294..31bf34895 100644 --- a/unison-cli/src/Unison/Share/Sync.hs +++ b/unison-cli/src/Unison/Share/Sync.hs @@ -134,7 +134,7 @@ checkAndSetPush httpClient unisonShareUrl conn path expectedHash causalHash = do data FastForwardPushError = FastForwardPushErrorNoHistory Share.Path | FastForwardPushErrorNoReadPermission Share.Path - | FastForwardPushErrorNotFastForward + | FastForwardPushErrorNotFastForward Share.Path | FastForwardPushErrorNoWritePermission Share.Path | FastForwardPushErrorServerMissingDependencies (NESet Share.Hash) @@ -160,7 +160,7 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash = Sqlite.runTransaction conn (fancyBfs localHeadHash remoteHeadHash) >>= \case -- After getting the remote causal hash, we can tell from a local computation that this wouldn't be a -- fast-forward push, so we don't bother trying - just report the error now. - Nothing -> pure (Left FastForwardPushErrorNotFastForward) + Nothing -> pure (Left (FastForwardPushErrorNotFastForward path)) Just localTailHashes -> doUpload (localHeadHash :| localTailHashes) >>= \case False -> pure (Left (FastForwardPushErrorNoWritePermission path)) @@ -173,7 +173,7 @@ fastForwardPush httpClient unisonShareUrl conn path localHeadHash = -- path but moments ago! Share.FastForwardPathNoHistory -> Left (FastForwardPushErrorNoHistory path) Share.FastForwardPathNoWritePermission _ -> Left (FastForwardPushErrorNoWritePermission path) - Share.FastForwardPathNotFastForward _ -> Left FastForwardPushErrorNotFastForward + Share.FastForwardPathNotFastForward _ -> Left (FastForwardPushErrorNotFastForward path) where doUpload :: List.NonEmpty CausalHash -> IO Bool -- Maybe we could save round trips here by including the tail (or the head *and* the tail) as "extra hashes", but we