gitlib-libgit2 3.0.1 → 3.1.0
raw patch · 4 files changed
+87/−46 lines, 4 filesdep +conduit-combinatorsdep +exceptionsdep −failuredep ~conduitdep ~monad-loggerdep ~resourcet
Dependencies added: conduit-combinators, exceptions
Dependencies removed: failure
Dependency ranges changed: conduit, monad-logger, resourcet, stm-conduit
Files
- Git/Libgit2.hs +71/−36
- Git/Libgit2/Internal.hs +2/−2
- Git/Libgit2/Types.hs +4/−2
- gitlib-libgit2.cabal +10/−6
Git/Libgit2.hs view
@@ -55,17 +55,16 @@ ) where import Bindings.Libgit2+import Conduit import Control.Applicative import Control.Concurrent (threadDelay) import Control.Concurrent.Async.Lifted import Control.Concurrent.STM-import Control.Exception.Lifted-import Control.Failure+--import Control.Exception.Lifted import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)-import Control.Monad.IO.Class+import Control.Monad.Catch import Control.Monad.Logger import Control.Monad.Loops-import Control.Monad.Morph hiding (embed) import Control.Monad.Reader.Class import Control.Monad.Trans.Control import Control.Monad.Trans.Reader (ReaderT, runReaderT)@@ -75,7 +74,6 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Unsafe as BU-import Data.Conduit import Data.Conduit.Async import Data.Foldable import Data.IORef@@ -154,11 +152,11 @@ lgParseOid :: MonadLg m => Text -> m Oid lgParseOid str- | len > 40 = failure (Git.OidParseFailed str)+ | len > 40 = throwM (Git.OidParseFailed str) | otherwise = do moid <- liftIO $ lgParseOidIO str len case moid of- Nothing -> failure (Git.OidParseFailed str)+ Nothing -> throwM (Git.OidParseFailed str) Just oid -> return oid where len = T.length str@@ -179,7 +177,7 @@ instance Eq OidPtr where oid1 == oid2 = oid1 `compare` oid2 == EQ -instance (Applicative m, Failure Git.GitException m,+instance (Applicative m, MonadExcept m, MonadBaseControl IO m, MonadIO m, MonadLogger m) => Git.MonadGit LgRepo (ReaderT LgRepo m) where type Oid LgRepo = OidPtr@@ -205,6 +203,7 @@ lookupTree = lgLookupTree lookupBlob = lgLookupBlob lookupTag = error "Not implemented: LgRepository.lookupTag"+ readIndex = lgReadIndex lookupObject = lgLookupObject existsObject = lgExistsObject sourceObjects = lgSourceObjects@@ -234,7 +233,7 @@ etrap <- lgExcTrap mexc <- liftIO $ readIORef etrap liftIO $ writeIORef etrap Nothing- maybe (throw (e :: SomeException)) throw mexc+ maybe (throwM (e :: SomeException)) throwM mexc lgHashContents :: MonadLg m => Git.BlobContents (ReaderT LgRepo m)@@ -343,7 +342,7 @@ ftoid <- coidPtrToOid toid return $ Tagged (mkOid ftoid) -gatherFrom' :: (MonadIO m, MonadBaseControl IO m)+gatherFrom' :: (MonadIO m, MonadBaseControl IO m, MonadExcept m) => Int -- ^ Size of the queue to create -> (TBQueue o -> m ()) -- ^ Action that generates output values -> Producer m o@@ -359,7 +358,7 @@ liftIO $ threadDelay 1 mapM_ yield xs case mres of- Just (Left e) -> liftIO $ throwIO (e :: SomeException)+ Just (Left e) -> throwM (e :: SomeException) Just (Right r) -> return r Nothing -> gather worker chan @@ -427,7 +426,7 @@ return $ Just fptr case mfptr of Nothing ->- failure (Git.TreeCreateFailed "Failed to create new tree builder")+ throwM (Git.TreeCreateFailed "Failed to create new tree builder") Just fptr -> do toid <- mapM Git.treeOid mtree return (lgMakeBuilder fptr) { Git.mtbBaseTreeOid = toid }@@ -441,7 +440,7 @@ withFilePath key $ \name -> c'git_treebuilder_insert nullPtr ptr name coid (fromIntegral mode)- when (r2 < 0) $ failure (Git.TreeBuilderInsertFailed key)+ when (r2 < 0) $ throwM (Git.TreeBuilderInsertFailed key) treeEntryToOid :: TreeEntry -> (Oid, CUInt) treeEntryToOid (Git.BlobEntry oid kind) =@@ -503,7 +502,7 @@ liftIO $ withForeignPtr fptr $ \builder -> alloca $ \pptr -> do r <- c'git_treebuilder_create pptr nullPtr when (r < 0) $- failure (Git.BackendError "Could not create new treebuilder")+ throwM (Git.BackendError "Could not create new treebuilder") builder' <- peek pptr bracket (mk'git_treebuilder_filter_cb (callback builder'))@@ -522,7 +521,7 @@ coid fmode when (r < 0) $- failure (Git.BackendError "Could not insert entry in treebuilder")+ throwM (Git.BackendError "Could not insert entry in treebuilder") return 0 lgLookupTree :: MonadLg m => TreeOid -> ReaderT LgRepo m Tree@@ -547,7 +546,7 @@ 0o100644 -> return Git.PlainBlob 0o100755 -> return Git.ExecutableBlob 0o120000 -> return Git.SymlinkBlob- _ -> failure $ Git.BackendError $+ _ -> throwM $ Git.BackendError $ "Unknown blob mode: " <> T.pack (show mode) | typ == c'GIT_OBJ_TREE -> return $ Git.TreeEntry (Tagged (mkOid oid))@@ -596,6 +595,42 @@ $ \coid obj _ -> liftIO $ withForeignPtr obj $ lgObjToCommit (Tagged (mkOid coid)) +lgReadIndex :: MonadLg m => Git.TreeT LgRepo (ReaderT LgRepo m) ()+lgReadIndex = do+ repo <- lift Git.getRepository+ xs <- liftIO $ withForeignPtr (repoObj repo) $ \repoPtr ->+ alloca $ \indexPp -> do+ r <- c'git_repository_index indexPp repoPtr+ idx <- if r < 0+ then lgThrow Git.BackendError+ else peek indexPp+ cnt <- c'git_index_entrycount idx+ fmap Prelude.concat $ forM [0..pred cnt] $ \i -> do+ entryPtr <- c'git_index_get_byindex idx i+ entry <- peek entryPtr+ let oid = c'git_index_entry'oid entry+ mode = c'git_index_entry'mode entry+ path = c'git_index_entry'path entry+ flags = c'git_index_entry'flags entry+ if 0 /= flags .&. 2 -- c'GIT_IDXENTRY_REMOVE+ then return []+ else do+ oid' <- new oid+ foid' <- newForeignPtr_ oid'+ path' <- peekFilePath path+ return+ [(path',+ if 0 /= mode .&. 16384 -- check if directory+ then Git.TreeEntry (Tagged (mkOid foid'))+ else Git.BlobEntry (Tagged (mkOid foid')) $+ if (0 /= mode .&. 64 -- check if owner executable+ )+ then Git.ExecutableBlob+ else Git.PlainBlob+ -- jww (2014-04-05): Handle CommitEntry+ )]+ forM_ xs $ uncurry Git.putEntry+ data ObjectPtr = BlobPtr (ForeignPtr C'git_blob) | TreePtr (ForeignPtr C'git_commit) | CommitPtr (ForeignPtr C'git_commit)@@ -642,7 +677,7 @@ r1 <- c'git_odb_exists ptr coid 0 c'git_odb_free ptr return (Just (r1 == 0))- maybe (failure Git.RepositoryInvalid) return result+ maybe (throwM Git.RepositoryInvalid) return result lgForEachObject :: Ptr C'git_odb -> (Ptr C'git_oid -> Ptr () -> IO CInt)@@ -663,7 +698,7 @@ r <- withForeignPtr (repoObj repo) $ \repoPtr -> c'git_revwalk_new pptr repoPtr when (r < 0) $- failure (Git.BackendError "Could not create revwalker")+ throwM (Git.BackendError "Could not create revwalker") ptr <- peek pptr FC.newForeignPtr ptr (c'git_revwalk_free ptr) @@ -673,7 +708,7 @@ liftIO $ withForeignPtr (getOid oid) $ \coid -> do r2 <- withForeignPtr walker $ flip c'git_revwalk_push coid when (r2 < 0) $- failure (Git.BackendError $ "Could not push oid "+ throwM (Git.BackendError $ "Could not push oid " <> pack (show oid) <> " onto revwalker") case mhave of@@ -681,7 +716,7 @@ Just have -> liftIO $ withForeignPtr (getOid (untag have)) $ \coid -> do r2 <- withForeignPtr walker $ flip c'git_revwalk_hide coid when (r2 < 0) $- failure (Git.BackendError $ "Could not hide commit "+ throwM (Git.BackendError $ "Could not hide commit " <> pack (show (untag have)) <> " from revwalker") liftIO $ withForeignPtr walker $ flip c'git_revwalk_sorting@@ -729,7 +764,7 @@ update_ref author' committer' nullPtr message toid' (fromIntegral (L.length pptrs)) parents'- when (r < 0) $ throwIO Git.CommitCreateFailed+ when (r < 0) $ throwM Git.CommitCreateFailed return coid return Git.Commit@@ -831,7 +866,7 @@ else do ref <- peek ptr c'git_reference_delete ref- when (r < 0) $ failure (Git.ReferenceDeleteFailed name)+ when (r < 0) $ throwM (Git.ReferenceDeleteFailed name) -- int git_reference_packall(git_repository *repo) @@ -957,7 +992,7 @@ --compareRef = c'git_reference_cmp -lgThrow :: (MonadIO m, Failure e m) => (Text -> e) -> m ()+lgThrow :: (MonadIO m, MonadExcept m, Exception e) => (Text -> e) -> m a lgThrow f = do errStr <- liftIO $ do errPtr <- c'giterr_last@@ -966,7 +1001,7 @@ else do err <- peek errPtr peekCString (c'git_error'message err)- failure (f (pack errStr))+ throwM (f (pack errStr)) -- withLgTempRepo :: MonadLg m => ReaderT LgRepo m a -> m a -- withLgTempRepo f = withTempDir $ \dir -> do@@ -985,7 +1020,7 @@ -> Tree -> Producer (ReaderT LgRepo m) ByteString lgDiffContentsWithTree _contents (LgTree Nothing) =- liftIO $ throwIO $+ liftIO $ throwM $ Git.DiffTreeToIndexFailed "Cannot diff against an empty tree" lgDiffContentsWithTree contents tree = do@@ -1048,13 +1083,13 @@ -- (Either Git.SHA ByteString)) m -- (Git.TreeFilePath, Either Git.SHA ByteString) handlePath (Right _) =- lift $ failure $ Git.DiffTreeToIndexFailed+ lift $ throwM $ Git.DiffTreeToIndexFailed "Received a Right value when a Left RawFilePath was expected" handlePath (Left path) = do mcontent <- await case mcontent of Nothing ->- lift $ failure $ Git.DiffTreeToIndexFailed $+ lift $ throwM $ Git.DiffTreeToIndexFailed $ "Content not provided for " <> T.pack (show path) Just x -> handleContent path x @@ -1064,11 +1099,11 @@ -- (Either Git.SHA ByteString)) m -- (Git.TreeFilePath, Either Git.SHA ByteString) handleContent _path (Left _) =- lift $ failure $ Git.DiffTreeToIndexFailed+ lift $ throwM $ Git.DiffTreeToIndexFailed "Received a Left value when a Right ByteString was expected" handleContent path (Right content) = return (path, content) - -- diffBlob :: Failure Git.GitException m+ -- diffBlob :: MonadExcept m -- => Git.TreeFilePath -- -> Maybe (Either Git.SHA ByteString) -- -> Maybe (ForeignPtr C'git_oid)@@ -1183,8 +1218,8 @@ B.cons (fromIntegral lineOrigin) bs return 0 -checkResult :: (Eq a, Num a, Failure Git.GitException m) => a -> Text -> m ()-checkResult r why = when (r /= 0) $ failure (Git.BackendError why)+checkResult :: (Eq a, Num a, MonadExcept m) => a -> Text -> m ()+checkResult r why = when (r /= 0) $ throwM (Git.BackendError why) lgBuildPackFile :: MonadLg m => FilePath -> [Either CommitOid TreeOid]@@ -1353,7 +1388,7 @@ lgLoadPackFileInMemory :: (MonadBaseControl IO m, MonadIO m, MonadLogger m,- Failure Git.GitException m)+ MonadExcept m) => FilePath -> Ptr (Ptr C'git_odb_backend) -> Ptr (Ptr C'git_odb)@@ -1385,7 +1420,7 @@ return odbPtr lgOpenPackFile :: (MonadBaseControl IO m, MonadIO m, MonadLogger m,- Failure Git.GitException m)+ MonadExcept m) => FilePath -> m (Ptr C'git_odb) lgOpenPackFile idxPath = control $ \run -> alloca $ \odbPtrPtr ->@@ -1393,17 +1428,17 @@ lgLoadPackFileInMemory idxPath backendPtrPtr odbPtrPtr lgClosePackFile :: (MonadBaseControl IO m, MonadIO m, MonadLogger m,- Failure Git.GitException m)+ MonadExcept m) => Ptr C'git_odb -> m () lgClosePackFile = liftIO . c'git_odb_free lgWithPackFile :: (MonadBaseControl IO m, MonadIO m, MonadLogger m,- Failure Git.GitException m)+ MonadExcept m) => FilePath -> (Ptr C'git_odb -> m a) -> m a lgWithPackFile idxPath = bracket (lgOpenPackFile idxPath) lgClosePackFile lgReadFromPack :: (MonadBaseControl IO m, MonadIO m, MonadLogger m,- Failure Git.GitException m)+ MonadExcept m) => Ptr C'git_odb -> Git.SHA -> Bool -> m (Maybe (C'git_otype, CSize, ByteString)) lgReadFromPack odbPtr sha metadataOnly = liftIO $ do
Git/Libgit2/Internal.hs view
@@ -8,8 +8,8 @@ import Bindings.Libgit2 import Control.Applicative-import Control.Failure import Control.Monad+import Control.Monad.Catch import Control.Monad.Trans.Control import Data.ByteString import qualified Data.Text as T@@ -85,7 +85,7 @@ let p = castPtr ptr' fptr <- FC.newForeignPtr p (c'git_object_free p) run $ Right <$> createFn coidCopy (castForeignPtr fptr) ptr'- either (failure . Git.BackendError) return result+ either (throwM . Git.BackendError) return result -- lgLookupObject :: Text -> LgRepository Dynamic -- lgLookupObject str
Git/Libgit2/Types.hs view
@@ -10,7 +10,7 @@ import Bindings.Libgit2 import Control.Applicative-import Control.Failure+import Control.Monad.Catch import Control.Monad.IO.Class import Control.Monad.Logger import Control.Monad.Trans.Control@@ -52,7 +52,9 @@ type TreeBuilder = Git.TreeBuilder LgRepo type Options = Git.Options LgRepo -type MonadLg m = (Applicative m, Failure Git.GitException m,+type MonadExcept m = (MonadThrow m, MonadCatch m, MonadMask m)++type MonadLg m = (Applicative m, MonadExcept m, MonadIO m, MonadBaseControl IO m, MonadLogger m) -- Types.hs
gitlib-libgit2.cabal view
@@ -1,5 +1,5 @@ Name: gitlib-libgit2-Version: 3.0.1+Version: 3.1.0 Synopsis: Libgit2 backend for gitlib License-file: LICENSE License: MIT@@ -29,6 +29,9 @@ , HUnit >= 1.2.5 , hspec >= 1.4.4 , hspec-expectations >= 0.3+ , monad-logger >= 0.3.4.1+ , exceptions >= 0.6+ , transformers >= 0.3.0.0 Library default-language: Haskell98@@ -39,10 +42,11 @@ , gitlib >= 3.0.0 , hlibgit2 >= 0.18.0.11 , 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.6 , fast-logger , filepath >= 1.3.0 , lifted-async >= 0.1.0@@ -50,12 +54,12 @@ , missing-foreign >= 0.1.1 , mmorph >= 1.0.0 , monad-control >= 0.3.2- , monad-logger >= 0.3.1.1+ , monad-logger >= 0.3.4.1 , monad-loops >= 0.3.3.0 , mtl >= 2.1.2- , resourcet >= 0.4.6+ , resourcet >= 1.1.0 , stm >= 2.4- , stm-conduit >= 2.1.4+ , stm-conduit >= 2.3.0 , tagged >= 0.2.3.1 , template-haskell , text >= 0.11.2