diff --git a/Git/CmdLine.hs b/Git/CmdLine.hs --- a/Git/CmdLine.hs +++ b/Git/CmdLine.hs @@ -16,16 +16,13 @@ module Git.CmdLine where +import Conduit import Control.Applicative hiding (many) -import Control.Failure import Control.Monad -import Control.Monad.IO.Class import Control.Monad.Reader.Class -import Control.Monad.Trans.Class 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 qualified Data.ByteString.Char8 as BC import Data.Foldable (for_) import Data.Function import qualified Data.HashMap.Strict as HashMap @@ -88,7 +85,7 @@ -- instance HasCliRepo (env, CliRepo) where -- getCliRepo = snd -instance (Applicative m, Failure GitException m, MonadIO m) +instance (Applicative m, MonadThrow m, MonadIO m) => MonadGit CliRepo (ReaderT CliRepo m) where type Oid CliRepo = SHA data Tree CliRepo = CmdLineTree (TreeOid CliRepo) @@ -112,7 +109,7 @@ lookupCommit = cliLookupCommit lookupTree = cliLookupTree lookupBlob = cliLookupBlob - lookupTag = error "Not defined cliLookupTag" + lookupTag = cliLookupTag lookupObject = error "Not defined cliLookupObject" existsObject = cliExistsObject sourceObjects = cliSourceObjects @@ -127,7 +124,7 @@ diffContentsWithTree = error "Not defined cliDiffContentsWithTree" -type MonadCli m = (Applicative m, Failure GitException m, MonadIO m) +type MonadCli m = (Applicative m, MonadThrow m, MonadIO m) mkOid :: MonadCli m => forall o. TL.Text -> ReaderT CliRepo m (Tagged o SHA) mkOid = fmap Tagged <$> textToSha . toStrict @@ -213,9 +210,9 @@ Nothing -> do mcref <- resolveReference remoteRefName case mcref of - Nothing -> failure $ BackendError "git push failed" + Nothing -> throwM $ BackendError "git push failed" Just cref -> return $ Tagged cref - Just err -> failure err + Just err -> throwM err cliResetHard :: MonadCli m => Text -> ReaderT CliRepo m () cliResetHard refname = @@ -244,13 +241,13 @@ ] Right <$> lastExitCode case eres of - Left err -> failure err + Left err -> throwM err Right r -> if r == 0 then MergeSuccess <$> (Tagged <$> getOid "HEAD") else case leftHead of Nothing -> - failure (BackendError + throwM (BackendError "Reference missing: HEAD (left)") Just lh -> recordMerge lh where @@ -289,7 +286,7 @@ getOid name = do mref <- cliResolveRef name case mref of - Nothing -> failure $ BackendError + Nothing -> throwM $ BackendError $ T.append "Reference missing: " name Just ref -> return ref @@ -335,7 +332,7 @@ B.empty if r == ExitSuccess then return (Blob oid (BlobString out)) - else failure BlobLookupFailed + else throwM BlobLookupFailed cliDoCreateBlob :: MonadCli m => BlobContents (ReaderT CliRepo m) @@ -353,7 +350,7 @@ bs if r == ExitSuccess then mkOid . fromStrict . T.init . T.decodeUtf8 $ out - else failure $ BlobCreateFailed "Failed to create blob" + else throwM $ BlobCreateFailed "Failed to create blob" cliHashContents :: MonadCli m => BlobContents (ReaderT CliRepo m) @@ -395,8 +392,8 @@ toid <- lift $ parseObjOid tsha yield $ TreeObjOid toid - go x = failure (BackendError $ - "Unexpected output from git-log: " <> T.pack (show x)) + go x = throwM (BackendError $ + "Unexpected output from git-log: " <> T.pack (show x)) cliReadTree :: MonadCli m => Tree CliRepo -> ReaderT CliRepo m (Pure.EntryHashMap CliRepo) @@ -419,17 +416,17 @@ "100644" -> return PlainBlob "100755" -> return ExecutableBlob "120000" -> return SymlinkBlob - _ -> failure $ BackendError $ + _ -> throwM $ BackendError $ "Unknown blob mode: " <> T.pack (show mode) "commit" -> CommitEntry <$> mkOid sha "tree" -> TreeEntry <$> mkOid sha - _ -> failure $ BackendError "This cannot happen" + _ -> throwM $ BackendError "This cannot happen" cliWriteTree :: MonadCli m => Pure.EntryHashMap CliRepo -> ReaderT CliRepo m (TreeOid CliRepo) cliWriteTree entMap = do rendered <- mapM renderLine (HashMap.toList entMap) - when (null rendered) $ failure TreeEmptyCreateFailed + when (null rendered) $ throwM TreeEmptyCreateFailed oid <- doRunGit run [ "mktree", "-z", "--missing" ] $ setStdin $ TL.append (TL.intercalate "\NUL" rendered) "\NUL" mkOid (TL.init oid) @@ -463,9 +460,16 @@ ec <- shellyNoDir $ silently $ errExit False $ do git_ repo [ "cat-file", "-t", fromStrict sha ] lastExitCode + -- res <- git repo [ "cat-file", "-t", fromStrict sha ] + -- ec <- lastExitCode + -- return $ if ec == 0 + -- then if res == "tree" + -- then 0 + -- else (-1) + -- else ec if ec == 0 then return $ CmdLineTree oid - else failure (ObjectLookupFailed sha 40) + else throwM (ObjectLookupFailed sha 40) cliTreeEntry :: MonadCli m => Tree CliRepo -> TreeFilePath @@ -509,10 +513,10 @@ setStdin (TL.append (fromStrict sha) "\n") result <- runParserT parseOutput () "" (TL.unpack output) case result of - Left e -> failure $ CommitLookupFailed (T.pack (show e)) + Left e -> throwM $ CommitLookupFailed (T.pack (show e)) Right c -> return c where - parseOutput :: (Stream s (ReaderT CliRepo m) Char, MonadCli m) + parseOutput :: (Stream s (ReaderT CliRepo m) Char, MonadCli m) => ParsecT s u (ReaderT CliRepo m) (Commit CliRepo) parseOutput = do coid <- manyTill alphaNum space @@ -632,7 +636,7 @@ cliSourceRefs :: MonadCli m => Producer (ReaderT CliRepo m) Text cliSourceRefs = do mxs <- lift $ cliShowRef Nothing - CL.sourceList $ case mxs of + yieldMany $ case mxs of Nothing -> [] Just xs -> map (toStrict . fst) xs @@ -649,9 +653,26 @@ then Just <$> textToSha (toStrict (TL.init rev)) else return Nothing --- cliLookupTag :: MonadCli m --- => TagOid CliRepo -> ReaderT CliRepo m (Tag CliRepo) --- cliLookupTag oid = undefined +cliLookupTag :: MonadCli m + => TagOid CliRepo -> ReaderT CliRepo m (Tag CliRepo) +cliLookupTag tag@(renderObjOid -> sha) = do + repo <- getRepository + (r,out,_) <- + liftIO $ readProcessWithExitCode "git" + (map TL.unpack (gitStdOpts repo) + ++ ["cat-file", "tag", TL.unpack (fromStrict sha)]) + B.empty + if r == ExitSuccess + then do + p <- runParserT parseOutput () "" (BC.unpack out) + case p of + Left e -> throwM $ TagLookupFailed $ T.pack $ show e + Right oid -> return $ Tag tag oid + else throwM $ TagLookupFailed "" + where + parseOutput = do + oid <- (string "object " *> manyTill alphaNum newline) + lift $ mkOid $ TL.pack oid cliCreateTag :: MonadCli m => CommitOid CliRepo -> Signature -> Text -> Text diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.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: 3.0.1 +Version: 3.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 @@ -22,10 +22,11 @@ base >= 3 && < 5 , gitlib >= 3.0.0 , bytestring >= 0.9.2.1 - , conduit >= 0.5.5 + , conduit >= 1.1.0 + , conduit-combinators >= 0.2.4 , containers >= 0.4.2.1 , directory >= 1.1.0.2 - , failure >= 0.2.0.1 + , exceptions >= 0.5 , monad-control >= 0.3.2 , mtl >= 2.1.2 , old-locale >= 1.0.0.4