diff --git a/Git/Libgit2.hs b/Git/Libgit2.hs --- a/Git/Libgit2.hs +++ b/Git/Libgit2.hs @@ -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 diff --git a/Git/Libgit2/Internal.hs b/Git/Libgit2/Internal.hs --- a/Git/Libgit2/Internal.hs +++ b/Git/Libgit2/Internal.hs @@ -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 diff --git a/Git/Libgit2/Types.hs b/Git/Libgit2/Types.hs --- a/Git/Libgit2/Types.hs +++ b/Git/Libgit2/Types.hs @@ -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 diff --git a/gitlib-libgit2.cabal b/gitlib-libgit2.cabal --- a/gitlib-libgit2.cabal +++ b/gitlib-libgit2.cabal @@ -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