diff --git a/Git/CmdLine.hs b/Git/CmdLine.hs --- a/Git/CmdLine.hs +++ b/Git/CmdLine.hs @@ -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 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: 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