diff --git a/Git/CmdLine.hs b/Git/CmdLine.hs --- a/Git/CmdLine.hs +++ b/Git/CmdLine.hs @@ -27,7 +27,6 @@ import Data.Function import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap -import Data.IORef import Data.List as L import qualified Data.Map as Map import Data.Maybe @@ -46,7 +45,6 @@ import qualified Filesystem as F import qualified Filesystem.Path.CurrentOS as F import qualified Git -import qualified Git.Utils as Git import Prelude hiding (FilePath) import Shelly hiding (trace) import System.Exit @@ -73,51 +71,42 @@ fromStrict = TL.fromStrict #endif -type BlobOid m = Git.BlobOid (CmdLineRepository m) -type TreeOid m = Git.TreeOid (CmdLineRepository m) -type CommitOid m = Git.CommitOid (CmdLineRepository m) -type TagOid m = Git.TagOid (CmdLineRepository m) +type BlobOid m = Git.BlobOid (CmdLineRepository m) +type TreeOid m = Git.TreeOid (CmdLineRepository m) +type CommitOid m = Git.CommitOid (CmdLineRepository m) +type TagOid m = Git.TagOid (CmdLineRepository m) -type Blob m = Git.Blob (CmdLineRepository m) -type Tree m = Git.Tree (CmdLineRepository m) -type TreeEntry m = Git.TreeEntry (CmdLineRepository m) -type Commit m = Git.Commit (CmdLineRepository m) -type Tag m = Git.Tag (CmdLineRepository m) +type Blob m = Git.Blob (CmdLineRepository m) +type Tree m = Git.Tree (CmdLineRepository m) +type TreeEntry m = Git.TreeEntry (CmdLineRepository m) +type Commit m = Git.Commit (CmdLineRepository m) +type Tag m = Git.Tag (CmdLineRepository m) -type TreeRef m = Git.TreeRef (CmdLineRepository m) -type CommitRef m = Git.CommitRef (CmdLineRepository m) -type CommitName m = Git.CommitName (CmdLineRepository m) +type TreeRef m = Git.TreeRef (CmdLineRepository m) +type CommitRef m = Git.CommitRef (CmdLineRepository m) +type CommitName m = Git.CommitName (CmdLineRepository m) -type Reference m = Git.Reference (CmdLineRepository m) (Commit m) -type Object m = Git.Object (CmdLineRepository m) +type Reference m = Git.Reference (CmdLineRepository m) (Commit m) +type Object m = Git.Object (CmdLineRepository m) +type TreeBuilder m = Git.TreeBuilder (CmdLineRepository m) +type ModifiedBuilder m = Git.ModifiedBuilder (CmdLineRepository m) instance Git.MonadGit m => Git.Repository (CmdLineRepository m) where - type Oid (CmdLineRepository m) = -#if MIN_VERSION_shelly(1, 0, 0) - Git.OidText -#else - Git.OidTextL -#endif - type TreeKind (CmdLineRepository m) = Git.PersistentTree - type Tree (CmdLineRepository m) = HashMapTree m - + type Oid (CmdLineRepository m) = Git.SHA + data Tree (CmdLineRepository m) = CmdLineTree (TreeOid m) data Options (CmdLineRepository m) = Options facts = return Git.RepositoryFacts { Git.hasSymbolicReferences = True } -#if MIN_VERSION_shelly(1, 0, 0) - parseOid = Git.parseOidText -#else - parseOid = Git.parseOidTextL -#endif + parseOid = Git.textToSha - lookupRef = cliLookupRef - createRef = cliUpdateRef - updateRef = cliUpdateRef - deleteRef = cliDeleteRef - resolveRef = cliResolveRef - allRefs = cliAllRefs + lookupReference = cliLookupRef + createReference = cliUpdateRef + updateReference = cliUpdateRef + deleteReference = cliDeleteRef + resolveReference = cliResolveRef + allReferences = cliAllRefs lookupCommit = cliLookupCommit lookupTree = cliLookupTree lookupBlob = cliLookupBlob @@ -128,30 +117,23 @@ traverseCommits = cliTraverseCommits missingObjects = cliMissingObjects traverseObjects = error "Not defined: CmdLineRepository.traverseObjects" - newTree = cliNewTree - cloneTree = cliCloneTree + newTreeBuilder = cliNewTreeBuilder + getTreeEntry = cliTreeEntry traverseEntries = cliTraverseEntries - unsafeUpdateTree = cliModifyTree - writeTree = cliWriteTree + treeOid = \(CmdLineTree toid) -> toid hashContents = cliHashContents createBlob = cliCreateBlob createCommit = cliCreateCommit createTag = cliCreateTag - - remoteFetch = error "Not defined: CmdLineRepository.remoteFetch" - + remoteFetch = error "Not defined: CmdLineRepository.remoteFetch" deleteRepository = cliGet >>= liftIO . F.removeTree . Git.repoPath . repoOptions git :: [TL.Text] -> Sh TL.Text -git args = do - -- liftIO $ putStrLn $ "CmdLine: git " ++ show args - run "git" args +git = run "git" git_ :: [TL.Text] -> Sh () -git_ args = do - -- liftIO $ putStrLn $ "CmdLine: git " ++ show args - run_ "git" args +git_ = run_ "git" doRunGit :: Git.MonadGit m => (FilePath -> [TL.Text] -> Sh a) -> [TL.Text] -> Sh () @@ -160,8 +142,6 @@ repo <- cliGet shellyNoDir $ silently $ do act - -- liftIO $ putStrLn $ "CmdLine: git " - -- ++ show (["--git-dir", repoPath repo] <> args) f "git" $ ["--git-dir", repoPath repo] <> args runGit :: Git.MonadGit m @@ -219,7 +199,7 @@ . toStrict <$> lastStderr case merr of Nothing -> do - mcref <- Git.resolveRef remoteRefName + mcref <- Git.resolveReference remoteRefName case mcref of Nothing -> failure (Git.BackendError $ "git push failed") Just cref -> return cref @@ -239,7 +219,7 @@ (Git.MergeResult (CmdLineRepository m)) cliPullCommitDirectly remoteNameOrURI remoteRefName user email msshCmd = do repo <- cliGet - leftHead <- Git.resolveRef "HEAD" + leftHead <- Git.resolveReference "HEAD" eres <- shellyNoDir $ silently $ errExit False $ do case msshCmd of @@ -307,7 +287,7 @@ git_ [ "--git-dir", repoPath repo, "add", toTextIgnore fp ] getOid name = do - mref <- Git.resolveRef name + mref <- Git.resolveReference name case mref of Nothing -> failure (Git.BackendError $ T.append "Reference missing: " name) @@ -341,23 +321,11 @@ (Just x, Just y) -> (x, y) (Nothing, Nothing) -> error "Both merge items cannot be Unchanged" -#if MIN_VERSION_shelly(1, 0, 0) -type Oid = Git.OidText - -mkOid :: T.Text -> Git.OidText -mkOid = Git.OidText - -getOid :: Git.OidText -> T.Text -getOid = Git.getOidT -#else -type Oid = Git.OidTextL - -mkOid :: TL.Text -> Git.OidTextL -mkOid = Git.OidTextL +mkOid :: Monad m => TL.Text -> m Git.SHA +mkOid = Git.textToSha . toStrict -getOid :: Git.OidTextL -> TL.Text -getOid = Git.getOidTL -#endif +getOid :: Git.SHA -> TL.Text +getOid = fromStrict . Git.shaToText cliLookupBlob :: Git.MonadGit m => BlobOid m -> CmdLineRepository m (Blob m) @@ -384,11 +352,7 @@ <> ["-w" | persist] <> ["--stdin"]) bs if r == ExitSuccess - then return . Tagged - . mkOid - . fromStrict - . T.init - . T.decodeUtf8 $ out + then Tagged <$> (mkOid . fromStrict . T.init . T.decodeUtf8 $ out) else failure Git.BlobCreateFailed cliHashContents :: Git.MonadGit m @@ -401,7 +365,7 @@ -> CmdLineRepository m (BlobOid m) cliCreateBlob b = cliDoCreateBlob b True -cliExistsObject :: Git.MonadGit m => Oid -> CmdLineRepository m Bool +cliExistsObject :: Git.MonadGit m => Git.SHA -> CmdLineRepository m Bool cliExistsObject (getOid -> sha) = do repo <- cliGet shellyNoDir $ silently $ errExit False $ do @@ -444,148 +408,96 @@ go x = failure (Git.BackendError $ "Unexpected output from git-log: " <> T.pack (show x)) -data HashMapTree m t = HashMapTree - { cliTreeOid :: IORef (Maybe (TreeOid m)) - , cliTreeContents :: IORef (HashMap Text (TreeEntry m)) - } - -cliMakeTree :: IORef (Maybe (TreeOid m)) - -> IORef (HashMap Text (TreeEntry m)) - -> Tree m Git.PersistentTree -cliMakeTree oid contents = HashMapTree oid contents +type EntryHashMap m = HashMap Text (TreeEntry m) -cliNewTree :: Git.MonadGit m - => CmdLineRepository m (Tree m Git.PersistentTree) -cliNewTree = cliMakeTree <$> liftIO (newIORef Nothing) - <*> liftIO (newIORef HashMap.empty) +cliMakeTree :: Git.MonadGit m + => EntryHashMap m -> TreeBuilder m +cliMakeTree entMap = mempty <> Git.TreeBuilder + { Git.mtbBaseTreeRef = Nothing + , Git.mtbPendingUpdates = mempty + , Git.mtbNewBuilder = cliNewTreeBuilder + , Git.mtbWriteContents = \tb -> (,) <$> pure (Git.BuilderUnchanged tb) + <*> cliWriteBuilder entMap + , Git.mtbLookupEntry = cliLookupBuilderEntry entMap + , Git.mtbEntryCount = cliBuilderEntryCount entMap + , Git.mtbPutEntry = flip cliPutEntry entMap + , Git.mtbDropEntry = flip cliDropEntry entMap + } -cliCloneTree :: Git.MonadGit m - => Tree m Git.PersistentTree - -> CmdLineRepository m (Tree m Git.PersistentTree) -cliCloneTree (HashMapTree oid contents) = - cliMakeTree <$> liftIO (newIORef =<< readIORef oid) - <*> liftIO (newIORef =<< readIORef contents) +-- | Create a new, empty tree. +-- +-- Since empty trees cannot exist in Git, attempting to write out an empty +-- tree is a no-op. +cliNewTreeBuilder :: Git.MonadGit m + => Maybe (Tree m) -> CmdLineRepository m (TreeBuilder m) +cliNewTreeBuilder mtree = do + entMap <- case mtree of + Nothing -> return HashMap.empty + Just tree -> go (Git.treeOid tree) + return $ (cliMakeTree entMap) { Git.mtbBaseTreeRef = Git.treeRef <$> mtree } -cliModifyTree :: Git.MonadGit m - => Tree m Git.PersistentTree - -> FilePath - -> Bool - -> (Maybe (TreeEntry m) - -> Git.ModifyTreeResult (CmdLineRepository m)) - -> CmdLineRepository m (Tree m Git.PersistentTree, Maybe (TreeEntry m)) -cliModifyTree t path createIfNotExist f = - fmap Git.fromModifyTreeResult - <$> doModifyTree t (Git.splitPath path) createIfNotExist where - -- Lookup the current name in this tree. If it doesn't exist, and there - -- are more names in the path and 'createIfNotExist' is True, create a new - -- Tree and descend into it. Otherwise, if it exists we'll have @Just - -- (TreeEntry {})@, and if not we'll have Nothing. - doModifyTree tr [] _ = - return (tr, Git.TreeEntryPersistent . Git.TreeEntry . Git.Known $ tr) - doModifyTree tr (name:names) createIfNotExist = do - y' <- doLookupTreeEntry tr [name] - y <- if isNothing y' && createIfNotExist && not (null names) - then Just . Git.TreeEntry . Git.Known <$> Git.newTree - else return y' - go tr name names y + go (Tagged (getOid -> sha)) = do + contents <- runGit ["ls-tree", "-z", sha] + -- Even though the tree entries are separated by \NUL, for whatever + -- reason @git ls-tree@ also outputs a newline at the end. + HashMap.fromList + <$> mapM cliParseLsTree (L.init (TL.splitOn "\NUL" contents)) - -- If there are no further names in the path, call the transformer - -- function, f. It receives a @Maybe TreeEntry@ to indicate if there was - -- a previous entry at this path. It should return a 'Left' value to - -- propagate out a user-defined error, or a @Maybe TreeEntry@ to indicate - -- whether the entry at this path should be deleted or replaced with - -- something new. - -- - -- NOTE: There is no provision for leaving the entry unchanged! It is - -- assumed to always be changed, as we have no reliable method of testing - -- object equality that is not O(n). - go tr name [] y = do - let ze = f y - liftIO $ modifyIORef (cliTreeContents tr) $ case ze of - Git.TreeEntryNotFound -> id - Git.TreeEntryPersistent _ -> id - Git.TreeEntryDeleted -> HashMap.delete name - Git.TreeEntryMutated z' -> HashMap.insert name z' - return (tr, ze) +cliParseLsTree :: Git.MonadGit m + => TL.Text -> CmdLineRepository m (Text, TreeEntry m) +cliParseLsTree line = + let [prefix,path] = TL.splitOn "\t" line + [mode,kind,sha] = TL.words prefix + in liftM2 (,) (return (toStrict path)) $ case kind of + "blob" -> do + oid <- Tagged <$> mkOid sha + return $ Git.BlobEntry oid $ case mode of + "100644" -> Git.PlainBlob + "100755" -> Git.ExecutableBlob + "120000" -> Git.SymlinkBlob + _ -> Git.UnknownBlob + "commit" -> Git.CommitEntry . Tagged <$> mkOid sha + "tree" -> Git.TreeEntry . Tagged <$> mkOid sha + _ -> failure (Git.BackendError "This cannot happen") - go tr _ _ Nothing = return (tr, Git.TreeEntryNotFound) - go _ _ _ (Just Git.BlobEntry {}) = failure Git.TreeCannotTraverseBlob - go _ _ _ (Just Git.CommitEntry {}) = failure Git.TreeCannotTraverseCommit +cliPutEntry :: Git.MonadGit m + => TreeBuilder m -> EntryHashMap m -> Text -> TreeEntry m + -> CmdLineRepository m (ModifiedBuilder m) +cliPutEntry tb entMap key ent = + return . Git.ModifiedBuilder $ + tb <> cliMakeTree (HashMap.insert key ent entMap) - -- If there are further names in the path, descend them now. If - -- 'createIfNotExist' was False and there is no 'Tree' under the current - -- name, or if we encountered a 'Blob' when a 'Tree' was required, throw - -- an exception to avoid colliding with user-defined 'Left' values. - go tr name names (Just (Git.TreeEntry st')) = do - st <- Git.resolveTreeRef st' - (st'', ze) <- doModifyTree st names createIfNotExist - case ze of - Git.TreeEntryNotFound -> return () - Git.TreeEntryPersistent _ -> return () - Git.TreeEntryDeleted -> postUpdate tr st'' name - Git.TreeEntryMutated _ -> postUpdate tr st'' name - return (tr, ze) +cliDropEntry :: Git.MonadGit m + => TreeBuilder m -> EntryHashMap m -> Text + -> CmdLineRepository m (ModifiedBuilder m) +cliDropEntry tb entMap key = + return . Git.ModifiedBuilder $ + tb <> cliMakeTree (HashMap.delete key entMap) - -- Lookup the current name in this tree. If it doesn't exist, and there - -- are more names in the path and 'createIfNotExist' is True, create a new - -- Tree and descend into it. Otherwise, if it exists we'll have @Just - -- (TreeEntry {})@, and if not we'll have Nothing. - doLookupTreeEntry tr [] = return (Just (Git.treeEntry tr)) - doLookupTreeEntry tr (name:names) = do - y <- liftIO $ HashMap.lookup name <$> readIORef (cliTreeContents tr) - if null names - then return y - else case y of - Just (Git.BlobEntry {}) -> failure Git.TreeCannotTraverseBlob - Just (Git.CommitEntry {}) -> failure Git.TreeCannotTraverseCommit - Just (Git.TreeEntry st) -> do - st' <- Git.resolveTreeRef st - doLookupTreeEntry st' names - _ -> return Nothing +cliLookupBuilderEntry :: Git.MonadGit m + => EntryHashMap m -> Text + -> CmdLineRepository m (Maybe (TreeEntry m)) +cliLookupBuilderEntry entMap key = return $ HashMap.lookup key entMap - postUpdate tr st name = liftIO $ do - modifyIORef (cliTreeOid tr) (const Nothing) - stc <- readIORef (cliTreeContents st) - modifyIORef (cliTreeContents tr) $ - if HashMap.null stc - then HashMap.delete name - else HashMap.insert name (Git.treeEntry st) +cliBuilderEntryCount :: Git.MonadGit m + => EntryHashMap m -> CmdLineRepository m Int +cliBuilderEntryCount entMap = return $ HashMap.size entMap -cliLookupTree :: Git.MonadGit m - => TreeOid m -> CmdLineRepository m (Tree m Git.PersistentTree) -cliLookupTree oid@(Tagged (getOid -> sha)) = do - contents <- runGit ["ls-tree", "-z", sha] - oidRef <- liftIO $ newIORef (Just oid) - -- Even though the tree entries are separated by \NUL, for whatever reason - -- @git ls-tree@ also outputs a newline at the end. - contentsRef <- liftIO $ newIORef $ HashMap.fromList $ - map parseLine (L.init (TL.splitOn "\NUL" contents)) - return $ cliMakeTree oidRef contentsRef - where - parseLine line = - let [prefix,path] = TL.splitOn "\t" line - [mode,kind,sha] = TL.words prefix - in (toStrict path, - case kind of - "blob" -> Git.BlobEntry (Tagged (mkOid sha)) $ - case mode of - "100644" -> Git.PlainBlob - "100755" -> Git.ExecutableBlob - "120000" -> Git.SymlinkBlob - _ -> Git.UnknownBlob - "commit" -> Git.CommitEntry (Tagged (mkOid sha)) - "tree" -> Git.TreeEntry (Git.ByOid (Tagged (mkOid sha))) - _ -> error "This cannot happen") +cliTreeEntryCount :: Git.MonadGit m => Tree m -> CmdLineRepository m Int +cliTreeEntryCount t = + L.length . L.init . TL.splitOn "\NUL" + <$> runGit [ "ls-tree", "-z" + , fromStrict (Git.renderObjOid (Git.treeOid t)) ] -cliWriteTree :: Git.MonadGit m - => Tree m Git.PersistentTree -> CmdLineRepository m (TreeOid m) -cliWriteTree tree = do - contents <- liftIO $ readIORef (cliTreeContents tree) - rendered <- mapM renderLine (HashMap.toList contents) +cliWriteBuilder :: Git.MonadGit m + => EntryHashMap m + -> CmdLineRepository m (TreeRef m) +cliWriteBuilder entMap = do + rendered <- mapM renderLine (HashMap.toList entMap) oid <- doRunGit run ["mktree", "-z", "--missing"] $ setStdin $ TL.append (TL.intercalate "\NUL" rendered) "\NUL" - return (Tagged (mkOid (TL.init oid))) + Git.ByOid . Tagged <$> mkOid (TL.init oid) where renderLine (path, Git.BlobEntry (Tagged (getOid -> sha)) kind) = return $ TL.concat [ case kind of @@ -598,38 +510,53 @@ return $ TL.concat [ "160000 commit " , fromStrict (Git.renderObjOid coid), "\t" , fromStrict path ] - renderLine (path, Git.TreeEntry tref) = do - treeOid <- Git.treeRefOid tref + renderLine (path, Git.TreeEntry toid) = do return $ TL.concat [ "040000 tree " - , fromStrict (Git.renderObjOid treeOid), "\t" + , fromStrict (Git.renderObjOid toid), "\t" , fromStrict path ] +cliLookupTree :: Git.MonadGit m => TreeOid m -> CmdLineRepository m (Tree m) +cliLookupTree oid@(Tagged (getOid -> sha)) = do + repo <- cliGet + ec <- shellyNoDir $ silently $ errExit False $ do + git_ $ [ "--git-dir", repoPath repo, "cat-file", "-t", sha ] + lastExitCode + if ec == 0 + then return $ CmdLineTree oid + else failure (Git.ObjectLookupFailed (toStrict sha) 40) + +cliTreeEntry :: Git.MonadGit m => Tree m -> FilePath + -> CmdLineRepository m (Maybe (TreeEntry m)) +cliTreeEntry tree fp = do + repo <- cliGet + mentryLines <- shellyNoDir $ silently $ errExit False $ do + contents <- git $ [ "--git-dir", repoPath repo + , "ls-tree", "-z" + , fromStrict (Git.renderObjOid (Git.treeOid tree)) + , "--", toTextIgnore fp ] + ec <- lastExitCode + return $ if ec == 0 + then Just $ L.init (TL.splitOn "\NUL" contents) + else Nothing + case mentryLines of + Nothing -> return Nothing + Just entryLines -> do + entries <- mapM cliParseLsTree entryLines + return $ case entries of + [] -> Nothing + ((_,x):_) -> Just x + cliTraverseEntries :: Git.MonadGit m => (FilePath -> TreeEntry m -> CmdLineRepository m b) - -> Tree m Git.PersistentTree + -> Tree m -> CmdLineRepository m [b] cliTraverseEntries f tree = do - Tagged (getOid -> sha) <- Git.writeTree tree - contents <- runGit ["ls-tree", "-t", "-r", "-z", sha] - -- Even though the tree entries are separated by \NUL, for whatever reason - -- @git ls-tree@ also outputs a newline at the end. - mapM (uncurry f) $ map parseLine (L.init (TL.splitOn "\NUL" contents)) - where - parseLine line = - let [prefix,path] = TL.splitOn "\t" line - [mode,kind,sha] = TL.words prefix - in (fromText path, - case kind of - "blob" -> Git.BlobEntry (Tagged (mkOid sha)) $ - case mode of - "100644" -> Git.PlainBlob - "100755" -> Git.ExecutableBlob - "120000" -> Git.SymlinkBlob - _ -> Git.UnknownBlob - "commit" -> Git.CommitEntry (Tagged (mkOid sha)) - "tree" -> Git.TreeEntry (Git.ByOid (Tagged (mkOid sha))) - _ -> error "This cannot happen") + contents <- runGit [ "ls-tree", "-t", "-r", "-z" + , fromStrict (Git.renderObjOid (Git.treeOid tree)) ] + mapM (uncurry go <=< cliParseLsTree) (L.init (TL.splitOn "\NUL" contents)) + where + go = f . fromText . fromStrict parseCliTime :: String -> ZonedTime parseCliTime = fromJust . parseTime defaultTimeLocale "%s %z" @@ -645,30 +572,32 @@ cliLookupCommit (Tagged (getOid -> sha)) = do output <- doRunGit run ["cat-file", "--batch"] $ setStdin (TL.append sha "\n") - case parse parseOutput "" (TL.unpack output) of + result <- runParserT parseOutput () "" (TL.unpack output) + case result of Left e -> failure $ Git.CommitLookupFailed (T.pack (show e)) Right c -> return c where + parseOutput :: Monad m => ParsecT String () (CmdLineRepository m) (Commit a) parseOutput = do - coid <- Tagged . mkOid . TL.pack - <$> manyTill alphaNum space + coid <- manyTill alphaNum space _ <- string "commit " *> manyTill digit newline - treeOid <- string "tree " *> - (Tagged . mkOid . TL.pack - <$> manyTill anyChar newline) - parentOids <- many (string "parent " *> - (Tagged . mkOid . TL.pack - <$> manyTill anyChar newline)) + treeOid <- string "tree " *> manyTill anyChar newline + parentOids <- many (string "parent " *> manyTill anyChar newline) author <- parseSignature "author" committer <- parseSignature "committer" message <- newline *> many anyChar + + coid' <- lift $ Tagged `liftM` mkOid (TL.pack coid) + toid' <- lift $ Tagged `liftM` mkOid (TL.pack treeOid) + poids' <- lift $ mapM (liftM Tagged . mkOid . TL.pack) parentOids + return Git.Commit - { Git.commitOid = coid + { Git.commitOid = coid' , Git.commitAuthor = author , Git.commitCommitter = committer , Git.commitLog = T.pack (init message) - , Git.commitTree = Git.ByOid treeOid - , Git.commitParents = map Git.ByOid parentOids + , Git.commitTree = Git.ByOid toid' + , Git.commitParents = map Git.ByOid poids' , Git.commitEncoding = "utf-8" } @@ -680,12 +609,16 @@ <*> (parseCliTime <$> manyTill anyChar newline) cliCreateCommit :: Git.MonadGit m - => [CommitRef m] -> TreeRef m - -> Git.Signature -> Git.Signature -> Text -> Maybe Text + => [CommitRef m] + -> TreeRef m + -> Git.Signature + -> Git.Signature + -> Text + -> Maybe Text -> CmdLineRepository m (Commit m) -cliCreateCommit parents tree author committer message ref = do - treeOid <- Git.treeRefOid tree - let parentOids = map Git.commitRefOid parents +cliCreateCommit parents tref author committer message ref = do + let treeOid = Git.treeRefOid tref + parentOids = map Git.commitRefOid parents oid <- doRunGit run (["commit-tree"] <> [fromStrict (Git.renderObjOid treeOid)] @@ -703,8 +636,9 @@ ] setStdin (fromStrict message) + coid <- Tagged <$> mkOid (TL.init oid) let commit = Git.Commit - { Git.commitOid = Tagged (mkOid (TL.init oid)) + { Git.commitOid = coid , Git.commitAuthor = author , Git.commitCommitter = committer , Git.commitLog = message @@ -738,10 +672,11 @@ $ TL.lines rev else Nothing -nameAndShaToRef :: TL.Text -> TL.Text -> Reference m +nameAndShaToRef :: Git.MonadGit m + => TL.Text -> TL.Text -> CmdLineRepository m (Reference m) nameAndShaToRef name sha = - Git.Reference (toStrict name) - (Git.RefObj (Git.ByOid (Tagged (mkOid sha)))) + Git.Reference <$> pure (toStrict name) + <*> (Git.RefObj . Git.ByOid . Tagged <$> mkOid sha) cliLookupRef :: Git.MonadGit m => Text -> CmdLineRepository m (Maybe (Reference m)) @@ -749,8 +684,8 @@ xs <- cliShowRef (Just refName) let name = fromStrict refName ref = maybe Nothing (lookup name) xs - return $ maybe Nothing (Just . uncurry nameAndShaToRef . - \sha -> (name,sha)) ref + maybe (return Nothing) + (fmap Just . uncurry nameAndShaToRef . \sha -> (name,sha)) ref cliUpdateRef :: Git.MonadGit m => Text -> Git.RefTarget (CmdLineRepository m) (Commit m) @@ -771,9 +706,9 @@ => CmdLineRepository m [Reference m] cliAllRefs = do mxs <- cliShowRef Nothing - return $ case mxs of - Nothing -> [] - Just xs -> map (uncurry nameAndShaToRef) xs + case mxs of + Nothing -> return [] + Just xs -> mapM (uncurry nameAndShaToRef) xs cliResolveRef :: Git.MonadGit m => Text -> CmdLineRepository m (Maybe (CommitRef m)) @@ -784,9 +719,9 @@ , "rev-parse", "--quiet", "--verify" , fromStrict refName ] ec <- lastExitCode - return $ if ec == 0 - then Just (Git.ByOid (Tagged (mkOid (TL.init rev)))) - else Nothing + if ec == 0 + then Just . Git.ByOid . Tagged <$> mkOid (TL.init rev) + else return Nothing -- cliLookupTag :: TagOid -> CmdLineRepository Tag -- cliLookupTag oid = undefined @@ -804,7 +739,8 @@ <> TL.pack (formatTime defaultTimeLocale "%s %z" (Git.signatureWhen tagger)) , ""] <> TL.lines (fromStrict msg) - return $ Git.Tag (Tagged (mkOid (TL.init tsha))) (Git.ByOid oid) + Git.Tag <$> (Tagged <$> mkOid (TL.init tsha)) + <*> pure (Git.ByOid oid) data Repository = Repository { repoOptions :: Git.RepositoryOptions @@ -882,7 +818,8 @@ case F.toText path of Left e -> failure (Git.BackendError e) Right p -> do - when (not exists && Git.repoAutoCreate opts) $ + when (not exists && Git.repoAutoCreate opts) $ do + liftIO $ F.createTree (fromText (fromStrict p)) shellyNoDir $ silently $ git_ $ ["--git-dir", fromStrict p] <> ["--bare" | Git.repoIsBare opts] diff --git a/gitlib-cmdline.cabal b/gitlib-cmdline.cabal --- a/gitlib-cmdline.cabal +++ b/gitlib-cmdline.cabal @@ -1,5 +1,5 @@ Name: gitlib-cmdline -Version: 1.2.1 +Version: 1.3.1 Synopsis: Gitlib repository backend that uses the git command-line tool. Description: Gitlib repository backend that uses the git command-line tool. License-file: LICENSE @@ -20,8 +20,7 @@ ghc-options: -Wall build-depends: base >= 3 && < 5 - , gitlib >= 1.1.0 - , gitlib-utils >= 1.1.0 + , gitlib >= 1.3.1 , bytestring >= 0.9.2.1 , conduit >= 0.5.5 , containers >= 0.4.2.1 @@ -50,10 +49,9 @@ hs-source-dirs: test build-depends: base >=3 - , gitlib >= 1.1.0 - , gitlib-utils >= 1.1.0 - , gitlib-test >= 1.1.0 - , gitlib-cmdline >= 1.1.0 + , gitlib >= 1.3.1 + , gitlib-test >= 1.3.1 + , gitlib-cmdline >= 1.3.1 , HUnit >= 1.2.5 , hspec >= 1.4.4 , hspec-expectations >= 0.3