unisonweb/unison
1
0
Fork 0
mirror of https://github.com/unisonweb/unison.git synced 2024-09-11 10:35:57 +03:00
Code Issues Projects Releases Wiki Activity

remove git push/pull

Browse Source
This commit is contained in:
Chris Penner 2024-05-28 09:38:49 -07:00
parent 5732d9a822
commit 1b5c93da11
24 changed files with 37 additions and 2176 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
lib/unison-prelude/src/Unison/Debug.hs
View File

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

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

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

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

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

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

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

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

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

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

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

13
parser-typechecker/src/Unison/Codebase/SqliteCodebase/GitError.hs
View 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)

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

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

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

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

35
unison-cli/src/Unison/Cli/DownloadUtils.hs
View File

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

3
unison-cli/src/Unison/Cli/MergeTypes.hs
View File

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

19
unison-cli/src/Unison/Cli/Pretty.hs
View File

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

14
unison-cli/src/Unison/Cli/UnisonConfigUtils.hs
View File

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

732
unison-cli/tests/Unison/Test/GitSync.hs
View File

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

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

@ -1,6 +1,6 @@
cabal-version: 1.12
-- This file has been generated from package.yaml by hpack version 0.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