diff --git a/Git/Libgit2.hs b/Git/Libgit2.hs --- a/Git/Libgit2.hs +++ b/Git/Libgit2.hs @@ -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) diff --git a/Git/Libgit2/Backend.hs b/Git/Libgit2/Backend.hs --- a/Git/Libgit2/Backend.hs +++ b/Git/Libgit2/Backend.hs @@ -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) diff --git a/Git/Libgit2/Internal.hs b/Git/Libgit2/Internal.hs --- a/Git/Libgit2/Internal.hs +++ b/Git/Libgit2/Internal.hs @@ -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 diff --git a/Git/Libgit2/Types.hs b/Git/Libgit2/Types.hs --- a/Git/Libgit2/Types.hs +++ b/Git/Libgit2/Types.hs @@ -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 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: 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