unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-21 23:37:23 +03:00
Code Issues Projects Releases Wiki Activity

⅄ ooo-sync-read-repo-sum-type → arya/ooo-sync

Browse Source
This commit is contained in:
Mitchell Rosen 2022-05-18 11:26:02 -04:00
commit a5a67f2d4b
30 changed files with 833 additions and 419 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
lib/unison-prelude/src/Unison/Prelude.hs
View File

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

2
parser-typechecker/package.yaml
View File

@ -77,6 +77,7 @@ library:
- safe
- safe-exceptions
- semialign
- servant-client
- mwc-random
- NanoID
- lucid
@ -173,6 +174,7 @@ default-extensions:
- DerivingStrategies
- DerivingVia
- DoAndIfThenElse
- DuplicateRecordFields
- FlexibleContexts
- FlexibleInstances
- GeneralizedNewtypeDeriving

8
parser-typechecker/src/Unison/Codebase.hs
View File

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

6
parser-typechecker/src/Unison/Codebase/Editor/Git.hs
View File

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

125
parser-typechecker/src/Unison/Codebase/Editor/RemoteRepo.hs
View File

@ -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
@ -11,40 +12,112 @@ 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
| ReadRepoShare ShareRepo
deriving (Eq, Show)
data WriteRepo = WriteGitRepo {url' :: Text, branch :: Maybe Text} deriving (Eq, Ord, Show)
data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text}
deriving (Eq, Show)
-- FIXME rename to ShareServer
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
deriving (Eq, Show)
data WriteGitRepo = WriteGitRepo {url :: Text, branch :: Maybe Text}
deriving (Eq, Show)
writeToRead :: WriteRepo -> ReadRepo
writeToRead (WriteGitRepo {url', branch}) = ReadGitRepo {url = url', ref = branch}
writeToRead = \case
WriteRepoGit repo -> ReadRepoGit (writeToReadGit repo)
WriteRepoShare repo -> ReadRepoShare repo
writeToReadGit :: WriteGitRepo -> ReadGitRepo
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 ReadGitRepo {url, ref} = url <> Monoid.fromMaybe (Text.cons ':' <$> ref)
printReadGitRepo :: ReadGitRepo -> Text
printReadGitRepo ReadGitRepo {url, ref} =
"git(" <> url <> Monoid.fromMaybe (Text.cons ':' <$> ref) <> ")"
printWriteRepo :: WriteRepo -> Text
printWriteRepo WriteGitRepo {url', branch} = url' <> Monoid.fromMaybe (Text.cons ':' <$> branch)
printWriteGitRepo :: WriteGitRepo -> Text
printWriteGitRepo WriteGitRepo {url, branch} = "git(" <> url <> Monoid.fromMaybe (Text.cons ':' <$> branch) <> ")"
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
then mempty
else "." <> Path.toText path
-- | print remote namespace
printNamespace :: ReadRemoteNamespace -> Text
printNamespace = \case
ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo, sbh, 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
printHead :: WriteRepo -> Path -> Text
printHead repo path =
printWriteRepo repo
<> if path == Path.empty then mempty else ":." <> Path.toText path
-- | Render a 'WriteRemotePath' as text.
printWriteRemotePath :: WriteRemotePath -> Text
printWriteRemotePath = \case
WriteRemotePathGit WriteGitRemotePath {repo, path} ->
printWriteGitRepo repo <> maybePrintPath path
WriteRemotePathShare WriteShareRemotePath {server = ShareRepo, repo, path} ->
repo <> maybePrintPath path
type ReadRemoteNamespace = (ReadRepo, Maybe ShortBranchHash, Path)
maybePrintPath :: Path -> Text
maybePrintPath path =
if path == Path.empty
then mempty
else "." <> Path.toText path
type WriteRemotePath = (WriteRepo, Path)
data ReadRemoteNamespace
= ReadRemoteNamespaceGit ReadGitRemoteNamespace
| ReadRemoteNamespaceShare ReadShareRemoteNamespace
deriving stock (Eq, Show)
data ReadGitRemoteNamespace = ReadGitRemoteNamespace
{ repo :: ReadGitRepo,
sbh :: Maybe ShortBranchHash,
path :: Path
}
deriving stock (Eq, Show)
data ReadShareRemoteNamespace = ReadShareRemoteNamespace
{ server :: ShareRepo,
repo :: Text,
-- sbh :: Maybe ShortBranchHash, -- maybe later
path :: Path
}
deriving stock (Eq, Show)
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)

26
parser-typechecker/src/Unison/Codebase/GitError.hs
View File

@ -2,7 +2,7 @@
module Unison.Codebase.GitError where
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo, WriteRepo)
import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, 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
| CouldntLoadSyncedBranch ReadRemoteNamespace h
| CouldntFindRemoteBranch ReadRepo Path
= NoRemoteNamespaceWithHash ReadGitRepo ShortBranchHash
| RemoteNamespaceHashAmbiguous ReadGitRepo ShortBranchHash (Set h)
| CouldntLoadRootBranch ReadGitRepo h
| CouldntParseRemoteBranch ReadGitRepo String
| CouldntLoadSyncedBranch ReadGitRemoteNamespace h
| CouldntFindRemoteBranch ReadGitRepo Path
deriving (Show)

