mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 10:35:57 +03:00
remove git push/pull
This commit is contained in:
parent
5732d9a822
commit
1b5c93da11
@ -25,7 +25,6 @@ import UnliftIO.Environment (lookupEnv)
|
||||
data DebugFlag
|
||||
= Auth
|
||||
| Codebase
|
||||
| Git
|
||||
| Integrity
|
||||
| Merge
|
||||
| Migration
|
||||
@ -59,7 +58,6 @@ debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of
|
||||
case Text.toUpper . Text.strip $ w of
|
||||
"AUTH" -> pure Auth
|
||||
"CODEBASE" -> pure Codebase
|
||||
"GIT" -> pure Git
|
||||
"INTEGRITY" -> pure Integrity
|
||||
"MERGE" -> pure Merge
|
||||
"MIGRATION" -> pure Migration
|
||||
@ -77,10 +75,6 @@ debugFlags = case (unsafePerformIO (lookupEnv "UNISON_DEBUG")) of
|
||||
_ -> empty
|
||||
{-# NOINLINE debugFlags #-}
|
||||
|
||||
debugGit :: Bool
|
||||
debugGit = Git `Set.member` debugFlags
|
||||
{-# NOINLINE debugGit #-}
|
||||
|
||||
debugSqlite :: Bool
|
||||
debugSqlite = Sqlite `Set.member` debugFlags
|
||||
{-# NOINLINE debugSqlite #-}
|
||||
@ -146,11 +140,11 @@ debugPatternCoverageConstraintSolver = PatternCoverageConstraintSolver `Set.memb
|
||||
{-# NOINLINE debugPatternCoverageConstraintSolver #-}
|
||||
|
||||
-- | Use for trace-style selective debugging.
|
||||
-- E.g. 1 + (debug Git "The second number" 2)
|
||||
-- E.g. 1 + (debug Sync "The second number" 2)
|
||||
--
|
||||
-- Or, use in pattern matching to view arguments.
|
||||
-- E.g.
|
||||
-- myFunc (debug Git "argA" -> argA) = ...
|
||||
-- myFunc (debug Sync "argA" -> argA) = ...
|
||||
debug :: (Show a) => DebugFlag -> String -> a -> a
|
||||
debug flag msg a =
|
||||
if shouldDebug flag
|
||||
@ -160,7 +154,7 @@ debug flag msg a =
|
||||
-- | Use for selective debug logging in monadic contexts.
|
||||
-- E.g.
|
||||
-- do
|
||||
-- debugM Git "source repo" srcRepo
|
||||
-- debugM Sync "source repo" srcRepo
|
||||
-- ...
|
||||
debugM :: (Show a, Monad m) => DebugFlag -> String -> a -> m ()
|
||||
debugM flag msg a =
|
||||
@ -187,7 +181,6 @@ shouldDebug :: DebugFlag -> Bool
|
||||
shouldDebug = \case
|
||||
Auth -> debugAuth
|
||||
Codebase -> debugCodebase
|
||||
Git -> debugGit
|
||||
Integrity -> debugIntegrity
|
||||
Merge -> debugMerge
|
||||
Migration -> debugMigration
|
||||
|
@ -86,10 +86,6 @@ module Unison.Codebase
|
||||
syncFromDirectory,
|
||||
syncToDirectory,
|
||||
|
||||
-- ** Remote sync
|
||||
viewRemoteBranch,
|
||||
pushGitBranch,
|
||||
|
||||
-- * Codebase path
|
||||
getCodebaseDir,
|
||||
CodebasePath,
|
||||
@ -124,13 +120,11 @@ import Unison.Codebase.Branch (Branch)
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.BuiltinAnnotation (BuiltinAnnotation (builtinAnnotation))
|
||||
import Unison.Codebase.CodeLookup qualified as CL
|
||||
import Unison.Codebase.Editor.Git qualified as Git
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace)
|
||||
import Unison.Codebase.Path
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
|
||||
import Unison.Codebase.SqliteCodebase.Operations qualified as SqliteCodebase.Operations
|
||||
import Unison.Codebase.Type (Codebase (..), GitError)
|
||||
import Unison.Codebase.Type (Codebase (..))
|
||||
import Unison.CodebasePath (CodebasePath, getCodebaseDir)
|
||||
import Unison.ConstructorReference (ConstructorReference, GConstructorReference (..))
|
||||
import Unison.DataDeclaration (Decl)
|
||||
@ -466,20 +460,6 @@ isType c r = case r of
|
||||
Reference.Builtin {} -> pure $ Builtin.isBuiltinType r
|
||||
Reference.DerivedId r -> isJust <$> getTypeDeclaration c r
|
||||
|
||||
-- * Git stuff
|
||||
|
||||
-- | Pull a git branch and view it from the cache, without syncing into the
|
||||
-- local codebase.
|
||||
viewRemoteBranch ::
|
||||
(MonadIO m) =>
|
||||
Codebase m v a ->
|
||||
ReadGitRemoteNamespace ->
|
||||
Git.GitBranchBehavior ->
|
||||
(Branch m -> m r) ->
|
||||
m (Either GitError r)
|
||||
viewRemoteBranch codebase ns gitBranchBehavior action =
|
||||
viewRemoteBranch' codebase ns gitBranchBehavior (\(b, _dir) -> action b)
|
||||
|
||||
unsafeGetComponentLength :: (HasCallStack) => Hash -> Sqlite.Transaction Reference.CycleSize
|
||||
unsafeGetComponentLength h =
|
||||
Operations.getCycleLen h >>= \case
|
||||
|
@ -1,317 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Unison.Codebase.Editor.Git
|
||||
( gitIn,
|
||||
gitTextIn,
|
||||
gitInCaptured,
|
||||
withRepo,
|
||||
withIOError,
|
||||
withStatus,
|
||||
withIsolatedRepo,
|
||||
debugGit,
|
||||
gitDirToPath,
|
||||
gitVerbosity,
|
||||
GitBranchBehavior (..),
|
||||
GitRepo (..),
|
||||
|
||||
-- * Exported for testing
|
||||
gitCacheDir,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Exception qualified
|
||||
import Control.Monad.Except (MonadError, throwError)
|
||||
import Data.ByteString.Base16 qualified as ByteString
|
||||
import Data.Char qualified as Char
|
||||
import Data.Text qualified as Text
|
||||
import Shellmet (($?), ($^), ($|))
|
||||
import System.Exit (ExitCode (ExitSuccess))
|
||||
import System.FilePath ((</>))
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo (..))
|
||||
import Unison.Codebase.GitError (GitProtocolError)
|
||||
import Unison.Codebase.GitError qualified as GitError
|
||||
import Unison.Debug qualified as Debug
|
||||
import Unison.Prelude
|
||||
import UnliftIO qualified
|
||||
import UnliftIO.Directory (XdgDirectory (XdgCache), doesDirectoryExist, findExecutable, getXdgDirectory)
|
||||
import UnliftIO.IO (hFlush, stdout)
|
||||
import UnliftIO.Process qualified as UnliftIO
|
||||
|
||||
debugGit :: Bool
|
||||
debugGit = Debug.shouldDebug Debug.Git
|
||||
|
||||
gitVerbosity :: [Text]
|
||||
gitVerbosity =
|
||||
if debugGit
|
||||
then []
|
||||
else ["--quiet"]
|
||||
|
||||
-- https://superuser.com/questions/358855/what-characters-are-safe-in-cross-platform-file-names-for-linux-windows-and-os
|
||||
encodeFileName :: String -> FilePath
|
||||
encodeFileName s =
|
||||
let go ('.' : rem) = "$dot$" <> go rem
|
||||
go ('$' : rem) = "$$" <> go rem
|
||||
go (c : rem)
|
||||
| elem @[] c "/\\:*?\"<>|" || not (Char.isPrint c && Char.isAscii c) =
|
||||
"$x" <> encodeHex [c] <> "$" <> go rem
|
||||
| otherwise = c : go rem
|
||||
go [] = []
|
||||
encodeHex :: String -> String
|
||||
encodeHex =
|
||||
Text.unpack
|
||||
. Text.toUpper
|
||||
. ByteString.encodeBase16
|
||||
. encodeUtf8
|
||||
. Text.pack
|
||||
in -- 'bare' suffix is to avoid clashes with non-bare repos initialized by earlier versions
|
||||
-- of ucm.
|
||||
go s <> "-bare"
|
||||
|
||||
gitCacheDir :: (MonadIO m) => Text -> m FilePath
|
||||
gitCacheDir url =
|
||||
getXdgDirectory XdgCache $
|
||||
"unisonlanguage"
|
||||
</> "gitfiles"
|
||||
</> encodeFileName (Text.unpack url)
|
||||
|
||||
withStatus :: (MonadIO m) => String -> m a -> m a
|
||||
withStatus str ma = do
|
||||
flushStr str
|
||||
a <- ma
|
||||
flushStr (const ' ' <$> str)
|
||||
pure a
|
||||
where
|
||||
flushStr str = do
|
||||
liftIO . putStr $ " " ++ str ++ "\r"
|
||||
hFlush stdout
|
||||
|
||||
-- | Run an action on an isolated copy of the provided repo.
|
||||
-- The repo is deleted when the action exits or fails.
|
||||
-- A branch or tag to check out from the source repo may be specified.
|
||||
withIsolatedRepo ::
|
||||
forall m r.
|
||||
(MonadUnliftIO m) =>
|
||||
GitRepo ->
|
||||
Text ->
|
||||
Maybe Text ->
|
||||
(GitRepo -> m r) ->
|
||||
m (Either GitProtocolError r)
|
||||
withIsolatedRepo srcPath origin mayGitRef action = do
|
||||
UnliftIO.withSystemTempDirectory "ucm-isolated-repo" $ \tempDir -> do
|
||||
let tempRepo = Worktree tempDir
|
||||
copyCommand tempRepo >>= \case
|
||||
Left gitErr -> pure $ Left (GitError.CopyException (gitDirToPath srcPath) tempDir (show gitErr))
|
||||
Right () -> Right <$> action tempRepo
|
||||
where
|
||||
copyCommand :: GitRepo -> m (Either IOException ())
|
||||
copyCommand dest = UnliftIO.tryIO . liftIO $ do
|
||||
gitGlobal
|
||||
( ["clone", "--origin", "git-cache"]
|
||||
-- tags work okay here too.
|
||||
++ maybe [] (\t -> ["--branch", t]) mayGitRef
|
||||
++ [Text.pack . gitDirToPath $ srcPath, Text.pack . gitDirToPath $ dest]
|
||||
)
|
||||
-- If a specific ref wasn't requested, ensure we have all branches and tags from the source.
|
||||
-- This is fast since it's a local fetch.
|
||||
when (isNothing mayGitRef) $ do
|
||||
-- If the source repo is empty, we can't fetch, but there won't be anything to
|
||||
-- fetch anyways.
|
||||
unlessM (isEmptyGitRepo srcPath) $ do
|
||||
gitIn dest $ ["fetch", "--tags", Text.pack . gitDirToPath $ srcPath] ++ gitVerbosity
|
||||
gitIn dest $ ["remote", "add", "origin", origin]
|
||||
|
||||
-- | Define what to do if the repo we're pulling/pushing doesn't have the specified branch.
|
||||
data GitBranchBehavior
|
||||
= -- If the desired branch doesn't exist in the repo,
|
||||
-- create a new branch by the provided name with a fresh codebase
|
||||
CreateBranchIfMissing
|
||||
| -- Fail with an error if the branch doesn't exist.
|
||||
RequireExistingBranch
|
||||
|
||||
-- | Clone or fetch an updated copy of the provided repository and check out the expected ref,
|
||||
-- then provide the action with a path to the codebase in that repository.
|
||||
-- Note that the repository provided to the action is temporary, it will be removed when the
|
||||
-- action completes or fails.
|
||||
withRepo ::
|
||||
forall m a.
|
||||
(MonadUnliftIO m) =>
|
||||
ReadGitRepo ->
|
||||
GitBranchBehavior ->
|
||||
(GitRepo -> m a) ->
|
||||
m (Either GitProtocolError a)
|
||||
withRepo repo@(ReadGitRepo {url = uri, ref = mayGitRef}) branchBehavior action = UnliftIO.try $ do
|
||||
throwExceptT $ checkForGit
|
||||
gitCachePath <- gitCacheDir uri
|
||||
-- Ensure we have the main branch in the cache dir no matter what
|
||||
_ :: GitRepo <- throwExceptT $ cloneIfMissing repo {ref = Nothing} gitCachePath
|
||||
let gitCacheRepo = Bare gitCachePath
|
||||
gitRef <- case mayGitRef of
|
||||
Nothing -> fromMaybe "main" <$> getDefaultBranch gitCacheRepo
|
||||
Just gitRef -> pure gitRef
|
||||
doesRemoteRefExist <- fetchAndUpdateRef gitCacheRepo gitRef
|
||||
if doesRemoteRefExist
|
||||
then do
|
||||
-- A ref by the requested name exists on the remote.
|
||||
withStatus ("Checking out " ++ Text.unpack gitRef ++ " ...") $ do
|
||||
-- Check out the ref in a new isolated repo
|
||||
throwEitherM . withIsolatedRepo gitCacheRepo uri (Just gitRef) $ action
|
||||
else do
|
||||
-- No ref by the given name exists on the remote
|
||||
case branchBehavior of
|
||||
RequireExistingBranch -> UnliftIO.throwIO (GitError.RemoteRefNotFound uri gitRef)
|
||||
CreateBranchIfMissing ->
|
||||
withStatus ("Creating new branch " ++ Text.unpack gitRef ++ " ...")
|
||||
. throwEitherM
|
||||
. withIsolatedRepo gitCacheRepo uri Nothing
|
||||
$ \(workTree) -> do
|
||||
-- It's possible for the branch to exist in the cache even if it's not in the
|
||||
-- remote, if for instance the branch was deleted from the remote.
|
||||
-- In that case we delete the branch from the cache and create a new one.
|
||||
localRefExists <- doesLocalRefExist gitCacheRepo gitRef
|
||||
when localRefExists $ do
|
||||
currentBranch <- gitTextIn workTree ["branch", "--show-current"]
|
||||
-- In the rare case where we've got the branch already checked out,
|
||||
-- we need to temporarily switch to a different branch so we can delete and
|
||||
-- reset the branch to an orphan.
|
||||
when (currentBranch == gitRef) $ gitIn workTree $ ["branch", "-B", "_unison_temp_branch"] ++ gitVerbosity
|
||||
gitIn workTree $ ["branch", "-D", gitRef] ++ gitVerbosity
|
||||
gitIn workTree $ ["checkout", "--orphan", gitRef] ++ gitVerbosity
|
||||
-- Checking out an orphan branch doesn't actually clear the worktree, do that manually.
|
||||
_ <- gitInCaptured workTree $ ["rm", "--ignore-unmatch", "-rf", "."] ++ gitVerbosity
|
||||
action workTree
|
||||
where
|
||||
-- Check if a ref exists in the repository at workDir.
|
||||
doesLocalRefExist :: GitRepo -> Text -> m Bool
|
||||
doesLocalRefExist workDir ref = liftIO $ do
|
||||
(gitIn workDir (["show-ref", "--verify", ref] ++ gitVerbosity) $> True)
|
||||
$? pure False
|
||||
-- fetch the given ref and update the local repositories ref to match the remote.
|
||||
-- returns whether or not the ref existed on the remote.
|
||||
fetchAndUpdateRef :: GitRepo -> Text -> m Bool
|
||||
fetchAndUpdateRef workDir gitRef = do
|
||||
(succeeded, _, _) <-
|
||||
gitInCaptured
|
||||
workDir
|
||||
( [ "fetch",
|
||||
"--tags", -- if the gitref is a tag, fetch and update that too.
|
||||
"--force", -- force updating local refs even if not fast-forward
|
||||
-- update local refs with the same name they have on the remote.
|
||||
"--refmap",
|
||||
"*:*",
|
||||
"--depth",
|
||||
"1",
|
||||
uri, -- The repo to fetch from
|
||||
gitRef -- The specific reference to fetch
|
||||
]
|
||||
++ gitVerbosity
|
||||
)
|
||||
pure succeeded
|
||||
|
||||
-- | Do a `git clone` (for a not-previously-cached repo).
|
||||
cloneIfMissing :: (MonadIO m, MonadError GitProtocolError m) => ReadGitRepo -> FilePath -> m GitRepo
|
||||
cloneIfMissing repo@(ReadGitRepo {url = uri}) localPath = do
|
||||
doesDirectoryExist localPath >>= \case
|
||||
True ->
|
||||
whenM (not <$> isGitRepo (Bare localPath)) $ do
|
||||
throwError (GitError.UnrecognizableCacheDir repo localPath)
|
||||
False -> do
|
||||
-- directory doesn't exist, so clone anew
|
||||
cloneRepo
|
||||
pure $ Bare localPath
|
||||
where
|
||||
cloneRepo = do
|
||||
withStatus ("Downloading from " ++ Text.unpack uri ++ " ...") $
|
||||
( liftIO $
|
||||
gitGlobal
|
||||
( ["clone"]
|
||||
++ ["--bare"]
|
||||
++ ["--depth", "1"]
|
||||
++ [uri, Text.pack localPath]
|
||||
)
|
||||
)
|
||||
`withIOError` (throwError . GitError.CloneException repo . show)
|
||||
isGitDir <- liftIO $ isGitRepo (Bare localPath)
|
||||
unless isGitDir . throwError $ GitError.UnrecognizableCheckoutDir repo localPath
|
||||
|
||||
-- | See if `git` is on the system path.
|
||||
checkForGit :: (MonadIO m) => (MonadError GitProtocolError m) => m ()
|
||||
checkForGit = do
|
||||
gitPath <- liftIO $ findExecutable "git"
|
||||
when (isNothing gitPath) $ throwError GitError.NoGit
|
||||
|
||||
-- | Returns the name of the default branch of a repository, if one exists.
|
||||
getDefaultBranch :: (MonadIO m) => GitRepo -> m (Maybe Text)
|
||||
getDefaultBranch dir = liftIO $ do
|
||||
(Text.stripPrefix "refs/heads/" <$> gitTextIn dir ["symbolic-ref", "HEAD"])
|
||||
$? pure Nothing
|
||||
|
||||
-- | Does `git` recognize this directory as being managed by git?
|
||||
isGitRepo :: (MonadIO m) => GitRepo -> m Bool
|
||||
isGitRepo dir =
|
||||
liftIO $
|
||||
(True <$ gitIn dir (["rev-parse"] ++ gitVerbosity)) $? pure False
|
||||
|
||||
-- | Returns True if the repo is empty, i.e. has no commits at the current branch,
|
||||
-- or if the dir isn't a git repo at all.
|
||||
isEmptyGitRepo :: (MonadIO m) => GitRepo -> m Bool
|
||||
isEmptyGitRepo dir = liftIO do
|
||||
(gitTextIn dir (["rev-parse", "HEAD"] ++ gitVerbosity) $> False) $? pure True
|
||||
|
||||
-- | Perform an IO action, passing any IO exception to `handler`
|
||||
withIOError :: (MonadIO m) => IO a -> (IOException -> m a) -> m a
|
||||
withIOError action handler =
|
||||
liftIO (fmap Right action `Control.Exception.catch` (pure . Left))
|
||||
>>= either handler pure
|
||||
|
||||
-- | A path to a git repository.
|
||||
data GitRepo
|
||||
= Bare FilePath
|
||||
| Worktree FilePath
|
||||
deriving (Show)
|
||||
|
||||
gitDirToPath :: GitRepo -> FilePath
|
||||
gitDirToPath = \case
|
||||
Bare fp -> fp
|
||||
Worktree fp -> fp
|
||||
|
||||
-- | Generate some `git` flags for operating on some arbitary checked out copy
|
||||
setupGitDir :: GitRepo -> [Text]
|
||||
setupGitDir dir =
|
||||
case dir of
|
||||
Bare localPath ->
|
||||
["--git-dir", Text.pack localPath]
|
||||
Worktree localPath ->
|
||||
[ "--git-dir",
|
||||
Text.pack (localPath </> ".git"),
|
||||
"--work-tree",
|
||||
Text.pack localPath
|
||||
]
|
||||
|
||||
-- | Run a git command in the current work directory.
|
||||
-- Note: this should only be used for commands like 'clone' which don't interact with an
|
||||
-- existing repository.
|
||||
gitGlobal :: (MonadIO m) => [Text] -> m ()
|
||||
gitGlobal args = do
|
||||
when debugGit $ traceM (Text.unpack . Text.unwords $ ["$ git"] <> args)
|
||||
liftIO $ "git" $^ (args ++ gitVerbosity)
|
||||
|
||||
-- | Run a git command in the repository at localPath
|
||||
gitIn :: (MonadIO m) => GitRepo -> [Text] -> m ()
|
||||
gitIn localPath args = do
|
||||
when debugGit $ traceM (Text.unpack . Text.unwords $ ["$ git"] <> setupGitDir localPath <> args)
|
||||
liftIO $ "git" $^ (setupGitDir localPath <> args)
|
||||
|
||||
-- | like 'gitIn', but silences all output from the command and returns whether the command
|
||||
-- succeeded.
|
||||
gitInCaptured :: (MonadIO m) => GitRepo -> [Text] -> m (Bool, Text, Text)
|
||||
gitInCaptured localPath args = do
|
||||
when debugGit $ traceM (Text.unpack . Text.unwords $ ["$ git"] <> setupGitDir localPath <> args)
|
||||
(exitCode, stdout, stderr) <- UnliftIO.readProcessWithExitCode "git" (Text.unpack <$> setupGitDir localPath <> args) ""
|
||||
pure (exitCode == ExitSuccess, Text.pack stdout, Text.pack stderr)
|
||||
|
||||
-- | Run a git command in the repository at localPath and capture stdout
|
||||
gitTextIn :: (MonadIO m) => GitRepo -> [Text] -> m Text
|
||||
gitTextIn localPath args = do
|
||||
when debugGit $ traceM (Text.unpack . Text.unwords $ ["$ git"] <> setupGitDir localPath <> args)
|
||||
liftIO $ "git" $| setupGitDir localPath <> args
|
@ -2,22 +2,13 @@ module Unison.Codebase.Editor.RemoteRepo where
|
||||
|
||||
import Control.Lens (Lens')
|
||||
import Control.Lens qualified as Lens
|
||||
import Data.Text qualified as Text
|
||||
import Data.Void (absurd)
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectAndBranch (..), ProjectBranchName, ProjectName)
|
||||
import Unison.Share.Types
|
||||
import Unison.Util.Monoid qualified as Monoid
|
||||
|
||||
data ReadRepo
|
||||
= ReadRepoGit ReadGitRepo
|
||||
| ReadRepoShare ShareCodeserver
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
data ShareCodeserver
|
||||
= DefaultCodeserver
|
||||
@ -44,58 +35,21 @@ displayShareCodeserver cs shareUser path =
|
||||
CustomCodeserver cu -> "share(" <> tShow cu <> ")."
|
||||
in shareServer <> shareUserHandleToText shareUser <> maybePrintPath path
|
||||
|
||||
data ReadGitRepo = ReadGitRepo {url :: Text, ref :: Maybe Text}
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
data WriteRepo
|
||||
= WriteRepoGit WriteGitRepo
|
||||
| WriteRepoShare ShareCodeserver
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
data WriteGitRepo = WriteGitRepo {url :: Text, branch :: Maybe Text}
|
||||
deriving stock (Eq, Ord, Show)
|
||||
|
||||
writeToRead :: WriteRepo -> ReadRepo
|
||||
writeToRead = \case
|
||||
WriteRepoGit repo -> ReadRepoGit (writeToReadGit repo)
|
||||
WriteRepoShare repo -> ReadRepoShare repo
|
||||
|
||||
writeToReadGit :: WriteGitRepo -> ReadGitRepo
|
||||
writeToReadGit = \case
|
||||
WriteGitRepo {url, branch} -> ReadGitRepo {url = url, ref = branch}
|
||||
|
||||
writeNamespaceToRead :: WriteRemoteNamespace Void -> ReadRemoteNamespace void
|
||||
writeNamespaceToRead = \case
|
||||
WriteRemoteNamespaceGit WriteGitRemoteNamespace {repo, path} ->
|
||||
ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo = writeToReadGit repo, sch = Nothing, path}
|
||||
WriteRemoteNamespaceShare WriteShareRemoteNamespace {server, repo, path} ->
|
||||
ReadShare'LooseCode ReadShareLooseCode {server, repo, path}
|
||||
WriteRemoteProjectBranch v -> absurd v
|
||||
|
||||
printReadGitRepo :: ReadGitRepo -> Text
|
||||
printReadGitRepo ReadGitRepo {url, ref} =
|
||||
"git(" <> url <> Monoid.fromMaybe (Text.cons ':' <$> ref) <> ")"
|
||||
|
||||
printWriteGitRepo :: WriteGitRepo -> Text
|
||||
printWriteGitRepo WriteGitRepo {url, branch} = "git(" <> url <> Monoid.fromMaybe (Text.cons ':' <$> branch) <> ")"
|
||||
|
||||
-- | print remote namespace
|
||||
printReadRemoteNamespace :: (a -> Text) -> ReadRemoteNamespace a -> Text
|
||||
printReadRemoteNamespace printProject = \case
|
||||
ReadRemoteNamespaceGit ReadGitRemoteNamespace {repo, sch, path} ->
|
||||
printReadGitRepo repo <> maybePrintSCH sch <> maybePrintPath path
|
||||
where
|
||||
maybePrintSCH = \case
|
||||
Nothing -> mempty
|
||||
Just sch -> "#" <> SCH.toText sch
|
||||
ReadShare'LooseCode ReadShareLooseCode {server, repo, path} -> displayShareCodeserver server repo path
|
||||
ReadShare'ProjectBranch project -> printProject project
|
||||
|
||||
-- | Render a 'WriteRemoteNamespace' as text.
|
||||
printWriteRemoteNamespace :: WriteRemoteNamespace (ProjectAndBranch ProjectName ProjectBranchName) -> Text
|
||||
printWriteRemoteNamespace = \case
|
||||
WriteRemoteNamespaceGit (WriteGitRemoteNamespace {repo, path}) ->
|
||||
printWriteGitRepo repo <> maybePrintPath path
|
||||
WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server, repo, path}) ->
|
||||
displayShareCodeserver server repo path
|
||||
WriteRemoteProjectBranch projectAndBranch -> into @Text projectAndBranch
|
||||
@ -107,20 +61,12 @@ maybePrintPath path =
|
||||
else "." <> Path.toText path
|
||||
|
||||
data ReadRemoteNamespace a
|
||||
= ReadRemoteNamespaceGit !ReadGitRemoteNamespace
|
||||
| ReadShare'LooseCode !ReadShareLooseCode
|
||||
= ReadShare'LooseCode !ReadShareLooseCode
|
||||
| -- | A remote project+branch, specified by name (e.g. @unison/base/main).
|
||||
-- Currently assumed to be hosted on Share, though we could include a ShareCodeserver in here, too.
|
||||
ReadShare'ProjectBranch !a
|
||||
deriving stock (Eq, Functor, Show, Generic)
|
||||
|
||||
data ReadGitRemoteNamespace = ReadGitRemoteNamespace
|
||||
{ repo :: !ReadGitRepo,
|
||||
sch :: !(Maybe ShortCausalHash),
|
||||
path :: !Path
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
data ReadShareLooseCode = ReadShareLooseCode
|
||||
{ server :: !ShareCodeserver,
|
||||
repo :: !ShareUserHandle,
|
||||
@ -136,8 +82,7 @@ isPublic ReadShareLooseCode {path} =
|
||||
_ -> False
|
||||
|
||||
data WriteRemoteNamespace a
|
||||
= WriteRemoteNamespaceGit !WriteGitRemoteNamespace
|
||||
| WriteRemoteNamespaceShare !WriteShareRemoteNamespace
|
||||
= WriteRemoteNamespaceShare !WriteShareRemoteNamespace
|
||||
| WriteRemoteProjectBranch a
|
||||
deriving stock (Eq, Functor, Show)
|
||||
|
||||
@ -146,23 +91,14 @@ remotePath_ :: Lens' (WriteRemoteNamespace Void) Path
|
||||
remotePath_ = Lens.lens getter setter
|
||||
where
|
||||
getter = \case
|
||||
WriteRemoteNamespaceGit (WriteGitRemoteNamespace _ path) -> path
|
||||
WriteRemoteNamespaceShare (WriteShareRemoteNamespace _ _ path) -> path
|
||||
WriteRemoteProjectBranch v -> absurd v
|
||||
setter remote path =
|
||||
case remote of
|
||||
WriteRemoteNamespaceGit (WriteGitRemoteNamespace repo _) ->
|
||||
WriteRemoteNamespaceGit $ WriteGitRemoteNamespace repo path
|
||||
WriteRemoteNamespaceShare (WriteShareRemoteNamespace server repo _) ->
|
||||
WriteRemoteNamespaceShare $ WriteShareRemoteNamespace server repo path
|
||||
WriteRemoteProjectBranch v -> absurd v
|
||||
|
||||
data WriteGitRemoteNamespace = WriteGitRemoteNamespace
|
||||
{ repo :: !WriteGitRepo,
|
||||
path :: !Path
|
||||
}
|
||||
deriving stock (Eq, Generic, Show)
|
||||
|
||||
data WriteShareRemoteNamespace = WriteShareRemoteNamespace
|
||||
{ server :: !ShareCodeserver,
|
||||
repo :: !ShareUserHandle,
|
||||
|
@ -1,37 +0,0 @@
|
||||
module Unison.Codebase.GitError
|
||||
( CodebasePath,
|
||||
GitProtocolError (..),
|
||||
GitCodebaseError (..),
|
||||
)
|
||||
where
|
||||
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo, WriteGitRepo)
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import Unison.Prelude
|
||||
|
||||
type CodebasePath = FilePath
|
||||
|
||||
data GitProtocolError
|
||||
= NoGit
|
||||
| UnrecognizableCacheDir ReadGitRepo CodebasePath
|
||||
| UnrecognizableCheckoutDir ReadGitRepo CodebasePath
|
||||
| -- srcPath destPath error-description
|
||||
CopyException FilePath FilePath String
|
||||
| CloneException ReadGitRepo String
|
||||
| PushException WriteGitRepo String
|
||||
| PushNoOp WriteGitRepo
|
||||
| -- url commit Diff of what would change on merge with remote
|
||||
PushDestinationHasNewStuff WriteGitRepo
|
||||
| CleanupError SomeException
|
||||
| -- Thrown when a commit, tag, or branch isn't found in a repo.
|
||||
-- repo ref
|
||||
RemoteRefNotFound Text Text
|
||||
deriving stock (Show)
|
||||
deriving anyclass (Exception)
|
||||
|
||||
data GitCodebaseError h
|
||||
= NoRemoteNamespaceWithHash ReadGitRepo ShortCausalHash
|
||||
| RemoteNamespaceHashAmbiguous ReadGitRepo ShortCausalHash (Set h)
|
||||
| CouldntFindRemoteBranch ReadGitRepo Path
|
||||
deriving (Show)
|
@ -14,17 +14,13 @@ where
|
||||
|
||||
import Control.Monad.Except qualified as Except
|
||||
import Control.Monad.Extra qualified as Monad
|
||||
import Data.Char qualified as Char
|
||||
import Data.Either.Extra ()
|
||||
import Data.IORef
|
||||
import Data.Map qualified as Map
|
||||
import Data.Set qualified as Set
|
||||
import Data.Text qualified as Text
|
||||
import Data.Time (getCurrentTime)
|
||||
import System.Console.ANSI qualified as ANSI
|
||||
import System.FileLock (SharedExclusive (Exclusive), withTryFileLock)
|
||||
import System.FilePath qualified as FilePath
|
||||
import System.FilePath.Posix qualified as FilePath.Posix
|
||||
import U.Codebase.HashTags (CausalHash, PatchHash (..))
|
||||
import U.Codebase.Reflog qualified as Reflog
|
||||
import U.Codebase.Sqlite.Operations qualified as Ops
|
||||
@ -36,15 +32,6 @@ import Unison.Codebase (Codebase, CodebasePath)
|
||||
import Unison.Codebase qualified as Codebase1
|
||||
import Unison.Codebase.Branch (Branch (..))
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Editor.Git (gitIn, gitInCaptured, gitTextIn, withRepo)
|
||||
import Unison.Codebase.Editor.Git qualified as Git
|
||||
import Unison.Codebase.Editor.RemoteRepo
|
||||
( ReadGitRemoteNamespace (..),
|
||||
ReadGitRepo,
|
||||
WriteGitRepo (..),
|
||||
writeToReadGit,
|
||||
)
|
||||
import Unison.Codebase.GitError qualified as GitError
|
||||
import Unison.Codebase.Init (BackupStrategy (..), CodebaseLockOption (..), MigrationStrategy (..), VacuumStrategy (..))
|
||||
import Unison.Codebase.Init qualified as Codebase
|
||||
import Unison.Codebase.Init.CreateCodebaseError qualified as Codebase1
|
||||
@ -54,12 +41,11 @@ import Unison.Codebase.RootBranchCache
|
||||
import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache)
|
||||
import Unison.Codebase.SqliteCodebase.Branch.Dependencies qualified as BD
|
||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
|
||||
import Unison.Codebase.SqliteCodebase.GitError qualified as GitError
|
||||
import Unison.Codebase.SqliteCodebase.Migrations qualified as Migrations
|
||||
import Unison.Codebase.SqliteCodebase.Operations qualified as CodebaseOps
|
||||
import Unison.Codebase.SqliteCodebase.Paths
|
||||
import Unison.Codebase.SqliteCodebase.SyncEphemeral qualified as SyncEphemeral
|
||||
import Unison.Codebase.Type (GitPushBehavior, LocalOrRemote (..))
|
||||
import Unison.Codebase.Type (LocalOrRemote (..))
|
||||
import Unison.Codebase.Type qualified as C
|
||||
import Unison.DataDeclaration (Decl)
|
||||
import Unison.Hash (Hash)
|
||||
@ -75,9 +61,8 @@ import Unison.Term (Term)
|
||||
import Unison.Type (Type)
|
||||
import Unison.Util.Timing (time)
|
||||
import Unison.WatchKind qualified as UF
|
||||
import UnliftIO (UnliftIO (..), finally, throwIO, try)
|
||||
import UnliftIO (UnliftIO (..), finally)
|
||||
import UnliftIO.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist)
|
||||
import UnliftIO.Exception (catch)
|
||||
import UnliftIO.STM
|
||||
|
||||
debug, debugProcessBranches :: Bool
|
||||
@ -103,30 +88,6 @@ initWithSetup onCreate =
|
||||
codebasePath = makeCodebaseDirPath
|
||||
}
|
||||
|
||||
data CodebaseStatus
|
||||
= ExistingCodebase
|
||||
| CreatedCodebase
|
||||
deriving (Eq)
|
||||
|
||||
-- | Open the codebase at the given location, or create it if one doesn't already exist.
|
||||
withOpenOrCreateCodebase ::
|
||||
(MonadUnliftIO m) =>
|
||||
Sqlite.Transaction () ->
|
||||
Codebase.DebugName ->
|
||||
CodebasePath ->
|
||||
LocalOrRemote ->
|
||||
CodebaseLockOption ->
|
||||
MigrationStrategy ->
|
||||
((CodebaseStatus, Codebase m Symbol Ann) -> m r) ->
|
||||
m (Either Codebase1.OpenCodebaseError r)
|
||||
withOpenOrCreateCodebase onCreate debugName codebasePath localOrRemote lockOption migrationStrategy action = do
|
||||
createCodebaseOrError onCreate debugName codebasePath lockOption (action' CreatedCodebase) >>= \case
|
||||
Left (Codebase1.CreateCodebaseAlreadyExists) -> do
|
||||
sqliteCodebase debugName codebasePath localOrRemote lockOption migrationStrategy (action' ExistingCodebase)
|
||||
Right r -> pure (Right r)
|
||||
where
|
||||
action' openOrCreate codebase = action (openOrCreate, codebase)
|
||||
|
||||
-- | Create a codebase at the given location.
|
||||
createCodebaseOrError ::
|
||||
(MonadUnliftIO m) =>
|
||||
@ -379,8 +340,6 @@ sqliteCodebase debugName root localOrRemote lockOption migrationStrategy action
|
||||
putBranch,
|
||||
syncFromDirectory,
|
||||
syncToDirectory,
|
||||
viewRemoteBranch',
|
||||
pushGitBranch = \repo opts action -> withConn \conn -> pushGitBranch conn repo opts action,
|
||||
getWatch,
|
||||
termsOfTypeImpl,
|
||||
termsMentioningTypeImpl,
|
||||
@ -571,214 +530,6 @@ 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) =>
|
||||
ReadGitRemoteNamespace ->
|
||||
Git.GitBranchBehavior ->
|
||||
((Branch m, CodebasePath) -> m r) ->
|
||||
m (Either C.GitError r)
|
||||
viewRemoteBranch' ReadGitRemoteNamespace {repo, sch, path} gitBranchBehavior action = UnliftIO.try $ do
|
||||
-- set up the cache dir
|
||||
time "Git fetch" $
|
||||
throwEitherMWith C.GitProtocolError . withRepo repo gitBranchBehavior $ \remoteRepo -> do
|
||||
let remotePath = Git.gitDirToPath remoteRepo
|
||||
-- In modern UCM all new codebases are created in WAL mode, but it's possible old
|
||||
-- codebases were pushed to git in DELETE mode, so when pulling remote branches we
|
||||
-- ensure we're in WAL mode just to be safe.
|
||||
ensureWALMode conn = Sqlite.trySetJournalMode conn Sqlite.JournalMode'WAL
|
||||
-- Tickle the database before calling into `sqliteCodebase`; this covers the case that the database file either
|
||||
-- doesn't exist at all or isn't a SQLite database file, but does not cover the case that the database file itself
|
||||
-- is somehow corrupt, or not even a Unison database.
|
||||
--
|
||||
-- FIXME it would probably make more sense to define some proper preconditions on `sqliteCodebase`, and perhaps
|
||||
-- update its output type, which currently indicates the only way it can fail is with an `UnknownSchemaVersion`
|
||||
-- error.
|
||||
(withConnection "codebase exists check" remotePath ensureWALMode) `catch` \exception ->
|
||||
if Sqlite.isCantOpenException exception
|
||||
then throwIO (C.GitSqliteCodebaseError (GitError.NoDatabaseFile repo remotePath))
|
||||
else throwIO exception
|
||||
|
||||
result <- sqliteCodebase "viewRemoteBranch.gitCache" remotePath Remote DoLock (MigrateAfterPrompt Codebase.Backup Codebase.Vacuum) \codebase -> do
|
||||
-- try to load the requested branch from it
|
||||
branch <- time "Git fetch (sch)" $ case sch of
|
||||
-- no sub-branch was specified, so use the root.
|
||||
Nothing -> time "Get remote root branch" $ Codebase1.getRootBranch codebase
|
||||
-- load from a specific `ShortCausalHash`
|
||||
Just sch -> do
|
||||
branchCompletions <- Codebase1.runTransaction codebase (Codebase1.causalHashesByPrefix sch)
|
||||
case toList branchCompletions of
|
||||
[] -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sch
|
||||
[h] ->
|
||||
(Codebase1.getBranchForHash codebase h) >>= \case
|
||||
Just b -> pure b
|
||||
Nothing -> throwIO . C.GitCodebaseError $ GitError.NoRemoteNamespaceWithHash repo sch
|
||||
_ -> throwIO . C.GitCodebaseError $ GitError.RemoteNamespaceHashAmbiguous repo sch branchCompletions
|
||||
case Branch.getAt path branch of
|
||||
Just b -> action (b, remotePath)
|
||||
Nothing -> throwIO . C.GitCodebaseError $ GitError.CouldntFindRemoteBranch repo path
|
||||
case result of
|
||||
Left err -> throwIO . C.GitSqliteCodebaseError $ C.gitErrorFromOpenCodebaseError remotePath repo err
|
||||
Right inner -> pure inner
|
||||
|
||||
-- | Push a branch to a repo. Optionally attempt to set the branch as the new root, which fails if the branch is not after
|
||||
-- the existing root.
|
||||
pushGitBranch ::
|
||||
forall m e.
|
||||
(MonadUnliftIO m) =>
|
||||
Sqlite.Connection ->
|
||||
WriteGitRepo ->
|
||||
GitPushBehavior ->
|
||||
-- An action which accepts the current root branch on the remote and computes a new branch.
|
||||
(Branch m -> m (Either e (Branch m))) ->
|
||||
m (Either C.GitError (Either e (Branch m)))
|
||||
pushGitBranch srcConn repo behavior action = UnliftIO.try do
|
||||
-- Pull the latest remote into our git cache
|
||||
-- Use a local git clone to copy this git repo into a temp-dir
|
||||
-- Delete the codebase in our temp-dir
|
||||
-- Use sqlite's VACUUM INTO command to make a copy of the remote codebase into our temp-dir
|
||||
-- Connect to the copied codebase and sync whatever it is we want to push.
|
||||
-- sync the branch to the staging codebase using `syncInternal`, which probably needs to be passed in instead of `syncToDirectory`
|
||||
-- if setting the remote root,
|
||||
-- do a `before` check on the staging codebase
|
||||
-- if it passes, proceed (see below)
|
||||
-- if it fails, throw an exception (which will rollback) and clean up.
|
||||
-- push from the temp-dir to the remote.
|
||||
-- Delete the temp-dir.
|
||||
--
|
||||
-- set up the cache dir
|
||||
throwEitherMWith C.GitProtocolError . withRepo readRepo Git.CreateBranchIfMissing $ \pushStaging -> do
|
||||
newBranchOrErr <- throwEitherMWith (C.GitSqliteCodebaseError . C.gitErrorFromOpenCodebaseError (Git.gitDirToPath pushStaging) readRepo)
|
||||
. withOpenOrCreateCodebase (pure ()) "push.dest" (Git.gitDirToPath pushStaging) Remote DoLock (MigrateAfterPrompt Codebase.Backup Codebase.Vacuum)
|
||||
$ \(codebaseStatus, destCodebase) -> do
|
||||
currentRootBranch <-
|
||||
Codebase1.runTransaction destCodebase CodebaseOps.getRootBranchExists >>= \case
|
||||
False -> pure Branch.empty
|
||||
True -> C.getRootBranch destCodebase
|
||||
action currentRootBranch >>= \case
|
||||
Left e -> pure $ Left e
|
||||
Right newBranch -> do
|
||||
C.withConnection destCodebase \destConn ->
|
||||
doSync codebaseStatus destConn newBranch
|
||||
pure (Right newBranch)
|
||||
for_ newBranchOrErr $ push pushStaging repo
|
||||
pure newBranchOrErr
|
||||
where
|
||||
readRepo :: ReadGitRepo
|
||||
readRepo = writeToReadGit repo
|
||||
doSync :: CodebaseStatus -> Sqlite.Connection -> Branch m -> m ()
|
||||
doSync codebaseStatus destConn newBranch = do
|
||||
progressStateRef <- liftIO (newIORef emptySyncProgressState)
|
||||
Sqlite.runReadOnlyTransaction srcConn \runSrc -> do
|
||||
Sqlite.runWriteTransaction destConn \runDest -> do
|
||||
_ <- syncInternal (syncProgress progressStateRef) runSrc runDest newBranch
|
||||
let overwriteRoot forcePush = do
|
||||
let newBranchHash = Branch.headHash newBranch
|
||||
case codebaseStatus of
|
||||
ExistingCodebase -> do
|
||||
when (not forcePush) do
|
||||
-- the call to runDB "handles" the possible DB error by bombing
|
||||
runDest Ops.loadRootCausalHash >>= \case
|
||||
Nothing -> pure ()
|
||||
Just oldRootHash -> do
|
||||
runDest (CodebaseOps.before oldRootHash newBranchHash) >>= \case
|
||||
False -> throwIO . C.GitProtocolError $ GitError.PushDestinationHasNewStuff repo
|
||||
True -> pure ()
|
||||
CreatedCodebase -> pure ()
|
||||
runDest (setRepoRoot newBranchHash)
|
||||
case behavior of
|
||||
C.GitPushBehaviorGist -> pure ()
|
||||
C.GitPushBehaviorFf -> overwriteRoot False
|
||||
C.GitPushBehaviorForce -> overwriteRoot True
|
||||
setRepoRoot :: CausalHash -> Sqlite.Transaction ()
|
||||
setRepoRoot h = do
|
||||
let err = error $ "Called SqliteCodebase.setNamespaceRoot on unknown causal hash " ++ show h
|
||||
chId <- fromMaybe err <$> Q.loadCausalHashIdByCausalHash h
|
||||
Q.setNamespaceRoot chId
|
||||
|
||||
-- This function makes sure that the result of git status is valid.
|
||||
-- Valid lines are any of:
|
||||
--
|
||||
-- ?? .unison/v2/unison.sqlite3 (initial commit to an empty repo)
|
||||
-- M .unison/v2/unison.sqlite3 (updating an existing repo)
|
||||
-- D .unison/v2/unison.sqlite3-wal (cleaning up the WAL from before bugfix)
|
||||
-- D .unison/v2/unison.sqlite3-shm (ditto)
|
||||
--
|
||||
-- Invalid lines are like:
|
||||
--
|
||||
-- ?? .unison/v2/unison.sqlite3-wal
|
||||
--
|
||||
-- Which will only happen if the write-ahead log hasn't been
|
||||
-- fully folded into the unison.sqlite3 file.
|
||||
--
|
||||
-- Returns `Just (hasDeleteWal, hasDeleteShm)` on success,
|
||||
-- `Nothing` otherwise. hasDeleteWal means there's the line:
|
||||
-- D .unison/v2/unison.sqlite3-wal
|
||||
-- and hasDeleteShm is `True` if there's the line:
|
||||
-- D .unison/v2/unison.sqlite3-shm
|
||||
--
|
||||
parseStatus :: Text -> Maybe (Bool, Bool)
|
||||
parseStatus status =
|
||||
if all okLine statusLines
|
||||
then Just (hasDeleteWal, hasDeleteShm)
|
||||
else Nothing
|
||||
where
|
||||
-- `git status` always displays paths using posix forward-slashes,
|
||||
-- so we have to convert our expected path to test.
|
||||
posixCodebasePath =
|
||||
FilePath.Posix.joinPath (FilePath.splitDirectories codebasePath)
|
||||
posixLockfilePath = FilePath.replaceExtension posixCodebasePath "lockfile"
|
||||
statusLines = Text.unpack <$> Text.lines status
|
||||
t = dropWhile Char.isSpace
|
||||
okLine (t -> '?' : '?' : (t -> p)) | p == posixCodebasePath || p == posixLockfilePath = True
|
||||
okLine (t -> 'M' : (t -> p)) | p == posixCodebasePath = True
|
||||
okLine line = isWalDelete line || isShmDelete line
|
||||
isWalDelete (t -> 'D' : (t -> p)) | p == posixCodebasePath ++ "-wal" = True
|
||||
isWalDelete _ = False
|
||||
isShmDelete (t -> 'D' : (t -> p)) | p == posixCodebasePath ++ "-wal" = True
|
||||
isShmDelete _ = False
|
||||
hasDeleteWal = any isWalDelete statusLines
|
||||
hasDeleteShm = any isShmDelete statusLines
|
||||
|
||||
-- Commit our changes
|
||||
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
|
||||
-- `?? .unison/v2/unison.sqlite3` and not
|
||||
-- `?? .unison/`
|
||||
status <- gitTextIn remotePath ["status", "--short", "-uall"]
|
||||
if Text.null status
|
||||
then pure False
|
||||
else case parseStatus status of
|
||||
Nothing ->
|
||||
error $
|
||||
"An error occurred during push.\n"
|
||||
<> "I was expecting only to see "
|
||||
<> codebasePath
|
||||
<> " modified, but saw:\n\n"
|
||||
<> Text.unpack status
|
||||
<> "\n\n"
|
||||
<> "Please visit https://github.com/unisonweb/unison/issues/2063\n"
|
||||
<> "and add any more details about how you encountered this!\n"
|
||||
Just (hasDeleteWal, hasDeleteShm) -> do
|
||||
-- Only stage files we're expecting; don't `git add --all .`
|
||||
-- which could accidentally commit some garbage
|
||||
gitIn remotePath ["add", Text.pack codebasePath]
|
||||
when hasDeleteWal $ gitIn remotePath ["rm", Text.pack $ codebasePath <> "-wal"]
|
||||
when hasDeleteShm $ gitIn remotePath ["rm", Text.pack $ codebasePath <> "-shm"]
|
||||
gitIn
|
||||
remotePath
|
||||
["commit", "-q", "-m", "Sync branch " <> Text.pack (show $ Branch.headHash newRootBranch)]
|
||||
-- Push our changes to the repo, silencing all output.
|
||||
-- Even with quiet, the remote (Github) can still send output through,
|
||||
-- so we capture stdout and stderr.
|
||||
(successful, _stdout, stderr) <- gitInCaptured remotePath $ ["push", url] ++ Git.gitVerbosity ++ maybe [] (pure @[]) mayGitBranch
|
||||
when (not successful) . throwIO $ GitError.PushException repo (Text.unpack stderr)
|
||||
pure True
|
||||
|
||||
-- | Given two codebase roots (e.g. "./mycodebase"), safely copy the codebase
|
||||
-- at the source to the destination.
|
||||
-- Note: this does not copy the .unisonConfig file.
|
||||
|
@ -1,13 +0,0 @@
|
||||
module Unison.Codebase.SqliteCodebase.GitError where
|
||||
|
||||
import U.Codebase.Sqlite.DbId (SchemaVersion)
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo)
|
||||
import Unison.CodebasePath (CodebasePath)
|
||||
|
||||
data GitSqliteCodebaseError
|
||||
= GitCouldntParseRootBranchHash ReadGitRepo String
|
||||
| CodebaseFileLockFailed
|
||||
| NoDatabaseFile ReadGitRepo CodebasePath
|
||||
| UnrecognizedSchemaVersion ReadGitRepo CodebasePath SchemaVersion
|
||||
| CodebaseRequiresMigration SchemaVersion SchemaVersion
|
||||
deriving (Show)
|
@ -4,21 +4,13 @@
|
||||
module Unison.Codebase.Type
|
||||
( Codebase (..),
|
||||
CodebasePath,
|
||||
GitPushBehavior (..),
|
||||
GitError (..),
|
||||
LocalOrRemote (..),
|
||||
gitErrorFromOpenCodebaseError,
|
||||
)
|
||||
where
|
||||
|
||||
import U.Codebase.HashTags (CausalHash)
|
||||
import U.Codebase.Reference qualified as V2
|
||||
import Unison.Codebase.Branch (Branch)
|
||||
import Unison.Codebase.Editor.Git qualified as Git
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadGitRepo, WriteGitRepo)
|
||||
import Unison.Codebase.GitError (GitCodebaseError, GitProtocolError)
|
||||
import Unison.Codebase.Init.OpenCodebaseError (OpenCodebaseError (..))
|
||||
import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError (..))
|
||||
import Unison.CodebasePath (CodebasePath)
|
||||
import Unison.ConstructorType qualified as CT
|
||||
import Unison.DataDeclaration (Decl)
|
||||
@ -80,9 +72,6 @@ data Codebase m v a = Codebase
|
||||
syncFromDirectory :: CodebasePath -> Branch m -> m (),
|
||||
-- | Copy a branch and all of its dependencies from this codebase into the given codebase.
|
||||
syncToDirectory :: CodebasePath -> Branch m -> m (),
|
||||
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. WriteGitRepo -> GitPushBehavior -> (Branch m -> m (Either e (Branch m))) -> m (Either GitError (Either e (Branch m))),
|
||||
-- | @getWatch k r@ returns watch result @t@ that was previously put by @putWatch k r t@.
|
||||
getWatch :: WK.WatchKind -> Reference.Id -> Sqlite.Transaction (Maybe (Term v a)),
|
||||
-- | Get the set of user-defined terms-or-constructors that have the given type.
|
||||
@ -106,28 +95,3 @@ data LocalOrRemote
|
||||
= Local
|
||||
| Remote
|
||||
deriving (Show, Eq, Ord)
|
||||
|
||||
data GitPushBehavior
|
||||
= -- | Don't set root, just sync entities.
|
||||
GitPushBehaviorGist
|
||||
| -- | After syncing entities, do a fast-forward check, then set the root.
|
||||
GitPushBehaviorFf
|
||||
| -- | After syncing entities, just set the root (force-pushy).
|
||||
GitPushBehaviorForce
|
||||
|
||||
data GitError
|
||||
= GitProtocolError GitProtocolError
|
||||
| GitCodebaseError (GitCodebaseError CausalHash)
|
||||
| GitSqliteCodebaseError GitSqliteCodebaseError
|
||||
deriving (Show)
|
||||
|
||||
instance Exception GitError
|
||||
|
||||
gitErrorFromOpenCodebaseError :: CodebasePath -> ReadGitRepo -> OpenCodebaseError -> GitSqliteCodebaseError
|
||||
gitErrorFromOpenCodebaseError path repo = \case
|
||||
OpenCodebaseDoesntExist -> NoDatabaseFile repo path
|
||||
OpenCodebaseUnknownSchemaVersion v ->
|
||||
UnrecognizedSchemaVersion repo path (fromIntegral v)
|
||||
OpenCodebaseRequiresMigration fromSv toSv ->
|
||||
CodebaseRequiresMigration fromSv toSv
|
||||
OpenCodebaseFileLockFailed -> CodebaseFileLockFailed
|
||||
|
@ -1,6 +1,6 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.36.0.
|
||||
-- This file has been generated from package.yaml by hpack version 0.35.2.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
@ -47,11 +47,9 @@ library
|
||||
Unison.Codebase.CodeLookup
|
||||
Unison.Codebase.CodeLookup.Util
|
||||
Unison.Codebase.Editor.DisplayObject
|
||||
Unison.Codebase.Editor.Git
|
||||
Unison.Codebase.Editor.RemoteRepo
|
||||
Unison.Codebase.Execute
|
||||
Unison.Codebase.FileCodebase
|
||||
Unison.Codebase.GitError
|
||||
Unison.Codebase.Init
|
||||
Unison.Codebase.Init.CreateCodebaseError
|
||||
Unison.Codebase.Init.OpenCodebaseError
|
||||
@ -71,7 +69,6 @@ library
|
||||
Unison.Codebase.SqliteCodebase.Branch.Cache
|
||||
Unison.Codebase.SqliteCodebase.Branch.Dependencies
|
||||
Unison.Codebase.SqliteCodebase.Conversions
|
||||
Unison.Codebase.SqliteCodebase.GitError
|
||||
Unison.Codebase.SqliteCodebase.Migrations
|
||||
Unison.Codebase.SqliteCodebase.Migrations.Helpers
|
||||
Unison.Codebase.SqliteCodebase.Migrations.MigrateSchema11To12
|
||||
|
@ -4,8 +4,6 @@
|
||||
module Unison.Cli.DownloadUtils
|
||||
( downloadProjectBranchFromShare,
|
||||
downloadLooseCodeFromShare,
|
||||
GitNamespaceHistoryTreatment (..),
|
||||
downloadLooseCodeFromGitRepo,
|
||||
)
|
||||
where
|
||||
|
||||
@ -18,27 +16,19 @@ import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.Share.Projects qualified as Share
|
||||
import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Editor.Git qualified as Git
|
||||
import Unison.Codebase.Editor.HandleInput.AuthLogin (ensureAuthenticatedWithCodeserver)
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadShareLooseCode, shareUserHandleToText)
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode, shareUserHandleToText)
|
||||
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.Type (GitError)
|
||||
import Unison.Codebase.Type qualified as Codebase (viewRemoteBranch')
|
||||
import Unison.Core.Project (ProjectAndBranch (..))
|
||||
import Unison.NameSegment qualified as NameSegment
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import Unison.Share.API.Hash qualified as Share
|
||||
import Unison.Share.Codeserver qualified as Codeserver
|
||||
import Unison.Share.Sync qualified as Share
|
||||
import Unison.Share.Sync.Types qualified as Share
|
||||
import Unison.Share.Types (codeserverBaseURL)
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Sync.Common qualified as Sync.Common
|
||||
import Unison.Sync.Types qualified as Share
|
||||
|
||||
@ -113,26 +103,3 @@ withEntitiesDownloadedProgressCallback action = do
|
||||
<> tShow entitiesDownloaded
|
||||
<> " entities...\n\n"
|
||||
action ((\n -> atomically (modifyTVar' entitiesDownloadedVar (+ n))), readTVarIO entitiesDownloadedVar)
|
||||
|
||||
data GitNamespaceHistoryTreatment
|
||||
= -- | Don't touch the history
|
||||
GitNamespaceHistoryTreatment'LetAlone
|
||||
| -- | Throw away all history at all levels
|
||||
GitNamespaceHistoryTreatment'DiscardAllHistory
|
||||
|
||||
-- | Download loose code that's in a SQLite codebase in a Git repo.
|
||||
downloadLooseCodeFromGitRepo ::
|
||||
MonadIO m =>
|
||||
Codebase IO Symbol Ann ->
|
||||
GitNamespaceHistoryTreatment ->
|
||||
ReadGitRemoteNamespace ->
|
||||
m (Either GitError CausalHash)
|
||||
downloadLooseCodeFromGitRepo codebase historyTreatment namespace = liftIO do
|
||||
Codebase.viewRemoteBranch' codebase namespace Git.RequireExistingBranch \(branch0, cacheDir) -> do
|
||||
let branch =
|
||||
case historyTreatment of
|
||||
GitNamespaceHistoryTreatment'LetAlone -> branch0
|
||||
GitNamespaceHistoryTreatment'DiscardAllHistory -> Branch.discardHistory branch0
|
||||
|
||||
Codebase.syncFromDirectory codebase cacheDir branch
|
||||
pure (Branch.headHash branch)
|
||||
|
@ -7,7 +7,7 @@ module Unison.Cli.MergeTypes
|
||||
)
|
||||
where
|
||||
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace, ReadShareLooseCode)
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode)
|
||||
import Unison.Project (ProjectAndBranch, ProjectBranchName, ProjectName)
|
||||
|
||||
-- | What are we merging in?
|
||||
@ -15,7 +15,6 @@ data MergeSource
|
||||
= MergeSource'LocalProjectBranch !(ProjectAndBranch ProjectName ProjectBranchName)
|
||||
| MergeSource'RemoteProjectBranch !(ProjectAndBranch ProjectName ProjectBranchName)
|
||||
| MergeSource'RemoteLooseCode !ReadShareLooseCode
|
||||
| MergeSource'RemoteGitRepo !ReadGitRemoteNamespace
|
||||
|
||||
type MergeTarget =
|
||||
ProjectAndBranch ProjectName ProjectBranchName
|
||||
|
@ -27,7 +27,6 @@ module Unison.Cli.Pretty
|
||||
prettyProjectName,
|
||||
prettyProjectNameSlash,
|
||||
prettyNamespaceKey,
|
||||
prettyReadGitRepo,
|
||||
prettyReadRemoteNamespace,
|
||||
prettyReadRemoteNamespaceWith,
|
||||
prettyRelative,
|
||||
@ -46,7 +45,6 @@ module Unison.Cli.Pretty
|
||||
prettyURI,
|
||||
prettyUnisonFile,
|
||||
prettyWhichBranchEmpty,
|
||||
prettyWriteGitRepo,
|
||||
prettyWriteRemoteNamespace,
|
||||
shareOrigin,
|
||||
unsafePrettyTermResultSigFull',
|
||||
@ -79,10 +77,8 @@ import Unison.Codebase.Editor.DisplayObject (DisplayObject (BuiltinObject, Missi
|
||||
import Unison.Codebase.Editor.Input qualified as Input
|
||||
import Unison.Codebase.Editor.Output
|
||||
import Unison.Codebase.Editor.RemoteRepo
|
||||
( ReadGitRepo,
|
||||
ReadRemoteNamespace (..),
|
||||
( ReadRemoteNamespace (..),
|
||||
ShareUserHandle (..),
|
||||
WriteGitRepo,
|
||||
WriteRemoteNamespace (..),
|
||||
WriteShareRemoteNamespace (..),
|
||||
shareUserHandleToText,
|
||||
@ -239,7 +235,6 @@ prettyMergeSource = \case
|
||||
MergeSource'LocalProjectBranch branch -> prettyProjectAndBranchName branch
|
||||
MergeSource'RemoteProjectBranch branch -> "remote " <> prettyProjectAndBranchName branch
|
||||
MergeSource'RemoteLooseCode info -> prettyReadRemoteNamespace (ReadShare'LooseCode info)
|
||||
MergeSource'RemoteGitRepo info -> prettyReadRemoteNamespace (ReadRemoteNamespaceGit info)
|
||||
|
||||
prettyMergeSourceOrTarget :: MergeSourceOrTarget -> Pretty
|
||||
prettyMergeSourceOrTarget = \case
|
||||
@ -348,18 +343,6 @@ prettyTypeName ppe r =
|
||||
P.syntaxToColor $
|
||||
prettyHashQualified (PPE.typeName ppe r)
|
||||
|
||||
prettyReadGitRepo :: ReadGitRepo -> Pretty
|
||||
prettyReadGitRepo = \case
|
||||
RemoteRepo.ReadGitRepo {url} -> P.blue (P.text url)
|
||||
|
||||
prettyWriteGitRepo :: WriteGitRepo -> Pretty
|
||||
prettyWriteGitRepo RemoteRepo.WriteGitRepo {url} = P.blue (P.text url)
|
||||
|
||||
-- prettyWriteRepo :: WriteRepo -> Pretty
|
||||
-- prettyWriteRepo = \case
|
||||
-- RemoteRepo.WriteRepoGit RemoteRepo.WriteGitRepo {url} -> P.blue (P.text url)
|
||||
-- RemoteRepo.WriteRepoShare s -> P.blue (P.text (RemoteRepo.printShareRepo s))
|
||||
|
||||
-- | Pretty-print a 'WhichBranchEmpty'.
|
||||
prettyWhichBranchEmpty :: WhichBranchEmpty -> Pretty
|
||||
prettyWhichBranchEmpty = \case
|
||||
|
@ -1,7 +1,6 @@
|
||||
-- | @.unisonConfig@ file utilities
|
||||
module Unison.Cli.UnisonConfigUtils
|
||||
( gitUrlKey,
|
||||
remoteMappingKey,
|
||||
( remoteMappingKey,
|
||||
resolveConfiguredUrl,
|
||||
)
|
||||
where
|
||||
@ -33,9 +32,6 @@ configKey k p =
|
||||
NameSegment.toEscapedText
|
||||
(Path.toSeq $ Path.unabsolute p)
|
||||
|
||||
gitUrlKey :: Path.Absolute -> Text
|
||||
gitUrlKey = configKey "GitUrl"
|
||||
|
||||
remoteMappingKey :: Path.Absolute -> Text
|
||||
remoteMappingKey = configKey "RemoteMapping"
|
||||
|
||||
@ -46,13 +42,7 @@ resolveConfiguredUrl :: PushPull -> Path' -> Cli (WriteRemoteNamespace Void)
|
||||
resolveConfiguredUrl pushPull destPath' = do
|
||||
destPath <- Cli.resolvePath' destPath'
|
||||
whenNothingM (remoteMappingForPath pushPull destPath) do
|
||||
let gitUrlConfigKey = gitUrlKey destPath
|
||||
-- Fall back to deprecated GitUrl key
|
||||
Cli.getConfig gitUrlConfigKey >>= \case
|
||||
Just url ->
|
||||
(WriteRemoteNamespaceGit <$> P.parse UriParser.deprecatedWriteGitRemoteNamespace (Text.unpack gitUrlConfigKey) url) & onLeft \err ->
|
||||
Cli.returnEarly (ConfiguredRemoteMappingParseError pushPull destPath url (show err))
|
||||
Nothing -> Cli.returnEarly (NoConfiguredRemoteMapping pushPull destPath)
|
||||
Cli.returnEarly (NoConfiguredRemoteMapping pushPull destPath)
|
||||
|
||||
-- | Tries to look up a remote mapping for a given path.
|
||||
-- Will also resolve paths relative to any mapping which is configured for a parent of that
|
||||
|
@ -78,7 +78,7 @@ import Unison.Codebase.Editor.HandleInput.ProjectRename (handleProjectRename)
|
||||
import Unison.Codebase.Editor.HandleInput.ProjectSwitch (projectSwitch)
|
||||
import Unison.Codebase.Editor.HandleInput.Projects (handleProjects)
|
||||
import Unison.Codebase.Editor.HandleInput.Pull (handlePull, mergeBranchAndPropagateDefaultPatch)
|
||||
import Unison.Codebase.Editor.HandleInput.Push (handleGist, handlePushRemoteBranch)
|
||||
import Unison.Codebase.Editor.HandleInput.Push (handlePushRemoteBranch)
|
||||
import Unison.Codebase.Editor.HandleInput.ReleaseDraft (handleReleaseDraft)
|
||||
import Unison.Codebase.Editor.HandleInput.Run (handleRun)
|
||||
import Unison.Codebase.Editor.HandleInput.RuntimeUtils qualified as RuntimeUtils
|
||||
@ -958,7 +958,6 @@ loop e = do
|
||||
Cli.respond output
|
||||
UpdateBuiltinsI -> Cli.respond NotImplemented
|
||||
QuitI -> Cli.haltRepl
|
||||
GistI input -> handleGist input
|
||||
AuthLoginI -> void $ authLogin (Codeserver.resolveCodeserver RemoteRepo.DefaultCodeserver)
|
||||
VersionI -> do
|
||||
Cli.Env {ucmVersion} <- ask
|
||||
@ -1118,7 +1117,6 @@ inputDescription input =
|
||||
FindShallowI {} -> wat
|
||||
StructuredFindI {} -> wat
|
||||
StructuredFindReplaceI {} -> wat
|
||||
GistI {} -> wat
|
||||
HistoryI {} -> wat
|
||||
LibInstallI {} -> wat
|
||||
ListDependenciesI {} -> wat
|
||||
|
@ -43,7 +43,7 @@ import U.Codebase.Sqlite.Project (Project (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import U.Codebase.Sqlite.Queries qualified as Queries
|
||||
import Unison.Builtin.Decls qualified as Builtin.Decls
|
||||
import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceOrTarget (..), MergeSourceAndTarget (..))
|
||||
import Unison.Cli.MergeTypes (MergeSource (..), MergeSourceAndTarget (..), MergeSourceOrTarget (..))
|
||||
import Unison.Cli.Monad (Cli)
|
||||
import Unison.Cli.Monad qualified as Cli
|
||||
import Unison.Cli.MonadUtils qualified as Cli
|
||||
@ -61,7 +61,7 @@ import Unison.Codebase.Editor.HandleInput.Update2
|
||||
typecheckedUnisonFileToBranchAdds,
|
||||
)
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadGitRemoteNamespace (..), ReadShareLooseCode (..))
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadShareLooseCode (..))
|
||||
import Unison.Codebase.Path (Path)
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.SqliteCodebase.Branch.Cache (newBranchCache)
|
||||
@ -220,7 +220,7 @@ doMerge info = do
|
||||
let aliceBranchNames = ProjectAndBranch info.alice.project.name info.alice.projectBranch.name
|
||||
let mergeSource = MergeSourceOrTarget'Source info.bob.source
|
||||
let mergeTarget = MergeSourceOrTarget'Target aliceBranchNames
|
||||
let mergeSourceAndTarget = MergeSourceAndTarget { alice = aliceBranchNames, bob = info.bob.source }
|
||||
let mergeSourceAndTarget = MergeSourceAndTarget {alice = aliceBranchNames, bob = info.bob.source}
|
||||
|
||||
Cli.Env {codebase} <- ask
|
||||
|
||||
@ -407,10 +407,6 @@ doMerge info = do
|
||||
case Path.toName info.path of
|
||||
Nothing -> "<root>"
|
||||
Just name -> Name.toText name
|
||||
MergeSource'RemoteGitRepo info ->
|
||||
case Path.toName info.path of
|
||||
Nothing -> "<root>"
|
||||
Just name -> Name.toText name
|
||||
}
|
||||
renderedConflicts
|
||||
renderedDependents
|
||||
@ -854,7 +850,6 @@ findTemporaryBranchName projectId mergeSourceAndTarget = do
|
||||
MergeSource'LocalProjectBranch (ProjectAndBranch _project branch) -> mangleBranchName branch
|
||||
MergeSource'RemoteProjectBranch (ProjectAndBranch _project branch) -> "remote-" <> mangleBranchName branch
|
||||
MergeSource'RemoteLooseCode info -> manglePath info.path
|
||||
MergeSource'RemoteGitRepo info -> manglePath info.path
|
||||
mangleBranchName :: ProjectBranchName -> Text.Builder
|
||||
mangleBranchName name =
|
||||
case classifyProjectBranchName name of
|
||||
|
@ -57,17 +57,7 @@ handlePull unresolvedSourceAndTarget pullMode = do
|
||||
(source, target) <- resolveSourceAndTarget includeSquashed unresolvedSourceAndTarget
|
||||
|
||||
remoteCausalHash <- do
|
||||
Cli.Env {codebase} <- ask
|
||||
case source of
|
||||
ReadRemoteNamespaceGit repo -> do
|
||||
downloadLooseCodeFromGitRepo
|
||||
codebase
|
||||
( case pullMode of
|
||||
Input.PullWithHistory -> GitNamespaceHistoryTreatment'LetAlone
|
||||
Input.PullWithoutHistory -> GitNamespaceHistoryTreatment'DiscardAllHistory
|
||||
)
|
||||
repo
|
||||
& onLeftM (Cli.returnEarly . Output.GitError)
|
||||
ReadShare'LooseCode repo -> downloadLooseCodeFromShare repo & onLeftM (Cli.returnEarly . Output.ShareError)
|
||||
ReadShare'ProjectBranch remoteBranch ->
|
||||
downloadProjectBranchFromShare
|
||||
@ -136,7 +126,6 @@ handlePull unresolvedSourceAndTarget pullMode = do
|
||||
ReadShare'ProjectBranch remoteBranch ->
|
||||
MergeSource'RemoteProjectBranch (ProjectAndBranch remoteBranch.projectName remoteBranch.branchName)
|
||||
ReadShare'LooseCode info -> MergeSource'RemoteLooseCode info
|
||||
ReadRemoteNamespaceGit info -> MergeSource'RemoteGitRepo info
|
||||
},
|
||||
lca =
|
||||
LcaMergeInfo
|
||||
@ -209,7 +198,6 @@ resolveExplicitSource ::
|
||||
ReadRemoteNamespace (These ProjectName ProjectBranchNameOrLatestRelease) ->
|
||||
Cli (ReadRemoteNamespace Share.RemoteProjectBranch)
|
||||
resolveExplicitSource includeSquashed = \case
|
||||
ReadRemoteNamespaceGit namespace -> pure (ReadRemoteNamespaceGit namespace)
|
||||
ReadShare'LooseCode namespace -> pure (ReadShare'LooseCode namespace)
|
||||
ReadShare'ProjectBranch (This remoteProjectName) -> do
|
||||
remoteProject <- ProjectUtils.expectRemoteProjectByName remoteProjectName
|
||||
|
@ -1,13 +1,11 @@
|
||||
-- | @push@ input handler
|
||||
module Unison.Codebase.Editor.HandleInput.Push
|
||||
( handleGist,
|
||||
handlePushRemoteBranch,
|
||||
( handlePushRemoteBranch,
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Concurrent.STM (atomically, modifyTVar', newTVarIO, readTVar, readTVarIO)
|
||||
import Control.Lens (over, view, (.~), (^.), _1, _2)
|
||||
import Control.Monad.Reader (ask)
|
||||
import Data.Set.NonEmpty qualified as Set.NonEmpty
|
||||
import Data.Text as Text
|
||||
import Data.These (These (..))
|
||||
@ -26,13 +24,9 @@ import Unison.Cli.MonadUtils qualified as Cli
|
||||
import Unison.Cli.ProjectUtils qualified as ProjectUtils
|
||||
import Unison.Cli.Share.Projects qualified as Share
|
||||
import Unison.Cli.UnisonConfigUtils qualified as UnisonConfigUtils
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Codebase.Branch (Branch (..))
|
||||
import Unison.Codebase.Branch qualified as Branch
|
||||
import Unison.Codebase.Editor.HandleInput.AuthLogin qualified as AuthLogin
|
||||
import Unison.Codebase.Editor.Input
|
||||
( GistInput (..),
|
||||
PushRemoteBranchInput (..),
|
||||
( PushRemoteBranchInput (..),
|
||||
PushSource (..),
|
||||
PushSourceTarget (..),
|
||||
)
|
||||
@ -40,20 +34,13 @@ import Unison.Codebase.Editor.Output
|
||||
import Unison.Codebase.Editor.Output qualified as Output
|
||||
import Unison.Codebase.Editor.Output.PushPull (PushPull (Push))
|
||||
import Unison.Codebase.Editor.RemoteRepo
|
||||
( ReadGitRemoteNamespace (..),
|
||||
ReadRemoteNamespace (..),
|
||||
WriteGitRemoteNamespace (..),
|
||||
WriteRemoteNamespace (..),
|
||||
( WriteRemoteNamespace (..),
|
||||
WriteShareRemoteNamespace (..),
|
||||
writeToReadGit,
|
||||
)
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.PushBehavior (PushBehavior)
|
||||
import Unison.Codebase.PushBehavior qualified as PushBehavior
|
||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||
import Unison.Codebase.Type (GitPushBehavior (..))
|
||||
import Unison.Core.Project (ProjectBranchName (UnsafeProjectBranchName))
|
||||
import Unison.Hash qualified as Hash
|
||||
import Unison.Hash32 (Hash32)
|
||||
import Unison.Hash32 qualified as Hash32
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
@ -76,25 +63,6 @@ import Unison.Sqlite qualified as Sqlite
|
||||
import Unison.Sync.Types qualified as Share
|
||||
import Witch (unsafeFrom)
|
||||
|
||||
-- | Handle a @gist@ command.
|
||||
handleGist :: GistInput -> Cli ()
|
||||
handleGist (GistInput repo) = do
|
||||
Cli.Env {codebase} <- ask
|
||||
sourceBranch <- Cli.getCurrentBranch
|
||||
result <-
|
||||
Cli.ioE (Codebase.pushGitBranch codebase repo GitPushBehaviorGist (\_remoteRoot -> pure (Right sourceBranch))) \err ->
|
||||
Cli.returnEarly (Output.GitError err)
|
||||
_branch <- result & onLeft Cli.returnEarly
|
||||
schLength <- Cli.runTransaction Codebase.branchHashLength
|
||||
Cli.respond $
|
||||
GistCreated $
|
||||
ReadRemoteNamespaceGit
|
||||
ReadGitRemoteNamespace
|
||||
{ repo = writeToReadGit repo,
|
||||
sch = Just (SCH.fromHash schLength (Branch.headHash sourceBranch)),
|
||||
path = Path.empty
|
||||
}
|
||||
|
||||
-- | Handle a @push@ command.
|
||||
handlePushRemoteBranch :: PushRemoteBranchInput -> Cli ()
|
||||
handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
|
||||
@ -105,7 +73,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
|
||||
Nothing -> do
|
||||
localPath <- Cli.getCurrentPath
|
||||
UnisonConfigUtils.resolveConfiguredUrl Push Path.currentPath >>= \case
|
||||
WriteRemoteNamespaceGit namespace -> pushLooseCodeToGitLooseCode localPath namespace pushBehavior
|
||||
WriteRemoteNamespaceShare namespace -> pushLooseCodeToShareLooseCode localPath namespace pushBehavior
|
||||
WriteRemoteProjectBranch v -> absurd v
|
||||
Just (localProjectAndBranch, _restPath) ->
|
||||
@ -113,10 +80,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
|
||||
force
|
||||
localProjectAndBranch
|
||||
Nothing
|
||||
-- push <implicit> to .some.path (git)
|
||||
PushSourceTarget1 (WriteRemoteNamespaceGit namespace) -> do
|
||||
localPath <- Cli.getCurrentPath
|
||||
pushLooseCodeToGitLooseCode localPath namespace pushBehavior
|
||||
-- push <implicit> to .some.path (share)
|
||||
PushSourceTarget1 (WriteRemoteNamespaceShare namespace) -> do
|
||||
localPath <- Cli.getCurrentPath
|
||||
@ -130,10 +93,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
|
||||
pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch
|
||||
Just (localProjectAndBranch, _restPath) ->
|
||||
pushProjectBranchToProjectBranch force localProjectAndBranch (Just remoteProjectAndBranch0)
|
||||
-- push .some.path to .some.path (git)
|
||||
PushSourceTarget2 (PathySource localPath0) (WriteRemoteNamespaceGit namespace) -> do
|
||||
localPath <- Cli.resolvePath' localPath0
|
||||
pushLooseCodeToGitLooseCode localPath namespace pushBehavior
|
||||
-- push .some.path to .some.path (share)
|
||||
PushSourceTarget2 (PathySource localPath0) (WriteRemoteNamespaceShare namespace) -> do
|
||||
localPath <- Cli.resolvePath' localPath0
|
||||
@ -143,13 +102,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
|
||||
localPath <- Cli.resolvePath' localPath0
|
||||
remoteProjectAndBranch <- ProjectUtils.hydrateNames remoteProjectAndBranch0
|
||||
pushLooseCodeToProjectBranch force localPath remoteProjectAndBranch
|
||||
-- push @some/project to .some.path (git)
|
||||
PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteNamespaceGit namespace) -> do
|
||||
ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0
|
||||
pushLooseCodeToGitLooseCode
|
||||
(ProjectUtils.projectBranchPath (ProjectAndBranch (project ^. #projectId) (branch ^. #branchId)))
|
||||
namespace
|
||||
pushBehavior
|
||||
-- push @some/project to .some.path (share)
|
||||
PushSourceTarget2 (ProjySource localProjectAndBranch0) (WriteRemoteNamespaceShare namespace) -> do
|
||||
ProjectAndBranch project branch <- ProjectUtils.expectProjectAndBranchByTheseNames localProjectAndBranch0
|
||||
@ -168,49 +120,6 @@ handlePushRemoteBranch PushRemoteBranchInput {sourceTarget, pushBehavior} = do
|
||||
PushBehavior.RequireEmpty -> False
|
||||
PushBehavior.RequireNonEmpty -> False
|
||||
|
||||
-- Push a local namespace ("loose code") to a Git-hosted remote namespace ("loose code").
|
||||
pushLooseCodeToGitLooseCode :: Path.Absolute -> WriteGitRemoteNamespace -> PushBehavior -> Cli ()
|
||||
pushLooseCodeToGitLooseCode localPath gitRemotePath pushBehavior = do
|
||||
sourceBranch <- Cli.getBranchAt localPath
|
||||
let withRemoteRoot :: Branch IO -> Either Output (Branch IO)
|
||||
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
|
||||
case Branch.modifyAtM (gitRemotePath ^. #path) f remoteRoot of
|
||||
Nothing -> Left (RefusedToPush pushBehavior (WriteRemoteNamespaceGit gitRemotePath))
|
||||
Just newRemoteRoot -> Right newRemoteRoot
|
||||
let behavior =
|
||||
case pushBehavior of
|
||||
PushBehavior.ForcePush -> GitPushBehaviorForce
|
||||
PushBehavior.RequireEmpty -> GitPushBehaviorFf
|
||||
PushBehavior.RequireNonEmpty -> GitPushBehaviorFf
|
||||
Cli.Env {codebase} <- ask
|
||||
let push =
|
||||
Codebase.pushGitBranch
|
||||
codebase
|
||||
(gitRemotePath ^. #repo)
|
||||
behavior
|
||||
(\remoteRoot -> pure (withRemoteRoot remoteRoot))
|
||||
result <-
|
||||
liftIO push & onLeftM \err ->
|
||||
Cli.returnEarly (Output.GitError err)
|
||||
_branch <- result & onLeft Cli.returnEarly
|
||||
Cli.respond Success
|
||||
where
|
||||
-- Per `pushBehavior`, we are either:
|
||||
--
|
||||
-- (1) force-pushing, in which case the remote branch state doesn't matter
|
||||
-- (2) updating an empty branch, which fails if the branch isn't empty (`push.create`)
|
||||
-- (3) updating a non-empty branch, which fails if the branch is empty (`push`)
|
||||
shouldPushTo :: PushBehavior -> Branch m -> Bool
|
||||
shouldPushTo pushBehavior remoteBranch =
|
||||
case pushBehavior of
|
||||
PushBehavior.ForcePush -> True
|
||||
PushBehavior.RequireEmpty -> Branch.isEmpty0 (Branch.head remoteBranch)
|
||||
PushBehavior.RequireNonEmpty -> not (Branch.isEmpty0 (Branch.head remoteBranch))
|
||||
|
||||
-- Push a local namespace ("loose code") to a Share-hosted remote namespace ("loose code").
|
||||
pushLooseCodeToShareLooseCode :: Path.Absolute -> WriteShareRemoteNamespace -> PushBehavior -> Cli ()
|
||||
pushLooseCodeToShareLooseCode _ _ _ = do
|
||||
@ -656,7 +565,6 @@ makeSetHeadAfterUploadAction force pushing localBranchHead remoteBranch = do
|
||||
Cli.respond (RemoteProjectBranchIsUpToDate Share.hardCodedUri remoteProjectAndBranchNames)
|
||||
Cli.returnEarly (ViewOnShare (Right (Share.hardCodedUri, remoteBranch.projectName, remoteBranch.branchName)))
|
||||
|
||||
|
||||
when (not force) do
|
||||
whenM (Cli.runTransaction (wouldNotBeFastForward localBranchHead remoteBranchHead)) do
|
||||
Cli.returnEarly (RemoteProjectBranchHeadMismatch Share.hardCodedUri remoteProjectAndBranchNames)
|
||||
|
@ -1,7 +1,6 @@
|
||||
module Unison.Codebase.Editor.Input
|
||||
( Input (..),
|
||||
BranchSourceI (..),
|
||||
GistInput (..),
|
||||
PullSourceTarget (..),
|
||||
PushRemoteBranchInput (..),
|
||||
PushSourceTarget (..),
|
||||
@ -32,7 +31,7 @@ import Data.List.NonEmpty (NonEmpty)
|
||||
import Data.Text qualified as Text
|
||||
import Data.These (These)
|
||||
import Unison.Codebase.Branch.Merge qualified as Branch
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteGitRepo, WriteRemoteNamespace)
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadRemoteNamespace, WriteRemoteNamespace)
|
||||
import Unison.Codebase.Path (Path, Path')
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.Path.Parse qualified as Path
|
||||
@ -210,7 +209,6 @@ data Input
|
||||
| UiI Path'
|
||||
| DocToMarkdownI Name
|
||||
| DocsToHtmlI Path' FilePath
|
||||
| GistI GistInput
|
||||
| AuthLoginI
|
||||
| VersionI
|
||||
| ProjectCreateI Bool {- try downloading base? -} (Maybe ProjectName)
|
||||
@ -239,12 +237,6 @@ data BranchSourceI
|
||||
BranchSourceI'LooseCodeOrProject LooseCodeOrProject
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
-- | @"push.gist repo"@ pushes the contents of the current namespace to @repo@.
|
||||
data GistInput = GistInput
|
||||
{ repo :: WriteGitRepo
|
||||
}
|
||||
deriving stock (Eq, Show)
|
||||
|
||||
-- | Pull source and target: either neither is specified, or only a source, or both.
|
||||
data PullSourceTarget
|
||||
= PullSourceTarget0
|
||||
|
@ -27,7 +27,7 @@ import U.Codebase.HashTags (CausalHash)
|
||||
import U.Codebase.Sqlite.Project qualified as Sqlite
|
||||
import U.Codebase.Sqlite.ProjectBranch qualified as Sqlite
|
||||
import Unison.Auth.Types (CredentialFailure)
|
||||
import Unison.Cli.MergeTypes (MergeSourceOrTarget, MergeSourceAndTarget)
|
||||
import Unison.Cli.MergeTypes (MergeSourceAndTarget, MergeSourceOrTarget)
|
||||
import Unison.Cli.Share.Projects.Types qualified as Share
|
||||
import Unison.Codebase.Editor.Input
|
||||
import Unison.Codebase.Editor.Output.BranchDiff (BranchDiffOutput)
|
||||
@ -44,7 +44,6 @@ import Unison.Codebase.PushBehavior (PushBehavior)
|
||||
import Unison.Codebase.Runtime qualified as Runtime
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||
import Unison.Codebase.Type (GitError)
|
||||
import Unison.CommandLine.InputPattern qualified as Input
|
||||
import Unison.DataDeclaration qualified as DD
|
||||
import Unison.DataDeclaration.ConstructorId (ConstructorId)
|
||||
@ -261,7 +260,6 @@ data Output
|
||||
-- todo: eventually replace these sets with [SearchResult' v Ann]
|
||||
-- and a nicer render.
|
||||
BustedBuiltins (Set Reference) (Set Reference)
|
||||
| GitError GitError
|
||||
| ShareError ShareError
|
||||
| ViewOnShare (Either WriteShareRemoteNamespace (URI, ProjectName, ProjectBranchName))
|
||||
| NoConfiguredRemoteMapping PushPull Path.Absolute
|
||||
@ -529,7 +527,6 @@ isFailure o = case o of
|
||||
TestIncrementalOutputEnd {} -> False
|
||||
TestResults _ _ _ _ _ fails -> not (null fails)
|
||||
CantUndo {} -> True
|
||||
GitError {} -> True
|
||||
BustedBuiltins {} -> True
|
||||
NoConfiguredRemoteMapping {} -> True
|
||||
ConfiguredRemoteMappingParseError {} -> True
|
||||
|
@ -1,36 +1,26 @@
|
||||
module Unison.Codebase.Editor.UriParser
|
||||
( readRemoteNamespaceParser,
|
||||
writeGitRepo,
|
||||
deprecatedWriteGitRemoteNamespace,
|
||||
writeRemoteNamespace,
|
||||
writeRemoteNamespaceWith,
|
||||
parseReadShareLooseCode,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Char (isAlphaNum, isDigit, isSpace)
|
||||
import Data.Sequence as Seq
|
||||
import Data.Char (isAlphaNum)
|
||||
import Data.Text qualified as Text
|
||||
import Data.These (These)
|
||||
import Data.Void
|
||||
import Text.Megaparsec qualified as P
|
||||
import Text.Megaparsec.Char qualified as C
|
||||
import U.Util.Base32Hex qualified as Base32Hex
|
||||
import Unison.Codebase.Editor.RemoteRepo
|
||||
( ReadGitRemoteNamespace (..),
|
||||
ReadGitRepo (..),
|
||||
ReadRemoteNamespace (..),
|
||||
( ReadRemoteNamespace (..),
|
||||
ReadShareLooseCode (..),
|
||||
ShareCodeserver (DefaultCodeserver),
|
||||
ShareUserHandle (..),
|
||||
WriteGitRemoteNamespace (..),
|
||||
WriteGitRepo (..),
|
||||
WriteRemoteNamespace (..),
|
||||
WriteShareRemoteNamespace (..),
|
||||
)
|
||||
import Unison.Codebase.Path (Path (..))
|
||||
import Unison.Codebase.Path qualified as Path
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash (..))
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
import Unison.Prelude
|
||||
import Unison.Project (ProjectBranchName, ProjectBranchSpecifier (..), ProjectName, projectAndBranchNamesParser)
|
||||
@ -41,28 +31,9 @@ import Unison.Util.Pretty.MegaParsec qualified as P
|
||||
|
||||
type P = P.Parsec Void Text.Text
|
||||
|
||||
-- Here are the git protocols that we know how to parse
|
||||
-- Local Protocol
|
||||
|
||||
-- $ git clone /srv/git/project.git
|
||||
|
||||
-- $ git clone /srv/git/project.git[:treeish][:[#hash][.path]]
|
||||
-- File Protocol
|
||||
|
||||
-- $ git clone file:///srv/git/project.git[:treeish][:[#hash][.path]]
|
||||
-- Smart / Dumb HTTP protocol
|
||||
|
||||
-- $ git clone https://example.com/gitproject.git[:treeish][:[#hash][.path]]
|
||||
-- SSH Protocol
|
||||
|
||||
-- $ git clone ssh://[user@]server/project.git[:treeish][:[#hash][.path]]
|
||||
|
||||
-- $ git clone [user@]server:project.git[:treeish][:[#hash][.path]]
|
||||
|
||||
readRemoteNamespaceParser :: ProjectBranchSpecifier branch -> P (ReadRemoteNamespace (These ProjectName branch))
|
||||
readRemoteNamespaceParser specifier =
|
||||
ReadRemoteNamespaceGit <$> readGitRemoteNamespace
|
||||
<|> ReadShare'ProjectBranch <$> projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths specifier
|
||||
ReadShare'ProjectBranch <$> projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths specifier
|
||||
<|> ReadShare'LooseCode <$> readShareLooseCode
|
||||
|
||||
projectAndBranchNamesParserInTheContextOfAlsoParsingLooseCodePaths ::
|
||||
@ -81,9 +52,7 @@ parseReadShareLooseCode label input =
|
||||
in first printError (P.parse readShareLooseCode label (Text.pack input))
|
||||
|
||||
-- >>> P.parseMaybe writeRemoteNamespace "unisonweb.base._releases.M4"
|
||||
-- >>> P.parseMaybe writeRemoteNamespace "git(git@github.com:unisonweb/base:v3)._releases.M3"
|
||||
-- Just (WriteRemoteNamespaceShare (WriteShareRemoteNamespace {server = ShareRepo, repo = "unisonweb", path = base._releases.M4}))
|
||||
-- Just (WriteRemoteNamespaceGit (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "git@github.com:unisonweb/base", branch = Just "v3"}, path = _releases.M3}))
|
||||
writeRemoteNamespace :: P (WriteRemoteNamespace (These ProjectName ProjectBranchName))
|
||||
writeRemoteNamespace =
|
||||
writeRemoteNamespaceWith
|
||||
@ -91,8 +60,7 @@ writeRemoteNamespace =
|
||||
|
||||
writeRemoteNamespaceWith :: P a -> P (WriteRemoteNamespace a)
|
||||
writeRemoteNamespaceWith projectBranchParser =
|
||||
WriteRemoteNamespaceGit <$> writeGitRemoteNamespace
|
||||
<|> WriteRemoteProjectBranch <$> projectBranchParser
|
||||
WriteRemoteProjectBranch <$> projectBranchParser
|
||||
<|> WriteRemoteNamespaceShare <$> writeShareRemoteNamespace
|
||||
|
||||
-- >>> P.parseMaybe writeShareRemoteNamespace "unisonweb.base._releases.M4"
|
||||
@ -130,252 +98,15 @@ shareUserHandle :: P ShareUserHandle
|
||||
shareUserHandle = do
|
||||
ShareUserHandle . Text.pack <$> P.some (P.satisfy \c -> isAlphaNum c || c == '-' || c == '_')
|
||||
|
||||
-- >>> 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"
|
||||
-- >>> P.parseMaybe readGitRemoteNamespace "git( user@server:project.git:branch )#asdf.foo.bar"
|
||||
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Just #asdf, path = })
|
||||
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Just #asdf, path = })
|
||||
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Nothing, path = })
|
||||
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "git@github.com:unisonweb/base", ref = Just "v3"}, sch = Nothing, path = _releases.M3})
|
||||
-- Just (ReadGitRemoteNamespace {repo = ReadGitRepo {url = "user@server:project.git", ref = Just "branch"}, sch = Just #asdf, path = foo.bar})
|
||||
readGitRemoteNamespace :: P ReadGitRemoteNamespace
|
||||
readGitRemoteNamespace = P.label "generic git repo" $ do
|
||||
C.string "git("
|
||||
protocol <- parseGitProtocol
|
||||
treeish <- P.optional gitTreeishSuffix
|
||||
let repo = ReadGitRepo {url = printProtocol protocol, ref = treeish}
|
||||
C.string ")"
|
||||
nshashPath <- P.optional namespaceHashPath
|
||||
pure case nshashPath of
|
||||
Nothing -> ReadGitRemoteNamespace {repo, sch = Nothing, path = Path.empty}
|
||||
Just (sch, path) -> ReadGitRemoteNamespace {repo, sch, path}
|
||||
|
||||
-- >>> P.parseMaybe writeGitRepo "git(/srv/git/project.git)"
|
||||
-- >>> P.parseMaybe writeGitRepo "git(/srv/git/project.git:branch)"
|
||||
-- Just (WriteGitRepo {url = "/srv/git/project.git", branch = Nothing})
|
||||
-- Just (WriteGitRepo {url = "/srv/git/project.git", branch = Just "branch"})
|
||||
--
|
||||
-- >>> P.parseMaybe writeGitRepo "git(file:///srv/git/project.git)"
|
||||
-- >>> P.parseMaybe writeGitRepo "git(file:///srv/git/project.git:branch)"
|
||||
-- Just (WriteGitRepo {url = "file:///srv/git/project.git", branch = Nothing})
|
||||
-- Just (WriteGitRepo {url = "file:///srv/git/project.git", branch = Just "branch"})
|
||||
--
|
||||
-- >>> P.parseMaybe writeGitRepo "git(https://example.com/gitproject.git)"
|
||||
-- >>> P.parseMaybe writeGitRepo "git(https://example.com/gitproject.git:base)"
|
||||
-- Just (WriteGitRepo {url = "https://example.com/gitproject.git", branch = Nothing})
|
||||
-- Just (WriteGitRepo {url = "https://example.com/gitproject.git", branch = Just "base"})
|
||||
--
|
||||
-- >>> P.parseMaybe writeGitRepo "git(ssh://user@server/project.git)"
|
||||
-- >>> P.parseMaybe writeGitRepo "git(ssh://user@server/project.git:branch)"
|
||||
-- >>> P.parseMaybe writeGitRepo "git(ssh://server/project.git)"
|
||||
-- >>> P.parseMaybe writeGitRepo "git(ssh://server/project.git:branch)"
|
||||
-- Just (WriteGitRepo {url = "ssh://user@server/project.git", branch = Nothing})
|
||||
-- Just (WriteGitRepo {url = "ssh://user@server/project.git", branch = Just "branch"})
|
||||
-- Just (WriteGitRepo {url = "ssh://server/project.git", branch = Nothing})
|
||||
-- Just (WriteGitRepo {url = "ssh://server/project.git", branch = Just "branch"})
|
||||
--
|
||||
-- >>> P.parseMaybe writeGitRepo "git(server:project)"
|
||||
-- >>> P.parseMaybe writeGitRepo "git(user@server:project.git:branch)"
|
||||
-- Just (WriteGitRepo {url = "server:project", branch = Nothing})
|
||||
-- Just (WriteGitRepo {url = "user@server:project.git", branch = Just "branch"})
|
||||
writeGitRepo :: P WriteGitRepo
|
||||
writeGitRepo = P.label "repo root for writing" $ do
|
||||
C.string "git("
|
||||
uri <- parseGitProtocol
|
||||
treeish <- P.optional gitTreeishSuffix
|
||||
C.string ")"
|
||||
pure WriteGitRepo {url = printProtocol uri, branch = treeish}
|
||||
|
||||
-- | A parser for the deprecated format of git URLs, which may still exist in old GitURL
|
||||
-- unisonConfigs.
|
||||
--
|
||||
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "/srv/git/project.git:.namespace"
|
||||
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "/srv/git/project.git:branch:.namespace"
|
||||
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "/srv/git/project.git", branch = Nothing}, path = namespace})
|
||||
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "/srv/git/project.git", branch = Just "branch"}, path = namespace})
|
||||
--
|
||||
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "file:///srv/git/project.git"
|
||||
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "file:///srv/git/project.git:branch"
|
||||
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "file:///srv/git/project.git", branch = Nothing}, path = })
|
||||
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "file:///srv/git/project.git", branch = Just "branch"}, path = })
|
||||
--
|
||||
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "https://example.com/gitproject.git"
|
||||
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "https://example.com/gitproject.git:base"
|
||||
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "https://example.com/gitproject.git", branch = Nothing}, path = })
|
||||
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "https://example.com/gitproject.git", branch = Just "base"}, path = })
|
||||
--
|
||||
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "ssh://user@server/project.git"
|
||||
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "ssh://user@server/project.git:branch"
|
||||
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "ssh://server/project.git"
|
||||
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "ssh://server/project.git:branch"
|
||||
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "ssh://user@server/project.git", branch = Nothing}, path = })
|
||||
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "ssh://user@server/project.git", branch = Just "branch"}, path = })
|
||||
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "ssh://server/project.git", branch = Nothing}, path = })
|
||||
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "ssh://server/project.git", branch = Just "branch"}, path = })
|
||||
--
|
||||
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "server:project"
|
||||
-- >>> P.parseMaybe deprecatedWriteGitRemoteNamespace "user@server:project.git:branch"
|
||||
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "server:project", branch = Nothing}, path = })
|
||||
-- Just (WriteGitRemoteNamespace {repo = WriteGitRepo {url = "user@server:project.git", branch = Just "branch"}, path = })
|
||||
deprecatedWriteGitRemoteNamespace :: P WriteGitRemoteNamespace
|
||||
deprecatedWriteGitRemoteNamespace = P.label "generic write repo" $ do
|
||||
repo <- deprecatedWriteGitRepo
|
||||
path <- P.optional (C.char ':' *> absolutePath)
|
||||
pure WriteGitRemoteNamespace {repo, path = fromMaybe Path.empty path}
|
||||
where
|
||||
deprecatedWriteGitRepo :: P WriteGitRepo
|
||||
deprecatedWriteGitRepo = do
|
||||
P.label "repo root for writing" $ do
|
||||
uri <- parseGitProtocol
|
||||
treeish <- P.optional deprecatedTreeishSuffix
|
||||
pure WriteGitRepo {url = printProtocol uri, branch = treeish}
|
||||
deprecatedTreeishSuffix :: P Text
|
||||
deprecatedTreeishSuffix = P.label "git treeish" . P.try $ do
|
||||
void $ C.char ':'
|
||||
notdothash <- P.noneOf @[] ".#:"
|
||||
rest <- P.takeWhileP (Just "not colon") (/= ':')
|
||||
pure $ Text.cons notdothash rest
|
||||
|
||||
-- git(myrepo@git.com).foo.bar
|
||||
writeGitRemoteNamespace :: P WriteGitRemoteNamespace
|
||||
writeGitRemoteNamespace = P.label "generic write repo" $ do
|
||||
repo <- writeGitRepo
|
||||
path <- P.optional absolutePath
|
||||
pure WriteGitRemoteNamespace {repo, path = fromMaybe Path.empty path}
|
||||
|
||||
data GitProtocol
|
||||
= HttpsProtocol (Maybe User) HostInfo UrlPath
|
||||
| SshProtocol (Maybe User) HostInfo UrlPath
|
||||
| ScpProtocol (Maybe User) Host UrlPath
|
||||
| FileProtocol UrlPath
|
||||
| LocalProtocol UrlPath
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
printProtocol :: GitProtocol -> Text
|
||||
-- printProtocol x | traceShow x False = undefined
|
||||
printProtocol x = case x of
|
||||
HttpsProtocol muser hostInfo path ->
|
||||
"https://"
|
||||
<> printUser muser
|
||||
<> printHostInfo hostInfo
|
||||
<> path
|
||||
SshProtocol muser hostInfo path ->
|
||||
"ssh://"
|
||||
<> printUser muser
|
||||
<> printHostInfo hostInfo
|
||||
<> path
|
||||
ScpProtocol muser host path -> printUser muser <> host <> ":" <> path
|
||||
FileProtocol path -> "file://" <> path
|
||||
LocalProtocol path -> path
|
||||
where
|
||||
printUser = maybe mempty (\(User u) -> u <> "@")
|
||||
printHostInfo :: HostInfo -> Text
|
||||
printHostInfo (HostInfo hostname mport) =
|
||||
hostname <> maybe mempty (Text.cons ':') mport
|
||||
|
||||
data Scheme = Ssh | Https
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
data User = User Text
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
type UrlPath = Text
|
||||
|
||||
data HostInfo = HostInfo Text (Maybe Text)
|
||||
deriving (Eq, Ord, Show)
|
||||
|
||||
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)
|
||||
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 == ')'))
|
||||
localRepo = LocalProtocol <$> parsePath
|
||||
fileRepo = P.label "fileRepo" $ do
|
||||
void $ C.string "file://"
|
||||
FileProtocol <$> parsePath
|
||||
httpsRepo = P.label "httpsRepo" $ do
|
||||
void $ C.string "https://"
|
||||
HttpsProtocol <$> P.optional userInfo <*> parseHostInfo <*> parsePath
|
||||
sshRepo = P.label "sshRepo" $ do
|
||||
void $ C.string "ssh://"
|
||||
SshProtocol <$> P.optional userInfo <*> parseHostInfo <*> parsePath
|
||||
scpRepo =
|
||||
P.label "scpRepo" . P.try $
|
||||
ScpProtocol <$> P.optional userInfo <*> parseHost <* C.string ":" <*> parsePath
|
||||
userInfo :: P User
|
||||
userInfo = P.label "userInfo" . P.try $ do
|
||||
username <- P.takeWhile1P (Just "username character") (/= '@')
|
||||
void $ C.char '@'
|
||||
pure $ User username
|
||||
parseHostInfo :: P HostInfo
|
||||
parseHostInfo =
|
||||
P.label "parseHostInfo" $
|
||||
HostInfo
|
||||
<$> parseHost
|
||||
<*> ( P.optional $ do
|
||||
void $ C.char ':'
|
||||
P.takeWhile1P (Just "digits") isDigit
|
||||
)
|
||||
|
||||
parseHost = P.label "parseHost" $ hostname <|> ipv4 -- <|> ipv6
|
||||
where
|
||||
hostname =
|
||||
P.takeWhile1P
|
||||
(Just "hostname character")
|
||||
(\c -> isAlphaNum c || c == '.' || c == '-')
|
||||
ipv4 = P.label "ipv4 address" $ do
|
||||
o1 <- decOctet
|
||||
void $ C.char '.'
|
||||
o2 <- decOctet
|
||||
void $ C.char '.'
|
||||
o3 <- decOctet
|
||||
void $ C.char '.'
|
||||
o4 <- decOctet
|
||||
pure $ Text.pack $ o1 <> "." <> o2 <> "." <> o3 <> "." <> o4
|
||||
decOctet = P.count' 1 3 C.digitChar
|
||||
|
||||
-- >>> 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 ShortCausalHash, Path)
|
||||
namespaceHashPath = do
|
||||
sch <- P.optional shortCausalHash
|
||||
p <- P.optional absolutePath
|
||||
pure (sch, 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 <$> P.sepBy nameSegment (C.char '.')
|
||||
|
||||
nameSegment :: P NameSegment
|
||||
nameSegment =
|
||||
NameSegment.unsafeParseText . Text.pack
|
||||
@ -383,14 +114,3 @@ nameSegment =
|
||||
<$> P.satisfy Unison.Syntax.Lexer.wordyIdStartChar
|
||||
<*> P.many (P.satisfy Unison.Syntax.Lexer.wordyIdChar)
|
||||
)
|
||||
|
||||
gitTreeishSuffix :: P Text
|
||||
gitTreeishSuffix = P.label "git treeish" . P.try $ do
|
||||
void $ C.char ':'
|
||||
P.takeWhile1P (Just "not close paren") (/= ')')
|
||||
|
||||
shortCausalHash :: P ShortCausalHash
|
||||
shortCausalHash = P.label "short causal hash" $ do
|
||||
void $ C.char '#'
|
||||
ShortCausalHash
|
||||
<$> P.takeWhile1P (Just "base32hex chars") (`elem` Base32Hex.validChars)
|
||||
|
@ -64,7 +64,6 @@ module Unison.CommandLine.InputPatterns
|
||||
findVerbose,
|
||||
findVerboseAll,
|
||||
forkLocal,
|
||||
gist,
|
||||
help,
|
||||
helpTopics,
|
||||
history,
|
||||
@ -163,8 +162,7 @@ import Unison.Codebase.Branch.Merge qualified as Branch
|
||||
import Unison.Codebase.Editor.Input (DeleteOutput (..), DeleteTarget (..), Input)
|
||||
import Unison.Codebase.Editor.Input qualified as Input
|
||||
import Unison.Codebase.Editor.Output.PushPull (PushPull (Pull, Push))
|
||||
import Unison.Codebase.Editor.Output.PushPull qualified as PushPull
|
||||
import Unison.Codebase.Editor.RemoteRepo (WriteGitRepo, WriteRemoteNamespace)
|
||||
import Unison.Codebase.Editor.RemoteRepo (WriteRemoteNamespace)
|
||||
import Unison.Codebase.Editor.SlurpResult qualified as SR
|
||||
import Unison.Codebase.Editor.UriParser (readRemoteNamespaceParser)
|
||||
import Unison.Codebase.Editor.UriParser qualified as UriParser
|
||||
@ -200,6 +198,7 @@ import Unison.Syntax.Name qualified as Name (parseText, unsafeParseText)
|
||||
import Unison.Syntax.NameSegment qualified as NameSegment (renderParseErr, segmentP)
|
||||
import Unison.Util.ColorText qualified as CT
|
||||
import Unison.Util.Monoid (intercalateMap)
|
||||
import Unison.Util.Monoid qualified as Monoid
|
||||
import Unison.Util.Pretty qualified as P
|
||||
import Unison.Util.Pretty.MegaParsec (prettyPrintParseError)
|
||||
|
||||
@ -2576,34 +2575,6 @@ createAuthor =
|
||||
_ -> Left $ showPatternHelp createAuthor
|
||||
)
|
||||
|
||||
gist :: InputPattern
|
||||
gist =
|
||||
InputPattern
|
||||
"push.gist"
|
||||
["gist"]
|
||||
I.Visible
|
||||
[("repository", Required, gitUrlArg)]
|
||||
( P.lines
|
||||
[ "Publish the current namespace.",
|
||||
"",
|
||||
P.wrapColumn2
|
||||
[ ( "`gist git(git@github.com:user/repo)`",
|
||||
"publishes the contents of the current namespace into the specified git repo."
|
||||
)
|
||||
],
|
||||
"",
|
||||
P.indentN 2 . P.wrap $
|
||||
"Note: Gists are not yet supported on Unison Share, though you can just do a normal"
|
||||
<> "`push.create` of the current namespace to your Unison Share codebase wherever you like!"
|
||||
]
|
||||
)
|
||||
( \case
|
||||
[repoString] -> do
|
||||
repo <- parseWriteGitRepo "gist git repo" repoString
|
||||
pure (Input.GistI (Input.GistInput repo))
|
||||
_ -> Left (showPatternHelp gist)
|
||||
)
|
||||
|
||||
authLogin :: InputPattern
|
||||
authLogin =
|
||||
InputPattern
|
||||
@ -2974,7 +2945,6 @@ validInputs =
|
||||
sfind,
|
||||
sfindReplace,
|
||||
forkLocal,
|
||||
gist,
|
||||
help,
|
||||
helpTopics,
|
||||
history,
|
||||
@ -3166,39 +3136,12 @@ filePathArg =
|
||||
fzfResolver = Nothing
|
||||
}
|
||||
|
||||
-- Arya: I could imagine completions coming from previous pulls
|
||||
gitUrlArg :: ArgumentType
|
||||
gitUrlArg =
|
||||
ArgumentType
|
||||
{ typeName = "git-url",
|
||||
suggestions =
|
||||
let complete s = pure [Completion s s False]
|
||||
in \input _ _ _ -> case input of
|
||||
"gh" -> complete "git(https://github.com/"
|
||||
"gl" -> complete "git(https://gitlab.com/"
|
||||
"bb" -> complete "git(https://bitbucket.com/"
|
||||
"ghs" -> complete "git(git@github.com:"
|
||||
"gls" -> complete "git(git@gitlab.com:"
|
||||
"bbs" -> complete "git(git@bitbucket.com:"
|
||||
_ -> pure [],
|
||||
fzfResolver = Nothing
|
||||
}
|
||||
|
||||
-- | Refers to a namespace on some remote code host.
|
||||
remoteNamespaceArg :: ArgumentType
|
||||
remoteNamespaceArg =
|
||||
ArgumentType
|
||||
{ typeName = "remote-namespace",
|
||||
suggestions =
|
||||
let complete s = pure [Completion s s False]
|
||||
in \input _cb http _p -> case input of
|
||||
"gh" -> complete "git(https://github.com/"
|
||||
"gl" -> complete "git(https://gitlab.com/"
|
||||
"bb" -> complete "git(https://bitbucket.com/"
|
||||
"ghs" -> complete "git(git@github.com:"
|
||||
"gls" -> complete "git(git@gitlab.com:"
|
||||
"bbs" -> complete "git(git@bitbucket.com:"
|
||||
_ -> sharePathCompletion http input,
|
||||
suggestions = \input _cb http _p -> sharePathCompletion http input,
|
||||
fzfResolver = Nothing
|
||||
}
|
||||
|
||||
@ -3655,27 +3598,18 @@ parseHashQualifiedName s =
|
||||
Right
|
||||
$ HQ.parseText (Text.pack s)
|
||||
|
||||
parseWriteGitRepo :: String -> String -> Either (P.Pretty P.ColorText) WriteGitRepo
|
||||
parseWriteGitRepo label input = do
|
||||
first
|
||||
(fromString . show) -- turn any parsing errors into a Pretty.
|
||||
(Megaparsec.parse (UriParser.writeGitRepo <* Megaparsec.eof) label (Text.pack input))
|
||||
|
||||
explainRemote :: PushPull -> P.Pretty CT.ColorText
|
||||
explainRemote pushPull =
|
||||
P.group $
|
||||
P.lines
|
||||
[ P.wrap $ "where `remote` is a hosted codebase, such as:",
|
||||
[ P.wrap $ "where `remote` is a project or project branch, such as:",
|
||||
P.indentN 2 . P.column2 $
|
||||
[ ("Unison Share", P.backticked "user.public.some.remote.path"),
|
||||
("Git + root", P.backticked $ "git(" <> gitRepo <> "user/repo)"),
|
||||
("Git + path", P.backticked $ "git(" <> gitRepo <> "user/repo).some.remote.path"),
|
||||
("Git + branch", P.backticked $ "git(" <> gitRepo <> "user/repo:some-branch)"),
|
||||
("Git + branch + path", P.backticked $ "git(" <> gitRepo <> "user/repo:some-branch).some.remote.path")
|
||||
[ ("Project (defaults to the /main branch)", P.backticked "@unison/base"),
|
||||
("Project Branch", P.backticked "@unison/base/feature"),
|
||||
("Contributor Branch", P.backticked "@unison/base/@johnsmith/feature")
|
||||
]
|
||||
<> Monoid.whenM (pushPull == Pull) [("Project Release", P.backticked "@unison/base/releases/1.0.0")]
|
||||
]
|
||||
where
|
||||
gitRepo = PushPull.fold @(P.Pretty P.ColorText) "git@github.com:" "https://github.com/" pushPull
|
||||
|
||||
megaparse :: Megaparsec.Parsec Void Text a -> Text -> Either (P.Pretty P.ColorText) a
|
||||
megaparse parser input =
|
||||
|
@ -35,7 +35,6 @@ import U.Codebase.Branch (NamespaceStats (..))
|
||||
import U.Codebase.Branch.Diff (NameChanges (..))
|
||||
import U.Codebase.HashTags (CausalHash (..))
|
||||
import U.Codebase.Reference qualified as Reference
|
||||
import U.Codebase.Sqlite.DbId (SchemaVersion (SchemaVersion))
|
||||
import U.Codebase.Sqlite.Project (Project (..))
|
||||
import U.Codebase.Sqlite.ProjectBranch (ProjectBranch (..))
|
||||
import Unison.ABT qualified as ABT
|
||||
@ -63,7 +62,6 @@ import Unison.Codebase.Editor.RemoteRepo (ShareUserHandle (..), WriteRemoteNames
|
||||
import Unison.Codebase.Editor.RemoteRepo qualified as RemoteRepo
|
||||
import Unison.Codebase.Editor.SlurpResult qualified as SlurpResult
|
||||
import Unison.Codebase.Editor.TodoOutput qualified as TO
|
||||
import Unison.Codebase.GitError
|
||||
import Unison.Codebase.IntegrityCheck (IntegrityResult (..), prettyPrintIntegrityErrors)
|
||||
import Unison.Codebase.Patch (Patch (..))
|
||||
import Unison.Codebase.Patch qualified as Patch
|
||||
@ -73,9 +71,7 @@ import Unison.Codebase.Runtime qualified as Runtime
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash)
|
||||
import Unison.Codebase.ShortCausalHash qualified as SCH
|
||||
import Unison.Codebase.SqliteCodebase.Conversions qualified as Cv
|
||||
import Unison.Codebase.SqliteCodebase.GitError (GitSqliteCodebaseError (..))
|
||||
import Unison.Codebase.TermEdit qualified as TermEdit
|
||||
import Unison.Codebase.Type (GitError (GitCodebaseError, GitProtocolError, GitSqliteCodebaseError))
|
||||
import Unison.Codebase.TypeEdit qualified as TypeEdit
|
||||
import Unison.CommandLine (bigproblem, note, tip)
|
||||
import Unison.CommandLine.FZFResolvers qualified as FZFResolvers
|
||||
@ -1092,133 +1088,6 @@ notifyUser dir = \case
|
||||
pure . P.wrap $
|
||||
"I loaded " <> P.text sourceName <> " and didn't find anything."
|
||||
else pure mempty
|
||||
GitError e -> pure $ case e of
|
||||
GitSqliteCodebaseError e -> case e of
|
||||
CodebaseFileLockFailed ->
|
||||
P.wrap $
|
||||
"It looks to me like another ucm process is using this codebase. Only one ucm process can use a codebase at a time."
|
||||
NoDatabaseFile repo localPath ->
|
||||
P.wrap $
|
||||
"I didn't find a codebase in the repository at"
|
||||
<> prettyReadGitRepo repo
|
||||
<> "in the cache directory at"
|
||||
<> P.backticked' (P.string localPath) "."
|
||||
CodebaseRequiresMigration (SchemaVersion fromSv) (SchemaVersion toSv) -> do
|
||||
P.wrap $
|
||||
"The specified codebase codebase is on version "
|
||||
<> P.shown fromSv
|
||||
<> " but needs to be on version "
|
||||
<> P.shown toSv
|
||||
UnrecognizedSchemaVersion repo localPath (SchemaVersion v) ->
|
||||
P.wrap $
|
||||
"I don't know how to interpret schema version "
|
||||
<> P.shown v
|
||||
<> "in the repository at"
|
||||
<> prettyReadGitRepo repo
|
||||
<> "in the cache directory at"
|
||||
<> P.backticked' (P.string localPath) "."
|
||||
GitCouldntParseRootBranchHash repo s ->
|
||||
P.wrap $
|
||||
"I couldn't parse the string"
|
||||
<> P.red (P.string s)
|
||||
<> "into a namespace hash, when opening the repository at"
|
||||
<> P.group (prettyReadGitRepo repo <> ".")
|
||||
GitProtocolError e -> case e of
|
||||
NoGit ->
|
||||
P.wrap $
|
||||
"I couldn't find git. Make sure it's installed and on your path."
|
||||
CleanupError e ->
|
||||
P.wrap $
|
||||
"I encountered an exception while trying to clean up a git cache directory:"
|
||||
<> P.group (P.shown e)
|
||||
CloneException repo msg ->
|
||||
P.wrap $
|
||||
"I couldn't clone the repository at"
|
||||
<> prettyReadGitRepo repo
|
||||
<> ";"
|
||||
<> "the error was:"
|
||||
<> (P.indentNAfterNewline 2 . P.group . P.string) msg
|
||||
CopyException srcRepoPath destPath msg ->
|
||||
P.wrap $
|
||||
"I couldn't copy the repository at"
|
||||
<> P.string srcRepoPath
|
||||
<> "into"
|
||||
<> P.string destPath
|
||||
<> ";"
|
||||
<> "the error was:"
|
||||
<> (P.indentNAfterNewline 2 . P.group . P.string) msg
|
||||
PushNoOp repo ->
|
||||
P.wrap $
|
||||
"The repository at" <> prettyWriteGitRepo repo <> "is already up-to-date."
|
||||
PushException repo msg ->
|
||||
P.wrap $
|
||||
"I couldn't push to the repository at"
|
||||
<> prettyWriteGitRepo repo
|
||||
<> ";"
|
||||
<> "the error was:"
|
||||
<> (P.indentNAfterNewline 2 . P.group . P.string) msg
|
||||
RemoteRefNotFound repo ref ->
|
||||
P.wrap $
|
||||
"I couldn't find the ref " <> P.green (P.text ref) <> " in the repository at " <> P.blue (P.text repo) <> ";"
|
||||
UnrecognizableCacheDir uri localPath ->
|
||||
P.wrap $
|
||||
"A cache directory for"
|
||||
<> P.backticked (P.text $ RemoteRepo.printReadGitRepo uri)
|
||||
<> "already exists at"
|
||||
<> P.backticked' (P.string localPath) ","
|
||||
<> "but it doesn't seem to"
|
||||
<> "be a git repository, so I'm not sure what to do next. Delete it?"
|
||||
UnrecognizableCheckoutDir uri localPath ->
|
||||
P.wrap $
|
||||
"I tried to clone"
|
||||
<> P.backticked (P.text $ RemoteRepo.printReadGitRepo uri)
|
||||
<> "into a cache directory at"
|
||||
<> P.backticked' (P.string localPath) ","
|
||||
<> "but I can't recognize the"
|
||||
<> "result as a git repository, so I'm not sure what to do next."
|
||||
PushDestinationHasNewStuff repo ->
|
||||
P.callout "⏸" . P.lines $
|
||||
[ P.wrap $
|
||||
"The repository at"
|
||||
<> prettyWriteGitRepo repo
|
||||
<> "has some changes I don't know about.",
|
||||
"",
|
||||
P.wrap $ "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
|
||||
GitCodebaseError e -> case e of
|
||||
CouldntFindRemoteBranch repo path ->
|
||||
P.wrap $
|
||||
"I couldn't find the remote branch at"
|
||||
<> P.shown path
|
||||
<> "in the repository at"
|
||||
<> prettyReadGitRepo repo
|
||||
NoRemoteNamespaceWithHash repo sch ->
|
||||
P.wrap $
|
||||
"The repository at"
|
||||
<> prettyReadGitRepo repo
|
||||
<> "doesn't contain a namespace with the hash prefix"
|
||||
<> (P.blue . P.text . SCH.toText) sch
|
||||
RemoteNamespaceHashAmbiguous repo sch hashes ->
|
||||
P.lines
|
||||
[ P.wrap $
|
||||
"The namespace hash"
|
||||
<> prettySCH sch
|
||||
<> "at"
|
||||
<> prettyReadGitRepo repo
|
||||
<> "is ambiguous."
|
||||
<> "Did you mean one of these hashes?",
|
||||
"",
|
||||
P.indentN 2 $
|
||||
P.lines
|
||||
( prettySCH . SCH.fromHash ((Text.length . SCH.toText) sch * 2)
|
||||
<$> Set.toList hashes
|
||||
),
|
||||
"",
|
||||
P.wrap "Try again with a few more hash characters to disambiguate."
|
||||
]
|
||||
BustedBuiltins (Set.toList -> new) (Set.toList -> old) ->
|
||||
-- todo: this could be prettier! Have a nice list like `find` gives, but
|
||||
-- that requires querying the codebase to determine term types. Probably
|
||||
@ -1267,7 +1136,7 @@ notifyUser dir = \case
|
||||
"Type `help " <> PushPull.fold "push" "pull" pp <> "` for more information."
|
||||
]
|
||||
|
||||
-- | ConfiguredGitUrlParseError PushPull Path' Text String
|
||||
-- | ConfiguredRemoteMappingParseError PushPull Path' Text String
|
||||
ConfiguredRemoteMappingParseError pp p url err ->
|
||||
pure . P.fatalCallout . P.lines $
|
||||
[ P.wrap $
|
||||
|
@ -1,732 +0,0 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
|
||||
module Unison.Test.GitSync where
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
import Data.String.Here.Interpolated (i)
|
||||
import Data.Text qualified as Text
|
||||
import EasyTest
|
||||
import Shellmet ()
|
||||
import System.Directory (removePathForcibly)
|
||||
import System.FilePath ((</>))
|
||||
import System.IO.Temp qualified as Temp
|
||||
import Unison.Codebase (Codebase)
|
||||
import Unison.Codebase qualified as Codebase
|
||||
import Unison.Parser.Ann (Ann)
|
||||
import Unison.Prelude
|
||||
import Unison.Symbol (Symbol)
|
||||
import Unison.Test.Ucm (CodebaseFormat, Transcript)
|
||||
import Unison.Test.Ucm qualified as Ucm
|
||||
import Unison.WatchKind (pattern TestWatch)
|
||||
|
||||
transcriptOutputFile :: String -> FilePath
|
||||
transcriptOutputFile name =
|
||||
(".." </> "unison-src" </> "transcripts" </> ("GitSync22." ++ name ++ ".output.md"))
|
||||
|
||||
-- keep it off for CI, since the random temp dirs it generates show up in the
|
||||
-- output, which causes the test output to change, and the "no change" check
|
||||
-- to fail
|
||||
writeTranscriptOutput :: Bool
|
||||
writeTranscriptOutput = False
|
||||
|
||||
test :: Test ()
|
||||
test =
|
||||
scope "gitsync22" . tests $
|
||||
fastForwardPush
|
||||
: nonFastForwardPush
|
||||
: destroyedRemote
|
||||
: flip
|
||||
map
|
||||
[(Ucm.CodebaseFormat2, "sc")]
|
||||
\(fmt, name) ->
|
||||
scope name $
|
||||
tests
|
||||
[ pushPullTest
|
||||
"pull-over-deleted-namespace"
|
||||
fmt
|
||||
( \repo ->
|
||||
[i|
|
||||
```unison:hide
|
||||
x = 1
|
||||
```
|
||||
```ucm:hide
|
||||
.> add
|
||||
.> push.create git(${repo})
|
||||
```
|
||||
|]
|
||||
)
|
||||
( \repo ->
|
||||
[i|
|
||||
```unison:hide
|
||||
child.y = 2
|
||||
```
|
||||
|
||||
Should be able to pull a branch from the repo over top of our deleted local branch.
|
||||
```ucm
|
||||
.> add
|
||||
.> delete.namespace child
|
||||
.> pull git(${repo}) child
|
||||
```
|
||||
|]
|
||||
),
|
||||
pushPullTest
|
||||
"pull.without-history"
|
||||
fmt
|
||||
( \repo ->
|
||||
[i|
|
||||
```unison:hide
|
||||
child.x = 1
|
||||
```
|
||||
|
||||
```ucm:hide
|
||||
.> add
|
||||
```
|
||||
|
||||
```unison:hide
|
||||
child.y = 2
|
||||
```
|
||||
|
||||
```ucm:hide
|
||||
.> add
|
||||
```
|
||||
|
||||
```unison:hide
|
||||
child.x = 3
|
||||
```
|
||||
|
||||
```ucm:hide
|
||||
.> update
|
||||
.> push.create git(${repo})
|
||||
```
|
||||
|]
|
||||
)
|
||||
( \repo ->
|
||||
[i|
|
||||
Should be able to pull the branch from the remote without its history.
|
||||
Note that this only tests that the pull succeeds, since (at time of writing) we don't
|
||||
track/test transcript output for these tests in the unison repo.
|
||||
```ucm
|
||||
.> pull.without-history git(${repo}):.child .child
|
||||
.> history .child
|
||||
```
|
||||
|]
|
||||
),
|
||||
pushPullTest
|
||||
"push-over-deleted-namespace"
|
||||
fmt
|
||||
( \repo ->
|
||||
[i|
|
||||
```unison:hide
|
||||
child.x = 1
|
||||
y = 2
|
||||
```
|
||||
```ucm:hide
|
||||
.> add
|
||||
.> delete.namespace child
|
||||
.> push.create git(${repo})
|
||||
```
|
||||
|]
|
||||
)
|
||||
( \repo ->
|
||||
[i|
|
||||
```unison:hide
|
||||
child.z = 3
|
||||
```
|
||||
|
||||
Should be able to push a branch over top of a deleted remote branch.
|
||||
```ucm
|
||||
.> add
|
||||
.> push.create git(${repo}).child child
|
||||
```
|
||||
|]
|
||||
),
|
||||
pushPullTest
|
||||
"typeAlias"
|
||||
fmt
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.> alias.type ##Nat builtin.Nat
|
||||
.> history
|
||||
.> history builtin
|
||||
.> push.create git(${repo})
|
||||
```
|
||||
|]
|
||||
)
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.> pull git(${repo})
|
||||
```
|
||||
```unison
|
||||
x : Nat
|
||||
x = 3
|
||||
```
|
||||
|]
|
||||
),
|
||||
pushPullTest
|
||||
"topLevelTerm"
|
||||
fmt
|
||||
( \repo ->
|
||||
[i|
|
||||
```unison:hide
|
||||
y = 3
|
||||
```
|
||||
```ucm
|
||||
.> add
|
||||
.> history
|
||||
.> push.create git(${repo})
|
||||
```
|
||||
|]
|
||||
)
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.> pull git(${repo})
|
||||
.> find
|
||||
```
|
||||
```unison
|
||||
> y
|
||||
```
|
||||
|]
|
||||
),
|
||||
pushPullTest
|
||||
"subNamespace"
|
||||
fmt
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.> alias.type ##Nat builtin.Nat
|
||||
```
|
||||
```unison
|
||||
unique type a.b.C = C Nat
|
||||
a.b.d = 4
|
||||
```
|
||||
```ucm
|
||||
.> add
|
||||
.> push.create git(${repo})
|
||||
```
|
||||
|]
|
||||
)
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.> pull.silent git(${repo})
|
||||
.> find
|
||||
```
|
||||
```unison
|
||||
> a.b.C.C a.b.d
|
||||
```
|
||||
|]
|
||||
),
|
||||
pushPullTest
|
||||
"accessPatch"
|
||||
fmt
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.> alias.type ##Nat builtin.Nat
|
||||
```
|
||||
```unison:hide
|
||||
unique type A = A Nat
|
||||
foo = A.A 3
|
||||
```
|
||||
```ucm
|
||||
.> debug.file
|
||||
.> add
|
||||
```
|
||||
```unison:hide
|
||||
unique type A = A Nat Nat
|
||||
foo = A.A 3 3
|
||||
```
|
||||
```ucm
|
||||
.> debug.file
|
||||
.> update
|
||||
```
|
||||
```ucm
|
||||
.> view.patch patch
|
||||
.> push.create git(${repo})
|
||||
```
|
||||
|]
|
||||
)
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.> pull.silent git(${repo})
|
||||
.> view.patch patch
|
||||
```
|
||||
|]
|
||||
),
|
||||
pushPullTest
|
||||
"history"
|
||||
fmt
|
||||
( \repo ->
|
||||
[i|
|
||||
```unison
|
||||
foo = 3
|
||||
```
|
||||
```ucm
|
||||
.> add
|
||||
```
|
||||
```unison
|
||||
foo = 4
|
||||
```
|
||||
```ucm
|
||||
.> update
|
||||
.> history
|
||||
.> push.create git(${repo})
|
||||
```
|
||||
|]
|
||||
)
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.> pull git(${repo})
|
||||
.> history
|
||||
.> reset-root #l43v9nr16v
|
||||
.> history
|
||||
```
|
||||
|] -- Not sure why this hash is here.
|
||||
-- Is it to test `reset-root`?
|
||||
-- Or to notice a change in hashing?
|
||||
-- Or to test that two distinct points of history were pulled?
|
||||
-- It would be great to not need the explicit hash here,
|
||||
-- since it does change periodically.
|
||||
-- Though, I guess that should also be rare, so maybe this is fine.
|
||||
),
|
||||
pushPullTest
|
||||
"one-term"
|
||||
fmt
|
||||
-- simplest-author
|
||||
( \repo ->
|
||||
[i|
|
||||
```unison
|
||||
c = 3
|
||||
```
|
||||
```ucm
|
||||
.> debug.file
|
||||
.myLib> add
|
||||
.myLib> push.create git(${repo})
|
||||
```
|
||||
|]
|
||||
)
|
||||
-- simplest-user
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.yourLib> pull git(${repo})
|
||||
```
|
||||
```unison
|
||||
> c
|
||||
```
|
||||
|]
|
||||
),
|
||||
pushPullTest
|
||||
"one-type"
|
||||
fmt
|
||||
-- simplest-author
|
||||
( \repo ->
|
||||
[i|
|
||||
```unison
|
||||
structural type Foo = Foo
|
||||
```
|
||||
```ucm
|
||||
.myLib> debug.file
|
||||
.myLib> add
|
||||
.myLib> push.create git(${repo})
|
||||
```
|
||||
|]
|
||||
)
|
||||
-- simplest-user
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.yourLib> pull git(${repo})
|
||||
```
|
||||
```unison
|
||||
> Foo.Foo
|
||||
```
|
||||
|]
|
||||
),
|
||||
pushPullTest
|
||||
"patching"
|
||||
fmt
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.myLib> alias.term ##Nat.+ +
|
||||
```
|
||||
```unison
|
||||
improveNat x = x + 3
|
||||
```
|
||||
```ucm
|
||||
.myLib> add
|
||||
.myLib> ls
|
||||
.myLib> move.namespace .myLib .workaround1552.myLib.v1
|
||||
.workaround1552.myLib> ls
|
||||
.workaround1552.myLib> fork v1 v2
|
||||
.workaround1552.myLib.v2>
|
||||
```
|
||||
```unison
|
||||
improveNat x = x + 100
|
||||
```
|
||||
```ucm
|
||||
.workaround1552.myLib.v2> update
|
||||
.workaround1552.myLib> push.create git(${repo})
|
||||
```
|
||||
|]
|
||||
)
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.myApp> pull git(${repo}).v1 external.yourLib
|
||||
.myApp> alias.term ##Nat.* *
|
||||
````
|
||||
```unison
|
||||
greatApp = improveNat 5 * improveNat 6
|
||||
> greatApp
|
||||
```
|
||||
```ucm
|
||||
.myApp> add
|
||||
.myApp> pull git(${repo}).v2 external.yourLib
|
||||
```
|
||||
```unison
|
||||
> greatApp
|
||||
```
|
||||
```ucm
|
||||
.myApp> patch external.yourLib.patch
|
||||
```
|
||||
```unison
|
||||
> greatApp
|
||||
```
|
||||
|]
|
||||
),
|
||||
-- TODO: remove the alias.type .defns.A A line once patch syncing is fixed
|
||||
pushPullTest
|
||||
"lightweightPatch"
|
||||
fmt
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.> builtins.merge
|
||||
```
|
||||
```unison
|
||||
structural type A = A Nat
|
||||
structural type B = B Int
|
||||
x = 3
|
||||
y = 4
|
||||
```
|
||||
```ucm
|
||||
.defns> add
|
||||
.patches> replace .defns.A .defns.B
|
||||
.patches> alias.type .defns.A A
|
||||
.patches> replace .defns.x .defns.y
|
||||
.patches> push.create git(${repo})
|
||||
```
|
||||
|]
|
||||
)
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.> builtins.merge
|
||||
.> pull git(${repo}) patches
|
||||
.> view.patch patches.patch
|
||||
```
|
||||
|]
|
||||
),
|
||||
watchPushPullTest
|
||||
"test-watches"
|
||||
fmt
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.> builtins.merge
|
||||
```
|
||||
```unison
|
||||
test> pass = [Ok "Passed"]
|
||||
```
|
||||
```ucm
|
||||
.> add
|
||||
.> push.create git(${repo})
|
||||
```
|
||||
|]
|
||||
)
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.> pull git(${repo})
|
||||
```
|
||||
|]
|
||||
)
|
||||
( \cb -> do
|
||||
Codebase.runTransaction cb do
|
||||
void . fmap (fromJust . sequence) $
|
||||
traverse (Codebase.getWatch cb TestWatch)
|
||||
=<< Codebase.watches TestWatch
|
||||
),
|
||||
gistTest fmt,
|
||||
pushPullBranchesTests fmt,
|
||||
pushPullTest
|
||||
"fix2068_a_"
|
||||
fmt
|
||||
-- this triggers
|
||||
{-
|
||||
gitsync22.sc.fix2068(a) EXCEPTION!!!: Called SqliteCodebase.setNamespaceRoot on unknown causal hash CausalHash (fromBase32Hex "codddvgt1ep57qpdkhe2j4pe1ehlpi5iitcrludtb8ves1aaqjl453onvfphqg83vukl7bbrj49itceqfob2b3alf47u4vves5s7pog")
|
||||
CallStack (from HasCallStack):
|
||||
error, called at src/Unison/Codebase/SqliteCodebase.hs:1072:17 in unison-parser-typechecker-0.0.0-6U6boimwb8GAC5qrhLfs8h:Unison.Codebase.SqliteCodebase
|
||||
-}
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.> alias.type ##Nat builtin.Nat2
|
||||
.> alias.type ##Int builtin.Int2
|
||||
.> push.create git(${repo}).foo.bar
|
||||
```
|
||||
|]
|
||||
)
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.> pull git(${repo}) pulled
|
||||
.> view pulled.foo.bar.builtin.Nat2
|
||||
.> view pulled.foo.bar.builtin.Int2
|
||||
```
|
||||
|]
|
||||
),
|
||||
pushPullTest
|
||||
"fix2068_b_"
|
||||
fmt
|
||||
-- this triggers
|
||||
{-
|
||||
- gitsync22.sc.fix2068(b) EXCEPTION!!!: I couldn't find the hash ndn6fa85ggqtbgffqhd4d3bca2d08pgp3im36oa8k6p257aid90ovjq75htmh7lmg7akaqneva80ml1o21iscjmp9n1uc3lmqgg9rgg that I just synced to the cached copy of /private/var/folders/6m/p3szds2j67d8vwmxr51yrf5c0000gn/T/git-simple-1047398c149d3d5c/repo.git in "/Users/pchiusano/.cache/unisonlanguage/gitfiles/$x2F$private$x2F$var$x2F$folders$x2F$6m$x2F$p3szds2j67d8vwmxr51yrf5c0000gn$x2F$T$x2F$git-simple-1047398c149d3d5c$x2F$repo$dot$git".
|
||||
CallStack (from HasCallStack):
|
||||
error, called at src/Unison/Codebase/SqliteCodebase.hs:1046:13 in unison-parser-typechecker-0.0.0-6U6boimwb8GAC5qrhLfs8h:Unison.Codebase.SqliteCodebase
|
||||
-}
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.> alias.type ##Nat builtin.Nat2
|
||||
.> alias.type ##Int builtin.Int2
|
||||
.> push.create git(${repo})
|
||||
.> push.create git(${repo}).foo.bar
|
||||
```
|
||||
|]
|
||||
)
|
||||
( \repo ->
|
||||
[i|
|
||||
```ucm
|
||||
.> pull git(${repo}) pulled
|
||||
.> view pulled.foo.bar.builtin.Nat2
|
||||
.> view pulled.foo.bar.builtin.Int2
|
||||
```
|
||||
|]
|
||||
)
|
||||
]
|
||||
|
||||
pushPullTest :: String -> CodebaseFormat -> (FilePath -> Transcript) -> (FilePath -> Transcript) -> Test ()
|
||||
pushPullTest name fmt authorScript userScript = scope name do
|
||||
io do
|
||||
repo <- initGitRepo
|
||||
author <- Ucm.initCodebase fmt
|
||||
authorOutput <- Ucm.runTranscript author (authorScript repo)
|
||||
user <- Ucm.initCodebase fmt
|
||||
userOutput <- Ucm.runTranscript user (userScript repo)
|
||||
|
||||
when writeTranscriptOutput $
|
||||
writeUtf8
|
||||
(transcriptOutputFile name)
|
||||
(Text.pack $ authorOutput <> "\n-------\n" <> userOutput)
|
||||
|
||||
-- if we haven't crashed, clean up!
|
||||
removePathForcibly repo
|
||||
Ucm.deleteCodebase author
|
||||
Ucm.deleteCodebase user
|
||||
ok
|
||||
|
||||
watchPushPullTest :: String -> CodebaseFormat -> (FilePath -> Transcript) -> (FilePath -> Transcript) -> (Codebase IO Symbol Ann -> IO ()) -> Test ()
|
||||
watchPushPullTest name fmt authorScript userScript codebaseCheck = scope name do
|
||||
io do
|
||||
repo <- initGitRepo
|
||||
author <- Ucm.initCodebase fmt
|
||||
authorOutput <- Ucm.runTranscript author (authorScript repo)
|
||||
user <- Ucm.initCodebase fmt
|
||||
userOutput <- Ucm.runTranscript user (userScript repo)
|
||||
Ucm.lowLevel user codebaseCheck
|
||||
|
||||
when writeTranscriptOutput $
|
||||
writeUtf8
|
||||
(transcriptOutputFile name)
|
||||
(Text.pack $ authorOutput <> "\n-------\n" <> userOutput)
|
||||
|
||||
-- if we haven't crashed, clean up!
|
||||
removePathForcibly repo
|
||||
Ucm.deleteCodebase author
|
||||
Ucm.deleteCodebase user
|
||||
ok
|
||||
|
||||
gistTest :: CodebaseFormat -> Test ()
|
||||
gistTest fmt =
|
||||
pushPullTest "gist" fmt authorScript userScript
|
||||
where
|
||||
authorScript repo =
|
||||
[i|
|
||||
```unison:hide
|
||||
y = 3
|
||||
```
|
||||
```ucm
|
||||
.> add
|
||||
.> gist git(${repo})
|
||||
```
|
||||
|]
|
||||
userScript repo =
|
||||
[i|
|
||||
```ucm
|
||||
.> pull git(${repo})#td09c6jlks
|
||||
.> find
|
||||
```
|
||||
```unison
|
||||
> y
|
||||
```
|
||||
|]
|
||||
|
||||
pushPullBranchesTests :: CodebaseFormat -> Test ()
|
||||
pushPullBranchesTests fmt = scope "branches" $ do
|
||||
simplePushPull
|
||||
multiplePushPull
|
||||
emptyBranchFailure
|
||||
where
|
||||
simplePushPull =
|
||||
let authorScript repo =
|
||||
[i|
|
||||
```unison:hide
|
||||
y = 3
|
||||
```
|
||||
```ucm
|
||||
.> add
|
||||
.> push.create git(${repo}:mybranch).path
|
||||
```
|
||||
|]
|
||||
userScript repo =
|
||||
[i|
|
||||
```ucm
|
||||
.> pull git(${repo}:mybranch) .dest
|
||||
.> view .dest.path.y
|
||||
```
|
||||
|]
|
||||
in pushPullTest "simple" fmt authorScript userScript
|
||||
emptyBranchFailure =
|
||||
let authorScript _repo = ""
|
||||
userScript repo =
|
||||
[i|
|
||||
```ucm:error
|
||||
.> pull git(${repo}:mybranch) .dest
|
||||
```
|
||||
|]
|
||||
in pushPullTest "empty" fmt authorScript userScript
|
||||
multiplePushPull =
|
||||
let authorScript repo =
|
||||
[i|
|
||||
```unison:hide
|
||||
ns1.x = 10
|
||||
ns2.y = 20
|
||||
```
|
||||
```ucm
|
||||
.> add
|
||||
.> push.create git(${repo}:mybranch).ns1 .ns1
|
||||
.> push.create git(${repo}:mybranch).ns2 .ns2
|
||||
```
|
||||
```unison
|
||||
ns1.x = 11
|
||||
ns1.new = 12
|
||||
```
|
||||
```ucm
|
||||
.> update
|
||||
.> push git(${repo}:mybranch).ns1 .ns1
|
||||
```
|
||||
|]
|
||||
userScript repo =
|
||||
[i|
|
||||
```ucm
|
||||
.> pull git(${repo}:mybranch).ns1 .ns1
|
||||
.> pull git(${repo}:mybranch).ns2 .ns2
|
||||
.> view .ns1.x
|
||||
.> view .ns1.new
|
||||
.> view .ns2.y
|
||||
```
|
||||
|]
|
||||
in pushPullTest "multiple" fmt authorScript userScript
|
||||
|
||||
fastForwardPush :: Test ()
|
||||
fastForwardPush = scope "fastforward-push" do
|
||||
io do
|
||||
repo <- initGitRepo
|
||||
author <- Ucm.initCodebase Ucm.CodebaseFormat2
|
||||
void $
|
||||
Ucm.runTranscript
|
||||
author
|
||||
[i|
|
||||
```ucm
|
||||
.lib> alias.type ##Nat Nat
|
||||
.lib> push.create git(${repo})
|
||||
.lib> alias.type ##Int Int
|
||||
.lib> push git(${repo})
|
||||
```
|
||||
|]
|
||||
ok
|
||||
|
||||
nonFastForwardPush :: Test ()
|
||||
nonFastForwardPush = scope "non-fastforward-push" do
|
||||
io do
|
||||
repo <- initGitRepo
|
||||
author <- Ucm.initCodebase Ucm.CodebaseFormat2
|
||||
void $
|
||||
Ucm.runTranscript
|
||||
author
|
||||
[i|
|
||||
```ucm:error
|
||||
.lib> alias.type ##Nat Nat
|
||||
.lib> push git(${repo})
|
||||
.lib2> alias.type ##Int Int
|
||||
.lib2> push git(${repo})
|
||||
```
|
||||
|]
|
||||
ok
|
||||
|
||||
destroyedRemote :: Test ()
|
||||
destroyedRemote = scope "destroyed-remote" do
|
||||
io do
|
||||
repo <- initGitRepo
|
||||
codebase <- Ucm.initCodebase Ucm.CodebaseFormat2
|
||||
void $
|
||||
Ucm.runTranscript
|
||||
codebase
|
||||
[i|
|
||||
```ucm
|
||||
.lib> alias.type ##Nat Nat
|
||||
.lib> push.create git(${repo})
|
||||
```
|
||||
|]
|
||||
reinitRepo repo
|
||||
void $
|
||||
Ucm.runTranscript
|
||||
codebase
|
||||
[i|
|
||||
```ucm
|
||||
.lib> push.create git(${repo})
|
||||
```
|
||||
|]
|
||||
ok
|
||||
where
|
||||
reinitRepo repoStr@(Text.pack -> repo) = do
|
||||
removePathForcibly repoStr
|
||||
"git" ["init", "--bare", repo]
|
||||
|
||||
initGitRepo :: IO FilePath
|
||||
initGitRepo = do
|
||||
tmp <- Temp.getCanonicalTemporaryDirectory >>= flip Temp.createTempDirectory ("git-simple")
|
||||
let repo = tmp </> "repo.git"
|
||||
"git" ["init", "--bare", Text.pack repo]
|
||||
pure repo
|
@ -1,6 +1,6 @@
|
||||
cabal-version: 1.12
|
||||
|
||||
-- This file has been generated from package.yaml by hpack version 0.36.0.
|
||||
-- This file has been generated from package.yaml by hpack version 0.35.2.
|
||||
--
|
||||
-- see: https://github.com/sol/hpack
|
||||
|
||||
@ -427,7 +427,6 @@ test-suite cli-tests
|
||||
other-modules:
|
||||
Unison.Test.ClearCache
|
||||
Unison.Test.Cli.Monad
|
||||
Unison.Test.GitSync
|
||||
Unison.Test.LSP
|
||||
Unison.Test.Ucm
|
||||
Unison.Test.UriParser
|
||||
|
Loading…
Reference in New Issue
Block a user