gitlib-cmdline 2.2.0.0 → 3.0.0
raw patch · 2 files changed
+302/−376 lines, 2 filesdep +mtldep ~gitlibdep ~gitlib-cmdlinedep ~gitlib-test
Dependencies added: mtl
Dependency ranges changed: gitlib, gitlib-cmdline, gitlib-test
Files
- Git/CmdLine.hs +296/−371
- gitlib-cmdline.cabal +6/−5
Git/CmdLine.hs view
@@ -9,22 +9,23 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TupleSections #-}+ {-# OPTIONS_GHC -Wall #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-# OPTIONS_GHC -fno-warn-orphans #-} module Git.CmdLine where import Control.Applicative hiding (many)-import Control.Exception hiding (try) import Control.Failure import Control.Monad-import Control.Monad.Base import Control.Monad.IO.Class+import Control.Monad.Reader.Class import Control.Monad.Trans.Class-import Control.Monad.Trans.Control-import Control.Monad.Trans.Reader+import Control.Monad.Trans.Reader (ReaderT, runReaderT) import qualified Data.ByteString as B import Data.Conduit hiding (MonadBaseControl)+import qualified Data.Conduit.List as CL import Data.Foldable (for_) import Data.Function import qualified Data.HashMap.Strict as HashMap@@ -43,12 +44,11 @@ #endif import Data.Time import qualified Filesystem.Path.CurrentOS as F-import qualified Git+import Git import qualified Git.Tree.Builder.Pure as Pure import Shelly hiding (FilePath, trace) import System.Directory import System.Exit-import System.IO.Unsafe import System.Locale (defaultTimeLocale) import System.Process.ByteString import Text.Parsec.Char@@ -71,70 +71,67 @@ 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)+newtype CliRepo = CliRepo RepositoryOptions -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)+cliRepoPath :: CliRepo -> TL.Text+cliRepoPath (CliRepo options) = TL.pack $ repoPath options -type Object m = Git.Object (CmdLineRepository m)-type ObjectOid m = Git.ObjectOid (CmdLineRepository m)-type RefTarget m = Git.RefTarget (CmdLineRepository m)+-- class HasCliRepo env where+-- getCliRepo :: env -> CliRepo -type TreeBuilder m = Git.TreeBuilder (CmdLineRepository m)-type ModifiedBuilder m = Git.ModifiedBuilder (CmdLineRepository m)+-- instance HasCliRepo CliRepo where+-- getCliRepo = id -instance Git.MonadGit m => Git.Repository (CmdLineRepository m) where- type Oid (CmdLineRepository m) = Git.SHA- data Tree (CmdLineRepository m) = CmdLineTree (TreeOid m)- data Options (CmdLineRepository m) = Options+-- instance HasCliRepo (env, CliRepo) where+-- getCliRepo = snd - facts = return Git.RepositoryFacts- { Git.hasSymbolicReferences = True }+instance (Applicative m, Failure GitException m, MonadIO m)+ => MonadGit CliRepo (ReaderT CliRepo m) where+ type Oid CliRepo = SHA+ data Tree CliRepo = CmdLineTree (TreeOid CliRepo)+ data Options CliRepo = Options - parseOid = Git.textToSha+ facts = return RepositoryFacts+ { hasSymbolicReferences = True } - lookupReference = cliLookupRef- createReference = cliUpdateRef- updateReference = cliUpdateRef- deleteReference = cliDeleteRef- listReferences = cliListRefs- lookupCommit = cliLookupCommit- lookupTree = cliLookupTree- lookupBlob = cliLookupBlob- lookupTag = error "Not defined cliLookupTag"- lookupObject = error "Not defined cliLookupObject"- existsObject = cliExistsObject- sourceObjects = cliSourceObjects- newTreeBuilder = Pure.newPureTreeBuilder cliReadTree cliWriteTree- treeEntry = cliTreeEntry- listTreeEntries = cliListTreeEntries- treeOid = \(CmdLineTree toid) -> toid- hashContents = cliHashContents- createBlob = cliCreateBlob- createCommit = cliCreateCommit- createTag = cliCreateTag+ getRepository = ask+ closeRepository = return ()+ deleteRepository = getRepository >>=+ liftIO . removeDirectoryRecursive . TL.unpack . cliRepoPath - -- remoteFetch = error "Not defined: CmdLineRepository.remoteFetch"+ parseOid = textToSha - deleteRepository =- cliGet >>= liftIO- . removeDirectoryRecursive . Git.repoPath . repoOptions+ lookupReference = cliLookupRef+ createReference = cliUpdateRef+ updateReference = cliUpdateRef+ deleteReference = cliDeleteRef+ sourceReferences = cliSourceRefs+ lookupCommit = cliLookupCommit+ lookupTree = cliLookupTree+ lookupBlob = cliLookupBlob+ lookupTag = error "Not defined cliLookupTag"+ lookupObject = error "Not defined cliLookupObject"+ existsObject = cliExistsObject+ sourceObjects = cliSourceObjects+ newTreeBuilder = Pure.newPureTreeBuilder cliReadTree cliWriteTree+ treeOid (CmdLineTree toid) = return toid+ treeEntry = cliTreeEntry+ sourceTreeEntries = cliSourceTreeEntries+ hashContents = cliHashContents+ createBlob = cliCreateBlob+ createCommit = cliCreateCommit+ createTag = cliCreateTag diffContentsWithTree = error "Not defined cliDiffContentsWithTree" -mkOid :: Git.MonadGit m- => forall o. TL.Text -> CmdLineRepository m (Tagged o Git.SHA)-mkOid = fmap Tagged <$> Git.textToSha . toStrict+type MonadCli m = (Applicative m, Failure GitException m, MonadIO m) -shaToRef :: Git.MonadGit m => TL.Text -> CmdLineRepository m (RefTarget m)-shaToRef = fmap (Git.RefObj . untag) . mkOid+mkOid :: MonadCli m => forall o. TL.Text -> ReaderT CliRepo m (Tagged o SHA)+mkOid = fmap Tagged <$> textToSha . toStrict +shaToRef :: MonadCli m => TL.Text -> ReaderT CliRepo m (RefTarget CliRepo)+shaToRef = fmap (RefObj . untag) . mkOid+ parseCliTime :: String -> ZonedTime parseCliTime = fromJust . parseTime defaultTimeLocale "%s %z" @@ -150,24 +147,22 @@ git_ :: [TL.Text] -> Sh () git_ = run_ "git" -doRunGit :: Git.MonadGit m+doRunGit :: MonadCli m => (F.FilePath -> [TL.Text] -> Sh a) -> [TL.Text] -> Sh ()- -> CmdLineRepository m a+ -> ReaderT CliRepo m a doRunGit f args act = do- repo <- cliGet+ repo <- getRepository shellyNoDir $ silently $ do act- f "git" $ ["--git-dir", repoPath repo] <> args+ f "git" $ ["--git-dir", cliRepoPath repo] <> args -runGit :: Git.MonadGit m- => [TL.Text] -> CmdLineRepository m TL.Text+runGit :: MonadCli m => [TL.Text] -> ReaderT CliRepo m TL.Text runGit = flip (doRunGit run) (return ()) -runGit_ :: Git.MonadGit m- => [TL.Text] -> CmdLineRepository m ()+runGit_ :: MonadCli m => [TL.Text] -> ReaderT CliRepo m () runGit_ = flip (doRunGit run_) (return ()) -cliRepoDoesExist :: Text -> Sh (Either Git.GitException ())+cliRepoDoesExist :: Text -> Sh (Either GitException ()) cliRepoDoesExist remoteURI = do setenv "SSH_ASKPASS" "echo" setenv "GIT_ASKPASS" "echo"@@ -175,16 +170,16 @@ ec <- lastExitCode return $ if ec == 0 then Right ()- else Left $ Git.RepositoryCannotAccess remoteURI+ else Left $ RepositoryCannotAccess remoteURI -cliFilePathToURI :: Git.MonadGit m => FilePath -> m FilePath+cliFilePathToURI :: (Functor m, MonadIO m) => FilePath -> m FilePath cliFilePathToURI = fmap ("file://localhost" <>) . liftIO . canonicalizePath -cliPushCommit :: Git.MonadGit m- => CommitOid m -> Text -> Text -> Maybe FilePath- -> CmdLineRepository m (CommitOid m)+cliPushCommit :: MonadCli m+ => CommitOid CliRepo -> Text -> Text -> Maybe FilePath+ -> ReaderT CliRepo m (CommitOid CliRepo) cliPushCommit cname remoteNameOrURI remoteRefName msshCmd = do- repo <- cliGet+ repo <- getRepository merr <- shellyNoDir $ silently $ errExit False $ do for_ msshCmd $ \sshCmd -> setenv "GIT_SSH" . TL.pack =<< liftIO (canonicalizePath sshCmd)@@ -193,9 +188,9 @@ case eres of Left e -> return $ Just e Right () -> do- git_ $ [ "--git-dir", repoPath repo ]+ git_ $ [ "--git-dir", cliRepoPath repo ] <> [ "push", fromStrict remoteNameOrURI- , TL.concat [ fromStrict (Git.renderObjOid cname)+ , TL.concat [ fromStrict (renderObjOid cname) , ":", fromStrict remoteRefName ] ] r <- lastExitCode if r == 0@@ -203,113 +198,111 @@ else Just . (\x -> if "non-fast-forward" `T.isInfixOf` x || "Note about fast-forwards" `T.isInfixOf` x- then Git.PushNotFastForward x- else (Git.BackendError $- "git push failed:\n" <> x))+ then PushNotFastForward x+ else BackendError $+ "git push failed:\n" <> x) . toStrict <$> lastStderr case merr of Nothing -> do- mcref <- Git.resolveReference remoteRefName+ mcref <- resolveReference remoteRefName case mcref of- Nothing -> failure (Git.BackendError $ "git push failed")- Just cref -> return (Tagged cref)+ Nothing -> failure $ BackendError "git push failed"+ Just cref -> return $ Tagged cref Just err -> failure err -cliResetHard :: Git.MonadGit m => Text -> CmdLineRepository m ()+cliResetHard :: MonadCli m => Text -> ReaderT CliRepo m () cliResetHard refname = doRunGit run_ [ "reset", "--hard", fromStrict refname ] $ return () -cliPullCommit :: Git.MonadGit m- => Text- -> Text- -> Text- -> Text- -> Maybe FilePath- -> CmdLineRepository m- (Git.MergeResult (CmdLineRepository m))+cliPullCommit :: MonadCli m+ => Text -> Text -> Text -> Text -> Maybe FilePath+ -> ReaderT CliRepo m (MergeResult CliRepo) cliPullCommit remoteNameOrURI remoteRefName user email msshCmd = do- repo <- cliGet+ repo <- getRepository leftHead <- fmap Tagged <$> cliResolveRef "HEAD"-- eres <- shellyNoDir $ silently $ errExit False $ do+ eres <- shellyNoDir $ silently $ errExit False $ do for_ msshCmd $ \sshCmd -> setenv "GIT_SSH" . TL.pack =<< liftIO (canonicalizePath sshCmd)- eres <- cliRepoDoesExist remoteNameOrURI case eres of Left e -> return (Left e) Right () -> do- git_ $ [ "--git-dir", repoPath repo- , "config", "user.name", fromStrict user- ]- git_ $ [ "--git-dir", repoPath repo- , "config", "user.email", fromStrict email- ]- git_ $ [ "--git-dir", repoPath repo+ git_ [ "--git-dir", cliRepoPath repo+ , "config", "user.name", fromStrict user+ ]+ git_ [ "--git-dir", cliRepoPath repo+ , "config", "user.email", fromStrict email+ ]+ git_ $ [ "--git-dir", cliRepoPath repo , "-c", "merge.conflictstyle=merge" ] <> [ "pull", "--quiet" , fromStrict remoteNameOrURI- , fromStrict remoteRefName ]+ , fromStrict remoteRefName+ ] Right <$> lastExitCode case eres of Left err -> failure err Right r -> if r == 0- then Git.MergeSuccess <$> (Tagged <$> getOid "HEAD")+ then MergeSuccess <$> (Tagged <$> getOid "HEAD") else case leftHead of Nothing ->- failure (Git.BackendError+ failure (BackendError "Reference missing: HEAD (left)")- Just lh -> recordMerge repo lh+ Just lh -> recordMerge lh where -- jww (2013-05-15): This function should not overwrite head, but simply -- create a detached commit and return its id.- recordMerge repo leftHead = do+ recordMerge :: MonadCli m+ => CommitOid CliRepo -> ReaderT CliRepo m (MergeResult CliRepo)+ recordMerge leftHead = do+ repo <- getRepository rightHead <- Tagged <$> getOid "MERGE_HEAD" xs <- shellyNoDir $ silently $ errExit False $ do xs <- returnConflict . TL.init- <$> git [ "--git-dir", repoPath repo+ <$> git [ "--git-dir", cliRepoPath repo , "status", "-z", "--porcelain" ] forM_ (Map.assocs xs) $ uncurry (handleFile repo)- git_ [ "--git-dir", repoPath repo+ git_ [ "--git-dir", cliRepoPath repo , "commit", "-F", ".git/MERGE_MSG" ] return xs- Git.MergeConflicted+ MergeConflicted <$> (Tagged <$> getOid "HEAD") <*> pure leftHead <*> pure rightHead <*> pure (Map.filter isConflict xs) - isConflict (Git.Deleted, Git.Deleted) = False- isConflict (_, Git.Unchanged) = False- isConflict (Git.Unchanged, _) = False+ isConflict (Deleted, Deleted) = False+ isConflict (_, Unchanged) = False+ isConflict (Unchanged, _) = False isConflict _ = True - handleFile repo fp (Git.Deleted, Git.Deleted) =- git_ [ "--git-dir", repoPath repo, "rm", "--cached"+ handleFile repo fp (Deleted, Deleted) =+ git_ [ "--git-dir", cliRepoPath repo, "rm", "--cached" , fromStrict . T.decodeUtf8 $ fp ]- handleFile repo fp (Git.Unchanged, Git.Deleted) =- git_ [ "--git-dir", repoPath repo, "rm", "--cached"+ handleFile repo fp (Unchanged, Deleted) =+ git_ [ "--git-dir", cliRepoPath repo, "rm", "--cached" , fromStrict . T.decodeUtf8 $ fp ] handleFile repo fp (_, _) =- git_ [ "--git-dir", repoPath repo, "add"+ git_ [ "--git-dir", cliRepoPath repo, "add" , fromStrict . T.decodeUtf8 $ fp ] + getOid :: MonadCli m => Text -> ReaderT CliRepo m (Oid CliRepo) getOid name = do mref <- cliResolveRef name case mref of- Nothing -> failure $ Git.BackendError+ Nothing -> failure $ BackendError $ T.append "Reference missing: " name Just ref -> return ref - charToModKind 'M' = Just Git.Modified- charToModKind 'U' = Just Git.Unchanged- charToModKind 'A' = Just Git.Added- charToModKind 'D' = Just Git.Deleted+ charToModKind 'M' = Just Modified+ charToModKind 'U' = Just Unchanged+ charToModKind 'A' = Just Added+ charToModKind 'D' = Just Deleted charToModKind _ = Nothing returnConflict xs =@@ -325,171 +318,173 @@ . TL.splitOn "\NUL" $ xs getModKinds l r = case (l, r) of- (Nothing, Just x) -> (Git.Unchanged, x)- (Just x, Nothing) -> (x, Git.Unchanged)+ (Nothing, Just x) -> (Unchanged, x)+ (Just x, Nothing) -> (x, Unchanged) -- 'U' really means unmerged, but it can mean both modified and -- unmodified as a result. Example: UU means both sides have modified -- a file, but AU means that the left side added the file and the -- right side knows nothing about the file.- (Just Git.Unchanged,- Just Git.Unchanged) -> (Git.Modified, Git.Modified)+ (Just Unchanged,+ Just Unchanged) -> (Modified, Modified) (Just x, Just y) -> (x, y) (Nothing, Nothing) -> error "Both merge items cannot be Unchanged" -cliLookupBlob :: Git.MonadGit m- => BlobOid m -> CmdLineRepository m (Blob m)-cliLookupBlob oid@(Git.renderObjOid -> sha) = do- repo <- cliGet+cliLookupBlob :: MonadCli m+ => BlobOid CliRepo+ -> ReaderT CliRepo m (Blob CliRepo (ReaderT CliRepo m))+cliLookupBlob oid@(renderObjOid -> sha) = do+ repo <- getRepository (r,out,_) <- liftIO $ readProcessWithExitCode "git"- [ "--git-dir", TL.unpack (repoPath repo)+ [ "--git-dir", TL.unpack (cliRepoPath repo) , "cat-file", "-p", TL.unpack (fromStrict sha) ] B.empty if r == ExitSuccess- then return (Git.Blob oid (Git.BlobString out))- else failure Git.BlobLookupFailed+ then return (Blob oid (BlobString out))+ else failure BlobLookupFailed -cliDoCreateBlob :: Git.MonadGit m- => Git.BlobContents (CmdLineRepository m) -> Bool- -> CmdLineRepository m (BlobOid m)+cliDoCreateBlob :: MonadCli m+ => BlobContents (ReaderT CliRepo m)+ -> Bool+ -> ReaderT CliRepo m (BlobOid CliRepo) cliDoCreateBlob b persist = do- repo <- cliGet- bs <- Git.blobContentsToByteString b+ repo <- getRepository+ bs <- blobContentsToByteString b (r,out,_) <- liftIO $ readProcessWithExitCode "git"- ([ "--git-dir", TL.unpack (repoPath repo), "hash-object" ]+ ([ "--git-dir", TL.unpack (cliRepoPath repo), "hash-object" ] <> ["-w" | persist] <> ["--stdin"]) bs if r == ExitSuccess then mkOid . fromStrict . T.init . T.decodeUtf8 $ out- else failure $ Git.BlobCreateFailed "Failed to create blob"+ else failure $ BlobCreateFailed "Failed to create blob" -cliHashContents :: Git.MonadGit m- => Git.BlobContents (CmdLineRepository m)- -> CmdLineRepository m (BlobOid m)+cliHashContents :: MonadCli m+ => BlobContents (ReaderT CliRepo m)+ -> ReaderT CliRepo m (BlobOid CliRepo) cliHashContents b = cliDoCreateBlob b False -cliCreateBlob :: Git.MonadGit m- => Git.BlobContents (CmdLineRepository m)- -> CmdLineRepository m (BlobOid m)+cliCreateBlob :: MonadCli m+ => BlobContents (ReaderT CliRepo m)+ -> ReaderT CliRepo m (BlobOid CliRepo) cliCreateBlob b = cliDoCreateBlob b True -cliExistsObject :: Git.MonadGit m- => Git.SHA -> CmdLineRepository m Bool-cliExistsObject (Git.shaToText -> sha) = do- repo <- cliGet+cliExistsObject :: MonadCli m => SHA -> ReaderT CliRepo m Bool+cliExistsObject (shaToText -> sha) = do+ repo <- getRepository shellyNoDir $ silently $ errExit False $ do- git_ [ "--git-dir", repoPath repo, "cat-file", "-e", fromStrict sha ]+ git_ [ "--git-dir", cliRepoPath repo, "cat-file", "-e", fromStrict sha ] ec <- lastExitCode return (ec == 0) -cliSourceObjects :: Git.MonadGit m- => Maybe (CommitOid m) -> CommitOid m -> Bool- -> Producer (CmdLineRepository m) (ObjectOid m)+cliSourceObjects :: MonadCli m+ => Maybe (CommitOid CliRepo) -> CommitOid CliRepo -> Bool+ -> Producer (ReaderT CliRepo m) (ObjectOid CliRepo) cliSourceObjects mhave need alsoTrees = do shas <- lift $ doRunGit run ([ "--no-pager", "log", "--format=%H %T" ] <> (case mhave of- Nothing -> [ fromStrict (Git.renderObjOid need) ]+ Nothing -> [ fromStrict (renderObjOid need) ] Just have ->- [ fromStrict (Git.renderObjOid have)+ [ fromStrict (renderObjOid have) , TL.append "^"- (fromStrict (Git.renderObjOid need)) ]))+ (fromStrict (renderObjOid need)) ])) $ return () mapM_ (go . T.words . toStrict) (TL.lines shas) where go [csha,tsha] = do- coid <- lift $ Git.parseObjOid csha- yield $ Git.CommitObjOid coid+ coid <- lift $ parseObjOid csha+ yield $ CommitObjOid coid when alsoTrees $ do- toid <- lift $ Git.parseObjOid tsha- yield $ Git.TreeObjOid toid+ toid <- lift $ parseObjOid tsha+ yield $ TreeObjOid toid - go x = failure (Git.BackendError $+ go x = failure (BackendError $ "Unexpected output from git-log: " <> T.pack (show x)) -cliReadTree :: Git.MonadGit m- => Tree m- -> CmdLineRepository m (Pure.EntryHashMap (CmdLineRepository m))-cliReadTree (CmdLineTree (Git.renderObjOid -> sha)) = do+cliReadTree :: MonadCli m+ => Tree CliRepo -> ReaderT CliRepo m (Pure.EntryHashMap CliRepo)+cliReadTree (CmdLineTree (renderObjOid -> sha)) = do contents <- runGit ["ls-tree", "-z", fromStrict 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)) -cliParseLsTree :: Git.MonadGit m- => TL.Text -> CmdLineRepository m (Git.TreeFilePath, TreeEntry m)+cliParseLsTree :: MonadCli m+ => TL.Text -> ReaderT CliRepo m (TreeFilePath, TreeEntry CliRepo) cliParseLsTree line = let [prefix,path] = TL.splitOn "\t" line [mode,kind,sha] = TL.words prefix in liftM2 (,) (return (T.encodeUtf8 . toStrict $ path)) $ case kind of "blob" -> do oid <- mkOid sha- return $ Git.BlobEntry oid $ case mode of- "100644" -> Git.PlainBlob- "100755" -> Git.ExecutableBlob- "120000" -> Git.SymlinkBlob- _ -> Git.UnknownBlob- "commit" -> Git.CommitEntry <$> mkOid sha- "tree" -> Git.TreeEntry <$> mkOid sha- _ -> failure $ Git.BackendError "This cannot happen"+ BlobEntry oid <$> case mode of+ "100644" -> return PlainBlob+ "100755" -> return ExecutableBlob+ "120000" -> return SymlinkBlob+ _ -> failure $ BackendError $+ "Unknown blob mode: " <> T.pack (show mode)+ "commit" -> CommitEntry <$> mkOid sha+ "tree" -> TreeEntry <$> mkOid sha+ _ -> failure $ BackendError "This cannot happen" -cliWriteTree :: Git.MonadGit m- => Pure.EntryHashMap (CmdLineRepository m)- -> CmdLineRepository m (TreeOid m)+cliWriteTree :: MonadCli m+ => Pure.EntryHashMap CliRepo -> ReaderT CliRepo m (TreeOid CliRepo) cliWriteTree entMap = do rendered <- mapM renderLine (HashMap.toList entMap)- when (null rendered) $ failure Git.TreeEmptyCreateFailed+ when (null rendered) $ failure TreeEmptyCreateFailed oid <- doRunGit run ["mktree", "-z", "--missing"] $ setStdin $ TL.append (TL.intercalate "\NUL" rendered) "\NUL" mkOid (TL.init oid) where renderLine (fromStrict . T.decodeUtf8 -> path,- Git.BlobEntry (Git.renderObjOid -> sha) kind) =+ BlobEntry (renderObjOid -> sha) kind) = return $ TL.concat [ case kind of- Git.PlainBlob -> "100644"- Git.ExecutableBlob -> "100755"- Git.SymlinkBlob -> "120000"- Git.UnknownBlob -> "100000"+ PlainBlob -> "100644"+ ExecutableBlob -> "100755"+ SymlinkBlob -> "120000" , " blob ", fromStrict sha, "\t", path ]- renderLine (fromStrict . T.decodeUtf8 -> path, Git.CommitEntry coid) = do+ renderLine (fromStrict . T.decodeUtf8 -> path, CommitEntry coid) = return $ TL.concat [ "160000 commit "- , fromStrict (Git.renderObjOid coid), "\t"+ , fromStrict (renderObjOid coid), "\t" , path ]- renderLine (fromStrict . T.decodeUtf8 -> path, Git.TreeEntry toid) = do+ renderLine (fromStrict . T.decodeUtf8 -> path, TreeEntry toid) = return $ TL.concat [ "040000 tree "- , fromStrict (Git.renderObjOid toid), "\t"+ , fromStrict (renderObjOid toid), "\t" , path ] -cliLookupTree :: Git.MonadGit m => TreeOid m -> CmdLineRepository m (Tree m)-cliLookupTree oid@(Git.renderObjOid -> sha) = do- repo <- cliGet+cliLookupTree :: MonadCli m+ => TreeOid CliRepo -> ReaderT CliRepo m (Tree CliRepo)+cliLookupTree oid@(renderObjOid -> sha) = do+ repo <- getRepository ec <- shellyNoDir $ silently $ errExit False $ do- git_ $ [ "--git-dir", repoPath repo, "cat-file", "-t", fromStrict sha ]+ git_ [ "--git-dir", cliRepoPath repo+ , "cat-file", "-t", fromStrict sha+ ] lastExitCode if ec == 0 then return $ CmdLineTree oid- else failure (Git.ObjectLookupFailed sha 40)+ else failure (ObjectLookupFailed sha 40) -cliTreeEntry :: Git.MonadGit m- => Tree m- -> Git.TreeFilePath- -> CmdLineRepository m (Maybe (TreeEntry m))+cliTreeEntry :: MonadCli m+ => Tree CliRepo -> TreeFilePath+ -> ReaderT CliRepo m (Maybe (TreeEntry CliRepo)) cliTreeEntry tree fp = do- repo <- cliGet+ repo <- getRepository+ toid <- treeOid tree mentryLines <- shellyNoDir $ silently $ errExit False $ do- contents <- git $ [ "--git-dir", repoPath repo- , "ls-tree", "-z"- , fromStrict (Git.renderObjOid (Git.treeOid tree))- , "--", fromStrict . T.decodeUtf8 $ fp- ]+ contents <- git [ "--git-dir", cliRepoPath repo+ , "ls-tree", "-z"+ , fromStrict (renderObjOid toid)+ , "--", fromStrict . T.decodeUtf8 $ fp+ ] ec <- lastExitCode return $ if ec == 0 then Just $ L.init (TL.splitOn "\NUL" contents)@@ -502,24 +497,30 @@ [] -> Nothing ((_,x):_) -> Just x -cliListTreeEntries :: Git.MonadGit m- => Tree m- -> CmdLineRepository m [(Git.TreeFilePath, TreeEntry m)]-cliListTreeEntries tree = do- contents <- runGit [ "ls-tree", "-t", "-r", "-z"- , fromStrict (Git.renderObjOid (Git.treeOid tree)) ]- mapM cliParseLsTree (L.init (TL.splitOn "\NUL" contents))+cliSourceTreeEntries :: MonadCli m+ => Tree CliRepo+ -> Producer (ReaderT CliRepo m) (TreeFilePath, TreeEntry CliRepo)+cliSourceTreeEntries tree = do+ contents <- lift $ do+ toid <- treeOid tree+ runGit [ "ls-tree", "-t", "-r", "-z"+ , fromStrict (renderObjOid toid)+ ]+ forM_ (L.init (TL.splitOn "\NUL" contents)) $+ yield <=< lift . cliParseLsTree -cliLookupCommit :: Git.MonadGit m- => CommitOid m -> CmdLineRepository m (Commit m)-cliLookupCommit (Git.renderObjOid -> sha) = do- output <- doRunGit run ["cat-file", "--batch"]- $ setStdin (TL.append (fromStrict sha) "\n")+cliLookupCommit :: MonadCli m+ => CommitOid CliRepo -> ReaderT CliRepo m (Commit CliRepo)+cliLookupCommit (renderObjOid -> sha) = do+ output <- doRunGit run ["cat-file", "--batch"] $+ setStdin (TL.append (fromStrict sha) "\n") result <- runParserT parseOutput () "" (TL.unpack output) case result of- Left e -> failure $ Git.CommitLookupFailed (T.pack (show e))+ Left e -> failure $ CommitLookupFailed (T.pack (show e)) Right c -> return c where+ parseOutput :: (Stream s (ReaderT CliRepo m) Char, MonadCli m)+ => ParsecT s u (ReaderT CliRepo m) (Commit CliRepo) parseOutput = do coid <- manyTill alphaNum space _ <- string "commit " *> manyTill digit newline@@ -529,66 +530,66 @@ committer <- parseSignature "committer" message <- newline *> many anyChar - coid' <- lift $ mkOid (TL.pack coid)- toid' <- lift $ mkOid (TL.pack treeOid)- poids' <- lift $ mapM (mkOid . TL.pack) parentOids-- return Git.Commit- { Git.commitOid = coid'- , Git.commitAuthor = author- , Git.commitCommitter = committer- , Git.commitLog = T.pack (init message)- , Git.commitTree = toid'- , Git.commitParents = poids'- , Git.commitEncoding = "utf-8"- }+ lift $ do+ coid' <- mkOid (TL.pack coid)+ toid' <- mkOid (TL.pack treeOid)+ poids' <- mapM (mkOid . TL.pack) parentOids+ return Commit+ { commitOid = coid'+ , commitAuthor = author+ , commitCommitter = committer+ , commitLog = T.pack (init message)+ , commitTree = toid'+ , commitParents = poids'+ , commitEncoding = "utf-8"+ } parseSignature txt =- Git.Signature+ Signature <$> (string (T.unpack txt ++ " ") *> (T.pack <$> manyTill anyChar (try (string " <")))) <*> (T.pack <$> manyTill anyChar (try (string "> "))) <*> (parseCliTime <$> manyTill anyChar newline) -cliCreateCommit :: Git.MonadGit m- => [CommitOid m]- -> TreeOid m- -> Git.Signature- -> Git.Signature+cliCreateCommit :: MonadCli m+ => [CommitOid CliRepo]+ -> TreeOid CliRepo+ -> Signature+ -> Signature -> Text -> Maybe Text- -> CmdLineRepository m (Commit m)+ -> ReaderT CliRepo m (Commit CliRepo) cliCreateCommit parentOids treeOid author committer message ref = do oid <- doRunGit run (["commit-tree"]- <> [fromStrict (Git.renderObjOid treeOid)]- <> L.concat [["-p", fromStrict (Git.renderObjOid poid)] |+ <> [fromStrict (renderObjOid treeOid)]+ <> L.concat [["-p", fromStrict (renderObjOid poid)] | poid <- parentOids]) $ do mapM_ (\(var,f,val) -> setenv var (fromStrict (f val)))- [ ("GIT_AUTHOR_NAME", Git.signatureName, author)- , ("GIT_AUTHOR_EMAIL", Git.signatureEmail, author)+ [ ("GIT_AUTHOR_NAME", signatureName, author)+ , ("GIT_AUTHOR_EMAIL", signatureEmail, author) , ("GIT_AUTHOR_DATE",- formatCliTime . Git.signatureWhen, author)- , ("GIT_COMMITTER_NAME", Git.signatureName, committer)- , ("GIT_COMMITTER_EMAIL", Git.signatureEmail, committer)+ formatCliTime . signatureWhen, author)+ , ("GIT_COMMITTER_NAME", signatureName, committer)+ , ("GIT_COMMITTER_EMAIL", signatureEmail, committer) , ("GIT_COMMITTER_DATE",- formatCliTime . Git.signatureWhen, committer)+ formatCliTime . signatureWhen, committer) ] setStdin (fromStrict message) coid <- mkOid (TL.init oid)- let commit = Git.Commit- { Git.commitOid = coid- , Git.commitAuthor = author- , Git.commitCommitter = committer- , Git.commitLog = message- , Git.commitTree = treeOid- , Git.commitParents = parentOids- , Git.commitEncoding = "utf-8"+ let commit = Commit+ { commitOid = coid+ , commitAuthor = author+ , commitCommitter = committer+ , commitLog = message+ , commitTree = treeOid+ , commitParents = parentOids+ , commitEncoding = "utf-8" } when (isJust ref) $ void $ cliUpdateRef (fromJust ref)- (Git.RefObj (untag (Git.commitOid commit)))+ (RefObj (untag (commitOid commit))) return commit @@ -600,12 +601,12 @@ { referenceRef :: Text , referenceObject :: CliObjectRef } deriving Show -cliShowRef :: Git.MonadGit m- => Maybe Text -> CmdLineRepository m (Maybe [(TL.Text,TL.Text)])+cliShowRef :: MonadCli m+ => Maybe Text -> ReaderT CliRepo m (Maybe [(TL.Text,TL.Text)]) cliShowRef mrefName = do- repo <- cliGet+ repo <- getRepository shellyNoDir $ silently $ errExit False $ do- rev <- git $ [ "--git-dir", repoPath repo, "show-ref" ]+ rev <- git $ [ "--git-dir", cliRepoPath repo, "show-ref" ] <> [ fromStrict (fromJust mrefName) | isJust mrefName ] ec <- lastExitCode return $ if ec == 0@@ -613,161 +614,85 @@ $ TL.lines rev else Nothing -cliLookupRef :: Git.MonadGit m- => Text -> CmdLineRepository m (Maybe (RefTarget m))+cliLookupRef :: MonadCli m+ => Text -> ReaderT CliRepo m (Maybe (RefTarget CliRepo)) cliLookupRef refName = do- repo <- cliGet+ repo <- getRepository (ec,rev) <- shellyNoDir $ silently $ errExit False $ do- rev <- git $ [ "--git-dir", repoPath repo- , "symbolic-ref", fromStrict refName ]+ rev <- git [ "--git-dir", cliRepoPath repo+ , "symbolic-ref", fromStrict refName+ ] ec <- lastExitCode return (ec,rev) if ec == 0- then return . Just . Git.RefSymbolic . toStrict . TL.init $ rev- else fmap Git.RefObj <$> cliResolveRef refName+ then return . Just . RefSymbolic . toStrict . TL.init $ rev+ else fmap RefObj <$> cliResolveRef refName -cliUpdateRef :: Git.MonadGit m- => Text -> Git.RefTarget (CmdLineRepository m)- -> CmdLineRepository m ()-cliUpdateRef refName (Git.RefObj (Git.renderOid -> sha)) =+cliUpdateRef :: MonadCli m => Text -> RefTarget CliRepo -> ReaderT CliRepo m ()+cliUpdateRef refName (RefObj (renderOid -> sha)) = runGit_ ["update-ref", fromStrict refName, fromStrict sha] -cliUpdateRef refName (Git.RefSymbolic targetName) =+cliUpdateRef refName (RefSymbolic targetName) = runGit_ ["symbolic-ref", fromStrict refName, fromStrict targetName] -cliDeleteRef :: Git.MonadGit m => Text -> CmdLineRepository m ()+cliDeleteRef :: MonadCli m => Text -> ReaderT CliRepo m () cliDeleteRef refName = runGit_ ["update-ref", "-d", fromStrict refName] -cliListRefs :: Git.MonadGit m- => CmdLineRepository m [Text]-cliListRefs = do- mxs <- cliShowRef Nothing- return $ case mxs of+cliSourceRefs :: MonadCli m => Producer (ReaderT CliRepo m) Text+cliSourceRefs = do+ mxs <- lift $ cliShowRef Nothing+ CL.sourceList $ case mxs of Nothing -> [] Just xs -> map (toStrict . fst) xs -cliResolveRef :: Git.MonadGit m- => Text- -> CmdLineRepository m (Maybe (Git.Oid (CmdLineRepository m)))+cliResolveRef :: MonadCli m => Text -> ReaderT CliRepo m (Maybe (Oid CliRepo)) cliResolveRef refName = do- repo <- cliGet+ repo <- getRepository (rev, ec) <- shellyNoDir $ silently $ errExit False $ do- rev <- git [ "--git-dir", repoPath repo+ rev <- git [ "--git-dir", cliRepoPath repo , "rev-parse", "--quiet", "--verify" , fromStrict refName ] ec <- lastExitCode return (rev, ec) if ec == 0- then Just <$> Git.textToSha (toStrict (TL.init rev))+ then Just <$> textToSha (toStrict (TL.init rev)) else return Nothing --- cliLookupTag :: TagOid -> CmdLineRepository Tag+-- cliLookupTag :: MonadCli m+-- => TagOid CliRepo -> ReaderT CliRepo m (Tag CliRepo) -- cliLookupTag oid = undefined -cliCreateTag :: Git.MonadGit m- => CommitOid m -> Git.Signature -> Text -> Text- -> CmdLineRepository m (Tag m)-cliCreateTag oid@(Git.renderObjOid -> sha) tagger msg name = do+cliCreateTag :: MonadCli m+ => CommitOid CliRepo -> Signature -> Text -> Text+ -> ReaderT CliRepo m (Tag CliRepo)+cliCreateTag oid@(renderObjOid -> sha) tagger msg name = do tsha <- doRunGit run ["mktag"] $ setStdin $ TL.unlines $ [ "object " <> fromStrict sha , "type commit" , "tag " <> fromStrict name- , "tagger " <> fromStrict (Git.signatureName tagger)- <> " <" <> fromStrict (Git.signatureEmail tagger) <> "> "+ , "tagger " <> fromStrict (signatureName tagger)+ <> " <" <> fromStrict (signatureEmail tagger) <> "> " <> TL.pack (formatTime defaultTimeLocale "%s %z"- (Git.signatureWhen tagger))+ (signatureWhen tagger)) , ""] <> TL.lines (fromStrict msg)- Git.Tag <$> mkOid (TL.init tsha) <*> pure oid--data Repository = Repository- { repoOptions :: Git.RepositoryOptions- }--repoPath :: Repository -> TL.Text-repoPath = TL.pack . Git.repoPath . repoOptions--newtype CmdLineRepository m a = CmdLineRepository- { cmdLineRepositoryReaderT :: ReaderT Repository m a }--instance Functor m => Functor (CmdLineRepository m) where- fmap f (CmdLineRepository x) = CmdLineRepository (fmap f x)--instance Applicative m => Applicative (CmdLineRepository m) where- pure = CmdLineRepository . pure- CmdLineRepository f <*> CmdLineRepository x = CmdLineRepository (f <*> x)--instance Monad m => Monad (CmdLineRepository m) where- return = CmdLineRepository . return- CmdLineRepository m >>= f =- CmdLineRepository (m >>= cmdLineRepositoryReaderT . f)--instance MonadIO m => MonadIO (CmdLineRepository m) where- liftIO m = CmdLineRepository (liftIO m)--instance (Monad m, MonadIO m, Applicative m)- => MonadBase IO (CmdLineRepository m) where- liftBase = liftIO--instance Monad m => MonadUnsafeIO (CmdLineRepository m) where- unsafeLiftIO = return . unsafePerformIO--instance Monad m => MonadThrow (CmdLineRepository m) where- monadThrow = throw--instance MonadTrans CmdLineRepository where- lift = CmdLineRepository . ReaderT . const--instance MonadTransControl CmdLineRepository where- newtype StT CmdLineRepository a = StCmdLineRepository- { unCmdLineRepository :: StT (ReaderT Repository) a- }- liftWith = defaultLiftWith CmdLineRepository- cmdLineRepositoryReaderT StCmdLineRepository- restoreT = defaultRestoreT CmdLineRepository unCmdLineRepository--instance (MonadIO m, MonadBaseControl IO m)- => MonadBaseControl IO (CmdLineRepository m) where- newtype StM (CmdLineRepository m) a = StMT- { unStMT :: ComposeSt CmdLineRepository m a- }- liftBaseWith = defaultLiftBaseWith StMT- restoreM = defaultRestoreM unStMT--cliGet :: Monad m => CmdLineRepository m Repository-cliGet = CmdLineRepository ask+ Tag <$> mkOid (TL.init tsha) <*> pure oid -cliFactory :: Git.MonadGit m- => Git.RepositoryFactory (CmdLineRepository m) m Repository-cliFactory = Git.RepositoryFactory- { Git.openRepository = openCliRepository- , Git.runRepository = runCliRepository- , Git.closeRepository = closeCliRepository- , Git.getRepository = cliGet- , Git.defaultOptions = defaultCliOptions- , Git.startupBackend = return ()- , Git.shutdownBackend = return ()+cliFactory :: MonadCli m => RepositoryFactory (ReaderT CliRepo m) m CliRepo+cliFactory = RepositoryFactory+ { openRepository = openCliRepository+ , runRepository = flip runReaderT } -openCliRepository :: Git.MonadGit m => Git.RepositoryOptions -> m Repository+openCliRepository :: MonadIO m => RepositoryOptions -> m CliRepo openCliRepository opts = do- let path = Git.repoPath opts+ let path = repoPath opts exists <- liftIO $ doesDirectoryExist path- when (not exists && Git.repoAutoCreate opts) $ do+ when (not exists && repoAutoCreate opts) $ do liftIO $ createDirectoryIfMissing True path shellyNoDir $ silently $ git_ $ ["--git-dir", TL.pack path]- <> ["--bare" | Git.repoIsBare opts]+ <> ["--bare" | repoIsBare opts] <> ["init"]- return Repository { repoOptions = opts }--runCliRepository :: Git.MonadGit m => Repository -> CmdLineRepository m a -> m a-runCliRepository repo action =- runReaderT (cmdLineRepositoryReaderT action) repo--closeCliRepository :: Git.MonadGit m => Repository -> m ()-closeCliRepository = const (return ())--defaultCliOptions :: Git.RepositoryOptions-defaultCliOptions = Git.RepositoryOptions "" False False+ return $ CliRepo opts -- Cli.hs
gitlib-cmdline.cabal view
@@ -1,5 +1,5 @@ Name: gitlib-cmdline-Version: 2.2.0.0+Version: 3.0.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,13 +20,14 @@ ghc-options: -Wall build-depends: base >= 3 && < 5- , gitlib >= 2.2.0.0+ , gitlib >= 3.0.0 , bytestring >= 0.9.2.1 , conduit >= 0.5.5 , containers >= 0.4.2.1 , directory >= 1.1.0.2 , failure >= 0.2.0.1 , monad-control >= 0.3.2+ , mtl >= 2.1.2 , old-locale >= 1.0.0.4 , parsec >= 3.1.3 , process-extras >= 0.2.0@@ -49,9 +50,9 @@ hs-source-dirs: test build-depends: base >=3- , gitlib >= 2.2.0.0- , gitlib-test >= 2.2.0.0- , gitlib-cmdline >= 2.2.0.0+ , gitlib >= 3.0.0+ , gitlib-test >= 3.0.0+ , gitlib-cmdline >= 3.0.0 , hspec >= 1.4.4 , hspec-expectations >= 0.3 , system-filepath >= 0.4.7