Merge pull request #976 from unisonweb/topic/971-git-error

fix #971 — `push` to empty repo fails

parser-typechecker/src/Unison/Codebase/BranchLoadMode.hs

@@ -0,0 +1,9 @@
+module Unison.Codebase.BranchLoadMode where
+
+-- When loading a nonexistent branch, what should happen?
+-- Could bomb (`FailIfMissing`) or return the empty branch (`EmptyIfMissing`).
+--
+-- `EmptyIfMissing` mode is used when attempting to load a user-specified
+-- branch. `FailIfMissing` is used when loading the root branch - if the root
+-- does not exist, that's a serious problem.
+data BranchLoadMode = FailIfMissing | EmptyIfMissing deriving (Eq, Show)

parser-typechecker/src/Unison/Codebase/Editor/Command.hs

@@ -38,6 +38,7 @@ import           Unison.ShortHash               ( ShortHash )
 import           Unison.Type                    ( Type )
 import           Unison.Codebase.ShortBranchHash
                                                 ( ShortBranchHash )
+import Unison.Codebase.BranchLoadMode (BranchLoadMode)
 
 
 type AmbientAbilities v = [Type v Ann]
@@ -127,7 +128,7 @@ data Command m i v a where
   LoadLocalBranch :: Branch.Hash -> Command m i v (Branch m)
 
   LoadRemoteRootBranch ::
-    RemoteRepo -> Command m i v (Either GitError (Branch m))
+    BranchLoadMode -> RemoteRepo -> Command m i v (Either GitError (Branch m))
   
   -- returns NoRemoteNamespaceWithHash or RemoteNamespaceHashAmbiguous 
   -- if no exact match.

parser-typechecker/src/Unison/Codebase/Editor/Git.hs

@@ -74,27 +74,30 @@ shallowPullFromGit localPath url gitBranch = do
 pullGitRootBranch
   :: MonadIO m
   => FilePath
+  -> BranchLoadMode
   -> Codebase m v a
   -> Text
   -> Maybe Text
   -> ExceptT GitError m (Branch m)
-pullGitRootBranch localPath codebase url treeish =
-  pullGitBranch localPath codebase url treeish Nothing
+pullGitRootBranch localPath loadMode codebase url treeish =
+  pullGitBranch localPath codebase url treeish (Left loadMode)
 
 -- pull repo & load arbitrary branch
+-- if `loadInfo` is Left, we try to load the root branch;
+-- if Right, we try to load the specified hash
 pullGitBranch
   :: MonadIO m
   => FilePath
   -> Codebase m v a
   -> Text
   -> Maybe Text
-  -> Maybe ShortBranchHash
+  -> Either BranchLoadMode ShortBranchHash
   -> ExceptT GitError m (Branch m)
-pullGitBranch localPath codebase url treeish sbh = do
+pullGitBranch localPath codebase url treeish loadInfo = do
   pullFromGit localPath url treeish
-  branch <- case sbh of
-    Nothing -> lift $ FC.getRootBranch (localPath </> codebasePath)
-    Just sbh -> do
+  branch <- case loadInfo of
+    Left loadMode -> lift $ FC.getRootBranch loadMode gitCodebasePath
+    Right sbh -> do
       branchCompletions <- lift $ FC.branchHashesByPrefix gitCodebasePath sbh
       case toList branchCompletions of
         [] -> throwError $ NoRemoteNamespaceWithHash url treeish sbh
@@ -122,15 +125,8 @@ clone :: MonadError GitError m => MonadIO m => Text -> FilePath -> m ()
 clone uri localPath = "git" ["clone", uri, Text.pack localPath]
   `onError` throwError (NoRemoteRepoAt uri)
 
-shallowClone :: MonadError GitError m => MonadIO m => Text -> FilePath -> m ()
-shallowClone uri localPath =
-  "git" ["clone", "--depth=1", uri, Text.pack localPath]
-    `onError` throwError (NoRemoteRepoAt uri)
-
 pull :: MonadError GitError m => MonadIO m => FilePath -> Text -> Maybe Text -> m ()
-pull localPath uri treeish = do
-  gitIn localPath (["fetch", uri] ++ toList treeish)
-    `onError` throwError (NoRemoteRepoAt uri)
+pull localPath _uri treeish = do
   for_ treeish $ \treeish ->
     liftIO $ gitIn localPath ["checkout", treeish]
 

parser-typechecker/src/Unison/Codebase/Editor/HandleCommand.hs

@@ -122,9 +122,9 @@ commandLine config awaitInput setBranchRef rt notifyUser codebase =
     SyncLocalRootBranch branch -> do
       setBranchRef branch
       Codebase.putRootBranch codebase branch
