gitlib-cmdline 3.0.1 → 3.1.0
raw patch · 3 files changed
+52/−30 lines, 3 filesdep +conduit-combinatorsdep +exceptionsdep −failuredep ~conduitsetup-changed
Dependencies added: conduit-combinators, exceptions
Dependencies removed: failure
Dependency ranges changed: conduit
Files
- Git/CmdLine.hs +48/−27
- Setup.hs +0/−0
- gitlib-cmdline.cabal +4/−3
Git/CmdLine.hs view
@@ -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
Setup.hs view
gitlib-cmdline.cabal view
@@ -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