diff --git a/Git/CmdLine.hs b/Git/CmdLine.hs --- a/Git/CmdLine.hs +++ b/Git/CmdLine.hs @@ -54,8 +54,6 @@ import Text.Parsec.Prim import Text.Parsec.Token -type Oid m = Git.Oid (CmdLineRepository m) - type BlobOid m = Git.BlobOid (CmdLineRepository m) type TreeOid m = Git.TreeOid (CmdLineRepository m) type CommitOid m = Git.CommitOid (CmdLineRepository m) @@ -75,57 +73,47 @@ type Object m = Git.Object (CmdLineRepository m) instance Git.MonadGit m => Git.Repository (CmdLineRepository m) where - data Oid (CmdLineRepository m) = Oid { getOid :: TL.Text } - - data TreeData (CmdLineRepository m) = TreeData - { cliTreeOid :: IORef (Maybe (TreeOid m)) - , cliTreeContents :: IORef (HashMap Text (TreeEntry m)) - } + type Oid (CmdLineRepository m) = Git.OidTextL + type Tree (CmdLineRepository m) = MutableTree m data Options (CmdLineRepository m) = Options facts = return Git.RepositoryFacts { Git.hasSymbolicReferences = True } - parseOid = return . Oid . TL.fromStrict - renderOid (Oid x) = TL.toStrict x + parseOid = Git.parseOidTextL - lookupRef = cliLookupRef - createRef = cliUpdateRef - updateRef = cliUpdateRef - deleteRef = cliDeleteRef - resolveRef = cliResolveRef - allRefs = cliAllRefs - lookupCommit = cliLookupCommit - lookupTree = cliLookupTree - lookupBlob = cliLookupBlob - lookupTag = error "Not defined CmdLineRepository.cliLookupTag" - lookupObject = error "Not defined CmdLineRepository.cliLookupObject" - existsObject = cliExistsObject - pushCommit = \name _ rrefname -> Git.genericPushCommit name rrefname - traverseCommits = cliTraverseCommits - missingObjects = cliMissingObjects - traverseObjects = error "Not defined: CmdLineRepository.traverseObjects" - newTree = cliNewTree - hashContents = cliHashContents - createBlob = cliCreateBlob - createCommit = cliCreateCommit - createTag = cliCreateTag + lookupRef = cliLookupRef + createRef = cliUpdateRef + updateRef = cliUpdateRef + deleteRef = cliDeleteRef + resolveRef = cliResolveRef + allRefs = cliAllRefs + lookupCommit = cliLookupCommit + lookupTree = cliLookupTree + lookupBlob = cliLookupBlob + lookupTag = error "Not defined CmdLineRepository.cliLookupTag" + lookupObject = error "Not defined CmdLineRepository.cliLookupObject" + existsObject = cliExistsObject + pushCommit = \name _ rrefname -> Git.genericPushCommit name rrefname + traverseCommits = cliTraverseCommits + missingObjects = cliMissingObjects + traverseObjects = error "Not defined: CmdLineRepository.traverseObjects" + newTree = cliNewTree + cloneTree = cliCloneTree + traverseEntries = cliTraverseEntries + unsafeUpdateTree = cliModifyTree + writeTree = cliWriteTree + hashContents = cliHashContents + createBlob = cliCreateBlob + createCommit = cliCreateCommit + createTag = cliCreateTag remoteFetch = error "Not defined: CmdLineRepository.remoteFetch" deleteRepository = cliGet >>= liftIO . F.removeTree . Git.repoPath . repoOptions -instance Show (Git.Oid (CmdLineRepository m)) where - show (Oid x) = show x - -instance Ord (Git.Oid (CmdLineRepository m)) where - compare (Oid l) (Oid r) = compare l r - -instance Eq (Git.Oid (CmdLineRepository m)) where - Oid l == Oid r = l == r - git :: [TL.Text] -> Sh TL.Text git args = do -- liftIO $ putStrLn $ "CmdLine: git " ++ show args @@ -324,9 +312,17 @@ (Just x, Just y) -> (x, y) (Nothing, Nothing) -> error "Both merge items cannot be Unchanged" +type Oid = Git.OidTextL + +mkOid :: TL.Text -> Git.OidTextL +mkOid = Git.OidTextL + +getOid :: Git.OidTextL -> TL.Text +getOid = Git.getOidTL + cliLookupBlob :: Git.MonadGit m => BlobOid m -> CmdLineRepository m (Blob m) -cliLookupBlob oid@(Tagged (Oid sha)) = do +cliLookupBlob oid@(Tagged (getOid -> sha)) = do repo <- cliGet (r,out,_) <- liftIO $ readProcessWithExitCode "git" @@ -349,7 +345,11 @@ <> ["-w" | persist] <> ["--stdin"]) bs if r == ExitSuccess - then return . Tagged . Oid . TL.fromStrict . T.init . T.decodeUtf8 $ out + then return . Tagged + . mkOid + . TL.fromStrict + . T.init + . T.decodeUtf8 $ out else failure Git.BlobCreateFailed cliHashContents :: Git.MonadGit m @@ -362,8 +362,8 @@ -> CmdLineRepository m (BlobOid m) cliCreateBlob b = cliDoCreateBlob b True -cliExistsObject :: Git.MonadGit m => Oid m -> CmdLineRepository m Bool -cliExistsObject (Oid sha) = do +cliExistsObject :: Git.MonadGit m => Oid -> CmdLineRepository m Bool +cliExistsObject (getOid -> sha) = do repo <- cliGet shellyNoDir $ silently $ errExit False $ do git_ [ "--git-dir", repoPath repo, "cat-file", "-e", sha ] @@ -405,20 +405,116 @@ go x = failure (Git.BackendError $ "Unexpected output from git-log: " <> T.pack (show x)) -cliMakeTree :: Git.MonadGit m - => IORef (Maybe (TreeOid m)) +data MutableTree m = MutableTree + { cliTreeOid :: IORef (Maybe (TreeOid m)) + , cliTreeContents :: IORef (HashMap Text (TreeEntry m)) + } + +cliMakeTree :: IORef (Maybe (TreeOid m)) -> IORef (HashMap Text (TreeEntry m)) -> Tree m -cliMakeTree oid contents = - Git.mkTree cliModifyTree cliWriteTree cliTraverseEntries $ - TreeData oid contents +cliMakeTree oid contents = MutableTree oid contents -cliNewTree :: Git.MonadGit m => CmdLineRepository m (Tree m) +cliNewTree :: Git.MonadGit m + => CmdLineRepository m (Tree m) cliNewTree = cliMakeTree <$> liftIO (newIORef Nothing) <*> liftIO (newIORef HashMap.empty) +cliCloneTree :: Git.MonadGit m + => Tree m + -> CmdLineRepository m (Tree m) +cliCloneTree (MutableTree oid contents) = + cliMakeTree <$> liftIO (newIORef =<< readIORef oid) + <*> liftIO (newIORef =<< readIORef contents) + +cliModifyTree :: Git.MonadGit m + => Tree m + -> FilePath + -> Bool + -> (Maybe (TreeEntry m) + -> Git.ModifyTreeResult (CmdLineRepository m)) + -> CmdLineRepository m (Tree m, 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 + + -- 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) + + go tr _ _ Nothing = return (tr, Git.TreeEntryNotFound) + go _ _ _ (Just Git.BlobEntry {}) = failure Git.TreeCannotTraverseBlob + go _ _ _ (Just Git.CommitEntry {}) = failure Git.TreeCannotTraverseCommit + + -- 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) + + -- 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 + + 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) + cliLookupTree :: Git.MonadGit m => TreeOid m -> CmdLineRepository m (Tree m) -cliLookupTree oid@(Tagged (Oid sha)) = do +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 @@ -432,134 +528,26 @@ [mode,kind,sha] = TL.words prefix in (TL.toStrict path, case kind of - "blob" -> Git.BlobEntry (Tagged (Oid sha)) $ + "blob" -> Git.BlobEntry (Tagged (mkOid sha)) $ case mode of "100644" -> Git.PlainBlob "100755" -> Git.ExecutableBlob "120000" -> Git.SymlinkBlob _ -> Git.UnknownBlob - "commit" -> Git.CommitEntry (Tagged (Oid sha)) - "tree" -> Git.TreeEntry (Git.ByOid (Tagged (Oid sha))) + "commit" -> Git.CommitEntry (Tagged (mkOid sha)) + "tree" -> Git.TreeEntry (Git.ByOid (Tagged (mkOid sha))) _ -> error "This cannot happen") -doLookupTreeEntry :: Git.MonadGit m => Tree m -> [Text] - -> CmdLineRepository m (Maybe (TreeEntry m)) -doLookupTreeEntry t [] = return (Just (Git.treeEntry t)) -doLookupTreeEntry t (name:names) = do - -- 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. - - y <- liftIO $ HashMap.lookup name - <$> readIORef (cliTreeContents (Git.getTreeData t)) - 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 t') -> do - t'' <- Git.resolveTreeRef t' - doLookupTreeEntry t'' names - _ -> return Nothing - -doModifyTree :: Git.MonadGit m - => Tree m - -> [Text] - -> Bool - -> (Maybe (TreeEntry m) - -> CmdLineRepository m - (Git.ModifyTreeResult (CmdLineRepository m))) - -> CmdLineRepository m (Git.ModifyTreeResult (CmdLineRepository m)) -doModifyTree t [] _ _ = - return . Git.TreeEntryPersistent . Git.TreeEntry . Git.Known $ t -doModifyTree t (name:names) createIfNotExist f = do - -- 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. - y' <- doLookupTreeEntry t [name] - y <- if isNothing y' && createIfNotExist && not (null names) - then Just . Git.TreeEntry . Git.Known <$> Git.newTree - else return y' - - if null names - then do - -- 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). - ze <- f y - liftIO $ modifyIORef (cliTreeContents (Git.getTreeData t)) $ - case ze of - Git.TreeEntryNotFound -> id - Git.TreeEntryPersistent _ -> id - Git.TreeEntryDeleted -> HashMap.delete name - Git.TreeEntryMutated z' -> HashMap.insert name z' - return ze - - else - -- 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. - case y of - Nothing -> return Git.TreeEntryNotFound - Just (Git.BlobEntry {}) -> failure Git.TreeCannotTraverseBlob - Just (Git.CommitEntry {}) -> failure Git.TreeCannotTraverseCommit - Just (Git.TreeEntry st') -> do - st <- Git.resolveTreeRef st' - ze <- doModifyTree st names createIfNotExist f - case ze of - Git.TreeEntryNotFound -> return () - Git.TreeEntryPersistent _ -> return () - Git.TreeEntryDeleted -> postUpdate st - Git.TreeEntryMutated _ -> postUpdate st - return ze - where - postUpdate st = liftIO $ do - modifyIORef (cliTreeOid (Git.getTreeData t)) (const Nothing) - stc <- readIORef (cliTreeContents (Git.getTreeData st)) - modifyIORef (cliTreeContents (Git.getTreeData t)) $ - if HashMap.null stc - then HashMap.delete name - else HashMap.insert name (Git.treeEntry st) - -cliModifyTree :: Git.MonadGit m - => Tree m -> FilePath -> Bool - -> (Maybe (TreeEntry m) - -> CmdLineRepository m - (Git.ModifyTreeResult (CmdLineRepository m))) - -> CmdLineRepository m (Maybe (TreeEntry m)) -cliModifyTree t path createIfNotExist f = - Git.fromModifyTreeResult <$> - doModifyTree t (splitPath path) createIfNotExist f - -splitPath :: FilePath -> [Text] -splitPath path = T.splitOn "/" text - where text = case F.toText path of - Left x -> error $ "Invalid path: " ++ T.unpack x - Right y -> y - cliWriteTree :: Git.MonadGit m => Tree m -> CmdLineRepository m (TreeOid m) cliWriteTree tree = do - contents <- liftIO $ readIORef (cliTreeContents (Git.getTreeData tree)) + contents <- liftIO $ readIORef (cliTreeContents tree) rendered <- mapM renderLine (HashMap.toList contents) oid <- doRunGit run ["mktree", "-z", "--missing"] $ setStdin $ TL.append (TL.intercalate "\NUL" rendered) "\NUL" - return (Tagged (Oid (TL.init oid))) + return (Tagged (mkOid (TL.init oid))) where - renderLine (path, Git.BlobEntry (Tagged (Oid sha)) kind) = + renderLine (path, Git.BlobEntry (Tagged (getOid -> sha)) kind) = return $ TL.concat [ case kind of Git.PlainBlob -> "100644" Git.ExecutableBlob -> "100755" @@ -578,11 +566,11 @@ , TL.fromStrict path ] cliTraverseEntries :: Git.MonadGit m - => Tree m - -> (FilePath -> TreeEntry m -> CmdLineRepository m b) + => (FilePath -> TreeEntry m -> CmdLineRepository m b) + -> Tree m -> CmdLineRepository m [b] -cliTraverseEntries tree f = do - Tagged (Oid sha) <- Git.writeTree tree +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. @@ -593,14 +581,14 @@ [mode,kind,sha] = TL.words prefix in (fromText path, case kind of - "blob" -> Git.BlobEntry (Tagged (Oid sha)) $ + "blob" -> Git.BlobEntry (Tagged (mkOid sha)) $ case mode of "100644" -> Git.PlainBlob "100755" -> Git.ExecutableBlob "120000" -> Git.SymlinkBlob _ -> Git.UnknownBlob - "commit" -> Git.CommitEntry (Tagged (Oid sha)) - "tree" -> Git.TreeEntry (Git.ByOid (Tagged (Oid sha))) + "commit" -> Git.CommitEntry (Tagged (mkOid sha)) + "tree" -> Git.TreeEntry (Git.ByOid (Tagged (mkOid sha))) _ -> error "This cannot happen") parseCliTime :: String -> ZonedTime @@ -614,7 +602,7 @@ cliLookupCommit :: Git.MonadGit m => CommitOid m -> CmdLineRepository m (Commit m) -cliLookupCommit (Tagged (Oid sha)) = do +cliLookupCommit (Tagged (getOid -> sha)) = do output <- doRunGit run ["cat-file", "--batch"] $ setStdin (TL.append sha "\n") case parse parseOutput "" (TL.unpack output) of @@ -622,14 +610,14 @@ Right c -> return c where parseOutput = do - coid <- Tagged . Oid . TL.pack + coid <- Tagged . mkOid . TL.pack <$> manyTill alphaNum space _ <- string "commit " *> manyTill digit newline treeOid <- string "tree " *> - (Tagged . Oid . TL.pack + (Tagged . mkOid . TL.pack <$> manyTill anyChar newline) parentOids <- many (string "parent " *> - (Tagged . Oid . TL.pack + (Tagged . mkOid . TL.pack <$> manyTill anyChar newline)) author <- parseSignature "author" committer <- parseSignature "committer" @@ -676,7 +664,7 @@ setStdin (TL.fromStrict message) let commit = Git.Commit - { Git.commitOid = Tagged (Oid (TL.init oid)) + { Git.commitOid = Tagged (mkOid (TL.init oid)) , Git.commitAuthor = author , Git.commitCommitter = committer , Git.commitLog = message @@ -713,7 +701,7 @@ nameAndShaToRef :: TL.Text -> TL.Text -> Reference m nameAndShaToRef name sha = Git.Reference (TL.toStrict name) - (Git.RefObj (Git.ByOid (Tagged (Oid sha)))) + (Git.RefObj (Git.ByOid (Tagged (mkOid sha)))) cliLookupRef :: Git.MonadGit m => Text -> CmdLineRepository m (Maybe (Reference m)) @@ -728,7 +716,7 @@ => Text -> Git.RefTarget (CmdLineRepository m) (Commit m) -> CmdLineRepository m (Reference m) cliUpdateRef refName refObj@(Git.RefObj commitRef) = do - let Tagged (Oid sha) = Git.commitRefOid commitRef + let Tagged (getOid -> sha) = Git.commitRefOid commitRef runGit_ ["update-ref", TL.fromStrict refName, sha] return (Git.Reference refName refObj) @@ -757,7 +745,7 @@ , TL.fromStrict refName ] ec <- lastExitCode return $ if ec == 0 - then Just (Git.ByOid (Tagged (Oid (TL.init rev)))) + then Just (Git.ByOid (Tagged (mkOid (TL.init rev)))) else Nothing -- cliLookupTag :: TagOid -> CmdLineRepository Tag @@ -766,7 +754,7 @@ cliCreateTag :: Git.MonadGit m => CommitOid m -> Git.Signature -> Text -> Text -> CmdLineRepository m (Tag m) -cliCreateTag oid@(Tagged (Oid sha)) tagger msg name = do +cliCreateTag oid@(Tagged (getOid -> sha)) tagger msg name = do tsha <- doRunGit run ["mktag"] $ setStdin $ TL.unlines $ [ "object " <> sha , "type commit" @@ -776,7 +764,7 @@ <> TL.pack (formatTime defaultTimeLocale "%s %z" (Git.signatureWhen tagger)) , ""] <> TL.lines (TL.fromStrict msg) - return $ Git.Tag (Tagged (Oid (TL.init tsha))) (Git.ByOid oid) + return $ Git.Tag (Tagged (mkOid (TL.init tsha))) (Git.ByOid oid) data Repository = Repository { repoOptions :: Git.RepositoryOptions 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.0.1 +Version: 1.1.0 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,8 @@ ghc-options: -Wall build-depends: base >= 3 && < 5 - , gitlib - , gitlib-utils + , gitlib >= 1.1.0 + , gitlib-utils >= 1.1.0 , bytestring >= 0.9.2.1 , conduit >= 0.5.5 , containers >= 0.4.2.1 @@ -50,10 +50,10 @@ hs-source-dirs: test build-depends: base >=3 - , gitlib - , gitlib-utils - , gitlib-test - , gitlib-cmdline + , gitlib >= 1.1.0 + , gitlib-utils >= 1.1.0 + , gitlib-test >= 1.1.0 + , gitlib-cmdline >= 1.1.0 , HUnit >= 1.2.5 , hspec >= 1.4.4 , hspec-expectations >= 0.3