-    LoadRemoteRootBranch GitRepo {..} -> do
+    LoadRemoteRootBranch loadMode GitRepo {..} -> do
       tmp <- tempGitDir url commit
-      runExceptT $ Git.pullGitRootBranch tmp codebase url commit
+      runExceptT $ Git.pullGitRootBranch tmp loadMode codebase url commit
     SyncRemoteRootBranch GitRepo {..} branch -> do
       tmp <- tempGitDir url commit
       runExceptT
@@ -152,7 +152,7 @@ commandLine config awaitInput setBranchRef rt notifyUser codebase =
     BranchHashesByPrefix h -> Codebase.branchHashesByPrefix codebase h
     LoadRemoteShortBranch GitRepo{..} sbh -> do
       tmp <- tempGitDir url commit
-      runExceptT $ Git.pullGitBranch tmp codebase url commit (Just sbh)
+      runExceptT $ Git.pullGitBranch tmp codebase url commit (Right sbh)
     ParseType names (src, _) -> pure $
       Parsers.parseType (Text.unpack src) (Parser.ParsingEnv mempty names)
 

parser-typechecker/src/Unison/Codebase/Editor/HandleInput.hs

@@ -1,8 +1,6 @@
 {-# OPTIONS_GHC -Wno-partial-type-signatures #-}
---{-# OPTIONS_GHC -Wno-unused-imports #-} -- todo: delete
 {-# OPTIONS_GHC -Wno-unused-top-binds #-} -- todo: delete
 {-# OPTIONS_GHC -Wno-unused-local-binds #-} -- todo: delete
---{-# OPTIONS_GHC -Wno-unused-matches #-} -- todo: delete
 
 {-# LANGUAGE ApplicativeDo       #-}
 {-# LANGUAGE OverloadedStrings   #-}
@@ -54,6 +52,7 @@ import           Unison.Codebase.Branch         ( Branch(..)
                                                 , Branch0(..)
                                                 )
 import qualified Unison.Codebase.Branch        as Branch
+import           Unison.Codebase.BranchLoadMode ( BranchLoadMode(FailIfMissing, EmptyIfMissing) )
 import qualified Unison.Codebase.BranchUtil    as BranchUtil
 import qualified Unison.Codebase.Causal        as Causal
 import qualified Unison.Codebase.Metadata      as Metadata
@@ -1278,7 +1277,7 @@ loop = do
           Left e -> eval . Notify $ e
           Right (repo, Nothing, remotePath) -> do
               -- push from srcb to repo's remotePath
-              eval (LoadRemoteRootBranch repo) >>= \case
+              eval (LoadRemoteRootBranch EmptyIfMissing repo) >>= \case
                 Left e -> eval . Notify $ GitError input e
                 Right remoteRoot -> do
                   newRemoteRoot <- eval . Eval $
@@ -1650,7 +1649,8 @@ searchBranchExact len names queries = let
 respond :: Output v -> Action m i v ()
 respond output = eval $ Notify output
 
--- merges the specified remote branch into the specified local absolute path
+-- Merges the specified remote branch into the specified local absolute path.
+-- Implementation detail of PullRemoteBranchI
 loadRemoteBranchAt
   :: Var v
   => Monad m
@@ -1660,7 +1660,7 @@ loadRemoteBranchAt
   -> Path.Absolute
   -> Action' m v ()
 loadRemoteBranchAt input inputDescription (repo, sbh, remotePath) p = do
-  b <- eval $ maybe (LoadRemoteRootBranch repo)
+  b <- eval $ maybe (LoadRemoteRootBranch FailIfMissing repo)
                     (LoadRemoteShortBranch repo) sbh
   case b of
     Left  e -> eval . Notify $ GitError input e

parser-typechecker/src/Unison/Codebase/FileCodebase.hs

@@ -70,6 +70,7 @@ import           Unison.Codebase.Causal         ( Causal
 import qualified Unison.Codebase.Causal        as Causal
 import           Unison.Codebase.Branch         ( Branch )
 import qualified Unison.Codebase.Branch        as Branch
+import           Unison.Codebase.BranchLoadMode ( BranchLoadMode(FailIfMissing, EmptyIfMissing) )
 import qualified Unison.Codebase.Reflog        as Reflog
 import qualified Unison.Codebase.Serialization as S
 import qualified Unison.Codebase.Serialization.V1
@@ -274,16 +275,10 @@ touchReferentFile id fp = do
 
 -- checks if `path` looks like a unison codebase
 minimalCodebaseStructure :: CodebasePath -> [FilePath]
-minimalCodebaseStructure root =
-  [ termsDir root
-  , typesDir root
-  , branchesDir root
-  , branchHeadDir root
-  , editsDir root
-  ]
+minimalCodebaseStructure root = [ branchHeadDir root ]
 
 -- checks if a minimal codebase structure exists at `path`
-exists :: CodebasePath -> IO Bool
+exists :: MonadIO m => CodebasePath -> m Bool
 exists root =
   and <$> traverse doesDirectoryExist (minimalCodebaseStructure root)
 
@@ -292,14 +287,6 @@ initialize :: CodebasePath -> IO ()
 initialize path =
   traverse_ (createDirectoryIfMissing True) (minimalCodebaseStructure path)
 
--- When loading a nonexistent branch, what should happen?
--- Could bomb (`FailIfMissing`) or return the empty branch (`EmptyIfMissing`).
---
--- `EmptyIfMissing` mode is used when attempting to load a user-specified
--- branch. `FailIfMissing` is used when loading the root branch - if the root
--- does not exist, that's a serious problem.
-data BranchLoadMode = FailIfMissing | EmptyIfMissing deriving Eq
-
 branchFromFiles :: MonadIO m => BranchLoadMode -> FilePath -> Branch.Hash -> m (Branch m)
 branchFromFiles loadMode rootDir h@(RawHash h') = do
   fileExists <- doesFileExist (branchPath rootDir h')
@@ -324,20 +311,26 @@ branchFromFiles loadMode rootDir h@(RawHash h') = do
           Left  err   -> failWith $ InvalidEditsFile file err
           Right edits -> pure edits
 
-getRootBranch :: MonadIO m => CodebasePath -> m (Branch m)
-getRootBranch root = do
-  unlessM (doesDirectoryExist $ branchHeadDir root)
-          (failWith . NoBranchHead $ branchHeadDir root)
-  liftIO (listDirectory $ branchHeadDir root) >>= \case
-    []       -> failWith . NoBranchHead $ branchHeadDir root
-    [single] -> go single
-    conflict -> traverse go conflict >>= \case
-      x : xs -> foldM Branch.merge x xs
-      []     -> failWith . NoBranchHead $ branchHeadDir root
+-- returns Nothing if `root` has no root branch (in `branchHeadDir root`)
+getRootBranch :: 
+  MonadIO m => BranchLoadMode -> CodebasePath -> m (Branch m)
+getRootBranch loadMode root = do
+  ifM (exists root)
+    (liftIO (listDirectory $ branchHeadDir root) >>= \case
+      []       -> missing
+      [single] -> go single
+      conflict -> traverse go conflict >>= \case
+        x : xs -> foldM Branch.merge x xs
+        []     -> missing
+    ) 
+    missing
  where
   go single = case hashFromString single of
     Nothing -> failWith $ CantParseBranchHead single
     Just h  -> branchFromFiles FailIfMissing root (RawHash h)
+  missing = case loadMode of
+    FailIfMissing -> failWith . NoBranchHead $ branchHeadDir root
+    EmptyIfMissing -> pure $ Branch.empty
 
 putRootBranch :: MonadIO m => CodebasePath -> Branch m -> m ()
 putRootBranch root b = do
@@ -409,6 +402,9 @@ referentToString = Text.unpack . Referent.toText
 copyDir :: (FilePath -> Bool) -> FilePath -> FilePath -> IO ()
 copyDir predicate from to = do
   createDirectoryIfMissing True to
+  -- createDir doesn't create a new directory on disk, 
+  -- it creates a description of an existing directory,
+  -- and it crashes if `from` doesn't exist.
   d <- createDir from
   when (predicate $ dirPath d) $ do
     forM_ (subDirs d)
@@ -418,10 +414,13 @@ copyDir predicate from to = do
       unless exists . copyFile path $ replaceRoot from to path
 
 copyFromGit :: MonadIO m => FilePath -> FilePath -> m ()
-copyFromGit = (liftIO .) . flip
-  (copyDir (\x -> not ((".git" `isSuffixOf` x) || ("_head" `isSuffixOf` x))))
+copyFromGit to from = liftIO . whenM (doesDirectoryExist from) $ 
+  copyDir (\x -> not ((".git" `isSuffixOf` x) || ("_head" `isSuffixOf` x))) 
+          from to
 
-writeAllTermsAndTypes
+-- Create a codebase structure at `localPath` if none exists, and
+-- copy (merge) all codebase elements from the current codebase into it.
+syncToDirectory
   :: forall m v a
    . (MonadUnliftIO m)
   => Var v
@@ -432,8 +431,8 @@ writeAllTermsAndTypes
   -> FilePath
   -> Branch m
   -> m (Branch m)
-writeAllTermsAndTypes fmtV fmtA codebase localPath branch = do
-  b <- doesDirectoryExist localPath
+syncToDirectory fmtV fmtA codebase localPath branch = do
+  b <- (liftIO . exists) localPath
   if b then do
     let code = codebase1 fmtV fmtA localPath
     remoteRoot <- Codebase.getRootBranch code
@@ -584,7 +583,7 @@ codebase1 fmtV@(S.Format getV putV) fmtA@(S.Format getA putA) path =
           getDecl
           (putTerm putV putA path)
           (putDecl putV putA path)
-          (getRootBranch path)
+          (getRootBranch FailIfMissing path)
           (putRootBranch path)
           (branchHeadUpdates path)
           (branchFromFiles EmptyIfMissing path)
@@ -593,7 +592,7 @@ codebase1 fmtV@(S.Format getV putV) fmtA@(S.Format getA putA) path =
           (copyFromGit path)
           -- This is fine as long as watat doesn't call
           -- syncToDirectory c
-          (writeAllTermsAndTypes fmtV fmtA c)
+          (syncToDirectory fmtV fmtA c)
           watches
           getWatch
           (putWatch putV putA path)

parser-typechecker/tests/Suite.hs

@@ -27,6 +27,7 @@ import qualified Unison.Test.Var as Var
 import qualified Unison.Test.Codebase as Codebase
 import qualified Unison.Test.Codebase.FileCodebase as FileCodebase
 import qualified Unison.Test.UriParser as UriParser
+import qualified Unison.Test.Git as Git
 
 test :: Test ()
 test = tests
@@ -52,6 +53,7 @@ test = tests
   , Codebase.test
   , Typechecker.test
   , UriParser.test
+  , Git.test
  ]
 
 main :: IO ()

parser-typechecker/tests/Unison/Test/Git.hs

@@ -0,0 +1,56 @@
+{-# Language OverloadedStrings #-}
+{-# Language QuasiQuotes #-}
+
+module Unison.Test.Git where
+
+import EasyTest
+import Data.String.Here (iTrim)
+import Unison.Prelude
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified System.IO.Temp as Temp
+import Shellmet ()
+import System.FilePath ((</>))
+import System.Directory (getCurrentDirectory)
+
+import Unison.Codebase.FileCodebase as FC
+import qualified Unison.Codebase.TranscriptParser as TR
+
+test :: Test ()
+test = scope "git" . tests $ [testBareRepo]
+
+testBareRepo :: Test ()
+testBareRepo = scope "testBareRepo" $ do
+  io . Temp.withSystemTempDirectory "testBareRepo" $ \tmp -> do
+    -- create a git repo and a transcript that references it
+    let repo = tmp </> "repo.git"
+    "git" ["init", "--bare", Text.pack repo]
+    let transcript = makeTranscript repo
+
+    -- initialize an fresh codebase
+    let codebase = tmp </> "codebase"
+    FC.initCodebase codebase
+
+    case TR.parse "transcript" transcript of
+      Left err -> error $ "Parse error: \n" <> show err
+      Right stanzas -> void $ do
+        currentDir <- getCurrentDirectory
+        theCodebase <- FC.getCodebaseOrExit $ Just codebase
+        TR.run currentDir stanzas theCodebase
+  ok
+
+makeTranscript :: FilePath -> Text
+makeTranscript repoPath = Text.pack $ [iTrim|
+```unison
+x = 3
+```
+```ucm
+.foo> add
+.foo> push ${repoPath}
+```
+Now we pull what we pushed
+```ucm
+.foo2> pull ${repoPath}
+.foo2> ls
+```
+|]

parser-typechecker/unison-parser-typechecker.cabal

@@ -40,6 +40,7 @@ library
     Unison.Codecs
     Unison.Codebase
     Unison.Codebase.Branch
+    Unison.Codebase.BranchLoadMode
     Unison.Codebase.BranchUtil
     Unison.Codebase.Causal
     Unison.Codebase.Classes
@@ -289,6 +290,7 @@ executable tests
     Unison.Test.Common
     Unison.Test.DataDeclaration
     Unison.Test.FileParser
+    Unison.Test.Git
     Unison.Test.Lexer
     Unison.Test.Range
     Unison.Test.Referent
@@ -315,10 +317,13 @@ executable tests
     extra,
     filepath,
     filemanip,
+    here,
     lens,
     megaparsec,
     mtl,
     raw-strings-qq,
+    shellmet,
+    temporary,
     text,
     transformers,
     unison-parser-typechecker