28
parser-typechecker/src/Unison/Codebase/SqliteCodebase.hs
View File

@ -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 (..),
printWriteGitRepo,
writeToReadGit,
)
import qualified Unison.Codebase.GitError as GitError
import qualified Unison.Codebase.Init as Codebase
import qualified Unison.Codebase.Init.CreateCodebaseError as Codebase1
@ -471,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,
@ -676,14 +683,15 @@ 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)
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
@ -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 $ printWriteGitRepo repo
setRepoRoot :: Branch.Hash -> Sqlite.Transaction ()
setRepoRoot h = do
let h2 = Cv.causalHash1to2 h
@ -854,8 +862,8 @@ 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 remotePath repo@(WriteGitRepo {url' = url, branch = mayGitBranch}) newRootBranch = time "SqliteCodebase.pushGitRootBranch.push" $ do
push :: forall n. MonadIO n => Git.GitRepo -> WriteGitRepo -> Branch m -> n Bool -- withIOError needs IO
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

8
parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs
View File

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

8
parser-typechecker/src/Unison/Codebase/Type.hs
View File

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

3
parser-typechecker/unison-parser-typechecker.cabal
View File

@ -178,6 +178,7 @@ library
DerivingStrategies
DerivingVia
DoAndIfThenElse
DuplicateRecordFields
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving
@ -259,6 +260,7 @@ library
, safe-exceptions
, semialign
, servant
, servant-client
, servant-docs
, servant-openapi3
, servant-server
@ -349,6 +351,7 @@ test-suite parser-typechecker-tests
DerivingStrategies
DerivingVia
DoAndIfThenElse
DuplicateRecordFields
FlexibleContexts
FlexibleInstances
GeneralizedNewtypeDeriving

4
unison-cli/src/Unison/Auth/HTTPClient.hs
View File

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

20
unison-cli/src/Unison/Codebase/Editor/Command.hs
View File

@ -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
@ -197,16 +195,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 +215,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 +314,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"

9
unison-cli/src/Unison/Codebase/Editor/HandleCommand.hs
View File

@ -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
@ -151,14 +152,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

333
unison-cli/src/Unison/Codebase/Editor/HandleInput.hs
View File

@ -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
@ -37,6 +36,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
@ -59,7 +59,19 @@ 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 (..),
ReadRemoteNamespace (..),
ReadShareRemoteNamespace (..),
WriteGitRemotePath (..),
WriteGitRepo,
WriteRemotePath (..),
WriteShareRemotePath (..),
printNamespace,
shareRepoToBaseUrl,
writePathToRead,
writeToReadGit,
)
import qualified Unison.Codebase.Editor.Slurp as Slurp
import Unison.Codebase.Editor.SlurpComponent (SlurpComponent (..))
import qualified Unison.Codebase.Editor.SlurpComponent as SC
@ -80,6 +92,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
@ -133,13 +146,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
( Hash,
HashMismatch (..),
RepoName (..),
RepoPath (..),
hashJWTHash,
)
import qualified Unison.Sync.Types as Share (Path (..))
import Unison.Term (Term)
import qualified Unison.Term as Term
import Unison.Type (Type)
@ -422,7 +429,7 @@ loop = do
-- todo: show the actual config-loaded namespace
<> maybe
"(remote namespace from .unisonConfig)"
(uncurry3 printNamespace)
printNamespace
orepo
<> " "
<> p' dest
@ -434,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
@ -498,9 +505,8 @@ 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
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
@ -656,24 +662,20 @@ loop = do
(resolveToAbsolute <$> after)
ppe
outputDiff
CreatePullRequestI baseRepo headRepo -> do
result <-
join @(Either GitError) <$> viewRemoteBranch baseRepo Git.RequireExistingBranch \baseBranch -> do
viewRemoteBranch 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 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
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 <- importRemoteBranch baseRepo SyncMode.ShortCircuit Unmodified
headb <- importRemoteBranch headRepo 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
@ -713,8 +715,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 $
@ -1407,11 +1409,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
@ -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
lift $ unlessGitError do
remoteBranch <- importRemoteBranch ns syncMode preprocess
ns <- maybe (writePathToRead <$> resolveConfiguredUrl Pull path) pure mayRepo
lift $ unlessError do
remoteBranch <- case ns of
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
@ -1665,6 +1669,65 @@ loop = do
Right input -> LoopState.lastInput .= Just input
_ -> pure ()
handleCreatePullRequest :: forall m v. MonadUnliftIO m => ReadRemoteNamespace -> ReadRemoteNamespace -> Action' m v ()
handleCreatePullRequest baseRepo0 headRepo0 = do
root' <- use LoopState.root
currentPath' <- use LoopState.currentPath
-- 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
case (baseRepo0, headRepo0) of
(ReadRemoteNamespaceGit baseRepo, ReadRemoteNamespaceGit headRepo) -> do
result <-
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) ->
importRemoteShareBranch headRepo >>= \case
Left err -> respond err
Right headBranch -> do
result <-
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 err -> respond err
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 err -> respond err
Right headBranch ->
importRemoteShareBranch baseRepo >>= \case
Left err -> respond err
Right baseBranch -> do
diff <- mergeAndDiff baseBranch headBranch
respondNumbered diff
handleDependents :: Monad m => HQ.HashQualified Name -> Action' m v ()
handleDependents hq = do
hqLength <- eval CodebaseHashLength
@ -1704,19 +1767,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
handlePullFromUnisonShare :: MonadIO m => Text -> Path -> Action' m v ()
handlePullFromUnisonShare remoteRepo remotePath = do
let repoPath = Share.RepoPath (Share.RepoName remoteRepo) (coerce @[NameSegment] @[Text] (Path.toList remotePath))
LoopState.Env {authHTTPClient, codebase = Codebase {connection}, unisonShareUrl} <- ask
liftIO (Share.pull authHTTPClient unisonShareUrl connection repoPath) >>= \case
Left (Share.PullErrorGetCausalHashByPath (Share.GetCausalHashByPathErrorNoReadPermission _)) -> undefined
Right Nothing -> undefined
Right (Just causalHash) -> do
undefined
doPushRemoteBranch (GistyPush repo) Path.relativeEmpty' SyncMode.ShortCircuit
-- | Handle a @push@ command.
handlePushRemoteBranch ::
@ -1730,50 +1781,71 @@ handlePushRemoteBranch ::
PushBehavior ->
SyncMode.SyncMode ->
Action' m v ()
handlePushRemoteBranch mayRepo path pushBehavior syncMode = do
unlessError do
(repo, remotePath) <- maybe (resolveConfiguredGitUrl Push path) pure mayRepo
lift (doPushRemoteBranch repo path syncMode (Just (remotePath, pushBehavior)))
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
-- | 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.
WriteRepo ->
PushFlavor ->
-- | 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
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
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 pushFlavor of
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
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 writeRemotePath)
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
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,
sbh = Just (SBH.fromHash sbhLength (Branch.headHash sourceBranch)),
path = Path.empty
}
)
where
-- Per `pushBehavior`, we are either:
--
@ -1785,41 +1857,42 @@ 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
let repoPath = Share.RepoPath (Share.RepoName remoteRepo) (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}, unisonShareUrl} <- ask
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 unisonShareUrl connection repoPath Nothing localCausalHash) >>= \case
Left err ->
case err of
Share.CheckAndSetPushErrorHashMismatch _mismatch -> error "remote not empty"
Share.CheckAndSetPushErrorNoWritePermission _repoPath -> errNoWritePermission repoPath
Share.CheckAndSetPushErrorServerMissingDependencies deps -> errServerMissingDependencies deps
PushBehavior.RequireEmpty -> do
let push :: IO (Either Share.CheckAndSetPushError ())
push =
Share.checkAndSetPush
authHTTPClient
(shareRepoToBaseUrl server)
connection
sharePath
Nothing
localCausalHash
liftIO push >>= \case
Left err -> respond (Output.ShareError (ShareErrorCheckAndSetPush err))
Right () -> pure ()
PushBehavior.RequireNonEmpty ->
liftIO (Share.fastForwardPush authHTTPClient unisonShareUrl connection repoPath localCausalHash) >>= \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.FastForwardPushErrorServerMissingDependencies deps -> errServerMissingDependencies deps
PushBehavior.RequireNonEmpty -> do
let push :: IO (Either Share.FastForwardPushError ())
push =
Share.fastForwardPush authHTTPClient (shareRepoToBaseUrl server) connection sharePath localCausalHash
liftIO push >>= \case
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
-- | Handle a @ShowDefinitionI@ input command, i.e. `view` or `edit`.
handleShowDefinition ::
@ -2147,17 +2220,17 @@ 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
(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)
@ -2177,26 +2250,38 @@ 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
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)
-- 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)
@ -2475,10 +2560,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
@ -2495,10 +2580,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
@ -2891,7 +2976,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 =>

