gitlib-libgit2 2.2.0.1 → 3.0.0
raw patch · 5 files changed
+324/−387 lines, 5 filesdep +mtldep +stm-conduitdep ~gitlibdep ~gitlib-libgit2dep ~gitlib-test
Dependencies added: mtl, stm-conduit
Dependency ranges changed: gitlib, gitlib-libgit2, gitlib-test, stm
Files
- Git/Libgit2.hs +278/−290
- Git/Libgit2/Backend.hs +3/−2
- Git/Libgit2/Internal.hs +10/−18
- Git/Libgit2/Types.hs +24/−70
- gitlib-libgit2.cabal +9/−7
Git/Libgit2.hs view
@@ -20,26 +20,22 @@ -- queried as needed. module Git.Libgit2 ( MonadLg- , LgRepository(..)+ , LgRepo(..) , BlobOid() , Commit() , CommitOid() , Git.Oid , OidPtr(..) , mkOid- , Repository(..) , Tree() , TreeOid()- , repoPath+ , lgRepoPath , addTracingBackend , checkResult- , closeLgRepository- , defaultLgOptions , lgBuildPackIndex , lgFactory , lgFactoryLogger , lgForEachObject- , lgGet , lgExcTrap , lgBuildPackFile , lgReadFromPack@@ -48,6 +44,7 @@ , lgDiffContentsWithTree , lgWrap , oidToSha+ , shaToCOid , shaToOid , openLgRepository , runLgRepository@@ -57,6 +54,7 @@ import Bindings.Libgit2 import Control.Applicative+import Control.Concurrent (threadDelay) import Control.Concurrent.Async.Lifted import Control.Concurrent.STM import Control.Exception.Lifted@@ -66,14 +64,17 @@ 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+import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Control.Monad.Trans.Resource import Data.Bits ((.|.), (.&.)) import Data.ByteString (ByteString) 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 import Data.List as L@@ -149,7 +150,7 @@ then Nothing else Just (OidPtr oid len) -lgParseOid :: MonadLg m => Text -> LgRepository m Oid+lgParseOid :: MonadLg m => Text -> m Oid lgParseOid str | len > 40 = failure (Git.OidParseFailed str) | otherwise = do@@ -160,7 +161,7 @@ where len = T.length str -lgRenderOid :: Git.Oid (LgRepository m) -> Text+lgRenderOid :: Oid -> Text lgRenderOid = pack . show instance Show OidPtr where@@ -176,15 +177,21 @@ instance Eq OidPtr where oid1 == oid2 = oid1 `compare` oid2 == EQ -instance MonadLg m => Git.Repository (LgRepository m) where- type Oid (LgRepository m) = OidPtr- data Tree (LgRepository m) = LgTree- { lgTreePtr :: Maybe (ForeignPtr C'git_tree) }- data Options (LgRepository m) = Options+instance (Applicative m, Failure Git.GitException m,+ MonadBaseControl IO m, MonadIO m, MonadLogger m)+ => Git.MonadGit LgRepo (ReaderT LgRepo m) where+ type Oid LgRepo = OidPtr+ data Tree LgRepo =+ LgTree { lgTreePtr :: Maybe (ForeignPtr C'git_tree) }+ data Options LgRepo = Options - facts = return Git.RepositoryFacts- { Git.hasSymbolicReferences = True }+ facts = return Git.RepositoryFacts { Git.hasSymbolicReferences = True } + getRepository = ask+ closeRepository = return ()+ deleteRepository =+ Git.getRepository >>= liftIO . removeDirectoryRecursive . lgRepoPath+ parseOid = lgParseOid lookupReference = lgLookupRef@@ -209,8 +216,6 @@ createCommit p t a c l r = lgWrap $ lgCreateCommit p t a c l r - deleteRepository = lgGet >>= liftIO . removeDirectoryRecursive . repoPath- diffContentsWithTree = error "Not implemented: lgDiffContentsWithTree" -- buildPackFile = lgBuildPackFile@@ -219,16 +224,19 @@ -- remoteFetch = lgRemoteFetch -lgWrap :: (MonadIO m, MonadBaseControl IO m)- => LgRepository m a -> LgRepository m a+lgExcTrap :: MonadLg m => ReaderT LgRepo m (IORef (Maybe Git.GitException))+lgExcTrap = repoExcTrap `liftM` Git.getRepository++lgWrap :: MonadLg m => ReaderT LgRepo m a -> ReaderT LgRepo m a lgWrap f = f `catch` \e -> do etrap <- lgExcTrap mexc <- liftIO $ readIORef etrap liftIO $ writeIORef etrap Nothing maybe (throw (e :: SomeException)) throw mexc -lgHashContents :: MonadLg m => Git.BlobContents (LgRepository m)- -> LgRepository m (BlobOid m)+lgHashContents :: MonadLg m+ => Git.BlobContents (ReaderT LgRepo m)+ -> ReaderT LgRepo m BlobOid lgHashContents b = do ptr <- liftIO mallocForeignPtr r <- Git.blobContentsToByteString b >>= \bs ->@@ -244,24 +252,27 @@ -- Note that since empty blobs cannot exist in Git, no means is provided for -- creating one; if the given string is 'empty', it is an error. lgCreateBlob :: MonadLg m- => Git.BlobContents (LgRepository m)- -> LgRepository m (BlobOid m)+ => Git.BlobContents (ReaderT LgRepo m)+ -> ReaderT LgRepo m BlobOid lgCreateBlob b = do- repo <- lgGet+ repo <- Git.getRepository ptr <- liftIO mallocForeignPtr -- freed automatically if GC'd r <- case b of- Git.BlobString bs ->- liftIO $ withForeignPtr ptr $ \coid' ->- withForeignPtr (repoObj repo) $ \repoPtr ->- BU.unsafeUseAsCStringLen bs $ uncurry $ \cstr len ->- c'git_blob_create_frombuffer coid' repoPtr- (castPtr cstr) (fromIntegral len)- Git.BlobStream src -> readFromSource repo ptr src+ Git.BlobString bs -> createBlob repo ptr bs+ Git.BlobStringLazy bs ->+ createBlob repo ptr (B.concat (BL.toChunks bs))+ Git.BlobStream src -> readFromSource repo ptr src Git.BlobSizedStream src _ -> readFromSource repo ptr src when (r < 0) $ lgThrow Git.BlobCreateFailed return $ Tagged (mkOid ptr) where+ createBlob repo ptr bs = liftIO $ withForeignPtr ptr $ \coid' ->+ withForeignPtr (repoObj repo) $ \repoPtr ->+ BU.unsafeUseAsCStringLen bs $ uncurry $ \cstr len ->+ c'git_blob_create_frombuffer coid' repoPtr+ (castPtr cstr) (fromIntegral len)+ readFromSource repo ptr src = src $$ drainTo 2 $ \queue -> liftIO $ withForeignPtr ptr $ \coid' ->@@ -293,8 +304,9 @@ return $ fromIntegral len lgObjToBlob :: MonadLg m- => BlobOid m -> ForeignPtr C'git_blob- -> LgRepository m (Git.Blob (LgRepository m))+ => BlobOid+ -> ForeignPtr C'git_blob+ -> ReaderT LgRepo m (Git.Blob LgRepo (ReaderT LgRepo m)) lgObjToBlob oid fptr = do bs <- liftIO $ withForeignPtr fptr $ \ptr -> do size <- c'git_blob_rawsize ptr@@ -302,17 +314,16 @@ B.packCStringLen (castPtr buf, fromIntegral size) return $ Git.Blob oid $ Git.BlobString bs -lgLookupBlob :: MonadLg m => BlobOid m- -> LgRepository m (Git.Blob (LgRepository m))+lgLookupBlob :: MonadLg m+ => BlobOid+ -> ReaderT LgRepo m (Git.Blob LgRepo (ReaderT LgRepo m)) lgLookupBlob oid = lookupObject' (getOid (untag oid)) (getOidLen (untag oid)) c'git_blob_lookup c'git_blob_lookup_prefix $ \boid obj _ -> lgObjToBlob (Tagged (mkOid boid)) obj -type TreeEntry m = Git.TreeEntry (LgRepository m)--lgTreeEntry :: MonadLg m => Tree m -> Git.TreeFilePath- -> LgRepository m (Maybe (TreeEntry m))+lgTreeEntry :: MonadLg m+ => Tree -> Git.TreeFilePath -> ReaderT LgRepo m (Maybe TreeEntry) lgTreeEntry (LgTree Nothing) _ = return Nothing lgTreeEntry (LgTree (Just tree)) fp = liftIO $ alloca $ \entryPtr -> withFilePath fp $ \pathStr ->@@ -322,21 +333,40 @@ then return Nothing else Just <$> (entryToTreeEntry =<< peek entryPtr) -lgTreeOid :: MonadLg m => Tree m -> TreeOid m+lgTreeOid :: MonadLg m => Tree -> ReaderT LgRepo m TreeOid lgTreeOid (LgTree Nothing) =- SU.unsafePerformIO . liftIO $- Tagged . fromJust <$> lgParseOidIO Git.emptyTreeId 40-lgTreeOid (LgTree (Just tree)) = SU.unsafePerformIO $ liftIO $ do+ liftIO $ Tagged . fromJust <$> lgParseOidIO Git.emptyTreeId 40+lgTreeOid (LgTree (Just tree)) = liftIO $ do toid <- withForeignPtr tree c'git_tree_id ftoid <- coidPtrToOid toid return $ Tagged (mkOid ftoid) +gatherFrom' :: (MonadIO m, MonadBaseControl IO m)+ => Int -- ^ Size of the queue to create+ -> (TBQueue o -> m ()) -- ^ Action that generates output values+ -> Producer m o+gatherFrom' size scatter = do+ chan <- liftIO $ newTBQueueIO size+ worker <- lift $ async (scatter chan)+ lift . restoreM =<< gather worker chan+ where+ gather worker chan = do+ (xs, mres) <- liftIO $ atomically $ do+ xs <- whileM (not <$> isEmptyTBQueue chan) (readTBQueue chan)+ (xs,) <$> pollSTM worker+ liftIO $ threadDelay 1+ mapM_ yield xs+ case mres of+ Just (Left e) -> liftIO $ throwIO (e :: SomeException)+ Just (Right r) -> return r+ Nothing -> gather worker chan+ lgSourceTreeEntries :: MonadLg m- => Tree m- -> Producer (LgRepository m) (Git.TreeFilePath, TreeEntry m)+ => Tree+ -> Producer (ReaderT LgRepo m) (Git.TreeFilePath, TreeEntry) lgSourceTreeEntries (LgTree Nothing) = return ()-lgSourceTreeEntries (LgTree (Just tree)) = gatherFrom 16 $ \queue -> do+lgSourceTreeEntries (LgTree (Just tree)) = gatherFrom' 16 $ \queue -> do liftIO $ withForeignPtr tree $ \tr -> do r <- bracket (mk'git_treewalk_cb (callback queue))@@ -355,7 +385,7 @@ return 0 lgMakeBuilder :: MonadLg m- => ForeignPtr C'git_treebuilder -> TreeBuilder m+ => ForeignPtr C'git_treebuilder -> TreeBuilder (ReaderT LgRepo m) lgMakeBuilder builder = Git.TreeBuilder { Git.mtbBaseTreeOid = Nothing , Git.mtbPendingUpdates = mempty@@ -365,9 +395,9 @@ , Git.mtbLookupEntry = lgLookupBuilderEntry builder , Git.mtbEntryCount = lgBuilderEntryCount builder , Git.mtbPutEntry = \tb name ent ->- lgPutEntry builder name ent >> return (Git.BuilderUnchanged tb)+ Git.BuilderUnchanged tb <$ lgPutEntry builder name ent , Git.mtbDropEntry = \tb name ->- lgDropEntry builder name >> return (Git.BuilderUnchanged tb)+ Git.BuilderUnchanged tb <$ lgDropEntry builder name } -- | Create a new, empty tree.@@ -375,7 +405,8 @@ -- Since empty trees cannot exist in Git, attempting to write out an empty -- tree is a no-op. lgNewTreeBuilder :: MonadLg m- => Maybe (Tree m) -> LgRepository m (TreeBuilder m)+ => Maybe Tree+ -> ReaderT LgRepo m (TreeBuilder (ReaderT LgRepo m)) lgNewTreeBuilder mtree = do mfptr <- liftIO $ alloca $ \pptr -> do r <- case mtree of@@ -395,13 +426,13 @@ case mfptr of Nothing -> failure (Git.TreeCreateFailed "Failed to create new tree builder")- Just fptr ->- return (lgMakeBuilder fptr)- { Git.mtbBaseTreeOid = Git.treeOid <$> mtree }+ Just fptr -> do+ toid <- mapM Git.treeOid mtree+ return (lgMakeBuilder fptr) { Git.mtbBaseTreeOid = toid } lgPutEntry :: MonadLg m- => ForeignPtr C'git_treebuilder -> Git.TreeFilePath -> TreeEntry m- -> LgRepository m ()+ => ForeignPtr C'git_treebuilder -> Git.TreeFilePath -> TreeEntry+ -> ReaderT LgRepo m () lgPutEntry builder key (treeEntryToOid -> (oid, mode)) = do r2 <- liftIO $ withForeignPtr (getOid oid) $ \coid -> withForeignPtr builder $ \ptr ->@@ -410,13 +441,12 @@ (fromIntegral mode) when (r2 < 0) $ failure (Git.TreeBuilderInsertFailed key) -treeEntryToOid :: TreeEntry m -> (Oid, CUInt)+treeEntryToOid :: TreeEntry -> (Oid, CUInt) treeEntryToOid (Git.BlobEntry oid kind) = (untag oid, case kind of Git.PlainBlob -> 0o100644 Git.ExecutableBlob -> 0o100755- Git.SymlinkBlob -> 0o120000- Git.UnknownBlob -> 0o100000)+ Git.SymlinkBlob -> 0o120000) treeEntryToOid (Git.CommitEntry coid) = (untag coid, 0o160000) treeEntryToOid (Git.TreeEntry toid) =@@ -424,7 +454,7 @@ lgDropEntry :: MonadLg m => ForeignPtr C'git_treebuilder -> Git.TreeFilePath- -> LgRepository m ()+ -> ReaderT LgRepo m () lgDropEntry builder key = void $ liftIO $ withForeignPtr builder $ \ptr -> withFilePath key $ c'git_treebuilder_remove ptr@@ -432,7 +462,7 @@ lgLookupBuilderEntry :: MonadLg m => ForeignPtr C'git_treebuilder -> Git.TreeFilePath- -> LgRepository m (Maybe (TreeEntry m))+ -> ReaderT LgRepo m (Maybe TreeEntry) lgLookupBuilderEntry builderPtr name = do entry <- liftIO $ withForeignPtr builderPtr $ \builder -> withFilePath name $ c'git_treebuilder_get builder@@ -441,20 +471,19 @@ else Just <$> liftIO (entryToTreeEntry entry) lgBuilderEntryCount :: MonadLg m- => ForeignPtr C'git_treebuilder -> LgRepository m Int+ => ForeignPtr C'git_treebuilder -> ReaderT LgRepo m Int lgBuilderEntryCount tb = fromIntegral <$> liftIO (withForeignPtr tb c'git_treebuilder_entrycount) -lgTreeEntryCount :: MonadLg m => Tree m -> LgRepository m Int+lgTreeEntryCount :: MonadLg m => Tree -> ReaderT LgRepo m Int lgTreeEntryCount (LgTree Nothing) = return 0 lgTreeEntryCount (LgTree (Just tree)) = fromIntegral <$> liftIO (withForeignPtr tree c'git_tree_entrycount) lgWriteBuilder :: MonadLg m- => ForeignPtr C'git_treebuilder- -> LgRepository m (TreeOid m)+ => ForeignPtr C'git_treebuilder -> ReaderT LgRepo m TreeOid lgWriteBuilder tb = do- repo <- lgGet+ repo <- Git.getRepository (r3,coid) <- liftIO $ do coid <- mallocForeignPtr withForeignPtr coid $ \coid' ->@@ -467,7 +496,7 @@ lgCloneBuilder :: MonadLg m => ForeignPtr C'git_treebuilder- -> LgRepository m (ForeignPtr C'git_treebuilder)+ -> ReaderT LgRepo m (ForeignPtr C'git_treebuilder) lgCloneBuilder fptr = liftIO $ withForeignPtr fptr $ \builder -> alloca $ \pptr -> do r <- c'git_treebuilder_create pptr nullPtr@@ -494,7 +523,7 @@ failure (Git.BackendError "Could not insert entry in treebuilder") return 0 -lgLookupTree :: MonadLg m => TreeOid m -> LgRepository m (Tree m)+lgLookupTree :: MonadLg m => TreeOid -> ReaderT LgRepo m Tree lgLookupTree (untag -> oid) | show oid == unpack Git.emptyTreeId = return $ LgTree Nothing | otherwise = do@@ -503,7 +532,7 @@ \_ obj _ -> return obj return $ LgTree (Just fptr) -entryToTreeEntry :: Ptr C'git_tree_entry -> IO (TreeEntry m)+entryToTreeEntry :: Ptr C'git_tree_entry -> IO TreeEntry entryToTreeEntry entry = do coid <- c'git_tree_entry_id entry oid <- coidPtrToOid coid@@ -511,20 +540,20 @@ case () of () | typ == c'GIT_OBJ_BLOB -> do mode <- c'git_tree_entry_filemode entry- return $ Git.BlobEntry (Tagged (mkOid oid)) $+ Git.BlobEntry (Tagged (mkOid oid)) <$> case mode of- 0o100644 -> Git.PlainBlob- 0o100755 -> Git.ExecutableBlob- 0o120000 -> Git.SymlinkBlob- _ -> Git.UnknownBlob+ 0o100644 -> return Git.PlainBlob+ 0o100755 -> return Git.ExecutableBlob+ 0o120000 -> return Git.SymlinkBlob+ _ -> failure $ Git.BackendError $+ "Unknown blob mode: " <> T.pack (show mode) | typ == c'GIT_OBJ_TREE -> return $ Git.TreeEntry (Tagged (mkOid oid)) | typ == c'GIT_OBJ_COMMIT -> return $ Git.CommitEntry (Tagged (mkOid oid)) | otherwise -> error "Unexpected" -lgObjToCommit :: MonadLg m- => CommitOid m -> Ptr C'git_commit -> IO (Commit m)+lgObjToCommit :: CommitOid -> Ptr C'git_commit -> IO Commit lgObjToCommit oid c = do enc <- c'git_commit_message_encoding c encs <- if enc == nullPtr@@ -558,8 +587,7 @@ , Git.commitEncoding = "utf-8" } -lgLookupCommit :: MonadLg m- => CommitOid m -> LgRepository m (Commit m)+lgLookupCommit :: MonadLg m => CommitOid -> ReaderT LgRepo m Commit lgLookupCommit oid = lookupObject' (getOid (untag oid)) (getOidLen (untag oid)) c'git_commit_lookup c'git_commit_lookup_prefix@@ -572,7 +600,8 @@ | TagPtr (ForeignPtr C'git_tag) lgLookupObject :: MonadLg m- => Oid -> LgRepository m (Git.Object (LgRepository m))+ => Oid+ -> ReaderT LgRepo m (Git.Object LgRepo (ReaderT LgRepo m)) lgLookupObject oid = do (oid', typ, fptr) <- lookupObject' (getOid oid) (getOidLen oid)@@ -595,9 +624,9 @@ | typ == c'GIT_OBJ_TAG -> error "jww (2013-07-08): NYI" | otherwise -> error $ "Unknown object type: " ++ show typ -lgExistsObject :: MonadLg m => Oid -> LgRepository m Bool+lgExistsObject :: MonadLg m => Oid -> ReaderT LgRepo m Bool lgExistsObject oid = do- repo <- lgGet+ repo <- Git.getRepository result <- liftIO $ withForeignPtr (repoObj repo) $ \repoPtr -> alloca $ \pptr -> do r <- c'git_repository_odb pptr repoPtr@@ -623,27 +652,22 @@ freeHaskellFunPtr (flip (c'git_odb_foreach odbPtr) payload) -lgSourceObjects- :: MonadLg m- => Maybe (CommitOid m) -> CommitOid m -> Bool- -> Producer (LgRepository m) (ObjectOid m)+lgSourceObjects :: MonadLg m+ => Maybe CommitOid -> CommitOid -> Bool+ -> Producer (ReaderT LgRepo m) ObjectOid lgSourceObjects mhave need alsoTrees = do- repo <- lift lgGet+ repo <- lift Git.getRepository walker <- liftIO $ alloca $ \pptr -> do r <- withForeignPtr (repoObj repo) $ \repoPtr -> c'git_revwalk_new pptr repoPtr when (r < 0) $ failure (Git.BackendError "Could not create revwalker") ptr <- peek pptr- newForeignPtr p'git_revwalk_free ptr+ FC.newForeignPtr ptr (c'git_revwalk_free ptr) c <- lift $ lgLookupCommit need let oid = untag (Git.commitOid c) - liftIO $ putStrLn $ "mhave = " ++ show mhave- liftIO $ putStrLn $ "need = " ++ show need- liftIO $ putStrLn $ "oid = " ++ show oid- liftIO $ withForeignPtr (getOid oid) $ \coid -> do r2 <- withForeignPtr walker $ flip c'git_revwalk_push coid when (r2 < 0) $@@ -677,15 +701,15 @@ -- | Write out a commit to its repository. If it has already been written, -- nothing will happen. lgCreateCommit :: MonadLg m- => [CommitOid m]- -> TreeOid m+ => [CommitOid]+ -> TreeOid -> Git.Signature -> Git.Signature -> Git.CommitMessage -> Maybe Git.RefName- -> LgRepository m (Commit m)+ -> ReaderT LgRepo m Commit lgCreateCommit pptrs tree author committer logText ref = do- repo <- lgGet+ repo <- Git.getRepository let toid = getOid . untag $ tree coid <- liftIO $ withForeignPtr (repoObj repo) $ \repoPtr -> do coid <- mallocForeignPtr@@ -732,10 +756,9 @@ mapM_ touchForeignPtr fos return r -lgLookupRef :: MonadLg m- => Git.RefName -> LgRepository m (Maybe (RefTarget m))+lgLookupRef :: MonadLg m => Git.RefName -> ReaderT LgRepo m (Maybe RefTarget) lgLookupRef name = do- repo <- lgGet+ repo <- Git.getRepository liftIO $ alloca $ \ptr -> do r <- withForeignPtr (repoObj repo) $ \repoPtr -> withCString (unpack name) $ \namePtr ->@@ -756,10 +779,9 @@ return (Just targ) lgUpdateRef :: MonadLg m- => Git.RefName -> Git.RefTarget (LgRepository m)- -> LgRepository m ()+ => Git.RefName -> Git.RefTarget LgRepo -> ReaderT LgRepo m () lgUpdateRef name refTarg = do- repo <- lgGet+ repo <- Git.getRepository r <- liftIO $ alloca $ \ptr -> withForeignPtr (repoObj repo) $ \repoPtr -> withCString (unpack name) $ \namePtr ->@@ -778,10 +800,9 @@ -- int git_reference_name_to_oid(git_oid *out, git_repository *repo, -- const char *name) -lgResolveRef :: MonadLg m- => Git.RefName -> LgRepository m (Maybe (CommitOid m))+lgResolveRef :: MonadLg m => Git.RefName -> ReaderT LgRepo m (Maybe CommitOid) lgResolveRef name = do- repo <- lgGet+ repo <- Git.getRepository oid <- liftIO $ alloca $ \ptr -> withCString (unpack name) $ \namePtr -> withForeignPtr (repoObj repo) $ \repoPtr -> do@@ -796,9 +817,9 @@ --renameRef = c'git_reference_rename -lgDeleteRef :: MonadLg m => Git.RefName -> LgRepository m ()+lgDeleteRef :: MonadLg m => Git.RefName -> ReaderT LgRepo m () lgDeleteRef name = do- repo <- lgGet+ repo <- Git.getRepository r <- liftIO $ alloca $ \ptr -> withCString (unpack name) $ \namePtr -> withForeignPtr (repoObj repo) $ \repoPtr -> do@@ -864,10 +885,10 @@ + (if listFlagPacked flags then 4 else 0) + (if listFlagHasPeel flags then 8 else 0) -lgSourceRefs :: MonadLg m => Producer (LgRepository m) Git.RefName+lgSourceRefs :: MonadLg m => Producer (ReaderT LgRepo m) Git.RefName lgSourceRefs =- gatherFrom 16 $ \queue -> do- repo <- lgGet+ gatherFrom' 16 $ \queue -> do+ repo <- Git.getRepository r <- liftIO $ bracket (mk'git_reference_foreach_cb (callback queue)) freeHaskellFunPtr@@ -900,7 +921,7 @@ -- lgMapRefs :: (Text -> LgRepository a) -> LgRepository [a] -- lgMapRefs cb = do--- repo <- lgGet+-- repo <- Git.getRepository -- liftIO $ do -- withForeignPtr (repoObj repo) $ \repoPtr -> do -- ioRef <- newIORef []@@ -934,56 +955,6 @@ --compareRef = c'git_reference_cmp --- | Gather output values asynchronously from an action in the base monad and--- then yield them downstream. This provides a means of working around the--- restriction that 'ConduitM' cannot be an instance of 'MonadBaseControl'--- in order to, for example, yield values from within a Haskell callback--- function called from a C library.-gatherFrom :: (MonadIO m, MonadBaseControl IO m)- => Int -- ^ Size of the queue to create- -> (TBQueue o -> m ()) -- ^ Action that generates output values- -> Producer m o-gatherFrom size scatter = do- chan <- liftIO $ newTBQueueIO size- worker <- lift $ async (scatter chan)- lift . restoreM =<< gather worker chan- where- gather worker chan = do- (xs, mres) <- liftIO $ atomically $ do- xs <- whileM (not <$> isEmptyTBQueue chan) (readTBQueue chan)- (xs,) <$> pollSTM worker- mapM_ yield xs- case mres of- Just (Left e) -> liftIO $ throwIO (e :: SomeException)- Just (Right r) -> return r- Nothing -> gather worker chan--drainTo :: (MonadIO m, MonadBaseControl IO m)- => Int -- ^ Size of the queue to create- -> (TBQueue (Maybe i) -> m r) -- ^ Action to consume input values- -> Consumer i m r-drainTo size gather = do- chan <- liftIO $ newTBQueueIO size- worker <- lift $ async (gather chan)- lift . restoreM =<< scatter worker chan- where- scatter worker chan = do- mval <- await- (mx, action) <- liftIO $ atomically $ do- mres <- pollSTM worker- case mres of- Just (Left e) ->- return (Nothing, liftIO $ throwIO (e :: SomeException))- Just (Right r) ->- return (Just r, return ())- Nothing -> do- writeTBQueue chan mval- return (Nothing, return ())- action- case mx of- Just x -> return x- Nothing -> scatter worker chan- lgThrow :: (MonadIO m, Failure e m) => (Text -> e) -> m () lgThrow f = do errStr <- liftIO $ do@@ -997,21 +968,23 @@ lgDiffContentsWithTree :: MonadLg m- => Source m (Either Git.TreeFilePath ByteString)- -> Tree m- -> Producer (LgRepository m) ByteString+ => Source (ReaderT LgRepo m)+ (Either Git.TreeFilePath (Either Git.SHA ByteString))+ -> Tree+ -> Producer (ReaderT LgRepo m) ByteString lgDiffContentsWithTree _contents (LgTree Nothing) = liftIO $ throwIO $ Git.DiffTreeToIndexFailed "Cannot diff against an empty tree" lgDiffContentsWithTree contents tree = do- repo <- lift lgGet- gatherFrom 16 $ generateDiff repo+ repo <- lift Git.getRepository+ gatherFrom' 16 $ generateDiff repo where+ -- generateDiff :: MonadLg m => LgRepo -> TBQueue ByteString -> m () generateDiff repo chan = do entries <- M.fromList <$> Git.listTreeEntries tree paths <- liftIO $ newIORef []- (src, ()) <- lift $ contents $$+ return ()+ (src, ()) <- contents $$+ return () handleEntries entries paths src contentsPaths <- liftIO $ readIORef paths@@ -1027,8 +1000,13 @@ Git.CommitEntry _coid -> return () Git.TreeEntry _toid -> return () where+ -- handleEntries :: M.Map Git.TreeFilePath TreeEntry+ -- -> IORef [Git.TreeFilePath]+ -- -> ResumableSource m (Either Git.TreeFilePath+ -- (Either Git.SHA ByteString))+ -- -> m () handleEntries entries paths src = do- (src', mres) <- lift $ src $$++ do+ (src', mres) <- src $$++ do mpath <- await case mpath of Nothing -> return Nothing@@ -1053,29 +1031,64 @@ Git.TreeEntry _toid -> return () handleEntries entries paths src' + -- handlePath :: Either Git.TreeFilePath (Either Git.SHA ByteString)+ -- -> Consumer (Either Git.TreeFilePath+ -- (Either Git.SHA ByteString)) m+ -- (Git.TreeFilePath, Either Git.SHA ByteString) handlePath (Right _) =- liftIO $ throwIO $ Git.DiffTreeToIndexFailed+ lift $ failure $ Git.DiffTreeToIndexFailed "Received a Right value when a Left RawFilePath was expected" handlePath (Left path) = do mcontent <- await case mcontent of Nothing ->- liftIO $ throwIO $ Git.DiffTreeToIndexFailed $+ lift $ failure $ Git.DiffTreeToIndexFailed $ "Content not provided for " <> T.pack (show path) Just x -> handleContent path x + -- handleContent :: Git.TreeFilePath+ -- -> Either Git.TreeFilePath (Either Git.SHA ByteString)+ -- -> Consumer (Either Git.TreeFilePath+ -- (Either Git.SHA ByteString)) m+ -- (Git.TreeFilePath, Either Git.SHA ByteString) handleContent _path (Left _) =- liftIO $ throwIO $ Git.DiffTreeToIndexFailed+ lift $ failure $ Git.DiffTreeToIndexFailed "Received a Left value when a Right ByteString was expected" handleContent path (Right content) = return (path, content) + -- diffBlob :: Failure Git.GitException m+ -- => Git.TreeFilePath+ -- -> Maybe (Either Git.SHA ByteString)+ -- -> Maybe (ForeignPtr C'git_oid)+ -- -> m () diffBlob path mcontent mboid = do- r <- liftIO $ runResourceT $ case mboid of- Nothing -> go nullPtr- Just boid -> withBlob boid+ r <- liftIO $ runResourceT $ do+ fileHeader <- liftIO $ newIORef Nothing++ let f = flip allocate freeHaskellFunPtr+ (_, fcb) <- f $ mk'git_diff_file_cb (file_cb fileHeader)+ (_, hcb) <- f $ mk'git_diff_hunk_cb (hunk_cb fileHeader)+ (_, pcb) <- f $ mk'git_diff_data_cb print_cb++ let db b o = diffBlobs fcb hcb pcb b o+ dbb b = diffBlobToBuffer fcb hcb pcb b+ case mboid of+ Nothing -> liftIO $ dbb nullPtr+ Just boid -> withBlob boid $ \blobp ->+ case mcontent of+ Just (Left sha) -> do+ boid2 <- liftIO $ shaToCOid sha+ if boid == boid2+ then withBlob boid2 $+ liftIO . db blobp+ else return 0+ _ -> liftIO $ dbb blobp when (r < 0) $ lgThrow Git.DiffBlobFailed where- withBlob boid = do+ withBlob :: ForeignPtr C'git_oid+ -> (Ptr C'git_blob -> ResourceT IO CInt)+ -> ResourceT IO CInt+ withBlob boid f = do (_, eblobp) <- flip allocate freeBlob $ alloca $ \blobpp -> withForeignPtr boid $ \boidPtr ->@@ -1086,56 +1099,59 @@ else Right <$> peek blobpp case eblobp of Left r -> return r- Right blobp -> go blobp+ Right blobp -> f blobp where freeBlob (Left _) = return () freeBlob (Right blobp) = c'git_blob_free blobp - go blobp = do- let f x = allocate x freeHaskellFunPtr- (_, file_cb') <- f $ mk'git_diff_file_cb file_cb- (_, hunk_cb') <- f $ mk'git_diff_hunk_cb hunk_cb- (_, print_cb') <- f $ mk'git_diff_data_cb print_cb-+ -- diffBlobToBuffer :: fcb -> hcb -> pcb -> Ptr C'git_blob -> IO CInt+ diffBlobToBuffer fcb hcb pcb blobp = do let diff s l = c'git_diff_blob_to_buffer blobp s (fromIntegral l)- nullPtr file_cb' hunk_cb' print_cb' nullPtr- liftIO $ case mcontent of- Nothing -> diff nullPtr 0- Just c -> BU.unsafeUseAsCStringLen c $ uncurry diff+ nullPtr fcb hcb pcb nullPtr+ case mcontent of+ Just (Right c) -> BU.unsafeUseAsCStringLen c $ uncurry diff+ _ -> diff nullPtr 0 + -- diffBlobs :: fcb -> hcb -> pcb -> Ptr C'git_blob -> Ptr C'git_blob+ -- -> IO CInt+ diffBlobs fcb hcb pcb blobp otherp =+ c'git_diff_blobs blobp otherp nullPtr fcb hcb pcb nullPtr++ isBinary :: C'git_diff_delta -> Bool isBinary delta = c'git_diff_delta'flags delta .&. c'GIT_DIFF_FLAG_BINARY /= 0 - deltaFileName = fmap (T.encodeUtf8 . T.pack) . peekCString- . c'git_diff_file'path-- file_cb :: Ptr C'git_diff_delta+ file_cb :: IORef (Maybe ByteString)+ -> Ptr C'git_diff_delta -> CFloat -> Ptr () -> IO CInt- file_cb deltap _progress _payload = do+ file_cb fh deltap _progress _payload = do delta <- peek deltap- atomically $+ writeIORef fh $ Just $ if isBinary delta- then writeTBQueue chan $- "Binary files a/" <> path- <> " and b/" <> path <> " differ\n"- else do- writeTBQueue chan $ "--- a/" <> path <> "\n"- writeTBQueue chan $ "+++ b/" <> path <> "\n"+ then "Binary files a/" <> path <> " and b/" <> path+ <> " differ\n"+ else "--- a/" <> path <> "\n" <> "+++ b/" <> path <> "\n" return 0 - hunk_cb :: Ptr C'git_diff_delta+ hunk_cb :: IORef (Maybe ByteString)+ -> Ptr C'git_diff_delta -> Ptr C'git_diff_range -> CString -> CSize -> Ptr () -> IO CInt- hunk_cb deltap _rangep header headerLen _payload = do+ hunk_cb fh deltap _rangep header headerLen _payload = do delta <- peek deltap+ mfh <- readIORef fh+ forM_ mfh $ \h -> do+ atomically $ writeTBQueue chan h+ writeIORef fh Nothing unless (isBinary delta) $ do- bs <- curry B.packCStringLen header (fromIntegral headerLen)+ bs <- curry B.packCStringLen header+ (fromIntegral headerLen) atomically $ writeTBQueue chan bs return 0 @@ -1159,10 +1175,10 @@ checkResult r why = when (r /= 0) $ failure (Git.BackendError why) lgBuildPackFile :: MonadLg m- => FilePath -> [Either (CommitOid m) (TreeOid m)]- -> LgRepository m FilePath+ => FilePath -> [Either CommitOid TreeOid]+ -> ReaderT LgRepo m FilePath lgBuildPackFile dir oids = do- repo <- lgGet+ repo <- Git.getRepository liftIO $ do (filePath, fHandle) <- openBinaryTempFile dir "pack" hClose fHandle@@ -1212,14 +1228,8 @@ lift_ :: (Monad m, Functor (t m), MonadTrans t) => m a -> t m () lift_ = void . lift -lgBuildPackIndexWrapper :: MonadLg m- => FilePath- -> ByteString- -> LgRepository m (Text, FilePath, FilePath)-lgBuildPackIndexWrapper = (lift .) . lgBuildPackIndex--lgBuildPackIndex :: (MonadLg m, MonadLogger m)- => FilePath -> ByteString -> m (Text, FilePath, FilePath)+lgBuildPackIndex :: (MonadIO m, MonadBaseControl IO m, MonadLogger m)+ => FilePath -> BL.ByteString -> m (Text, FilePath, FilePath) lgBuildPackIndex dir bytes = do sha <- go dir bytes return (sha, dir </> ("pack-" <> unpack sha <> ".pack"),@@ -1236,10 +1246,10 @@ lift_ . run $ lgDebug $ "Add the incoming packfile data to the stream ("- ++ show (B.length bytes) ++ " bytes)"+ ++ show (BL.length bytes) ++ " bytes)" (_,statsPtr) <- allocate calloc free- liftIO $ BU.unsafeUseAsCStringLen bytes $- uncurry $ \dataPtr dataLen -> do+ liftIO $ forM_ (BL.toChunks bytes) $ \chunk ->+ BU.unsafeUseAsCStringLen chunk $ uncurry $ \dataPtr dataLen -> do r <- c'git_indexer_stream_add idxPtr (castPtr dataPtr) (fromIntegral dataLen) statsPtr checkResult r "c'git_indexer_stream_add failed"@@ -1260,14 +1270,17 @@ Git.SHA <$> B.packCStringLen (castPtr oidPtr, sizeOf (undefined :: C'git_oid)) -shaToOid :: Git.SHA -> IO (ForeignPtr C'git_oid)-shaToOid (Git.SHA bs) = BU.unsafeUseAsCString bs $ \bytes -> do+shaToCOid :: Git.SHA -> IO (ForeignPtr C'git_oid)+shaToCOid (Git.SHA bs) = BU.unsafeUseAsCString bs $ \bytes -> do ptr <- mallocForeignPtr withForeignPtr ptr $ \ptr' -> do c'git_oid_fromraw ptr' (castPtr bytes) return ptr -lgCopyPackFile :: MonadLg m => FilePath -> LgRepository m ()+shaToOid :: Git.SHA -> IO OidPtr+shaToOid = fmap mkOid . shaToCOid++lgCopyPackFile :: MonadLg m => FilePath -> ReaderT LgRepo m () lgCopyPackFile packFile = do -- jww (2013-04-23): This would be much more efficient (we already have -- the pack file on disk, why not just copy it?), but we have no way at@@ -1284,7 +1297,7 @@ -- yet because it only calls into the Libgit2 backend, which doesn't know -- anything about the S3 backend. As far as Libgit2 is concerned, the S3 -- backend is just a black box with no special properties.- repo <- lgGet+ repo <- Git.getRepository control $ \run -> withForeignPtr (repoObj repo) $ \repoPtr -> alloca $ \odbPtrPtr -> alloca $ \statsPtr ->@@ -1300,15 +1313,11 @@ peek odbPtrPtr lift_ . run $ lgDebug "Opening pack writer into odb"- (_,writepackPtr) <- allocate- (do r <- c'git_odb_write_pack writepackPtrPtr odbPtr- nullFunPtr nullPtr- checkResult r "c'git_odb_write_pack failed"- peek writepackPtrPtr)- (\writepackPtr -> do- writepack <- peek writepackPtr- mK'git_odb_writepack_free_callback- (c'git_odb_writepack'free writepack) writepackPtr)+ writepackPtr <- liftIO $ do+ r <- c'git_odb_write_pack writepackPtrPtr odbPtr+ nullFunPtr nullPtr+ checkResult r "c'git_odb_write_pack failed"+ peek writepackPtrPtr writepack <- liftIO $ peek writepackPtr bs <- liftIO $ B.readFile packFile@@ -1330,59 +1339,55 @@ statsPtr checkResult r "c'git_odb_writepack'commit failed" -lgLoadPackFileInMemory :: (MonadLg m, MonadUnsafeIO m, MonadThrow m,- MonadLogger m)- => FilePath- -> Ptr (Ptr C'git_odb_backend)- -> Ptr (Ptr C'git_odb)- -> ResourceT m (Ptr C'git_odb)+lgLoadPackFileInMemory+ :: (MonadBaseControl IO m, MonadIO m, Failure Git.GitException m,+ MonadUnsafeIO m, MonadThrow m, MonadLogger m)+ => FilePath+ -> Ptr (Ptr C'git_odb_backend)+ -> Ptr (Ptr C'git_odb)+ -> ResourceT m (Ptr C'git_odb) lgLoadPackFileInMemory idxPath backendPtrPtr odbPtrPtr = do- lgDebug "Creating temporary, in-memory object database"- (freeKey,odbPtr) <- flip allocate c'git_odb_free $ do+ lgDebug "Create temporary, in-memory object database"+ (_,odbPtr) <- flip allocate c'git_odb_free $ do r <- c'git_odb_new odbPtrPtr checkResult r "c'git_odb_new failed" peek odbPtrPtr lgDebug $ "Load pack index " ++ show idxPath ++ " into temporary odb"- (_,backendPtr) <- allocate- (do r <- withCString idxPath $ \idxPathStr ->+ bracketOnError+ (do r <- liftIO $ withCString idxPath $ \idxPathStr -> c'git_odb_backend_one_pack backendPtrPtr idxPathStr checkResult r "c'git_odb_backend_one_pack failed"- peek backendPtrPtr)+ liftIO $ peek backendPtrPtr)+ (\backendPtr -> liftIO $ do+ backend <- peek backendPtr+ mK'git_odb_backend_free_callback+ (c'git_odb_backend'free backend) backendPtr) (\backendPtr -> do- backend <- peek backendPtr- mK'git_odb_backend_free_callback- (c'git_odb_backend'free backend) backendPtr)-- -- Since freeing the backend will now free the object database, unregister- -- the finalizer we had setup for the odbPtr- void $ unprotect freeKey-- -- Associate the new backend containing our single index file with the- -- in-memory object database- lgDebug "Associate odb with backend"- r <- liftIO $ c'git_odb_add_backend odbPtr backendPtr 1- checkResult r "c'git_odb_add_backend failed"+ -- Associate the new backend containing our single index file with+ -- the in-memory object database+ lgDebug "Associate odb with backend"+ r <- liftIO $ c'git_odb_add_backend odbPtr backendPtr 1+ checkResult r "c'git_odb_add_backend failed") return odbPtr -lgWithPackFile :: (MonadLg m, MonadUnsafeIO m, MonadThrow m, MonadLogger m)+lgWithPackFile :: (MonadBaseControl IO m, MonadIO m, Failure Git.GitException m,+ MonadUnsafeIO m, MonadThrow m, MonadLogger m) => FilePath -> (Ptr C'git_odb -> ResourceT m a) -> m a lgWithPackFile idxPath f = control $ \run -> alloca $ \odbPtrPtr ->- alloca $ \backendPtrPtr -> run $ runResourceT $ do- lift $ lgDebug "Load pack file into an in-memory object database"- odbPtr <- lgLoadPackFileInMemory idxPath backendPtrPtr odbPtrPtr- lift $ lgDebug "Calling function using in-memory odb"- f odbPtr+ alloca $ \backendPtrPtr -> run $ runResourceT $+ f =<< lgLoadPackFileInMemory idxPath backendPtrPtr odbPtrPtr -lgReadFromPack :: (MonadLg m, MonadUnsafeIO m, MonadThrow m, MonadLogger m)+lgReadFromPack :: (MonadBaseControl IO m, MonadIO m, Failure Git.GitException m,+ MonadUnsafeIO m, MonadThrow m, MonadLogger m) => FilePath -> Git.SHA -> Bool -> m (Maybe (C'git_otype, CSize, ByteString)) lgReadFromPack idxPath sha metadataOnly = control $ \run -> alloca $ \objectPtrPtr -> run $ lgWithPackFile idxPath $ \odbPtr -> do- foid <- liftIO $ shaToOid sha+ foid <- liftIO $ shaToCOid sha if metadataOnly then readMetadata odbPtr foid else readObject odbPtr foid objectPtrPtr@@ -1421,9 +1426,9 @@ (fromIntegral len) return (typ,len,bytes) -lgRemoteFetch :: MonadLg m => Text -> Text -> LgRepository m ()+lgRemoteFetch :: MonadLg m => Text -> Text -> ReaderT LgRepo m () lgRemoteFetch uri fetchSpec = do- xferRepo <- lgGet+ xferRepo <- Git.getRepository liftIO $ withForeignPtr (repoObj xferRepo) $ \repoPtr -> withCString (unpack uri) $ \uriStr -> withCString (unpack fetchSpec) $ \fetchStr ->@@ -1445,31 +1450,24 @@ lgFactory :: MonadIO m => Git.RepositoryFactory- (LgRepository (NoLoggingT m)) m Repository+ (ReaderT LgRepo (NoLoggingT m)) m LgRepo lgFactory = Git.RepositoryFactory { Git.openRepository = runNoLoggingT . openLgRepository , Git.runRepository = \c m -> runNoLoggingT $ runLgRepository c m- , Git.closeRepository = runNoLoggingT . closeLgRepository- , Git.getRepository = hoist NoLoggingT lgGet- , Git.defaultOptions = defaultLgOptions- , Git.startupBackend = runNoLoggingT startupLgBackend- , Git.shutdownBackend = runNoLoggingT shutdownLgBackend } lgFactoryLogger :: (MonadIO m, MonadLogger m)- => Git.RepositoryFactory (LgRepository m) m Repository+ => Git.RepositoryFactory (ReaderT LgRepo m) m LgRepo lgFactoryLogger = Git.RepositoryFactory { Git.openRepository = openLgRepository , Git.runRepository = runLgRepository- , Git.closeRepository = closeLgRepository- , Git.getRepository = lgGet- , Git.defaultOptions = defaultLgOptions- , Git.startupBackend = startupLgBackend- , Git.shutdownBackend = shutdownLgBackend } -openLgRepository :: MonadIO m => Git.RepositoryOptions -> m Repository+runLgRepository :: LgRepo -> ReaderT LgRepo m a -> m a+runLgRepository = flip runReaderT++openLgRepository :: MonadIO m => Git.RepositoryOptions -> m LgRepo openLgRepository opts = do startupLgBackend let path = Git.repoPath opts@@ -1487,23 +1485,13 @@ when (r < 0) $ error $ "Could not open repository " ++ show path ptr' <- peek ptr- newForeignPtr p'git_repository_free ptr'+ FC.newForeignPtr ptr' (c'git_repository_free ptr') excTrap <- newIORef Nothing- return Repository { repoOptions = opts- , repoObj = fptr- , repoExcTrap = excTrap- }--runLgRepository :: MonadIO m => Repository -> LgRepository m a -> m a-runLgRepository repo action = do- startupLgBackend- runReaderT (lgRepositoryReaderT action) repo--closeLgRepository :: Monad m => Repository -> m ()-closeLgRepository = const (return ())--defaultLgOptions :: Git.RepositoryOptions-defaultLgOptions = Git.RepositoryOptions "" False False+ return LgRepo+ { repoOptions = opts+ , repoObj = fptr+ , repoExcTrap = excTrap+ } startupLgBackend :: MonadIO m => m () startupLgBackend = liftIO (void c'git_threads_init)
Git/Libgit2/Backend.hs view
@@ -67,8 +67,8 @@ type F'git_odb_writepack_free_callback = Ptr C'git_odb_writepack -> IO () -odbBackendAdd :: Repository -> Ptr C'git_odb_backend -> Int- -> IO (Either String Repository)+odbBackendAdd :: LgRepo -> Ptr C'git_odb_backend -> Int+ -> IO (Either String LgRepo) odbBackendAdd repo backend priority = withForeignPtr (repoObj repo) $ \repoPtr -> alloca $ \odbPtr -> do@@ -78,6 +78,7 @@ else do odb <- peek odbPtr r2 <- c'git_odb_add_backend odb backend (fromIntegral priority)+ c'git_odb_free odb if r2 < 0 then return (Left "Cannot add backend to repository ODB") else return (Right repo)
Git/Libgit2/Internal.hs view
@@ -10,10 +10,8 @@ import Control.Applicative import Control.Failure import Control.Monad-import Control.Monad.IO.Class import Control.Monad.Trans.Control import Data.ByteString-import Data.Tagged import qualified Data.Text as T import qualified Data.Text.ICU.Convert as U import Data.Time@@ -21,6 +19,7 @@ utcTimeToPOSIXSeconds) import Foreign.C.String import Foreign.C.Types+import qualified Foreign.Concurrent as FC import Foreign.ForeignPtr import Foreign.Marshal.Alloc import Foreign.Ptr@@ -31,17 +30,9 @@ import Git.Libgit2.Types import System.FilePath.Posix -type ObjPtr a = Maybe (ForeignPtr a)--data Base m a b = Base- { gitId :: Maybe (Tagged a (Git.Oid (LgRepository m)))- , gitObj :: ObjPtr b- }--addTracingBackend :: Git.MonadGit m => LgRepository m ()-addTracingBackend = do- repo <- lgGet- liftIO $ withCString (repoPath repo </> "objects") $ \objectsDir ->+addTracingBackend :: LgRepo -> IO ()+addTracingBackend repo =+ withCString (lgRepoPath repo </> "objects") $ \objectsDir -> alloca $ \loosePtr -> do r <- c'git_odb_backend_loose loosePtr objectsDir (-1) 0 when (r < 0) $@@ -60,14 +51,14 @@ return fptr lookupObject'- :: Git.MonadGit m+ :: (Git.MonadGit LgRepo m, MonadBaseControl IO m) => ForeignPtr C'git_oid -> Int -> (Ptr (Ptr a) -> Ptr C'git_repository -> Ptr C'git_oid -> IO CInt) -> (Ptr (Ptr a) -> Ptr C'git_repository -> Ptr C'git_oid -> CSize -> IO CInt)- -> (ForeignPtr C'git_oid -> ForeignPtr a -> Ptr a -> LgRepository m b)- -> LgRepository m b+ -> (ForeignPtr C'git_oid -> ForeignPtr a -> Ptr a -> m b)+ -> m b lookupObject' oid len lookupFn lookupPrefixFn createFn = do- repo <- lgGet+ repo <- Git.getRepository result <- control $ \run -> alloca $ \ptr -> do r <- withForeignPtr (repoObj repo) $ \repoPtr -> withForeignPtr oid $ \oidPtr ->@@ -91,7 +82,8 @@ coidCopy <- mallocForeignPtr withForeignPtr coidCopy $ flip c'git_oid_cpy coid - fptr <- newForeignPtr p'git_object_free (castPtr ptr')+ 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
Git/Libgit2/Types.hs view
@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE RankNTypes #-}@@ -11,94 +10,49 @@ import Bindings.Libgit2 import Control.Applicative-import Control.Exception-import Control.Monad (liftM)-import Control.Monad.Base+import Control.Failure import Control.Monad.IO.Class import Control.Monad.Logger-import Control.Monad.Morph import Control.Monad.Trans.Control-import Control.Monad.Trans.Reader-import Data.Conduit import Data.IORef-import Data.Monoid import Foreign.ForeignPtr import qualified Git -data Repository = Repository+data LgRepo = LgRepo { repoOptions :: Git.RepositoryOptions , repoObj :: ForeignPtr C'git_repository , repoExcTrap :: IORef (Maybe Git.GitException) } -repoPath :: Repository -> FilePath-repoPath = Git.repoPath . repoOptions--instance Eq Repository where- x == y = repoPath x == repoPath y && repoObj x == repoObj y--instance Show Repository where- show x = "Repository " <> repoPath x--newtype LgRepository m a = LgRepository- { lgRepositoryReaderT :: ReaderT Repository m a }- deriving (Functor, Applicative, Monad, MonadIO)--instance (Monad m, MonadIO m, Applicative m)- => MonadBase IO (LgRepository m) where- liftBase = liftIO--instance Monad m => MonadThrow (LgRepository m) where- -- monadThrow :: Exception e => e -> m a- monadThrow = throw--instance MonadLogger m => MonadLogger (LgRepository m) where- monadLoggerLog a b c d = LgRepository $ monadLoggerLog a b c d--instance MonadTrans LgRepository where- lift = LgRepository . ReaderT . const--instance MFunctor LgRepository where- hoist nat m = LgRepository $ ReaderT $ \i ->- nat (runReaderT (lgRepositoryReaderT m) i)--instance MonadTransControl LgRepository where- newtype StT LgRepository a = StLgRepository- { unLgRepository :: StT (ReaderT Repository) a- }- liftWith = defaultLiftWith LgRepository- lgRepositoryReaderT StLgRepository- restoreT = defaultRestoreT LgRepository unLgRepository+lgRepoPath :: LgRepo -> FilePath+lgRepoPath = Git.repoPath . repoOptions -instance (MonadIO m, MonadBaseControl IO m)- => MonadBaseControl IO (LgRepository m) where- newtype StM (LgRepository m) a = StMT- { unStMT :: ComposeSt LgRepository m a- }- liftBaseWith = defaultLiftBaseWith StMT- restoreM = defaultRestoreM unStMT+-- class HasLgRepo env where+-- getLgRepo :: env -> LgRepo -type BlobOid m = Git.BlobOid (LgRepository m)-type TreeOid m = Git.TreeOid (LgRepository m)-type CommitOid m = Git.CommitOid (LgRepository m)+-- instance HasLgRepo LgRepo where+-- getLgRepo = id -type Tree m = Git.Tree (LgRepository m)-type Commit m = Git.Commit (LgRepository m)-type Tag m = Git.Tag (LgRepository m)+-- instance HasLgRepo (env, LgRepo) where+-- getLgRepo = snd -type Object m = Git.Object (LgRepository m)-type ObjectOid m = Git.ObjectOid (LgRepository m)-type RefTarget m = Git.RefTarget (LgRepository m)+type BlobOid = Git.BlobOid LgRepo+type TreeOid = Git.TreeOid LgRepo+type CommitOid = Git.CommitOid LgRepo -type TreeBuilder m = Git.TreeBuilder (LgRepository m)-type Options m = Git.Options (LgRepository m)+type Tree = Git.Tree LgRepo+type TreeEntry = Git.TreeEntry LgRepo+type Commit = Git.Commit LgRepo+type Tag = Git.Tag LgRepo -type MonadLg m = (Git.MonadGit m, MonadLogger m)+type Object = Git.Object LgRepo+type ObjectOid = Git.ObjectOid LgRepo+type RefTarget = Git.RefTarget LgRepo -lgGet :: Monad m => LgRepository m Repository-lgGet = LgRepository ask+type TreeBuilder = Git.TreeBuilder LgRepo+type Options = Git.Options LgRepo -lgExcTrap :: Monad m => LgRepository m (IORef (Maybe Git.GitException))-lgExcTrap = repoExcTrap `liftM` lgGet+type MonadLg m = (Applicative m, Failure Git.GitException m,+ MonadIO m, MonadBaseControl IO m, MonadLogger m) -- Types.hs
gitlib-libgit2.cabal view
@@ -1,5 +1,5 @@ Name: gitlib-libgit2-Version: 2.2.0.1+Version: 3.0.0 Synopsis: Libgit2 backend for gitlib License-file: LICENSE License: MIT@@ -23,9 +23,9 @@ Hs-source-dirs: test Build-depends: base >=3- , gitlib >= 2.2.0.0- , gitlib-test >= 2.2.0.0- , gitlib-libgit2 >= 2.2.0.0+ , gitlib >= 3.0.0+ , gitlib-test >= 3.0.0+ , gitlib-libgit2 >= 3.0.0 , HUnit >= 1.2.5 , hspec >= 1.4.4 , hspec-expectations >= 0.3@@ -36,7 +36,7 @@ ghc-options: -Wall build-depends: base >= 3 && < 5- , gitlib >= 2.2.0.0+ , gitlib >= 3.0.0 , hlibgit2 >= 0.18.0.11 , bytestring >= 0.9.2.1 , conduit >= 0.5.5@@ -48,12 +48,14 @@ , lifted-async >= 0.1.0 , lifted-base >= 0.2.0.2 , missing-foreign >= 0.1.1+ , mmorph >= 1.0.0 , monad-control >= 0.3.2 , monad-logger >= 0.3.1.1 , monad-loops >= 0.3.3.0- , mmorph >= 1.0.0+ , mtl >= 2.1.2 , resourcet >= 0.4.6- , stm >= 2.4.2+ , stm >= 2.4+ , stm-conduit >= 2.1.4 , tagged >= 0.2.3.1 , template-haskell , text >= 0.11.2