diff --git a/Git/Libgit2.hs b/Git/Libgit2.hs --- a/Git/Libgit2.hs +++ b/Git/Libgit2.hs @@ -21,6 +21,7 @@ -- queried as needed. module Git.Libgit2 ( MonadLg + , HasLgRepo(..) , LgRepo(..) , BlobOid() , Commit() @@ -58,16 +59,15 @@ import Conduit import Control.Applicative import Control.Concurrent (threadDelay) -import Control.Concurrent.Async.Lifted import Control.Concurrent.STM ---import Control.Exception.Lifted +import UnliftIO.Async import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence) import Control.Monad.Catch import Control.Monad.Loops import Control.Monad.Reader.Class -import Control.Monad.Trans.Control import Control.Monad.Trans.Reader (ReaderT, runReaderT) import Control.Monad.Trans.Resource +import Control.Monad.IO.Unlift import Data.Bits ((.|.), (.&.)) import Data.ByteString (ByteString) import qualified Data.ByteString as B @@ -174,10 +174,15 @@ instance Eq OidPtr where oid1 == oid2 = oid1 `compare` oid2 == EQ - -instance (Applicative m, MonadExcept m, - MonadBaseControl IO m, MonadIO m) - => Git.MonadGit LgRepo (ReaderT LgRepo m) where + +class HasLgRepo m where + getRepository :: m LgRepo + +instance Monad m => HasLgRepo (ReaderT LgRepo m) where + getRepository = ask + +instance (Applicative m, MonadExcept m, MonadUnliftIO m, HasLgRepo m) + => Git.MonadGit LgRepo m where type Oid LgRepo = OidPtr data Tree LgRepo = LgTree { lgTreePtr :: Maybe (ForeignPtr C'git_tree) } @@ -185,7 +190,7 @@ facts = return Git.RepositoryFacts { Git.hasSymbolicReferences = True } - getRepository = ask + getRepository = getRepository closeRepository = return () deleteRepository = Git.getRepository >>= liftIO . removeDirectoryRecursive . lgRepoPath @@ -202,6 +207,7 @@ lookupBlob = lgLookupBlob lookupTag = error "Not implemented: LgRepository.lookupTag" readIndex = lgReadIndex + writeIndex = error "Not implemented: LgRepository.writeIndex" lookupObject = lgLookupObject existsObject = lgExistsObject sourceObjects = lgSourceObjects @@ -223,19 +229,20 @@ -- remoteFetch = lgRemoteFetch -lgExcTrap :: MonadLg m => ReaderT LgRepo m (IORef (Maybe Git.GitException)) -lgExcTrap = repoExcTrap `liftM` Git.getRepository +lgExcTrap :: (MonadLg m, HasLgRepo m) + => m (IORef (Maybe Git.GitException)) +lgExcTrap = repoExcTrap `liftM` getRepository -lgWrap :: MonadLg m => ReaderT LgRepo m a -> ReaderT LgRepo m a +lgWrap :: (MonadLg m, HasLgRepo m) => m a -> m a lgWrap f = f `catch` \e -> do etrap <- lgExcTrap mexc <- liftIO $ readIORef etrap liftIO $ writeIORef etrap Nothing maybe (throwM (e :: SomeException)) throwM mexc -lgHashContents :: MonadLg m - => Git.BlobContents (ReaderT LgRepo m) - -> ReaderT LgRepo m BlobOid +lgHashContents :: (MonadLg m, HasLgRepo m) + => Git.BlobContents m + -> m BlobOid lgHashContents b = do ptr <- liftIO mallocForeignPtr r <- Git.blobContentsToByteString b >>= \bs -> @@ -250,11 +257,11 @@ -- -- 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 (ReaderT LgRepo m) - -> ReaderT LgRepo m BlobOid +lgCreateBlob :: (MonadLg m, HasLgRepo m) + => Git.BlobContents m + -> m BlobOid lgCreateBlob b = do - repo <- Git.getRepository + repo <- getRepository ptr <- liftIO mallocForeignPtr -- freed automatically if GC'd r <- case b of Git.BlobString bs -> createBlob repo ptr bs @@ -305,7 +312,7 @@ lgObjToBlob :: MonadLg m => BlobOid -> ForeignPtr C'git_blob - -> ReaderT LgRepo m (Git.Blob LgRepo (ReaderT LgRepo m)) + -> m (Git.Blob LgRepo m) lgObjToBlob oid fptr = do bs <- liftIO $ withForeignPtr fptr $ \ptr -> do size <- c'git_blob_rawsize ptr @@ -313,16 +320,16 @@ B.packCStringLen (castPtr buf, fromIntegral size) return $ Git.Blob oid $ Git.BlobString bs -lgLookupBlob :: MonadLg m +lgLookupBlob :: (MonadLg m, HasLgRepo m) => BlobOid - -> ReaderT LgRepo m (Git.Blob LgRepo (ReaderT LgRepo m)) + -> m (Git.Blob 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 -lgTreeEntry :: MonadLg m - => Tree -> Git.TreeFilePath -> ReaderT LgRepo m (Maybe TreeEntry) +lgTreeEntry :: (MonadLg m, HasLgRepo m) + => Tree -> Git.TreeFilePath -> m (Maybe TreeEntry) lgTreeEntry (LgTree Nothing) _ = return Nothing lgTreeEntry (LgTree (Just tree)) fp = liftIO $ alloca $ \entryPtr -> withFilePath fp $ \pathStr -> @@ -332,7 +339,7 @@ then return Nothing else Just <$> (entryToTreeEntry =<< peek entryPtr) -lgTreeOid :: MonadLg m => Tree -> ReaderT LgRepo m TreeOid +lgTreeOid :: (MonadLg m, HasLgRepo m) => Tree -> m TreeOid lgTreeOid (LgTree Nothing) = liftIO $ Tagged . fromJust <$> lgParseOidIO Git.emptyTreeId 40 lgTreeOid (LgTree (Just tree)) = liftIO $ do @@ -340,14 +347,14 @@ ftoid <- coidPtrToOid toid return $ Tagged (mkOid ftoid) -gatherFrom' :: (MonadIO m, MonadBaseControl IO m, MonadExcept m) +gatherFrom' :: (MonadExcept m, MonadUnliftIO 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 + gather worker chan where gather worker chan = do (xs, mres) <- liftIO $ atomically $ do @@ -361,9 +368,9 @@ Nothing -> gather worker chan lgSourceTreeEntries - :: MonadLg m + :: (MonadLg m, HasLgRepo m) => Tree - -> Producer (ReaderT LgRepo m) (Git.TreeFilePath, TreeEntry) + -> Producer m (Git.TreeFilePath, TreeEntry) lgSourceTreeEntries (LgTree Nothing) = return () lgSourceTreeEntries (LgTree (Just tree)) = gatherFrom' 16 $ \queue -> do liftIO $ withForeignPtr tree $ \tr -> do @@ -383,8 +390,8 @@ writeTBQueue queue $ name `seq` entry `seq` (name,entry) return 0 -lgMakeBuilder :: MonadLg m - => ForeignPtr C'git_treebuilder -> TreeBuilder (ReaderT LgRepo m) +lgMakeBuilder :: (MonadLg m, HasLgRepo m) + => ForeignPtr C'git_treebuilder -> TreeBuilder m lgMakeBuilder builder = Git.TreeBuilder { Git.mtbBaseTreeOid = Nothing , Git.mtbPendingUpdates = mempty @@ -403,9 +410,9 @@ -- -- Since empty trees cannot exist in Git, attempting to write out an empty -- tree is a no-op. -lgNewTreeBuilder :: MonadLg m +lgNewTreeBuilder :: (MonadLg m, HasLgRepo m) => Maybe Tree - -> ReaderT LgRepo m (TreeBuilder (ReaderT LgRepo m)) + -> m (TreeBuilder m) lgNewTreeBuilder mtree = do mfptr <- liftIO $ alloca $ \pptr -> do r <- case mtree of @@ -431,7 +438,7 @@ lgPutEntry :: MonadLg m => ForeignPtr C'git_treebuilder -> Git.TreeFilePath -> TreeEntry - -> ReaderT LgRepo m () + -> m () lgPutEntry builder key (treeEntryToOid -> (oid, mode)) = do r2 <- liftIO $ withForeignPtr (getOid oid) $ \coid -> withForeignPtr builder $ \ptr -> @@ -453,7 +460,7 @@ lgDropEntry :: MonadLg m => ForeignPtr C'git_treebuilder -> Git.TreeFilePath - -> ReaderT LgRepo m () + -> m () lgDropEntry builder key = void $ liftIO $ withForeignPtr builder $ \ptr -> withFilePath key $ c'git_treebuilder_remove ptr @@ -461,7 +468,7 @@ lgLookupBuilderEntry :: MonadLg m => ForeignPtr C'git_treebuilder -> Git.TreeFilePath - -> ReaderT LgRepo m (Maybe TreeEntry) + -> m (Maybe TreeEntry) lgLookupBuilderEntry builderPtr name = do entry <- liftIO $ withForeignPtr builderPtr $ \builder -> withFilePath name $ c'git_treebuilder_get builder @@ -470,7 +477,7 @@ else Just <$> liftIO (entryToTreeEntry entry) lgBuilderEntryCount :: MonadLg m - => ForeignPtr C'git_treebuilder -> ReaderT LgRepo m Int + => ForeignPtr C'git_treebuilder -> m Int lgBuilderEntryCount tb = fromIntegral <$> liftIO (withForeignPtr tb c'git_treebuilder_entrycount) @@ -479,10 +486,10 @@ lgTreeEntryCount (LgTree (Just tree)) = fromIntegral <$> liftIO (withForeignPtr tree c'git_tree_entrycount) -lgWriteBuilder :: MonadLg m - => ForeignPtr C'git_treebuilder -> ReaderT LgRepo m TreeOid +lgWriteBuilder :: (MonadLg m, HasLgRepo m) + => ForeignPtr C'git_treebuilder -> m TreeOid lgWriteBuilder tb = do - repo <- Git.getRepository + repo <- getRepository (r3,coid) <- liftIO $ do coid <- mallocForeignPtr withForeignPtr coid $ \coid' -> @@ -522,7 +529,7 @@ throwM (Git.BackendError "Could not insert entry in treebuilder") return 0 -lgLookupTree :: MonadLg m => TreeOid -> ReaderT LgRepo m Tree +lgLookupTree :: (MonadLg m, HasLgRepo m) => TreeOid -> m Tree lgLookupTree (untag -> oid) | show oid == unpack Git.emptyTreeId = return $ LgTree Nothing | otherwise = do @@ -586,16 +593,16 @@ , Git.commitEncoding = "utf-8" } -lgLookupCommit :: MonadLg m => CommitOid -> ReaderT LgRepo m Commit +lgLookupCommit :: (MonadLg m, HasLgRepo m) => CommitOid -> m Commit lgLookupCommit oid = lookupObject' (getOid (untag oid)) (getOidLen (untag oid)) c'git_commit_lookup c'git_commit_lookup_prefix $ \coid obj _ -> liftIO $ withForeignPtr obj $ lgObjToCommit (Tagged (mkOid coid)) -lgReadIndex :: MonadLg m => Git.TreeT LgRepo (ReaderT LgRepo m) () +lgReadIndex :: (MonadLg m, HasLgRepo m) => Git.TreeT LgRepo m () lgReadIndex = do - repo <- lift Git.getRepository + repo <- lift getRepository xs <- liftIO $ withForeignPtr (repoObj repo) $ \repoPtr -> alloca $ \indexPp -> do r <- c'git_repository_index indexPp repoPtr @@ -634,10 +641,11 @@ | CommitPtr (ForeignPtr C'git_commit) | TagPtr (ForeignPtr C'git_tag) -lgLookupObject :: MonadLg m +lgLookupObject :: (MonadLg m, HasLgRepo m) => Oid - -> ReaderT LgRepo m (Git.Object LgRepo (ReaderT LgRepo m)) + -> m (Git.Object LgRepo m) lgLookupObject oid = do + repo <- getRepository (oid', typ, fptr) <- lookupObject' (getOid oid) (getOidLen oid) (\x y z -> c'git_object_lookup x y z c'GIT_OBJ_ANY) @@ -656,12 +664,22 @@ Git.CommitObj <$> liftIO (withForeignPtr fptr $ \y -> lgObjToCommit (Tagged oid') (castPtr y)) - | typ == c'GIT_OBJ_TAG -> error "jww (2013-07-08): NYI" + | typ == c'GIT_OBJ_TAG -> do + commit <- liftIO (withForeignPtr (repoObj repo) $ \repoPtr -> + liftIO (withForeignPtr fptr $ \y -> + do oid'' <- c'git_tag_target_id (castPtr y) + alloca $ \pptr -> do + _ <- c'git_commit_lookup pptr repoPtr oid'' + ptr <- peek pptr + coid <- coidPtrToOid oid'' + lgObjToCommit (Tagged . mkOid $ coid) ptr + )) + Git.CommitObj <$> (pure commit) | otherwise -> error $ "Unknown object type: " ++ show typ -lgExistsObject :: MonadLg m => Oid -> ReaderT LgRepo m Bool +lgExistsObject :: (MonadLg m, HasLgRepo m) => Oid -> m Bool lgExistsObject oid = do - repo <- Git.getRepository + repo <- getRepository result <- liftIO $ withForeignPtr (repoObj repo) $ \repoPtr -> alloca $ \pptr -> do r <- c'git_repository_odb pptr repoPtr @@ -687,11 +705,11 @@ freeHaskellFunPtr (flip (c'git_odb_foreach odbPtr) payload) -lgSourceObjects :: MonadLg m +lgSourceObjects :: (MonadLg m, HasLgRepo m) => Maybe CommitOid -> CommitOid -> Bool - -> Producer (ReaderT LgRepo m) ObjectOid + -> Producer m ObjectOid lgSourceObjects mhave need alsoTrees = do - repo <- lift Git.getRepository + repo <- lift getRepository walker <- liftIO $ alloca $ \pptr -> do r <- withForeignPtr (repoObj repo) $ \repoPtr -> c'git_revwalk_new pptr repoPtr @@ -735,16 +753,16 @@ -- | Write out a commit to its repository. If it has already been written, -- nothing will happen. -lgCreateCommit :: MonadLg m +lgCreateCommit :: (MonadLg m, HasLgRepo m) => [CommitOid] -> TreeOid -> Git.Signature -> Git.Signature -> Git.CommitMessage -> Maybe Git.RefName - -> ReaderT LgRepo m Commit + -> m Commit lgCreateCommit pptrs tree author committer logText ref = do - repo <- Git.getRepository + repo <- getRepository let toid = getOid . untag $ tree coid <- liftIO $ withForeignPtr (repoObj repo) $ \repoPtr -> do coid <- mallocForeignPtr @@ -791,9 +809,9 @@ mapM_ touchForeignPtr fos return r -lgLookupRef :: MonadLg m => Git.RefName -> ReaderT LgRepo m (Maybe RefTarget) +lgLookupRef :: (MonadLg m, HasLgRepo m) => Git.RefName -> m (Maybe RefTarget) lgLookupRef name = do - repo <- Git.getRepository + repo <- getRepository liftIO $ alloca $ \ptr -> do r <- withForeignPtr (repoObj repo) $ \repoPtr -> withCString (unpack name) $ \namePtr -> @@ -813,10 +831,10 @@ c'git_reference_free ref return (Just targ) -lgUpdateRef :: MonadLg m - => Git.RefName -> Git.RefTarget LgRepo -> ReaderT LgRepo m () +lgUpdateRef :: (MonadLg m, HasLgRepo m) + => Git.RefName -> Git.RefTarget LgRepo -> m () lgUpdateRef name refTarg = do - repo <- Git.getRepository + repo <- getRepository r <- liftIO $ alloca $ \ptr -> withForeignPtr (repoObj repo) $ \repoPtr -> withCString (unpack name) $ \namePtr -> @@ -837,7 +855,7 @@ lgResolveRef :: MonadLg m => Git.RefName -> ReaderT LgRepo m (Maybe CommitOid) lgResolveRef name = do - repo <- Git.getRepository + repo <- getRepository oid <- liftIO $ alloca $ \ptr -> withCString (unpack name) $ \namePtr -> withForeignPtr (repoObj repo) $ \repoPtr -> do @@ -852,9 +870,9 @@ --renameRef = c'git_reference_rename -lgDeleteRef :: MonadLg m => Git.RefName -> ReaderT LgRepo m () +lgDeleteRef :: (MonadLg m, HasLgRepo m) => Git.RefName -> m () lgDeleteRef name = do - repo <- Git.getRepository + repo <- getRepository r <- liftIO $ alloca $ \ptr -> withCString (unpack name) $ \namePtr -> withForeignPtr (repoObj repo) $ \repoPtr -> do @@ -920,10 +938,11 @@ + (if listFlagPacked flags then 4 else 0) + (if listFlagHasPeel flags then 8 else 0) -lgSourceRefs :: MonadLg m => Producer (ReaderT LgRepo m) Git.RefName + +lgSourceRefs :: (MonadLg m, HasLgRepo m) => Producer m Git.RefName lgSourceRefs = gatherFrom' 16 $ \queue -> do - repo <- Git.getRepository + repo <- getRepository r <- liftIO $ bracket (mk'git_reference_foreach_cb (callback queue)) freeHaskellFunPtr @@ -1022,7 +1041,7 @@ Git.DiffTreeToIndexFailed "Cannot diff against an empty tree" lgDiffContentsWithTree contents tree = do - repo <- lift Git.getRepository + repo <- lift getRepository gatherFrom' 16 $ generateDiff repo where -- generateDiff :: MonadLg m => LgRepo -> TBQueue ByteString -> m () @@ -1223,7 +1242,7 @@ => FilePath -> [Either CommitOid TreeOid] -> ReaderT LgRepo m FilePath lgBuildPackFile dir oids = do - repo <- Git.getRepository + repo <- getRepository liftIO $ do (filePath, fHandle) <- openBinaryTempFile dir "pack" hClose fHandle @@ -1273,14 +1292,14 @@ lift_ :: (Monad m, Functor (t m), MonadTrans t) => m a -> t m () lift_ = void . lift -lgBuildPackIndex :: (MonadIO m, MonadBaseControl IO m) +lgBuildPackIndex :: MonadUnliftIO m => FilePath -> BL.ByteString -> m (Text, FilePath, FilePath) lgBuildPackIndex dir bytes = do sha <- go dir bytes return (sha, dir ("pack-" <> unpack sha <> ".pack"), dir ("pack-" <> unpack sha <> ".idx")) where - go dir bytes = control $ \run -> alloca $ \idxPtrPtr -> runResourceT $ do + go dir bytes = withRunInIO $ \run -> alloca $ \idxPtrPtr -> runResourceT $ do lift_ . run $ lgDebug "Allocate a new indexer stream" (_,idxPtr) <- flip allocate c'git_indexer_stream_free $ withCString dir $ \dirStr -> do @@ -1342,8 +1361,8 @@ -- 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 <- Git.getRepository - control $ \run -> withForeignPtr (repoObj repo) $ \repoPtr -> + repo <- getRepository + withRunInIO $ \run -> withForeignPtr (repoObj repo) $ \repoPtr -> alloca $ \odbPtrPtr -> alloca $ \statsPtr -> alloca $ \writepackPtrPtr -> do @@ -1385,7 +1404,7 @@ checkResult r "c'git_odb_writepack'commit failed" lgLoadPackFileInMemory - :: (MonadBaseControl IO m, MonadIO m, MonadExcept m) + :: (MonadIO m, MonadExcept m) => FilePath -> Ptr (Ptr C'git_odb_backend) -> Ptr (Ptr C'git_odb) @@ -1416,22 +1435,22 @@ return odbPtr -lgOpenPackFile :: (MonadBaseControl IO m, MonadIO m, MonadExcept m) +lgOpenPackFile :: (MonadExcept m, MonadUnliftIO m) => FilePath -> m (Ptr C'git_odb) -lgOpenPackFile idxPath = control $ \run -> +lgOpenPackFile idxPath = withRunInIO $ \run -> alloca $ \odbPtrPtr -> alloca $ \backendPtrPtr -> run $ lgLoadPackFileInMemory idxPath backendPtrPtr odbPtrPtr -lgClosePackFile :: (MonadBaseControl IO m, MonadIO m, MonadExcept m) +lgClosePackFile :: (MonadIO m, MonadExcept m) => Ptr C'git_odb -> m () lgClosePackFile = liftIO . c'git_odb_free -lgWithPackFile :: (MonadBaseControl IO m, MonadIO m, MonadExcept m) +lgWithPackFile :: (MonadExcept m, MonadUnliftIO m) => FilePath -> (Ptr C'git_odb -> m a) -> m a lgWithPackFile idxPath = bracket (lgOpenPackFile idxPath) lgClosePackFile -lgReadFromPack :: (MonadBaseControl IO m, MonadIO m, MonadExcept m) +lgReadFromPack :: (MonadIO m, MonadExcept m) => Ptr C'git_odb -> Git.SHA -> Bool -> m (Maybe (C'git_otype, CSize, ByteString)) lgReadFromPack odbPtr sha metadataOnly = liftIO $ do @@ -1472,7 +1491,7 @@ lgRemoteFetch :: MonadLg m => Text -> Text -> ReaderT LgRepo m () lgRemoteFetch uri fetchSpec = do - xferRepo <- Git.getRepository + xferRepo <- getRepository liftIO $ withForeignPtr (repoObj xferRepo) $ \repoPtr -> withCString (unpack uri) $ \uriStr -> withCString (unpack fetchSpec) $ \fetchStr -> @@ -1492,7 +1511,7 @@ r2 <- liftIO $ c'git_remote_download remotePtr nullFunPtr nullPtr checkResult r2 "c'git_remote_download failed" -lgFactory :: MonadIO m +lgFactory :: (MonadIO m, MonadMask m) => Git.RepositoryFactory (ReaderT LgRepo m) m LgRepo lgFactory = Git.RepositoryFactory { Git.openRepository = openLgRepository @@ -1502,26 +1521,25 @@ runLgRepository :: LgRepo -> ReaderT LgRepo m a -> m a runLgRepository = flip runReaderT -openLgRepository :: MonadIO m => Git.RepositoryOptions -> m LgRepo +openLgRepository :: (MonadIO m, MonadMask m) => Git.RepositoryOptions -> m LgRepo openLgRepository opts = do startupLgBackend let path = Git.repoPath opts p <- liftIO $ doesDirectoryExist path - liftIO $ openRepositoryWith path $ + openRepositoryWith path $ if not (Git.repoAutoCreate opts) || p then c'git_repository_open else \x y -> c'git_repository_init x y (fromBool (Git.repoIsBare opts)) where openRepositoryWith path fn = do - fptr <- alloca $ \ptr -> - withCString path $ \str -> do - r <- fn ptr str - when (r < 0) $ - error $ "Could not open repository " ++ show path - ptr' <- peek ptr - FC.newForeignPtr ptr' (c'git_repository_free ptr') - excTrap <- newIORef Nothing + ptr <- liftIO malloc + r <- liftIO $ withCString path $ fn ptr + when (r < 0) $ lgThrow Git.RepositoryCannotAccess + excTrap <- liftIO $ newIORef Nothing + fptr <- liftIO $ do + ptr' <- peek ptr + FC.newForeignPtr ptr' (c'git_repository_free ptr') return LgRepo { repoOptions = opts , repoObj = fptr diff --git a/Git/Libgit2/Internal.hs b/Git/Libgit2/Internal.hs --- a/Git/Libgit2/Internal.hs +++ b/Git/Libgit2/Internal.hs @@ -10,7 +10,7 @@ import Control.Applicative import Control.Monad import Control.Monad.Catch -import Control.Monad.Trans.Control +import Control.Monad.IO.Unlift import Data.ByteString import qualified Data.Text as T import qualified Data.Text.ICU.Convert as U @@ -51,7 +51,7 @@ return fptr lookupObject' - :: (Git.MonadGit LgRepo m, MonadBaseControl IO m) + :: (Git.MonadGit LgRepo m, MonadUnliftIO 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) @@ -59,7 +59,7 @@ -> m b lookupObject' oid len lookupFn lookupPrefixFn createFn = do repo <- Git.getRepository - result <- liftBaseWith $ \run -> alloca $ \ptr -> do + result <- withRunInIO $ \run -> alloca $ \ptr -> do r <- withForeignPtr (repoObj repo) $ \repoPtr -> withForeignPtr oid $ \oidPtr -> if len == 40 @@ -85,7 +85,7 @@ let p = castPtr ptr' fptr <- FC.newForeignPtr p (c'git_object_free p) Right <$> run (createFn coidCopy (castForeignPtr fptr) ptr') - either (throwM . Git.BackendError) restoreM result + either (throwM . Git.BackendError) pure 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 @@ -12,7 +12,7 @@ import Control.Applicative import Control.Monad.Catch import Control.Monad.IO.Class -import Control.Monad.Trans.Control +import Control.Monad.IO.Unlift import Data.IORef import Foreign.ForeignPtr import qualified Git @@ -53,7 +53,6 @@ type MonadExcept m = (MonadThrow m, MonadCatch m, MonadMask m) -type MonadLg m = (Applicative m, MonadExcept m, - MonadIO m, MonadBaseControl IO m) +type MonadLg m = (Applicative m, MonadExcept m, MonadUnliftIO 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.1.1 +Version: 3.1.2 Synopsis: Libgit2 backend for gitlib License-file: LICENSE License: MIT @@ -21,11 +21,11 @@ Type: exitcode-stdio-1.0 Main-is: Smoke.hs Hs-source-dirs: test - Build-depends: + Build-depends: base >=3 , gitlib >= 3.1.1 , gitlib-test >= 3.0.0 - , gitlib-libgit2 >= 3.1.1 + , gitlib-libgit2 , HUnit >= 1.2.5 , hspec >= 1.4.4 , hspec-expectations >= 0.3 @@ -48,10 +48,7 @@ , exceptions >= 0.6 , fast-logger , filepath >= 1.3.0 - , lifted-async >= 0.1.0 - , lifted-base >= 0.2.0.2 , mmorph >= 1.0.0 - , monad-control >= 1.0 , monad-loops >= 0.3.3.0 , mtl >= 2.1.2 , resourcet >= 1.1.0 @@ -64,6 +61,8 @@ , time >= 1.4 , transformers >= 0.3.0.0 , transformers-base >= 0.4.1 + , unliftio-core >= 0.1.1 + , unliftio exposed-modules: Git.Libgit2 Git.Libgit2.Backend