5
unison-cli/src/Unison/Codebase/Editor/HandleInput/LoopState.hs
View File

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

4
unison-cli/src/Unison/Codebase/Editor/Input.hs
View File

@ -189,9 +189,9 @@ 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
{ repo :: WriteGitRepo
}
deriving stock (Eq, Show)

16
unison-cli/src/Unison/Codebase/Editor/Output.hs
View File

@ -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
@ -247,15 +250,21 @@ 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
| -- | @GistCreated repo hash@ means causal @hash@ was just published to @repo@.
GistCreated Int WriteRepo Branch.Hash
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.
InitiateAuthFlow URI
| UnknownCodeServer Text
| 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

5
unison-cli/src/Unison/Codebase/Editor/UCMVersion.hs Normal file
View File

@ -0,0 +1,5 @@
module Unison.Codebase.Editor.UCMVersion where
import Data.Text (Text)
type UCMVersion = Text

201
unison-cli/src/Unison/Codebase/Editor/UriParser.hs
View File

@ -1,6 +1,11 @@
{-# LANGUAGE OverloadedStrings #-}
module Unison.Codebase.Editor.UriParser (repoPath, writeRepo, writeRepoPath) where
module Unison.Codebase.Editor.UriParser
( repoPath,
writeGitRepo,
writeRemotePath,
)
where
import Data.Char (isAlphaNum, isDigit, isSpace)
import Data.Sequence as Seq
@ -8,14 +13,25 @@ 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 Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, ReadRepo (..), WriteRemotePath, WriteRepo (..))
import qualified Text.Megaparsec.Char as P
import Unison.Codebase.Editor.RemoteRepo
( ReadGitRemoteNamespace (..),
ReadGitRepo (..),
ReadRemoteNamespace (..),
ReadShareRemoteNamespace (..),
ShareRepo (..),
WriteGitRemotePath (..),
WriteGitRepo (..),
WriteRemotePath (..),
WriteShareRemotePath (..),
)
import Unison.Codebase.Path (Path (..))
import qualified Unison.Codebase.Path as Path
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
@ -39,30 +55,107 @@ 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)
case nshashPath of
Nothing -> pure (repo, Nothing, Path.empty)
Just (sbh, p) -> pure (repo, sbh, p)
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}
writeRepo :: P WriteRepo
writeRepo = P.label "repo root for writing" $ do
uri <- parseProtocol
treeish <- P.optional treeishSuffix
pure WriteGitRepo {url' = printProtocol uri, branch = treeish}
-- >>> 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
P.string "git("
uri <- parseGitProtocol
treeish <- P.optional gitTreeishSuffix
P.string ")"
pure WriteGitRepo {url = printProtocol uri, branch = treeish}
writeRepoPath :: P WriteRemotePath
writeRepoPath = P.label "generic git repo" $ do
repo <- writeRepo
path <- P.optional (C.char ':' *> absolutePath)
pure (repo, fromMaybe Path.empty path)
-- does this not exist somewhere in megaparsec? yes in 7.0
symbol :: Text -> P Text
symbol = L.symbol (pure ())
-- git(myrepo@git.com).foo.bar
writeGitRemotePath :: P WriteGitRemotePath
writeGitRemotePath = P.label "generic write repo" $ do
repo <- writeGitRepo
path <- P.optional absolutePath
pure WriteGitRemotePath {repo, path = fromMaybe Path.empty path}
data GitProtocol
= HttpsProtocol (Maybe User) HostInfo UrlPath
@ -110,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") (/= '@')
@ -143,7 +236,7 @@ parseProtocol =
P.label "parseHostInfo" $
HostInfo <$> parseHost
<*> ( P.optional $ do
void $ symbol ":"
void $ P.string ":"
P.takeWhile1P (Just "digits") isDigit
)
@ -164,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

28
unison-cli/src/Unison/Codebase/Editor/VersionParser.hs
View File

@ -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,16 +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 =
( 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
)
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
}

