gitlib-cmdline 1.0.1 → 1.1.0
raw patch · 2 files changed
+177/−189 lines, 2 filesdep ~gitlibdep ~gitlib-cmdlinedep ~gitlib-test
Dependency ranges changed: gitlib, gitlib-cmdline, gitlib-test, gitlib-utils
Files
- Git/CmdLine.hs +170/−182
- gitlib-cmdline.cabal +7/−7
Git/CmdLine.hs view
@@ -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
gitlib-cmdline.cabal view
@@ -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