6
unison-cli/src/Unison/Codebase/TranscriptParser.hs
View File

@ -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
@ -425,8 +426,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))

24
unison-cli/src/Unison/CommandLine/InputPatterns.hs
View File

@ -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
@ -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
@ -1263,17 +1263,17 @@ 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
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 =
@ -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)
)

6
unison-cli/src/Unison/CommandLine/Main.hs
View File

@ -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
@ -197,8 +198,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 =

208
unison-cli/src/Unison/CommandLine/OutputMessages.hs
View File

@ -1,8 +1,6 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE PartialTypeSignatures #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
module Unison.CommandLine.OutputMessages where
@ -23,7 +21,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,
@ -31,6 +29,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 +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, WriteRepo)
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
@ -117,8 +124,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 Share
import qualified Unison.ShortHash as SH
import qualified Unison.ShortHash as ShortHash
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
@ -267,9 +277,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
)
@ -284,8 +294,8 @@ notifyNumbered o = case o of
P.indentN 2 $
IP.makeExampleNoBackticks
IP.loadPullRequest
[ (prettyRemoteNamespace baseRepo),
(prettyRemoteNamespace headRepo)
[ (prettyReadRemoteNamespace baseRepo),
(prettyReadRemoteNamespace headRepo)
],
"",
p
@ -506,11 +516,13 @@ showListEdits patch ppe =
prettyURI :: URI -> Pretty
prettyURI = P.bold . P.blue . P.shown
prettyRemoteNamespace ::
ReadRemoteNamespace ->
Pretty
prettyRemoteNamespace =
P.group . P.blue . P.text . uncurry3 RemoteRepo.printNamespace
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
@ -582,8 +594,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 <> "."),
@ -609,11 +621,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 ->
@ -624,8 +636,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
@ -634,6 +646,7 @@ notifyUser dir o = case o of
P.indentN 2 $
P.lines ["", cache, "", displayTestResults False ppe oks fails, "", "✅ "]
where
NewlyComputed -> do
clearCurrentLine
pure $
@ -1045,14 +1058,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 +1073,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 +1084,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 +1094,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 +1106,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 +1114,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 +1122,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 +1136,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 (prettyReadRemoteNamespace (RemoteRepo.ReadRemoteNamespaceGit 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 +1165,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?",
"",
@ -1378,12 +1391,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 $
@ -1513,28 +1526,22 @@ 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?"
]
GistCreated hqLength repo hash ->
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
[ "Gist created. Pull via:",
"",
P.indentN 2 (IP.patternName IP.pull <> " " <> prettyRemoteNamespace remoteNamespace)
P.indentN 2 (IP.patternName IP.pull <> " " <> prettyReadRemoteNamespace remoteNamespace)
]
where
remoteNamespace =
(RemoteRepo.writeToRead repo, Just (SBH.fromHash hqLength hash), Path.empty)
InitiateAuthFlow authURI -> do
pure $
P.wrap $
@ -1580,8 +1587,81 @@ notifyUser dir o = case o of
"Host names should NOT include a schema or path."
]
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 = _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) -> 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
( 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)))
]
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 =
P.lines
[ "The remote namespace" <> prettyWriteRemotePath writeRemotePath <> "is empty.",
"",
"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 $
@ -1637,6 +1717,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)] ->
@ -2167,7 +2259,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
@ -2821,10 +2913,14 @@ prettyTypeName ppe r =
prettyHashQualified (PPE.typeName ppe r)
prettyReadRepo :: ReadRepo -> Pretty
prettyReadRepo (RemoteRepo.ReadGitRepo {url}) = P.blue (P.text url)
prettyReadRepo = \case
RemoteRepo.ReadRepoGit RemoteRepo.ReadGitRepo {url} -> P.blue (P.text url)
RemoteRepo.ReadRepoShare s -> P.blue (P.text (RemoteRepo.printShareRepo s))
prettyWriteRepo :: WriteRepo -> Pretty
prettyWriteRepo (RemoteRepo.WriteGitRepo {url'}) = P.blue (P.text url')
prettyWriteRepo = \case
RemoteRepo.WriteRepoGit RemoteRepo.WriteGitRepo {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

20
unison-cli/src/Unison/CommandLine/Welcome.hs
View File

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

64
unison-cli/src/Unison/Share/Sync.hs
View File

@ -65,7 +65,6 @@ import Unison.Prelude
import qualified Unison.Sqlite as Sqlite
import qualified Unison.Sync.API as Share (api)
import qualified Unison.Sync.Types as Share
import qualified Unison.Sync.Types as Share.RepoPath (RepoPath (..))
import Unison.Util.Monoid (foldMapM)
import qualified Unison.Util.Set as Set
@ -75,7 +74,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 +87,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 +102,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 +116,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 +125,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
| FastForwardPushErrorNotFastForward
| FastForwardPushErrorNoWritePermission Share.RepoPath
= FastForwardPushErrorNoHistory Share.Path
| FastForwardPushErrorNoReadPermission Share.Path
| FastForwardPushErrorNotFastForward Share.Path
| FastForwardPushErrorNoWritePermission Share.Path
| FastForwardPushErrorServerMissingDependencies (NESet Share.Hash)
-- | Push a causal to Unison Share.
@ -149,22 +148,22 @@ 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
-- 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 repoPath))
False -> pure (Left (FastForwardPushErrorNoWritePermission path))
True ->
doFastForwardPath (localHeadHash : localTailHashes) <&> \case
Share.FastForwardPathSuccess -> Right ()
@ -172,9 +171,9 @@ 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.FastForwardPathNotFastForward _ -> Left FastForwardPushErrorNotFastForward
Share.FastForwardPathNoHistory -> Left (FastForwardPushErrorNoHistory path)
Share.FastForwardPathNoWritePermission _ -> Left (FastForwardPushErrorNoWritePermission path)
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
@ -185,7 +184,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 +194,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.
@ -319,6 +318,7 @@ dagbfs goal children =
data PullError
= -- | An error occurred while resolving a repo+path to a causal hash.
PullErrorGetCausalHashByPath GetCausalHashByPathError
| PullErrorNoHistoryAtPath Share.Path
pull ::
-- | The HTTP client to use for Unison Share requests.
@ -328,24 +328,24 @@ pull ::
-- | SQLite connection, for writing entities we pull.
Sqlite.Connection ->
-- | The repo+path to pull from.
Share.RepoPath ->
IO (Either PullError (Maybe CausalHash))
Share.Path ->
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 =
downloadEntities httpClient unisonShareUrl conn (Share.RepoPath.repoName repoPath)
downloadEntities httpClient unisonShareUrl conn (Share.pathRepoName repoPath)
------------------------------------------------------------------------------------------------------------------------
-- Get causal hash by path
@ -353,7 +353,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 ::
@ -361,7 +361,7 @@ getCausalHashByPath ::
AuthorizedHttpClient ->
-- | The Unison Share URL.
BaseUrl ->
Share.RepoPath ->
Share.Path ->
IO (Either GetCausalHashByPathError (Maybe Share.HashJWT))
getCausalHashByPath httpClient unisonShareUrl repoPath =
httpGetCausalHashByPath httpClient unisonShareUrl (Share.GetCausalHashByPathRequest repoPath) <&> \case

2
unison-cli/src/Unison/Util/HTTP.hs
View File

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

3
unison-cli/unison-cli.cabal
View File

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

4
unison-cli/unison/Main.hs
View File

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

71
unison-share-api/src/Unison/Sync/Types.hs
View File

@ -4,7 +4,9 @@ module Unison.Sync.Types
( -- * Misc. types
Base64Bytes (..),
RepoName (..),
RepoPath (..),
Path (..),
pathRepoName,
pathCodebasePath,
-- ** Hash types
Hash (..),
@ -65,6 +67,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
@ -88,27 +91,35 @@ 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 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
pathCodebasePath :: Path -> [Text]
pathCodebasePath (Path (_ :| ps)) = ps
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 +545,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 +686,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 +708,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 +719,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 +738,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 +763,7 @@ data UpdatePathResponse
= UpdatePathSuccess
| UpdatePathHashMismatch HashMismatch
| UpdatePathMissingDependencies (NeedDependencies Hash)
| UpdatePathNoWritePermission RepoPath
| UpdatePathNoWritePermission Path
deriving stock (Show, Eq, Ord)
instance ToJSON UpdatePathResponse where
@ -760,7 +771,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 +784,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 {..}