gitlib-libgit2 2.1.0.0 → 2.2.0.0
raw patch · 6 files changed
+599/−346 lines, 6 filesdep +fast-loggerdep +lifted-asyncdep +mmorphdep −attemptdep −base16-bytestringdep −binarydep ~containersdep ~gitlibdep ~gitlib-libgit2
Dependencies added: fast-logger, lifted-async, mmorph, monad-logger, stm, template-haskell
Dependencies removed: attempt, base16-bytestring, binary, hashable, hex, parallel-io, pointless-fun, temporary, unix, unordered-containers
Dependency ranges changed: containers, gitlib, gitlib-libgit2, gitlib-test, hlibgit2
Files
- Git/Libgit2.hs +543/−282
- Git/Libgit2/Internal.hs +13/−9
- Git/Libgit2/Trace.hs +16/−16
- Git/Libgit2/Types.hs +11/−5
- gitlib-libgit2.cabal +13/−17
- test/Smoke.hs +3/−17
Git/Libgit2.hs view
@@ -3,6 +3,8 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE ViewPatterns #-}@@ -16,7 +18,8 @@ -- associated with the repository — such as the list of branches — is -- queried as needed. module Git.Libgit2- ( LgRepository(..)+ ( MonadLg+ , LgRepository(..) , BlobOid() , Commit() , CommitOid()@@ -33,40 +36,47 @@ , defaultLgOptions , lgBuildPackIndex , lgFactory+ , lgFactoryLogger , lgForEachObject , lgGet , lgExcTrap- , lgLoadPackFileInMemory , lgBuildPackFile , lgReadFromPack , lgWithPackFile , lgCopyPackFile+ , lgDiffContentsWithTree , lgWrap , oidToSha , shaToOid , openLgRepository , runLgRepository- , strToOid- , withLibGitDo+ , lgDebug+ , lgWarn ) where import Bindings.Libgit2 import Control.Applicative-import Control.Exception-import qualified Control.Exception.Lifted as Exc+import Control.Concurrent.Async.Lifted+import Control.Concurrent.STM+import Control.Exception.Lifted import Control.Failure-import Control.Monad+import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence) import Control.Monad.IO.Class+import Control.Monad.Logger import Control.Monad.Loops-import Control.Monad.Trans.Class+import Control.Monad.Morph hiding (embed)+import Control.Monad.Trans.Control import Control.Monad.Trans.Reader import Control.Monad.Trans.Resource-import Data.Bits ((.|.))+import Data.Bits ((.|.), (.&.))+import Data.ByteString (ByteString) import qualified Data.ByteString as B import qualified Data.ByteString.Unsafe as BU import Data.Conduit+import Data.Foldable import Data.IORef import Data.List as L+import qualified Data.Map as M import Data.Maybe import Data.Monoid import Data.Tagged@@ -74,6 +84,7 @@ import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.ICU.Convert as U+import Data.Traversable import Foreign.C.String import Foreign.C.Types import qualified Foreign.Concurrent as FC@@ -88,40 +99,56 @@ import qualified Git import Git.Libgit2.Internal import Git.Libgit2.Types+import Language.Haskell.TH.Syntax (Loc(..))++import Prelude hiding (mapM, mapM_, sequence, catch) import System.Directory import System.FilePath.Posix import System.IO (openBinaryTempFile, hClose) import qualified System.IO.Unsafe as SU-import System.Posix.ByteString.FilePath import Unsafe.Coerce -debug :: MonadIO m => String -> m ()---debug = liftIO . putStrLn-debug = const (return ())+defaultLoc :: Loc+defaultLoc = Loc "<unknown>" "<unknown>" "<unknown>" (0,0) (0,0)++lgDebug :: MonadLogger m => String -> m ()+lgDebug = monadLoggerLog defaultLoc "Git" LevelDebug . pack++lgWarn :: MonadLogger m => String -> m ()+lgWarn = monadLoggerLog defaultLoc "Git" LevelWarn . pack++withFilePath :: Git.RawFilePath -> (CString -> IO a) -> IO a+withFilePath = B.useAsCString++peekFilePath :: CString -> IO Git.RawFilePath+peekFilePath = B.packCString type Oid = OidPtr -data OidPtr = OidPtr { getOid :: ForeignPtr C'git_oid }+data OidPtr = OidPtr+ { getOid :: ForeignPtr C'git_oid+ , getOidLen :: Int -- the number of digits, not bytes+ } instance Git.IsOid OidPtr where renderOid = lgRenderOid mkOid :: ForeignPtr C'git_oid -> OidPtr-mkOid = OidPtr+mkOid fptr = OidPtr fptr 40 lgParseOidIO :: Text -> Int -> IO (Maybe Oid) lgParseOidIO str len = do- oid <- liftIO $ mallocForeignPtr+ oid <- liftIO mallocForeignPtr r <- liftIO $ withCString (unpack str) $ \cstr -> withForeignPtr oid $ \ptr -> if len == 40- then c'git_oid_fromstr ptr cstr- else c'git_oid_fromstrn ptr cstr (fromIntegral len)+ then c'git_oid_fromstr ptr cstr+ else c'git_oid_fromstrn ptr cstr (fromIntegral len) return $ if r < 0 then Nothing- else Just (mkOid oid)+ else Just (OidPtr oid len) -lgParseOid :: Git.MonadGit m => Text -> LgRepository m Oid+lgParseOid :: MonadLg m => Text -> LgRepository m Oid lgParseOid str | len > 40 = failure (Git.OidParseFailed str) | otherwise = do@@ -136,24 +163,19 @@ lgRenderOid = pack . show instance Show OidPtr where- show (getOid -> coid) = SU.unsafePerformIO $ withForeignPtr coid oidToStr+ show OidPtr {..} = SU.unsafePerformIO $+ withForeignPtr getOid (`oidToStr` getOidLen) instance Ord OidPtr where (getOid -> coid1) `compare` (getOid -> coid2) = SU.unsafePerformIO $ withForeignPtr coid1 $ \coid1Ptr ->- withForeignPtr coid2 $ \coid2Ptr -> do- r <- c'git_oid_cmp coid1Ptr coid2Ptr- return $ if r < 0- then LT- else if r > 0- then GT- else EQ+ withForeignPtr coid2 $ fmap (`compare` 0) . c'git_oid_cmp coid1Ptr instance Eq OidPtr where oid1 == oid2 = oid1 `compare` oid2 == EQ -instance Git.MonadGit m => Git.Repository (LgRepository m) where+instance MonadLg m => Git.Repository (LgRepository m) where type Oid (LgRepository m) = OidPtr data Tree (LgRepository m) = LgTree { lgTreePtr :: Maybe (ForeignPtr C'git_tree) }@@ -169,8 +191,8 @@ updateReference = lgUpdateRef deleteReference = lgDeleteRef listReferences = lgListRefs- lookupCommit = lgLookupCommit 40- lookupTree = lgLookupTree 40+ lookupCommit = lgLookupCommit+ lookupTree = lgLookupTree lookupBlob = lgLookupBlob lookupTag = error "Not implemented: LgRepository.lookupTag" lookupObject = lgLookupObject@@ -188,6 +210,8 @@ deleteRepository = lgGet >>= liftIO . removeDirectoryRecursive . repoPath + diffContentsWithTree = error "Not implemented: lgDiffContentsWithTree"+ -- buildPackFile = lgBuildPackFile -- buildPackIndex = lgBuildPackIndexWrapper -- writePackFile = lgWrap . lgWritePackFile@@ -196,74 +220,97 @@ lgWrap :: (MonadIO m, MonadBaseControl IO m) => LgRepository m a -> LgRepository m a-lgWrap f = f `Exc.catch` \e -> do+lgWrap f = f `catch` \e -> do etrap <- lgExcTrap mexc <- liftIO $ readIORef etrap liftIO $ writeIORef etrap Nothing maybe (throw (e :: SomeException)) throw mexc -lgHashContents :: Git.MonadGit m => Git.BlobContents (LgRepository m)+lgHashContents :: MonadLg m => Git.BlobContents (LgRepository m) -> LgRepository m (BlobOid m) lgHashContents b = do ptr <- liftIO mallocForeignPtr r <- Git.blobContentsToByteString b >>= \bs -> liftIO $ withForeignPtr ptr $ \oidPtr ->- BU.unsafeUseAsCStringLen bs $- uncurry (\cstr len ->- c'git_odb_hash oidPtr (castPtr cstr)- (fromIntegral len) c'GIT_OBJ_BLOB)- when (r < 0) $ failure Git.BlobCreateFailed- return (Tagged (mkOid ptr))+ BU.unsafeUseAsCStringLen bs $ uncurry $ \cstr len ->+ c'git_odb_hash oidPtr (castPtr cstr) (fromIntegral len)+ c'GIT_OBJ_BLOB+ when (r < 0) $ lgThrow Git.BlobCreateFailed+ return $ Tagged (mkOid ptr) -- | Create a new blob in the 'Repository', with 'ByteString' as its contents. -- -- 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 :: Git.MonadGit m+lgCreateBlob :: MonadLg m => Git.BlobContents (LgRepository m) -> LgRepository m (BlobOid m) lgCreateBlob b = do repo <- lgGet- ptr <- liftIO mallocForeignPtr- r <- Git.blobContentsToByteString b- >>= \bs -> liftIO $ evaluate- =<< createBlobFromByteString repo ptr bs- when (r < 0) $ failure Git.BlobCreateFailed- return (Tagged (mkOid ptr))+ 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.BlobSizedStream src _ -> readFromSource repo ptr src+ when (r < 0) $ lgThrow Git.BlobCreateFailed+ return $ Tagged (mkOid ptr) where- createBlobFromByteString repo coid bs =- BU.unsafeUseAsCStringLen bs $- uncurry (\cstr len ->- withForeignPtr coid $ \coid' ->- withForeignPtr (repoObj repo) $ \repoPtr ->- c'git_blob_create_frombuffer- coid' repoPtr (castPtr cstr) (fromIntegral len))+ readFromSource repo ptr src =+ src $$ drainTo 2 $ \queue ->+ liftIO $ withForeignPtr ptr $ \coid' ->+ withForeignPtr (repoObj repo) $ \repoPtr ->+ bracket+ (mk'git_blob_chunk_cb (chunk_cb queue))+ freeHaskellFunPtr+ (\cb -> c'git_blob_create_fromchunks coid' repoPtr+ nullPtr cb nullPtr) -lgObjToBlob :: Git.MonadGit m- => BlobOid m -> Ptr C'git_blob -> IO (Git.Blob (LgRepository m))-lgObjToBlob oid ptr = do- size <- c'git_blob_rawsize ptr- buf <- c'git_blob_rawcontent ptr- -- The lifetime of buf is tied to the lifetime of the blob object in- -- libgit2, which this Blob object controls, so we can use- -- unsafePackCStringLen to refer to its bytes.- bstr <- curry B.packCStringLen (castPtr buf) (fromIntegral size)- return $ Git.Blob oid (Git.BlobString bstr)+ chunk_cb :: TBQueue (Maybe ByteString)+ -> CString -- ^ content+ -> CSize -- ^ max_length+ -> Ptr () -- ^ payload+ -> IO CInt+ chunk_cb queue content (fromIntegral -> maxLength) _payload = do+ (bs, len) <- atomically $ do+ mval <- readTBQueue queue+ let len = case mval of Nothing -> 0; Just val -> B.length val+ case mval of+ Nothing -> return (B.empty, 0)+ Just val+ | len <= maxLength -> return (val, len)+ | otherwise -> do+ let (b, b') = B.splitAt maxLength val+ unGetTBQueue queue (Just b')+ return (b, maxLength)+ BU.unsafeUseAsCString bs $ flip (copyBytes content) len+ return $ fromIntegral len -lgLookupBlob :: Git.MonadGit m => BlobOid m+lgObjToBlob :: MonadLg m+ => BlobOid m -> ForeignPtr C'git_blob+ -> LgRepository m (Git.Blob (LgRepository m))+lgObjToBlob oid fptr = do+ bs <- liftIO $ withForeignPtr fptr $ \ptr -> do+ size <- c'git_blob_rawsize ptr+ buf <- c'git_blob_rawcontent ptr+ 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 oid =- lookupObject'- (getOid (untag oid))- 40- c'git_blob_lookup- c'git_blob_lookup_prefix- $ \_ obj _ -> withForeignPtr obj $ lgObjToBlob 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 :: Git.MonadGit m => Tree m -> Git.TreeFilePath+lgTreeEntry :: MonadLg m => Tree m -> Git.TreeFilePath -> LgRepository m (Maybe (TreeEntry m)) lgTreeEntry (LgTree Nothing) _ = return Nothing lgTreeEntry (LgTree (Just tree)) fp = liftIO $ alloca $ \entryPtr ->@@ -274,20 +321,20 @@ then return Nothing else Just <$> (entryToTreeEntry =<< peek entryPtr) -lgTreeOid :: Git.MonadGit m => Tree m -> TreeOid m+lgTreeOid :: MonadLg m => Tree m -> TreeOid m lgTreeOid (LgTree Nothing) = SU.unsafePerformIO . liftIO $ Tagged . fromJust <$> lgParseOidIO Git.emptyTreeId 40 lgTreeOid (LgTree (Just tree)) = SU.unsafePerformIO $ liftIO $ do- toid <- withForeignPtr tree $ c'git_tree_id+ toid <- withForeignPtr tree c'git_tree_id ftoid <- coidPtrToOid toid return $ Tagged (mkOid ftoid) -lgListTreeEntries :: Git.MonadGit m+lgListTreeEntries :: MonadLg m => Tree m -> LgRepository m [(Git.TreeFilePath, TreeEntry m)] lgListTreeEntries (LgTree Nothing) = return []-lgListTreeEntries (LgTree (Just tree)) = do+lgListTreeEntries (LgTree (Just tree)) = liftIO $ withForeignPtr tree $ \tr -> do ior <- newIORef [] r <- bracket@@ -306,7 +353,7 @@ seq name $ seq entry $ modifyIORef ior $ \xs -> (name,entry):xs return 0 -lgMakeBuilder :: Git.MonadGit m+lgMakeBuilder :: MonadLg m => ForeignPtr C'git_treebuilder -> TreeBuilder m lgMakeBuilder builder = Git.TreeBuilder { Git.mtbBaseTreeOid = Nothing@@ -326,7 +373,7 @@ -- -- Since empty trees cannot exist in Git, attempting to write out an empty -- tree is a no-op.-lgNewTreeBuilder :: Git.MonadGit m+lgNewTreeBuilder :: MonadLg m => Maybe (Tree m) -> LgRepository m (TreeBuilder m) lgNewTreeBuilder mtree = do mfptr <- liftIO $ alloca $ \pptr -> do@@ -351,10 +398,10 @@ return (lgMakeBuilder fptr) { Git.mtbBaseTreeOid = Git.treeOid <$> mtree } -lgPutEntry :: Git.MonadGit m+lgPutEntry :: MonadLg m => ForeignPtr C'git_treebuilder -> Git.TreeFilePath -> TreeEntry m -> LgRepository m ()-lgPutEntry builder key (treeEntryToOid -> (oid,mode)) = do+lgPutEntry builder key (treeEntryToOid -> (oid, mode)) = do r2 <- liftIO $ withForeignPtr (getOid oid) $ \coid -> withForeignPtr builder $ \ptr -> withFilePath key $ \name ->@@ -374,14 +421,14 @@ treeEntryToOid (Git.TreeEntry toid) = (untag toid, 0o040000) -lgDropEntry :: Git.MonadGit m+lgDropEntry :: MonadLg m => ForeignPtr C'git_treebuilder -> Git.TreeFilePath -> LgRepository m ()-lgDropEntry builder key = do+lgDropEntry builder key = void $ liftIO $ withForeignPtr builder $ \ptr -> withFilePath key $ c'git_treebuilder_remove ptr -lgLookupBuilderEntry :: Git.MonadGit m+lgLookupBuilderEntry :: MonadLg m => ForeignPtr C'git_treebuilder -> Git.TreeFilePath -> LgRepository m (Maybe (TreeEntry m))@@ -392,17 +439,17 @@ then return Nothing else Just <$> liftIO (entryToTreeEntry entry) -lgBuilderEntryCount :: Git.MonadGit m+lgBuilderEntryCount :: MonadLg m => ForeignPtr C'git_treebuilder -> LgRepository m Int-lgBuilderEntryCount tb = do+lgBuilderEntryCount tb = fromIntegral <$> liftIO (withForeignPtr tb c'git_treebuilder_entrycount) -lgTreeEntryCount :: Git.MonadGit m => Tree m -> LgRepository m Int+lgTreeEntryCount :: MonadLg m => Tree m -> LgRepository m Int lgTreeEntryCount (LgTree Nothing) = return 0-lgTreeEntryCount (LgTree (Just tree)) = do+lgTreeEntryCount (LgTree (Just tree)) = fromIntegral <$> liftIO (withForeignPtr tree c'git_tree_entrycount) -lgWriteBuilder :: Git.MonadGit m+lgWriteBuilder :: MonadLg m => ForeignPtr C'git_treebuilder -> LgRepository m (TreeOid m) lgWriteBuilder tb = do@@ -414,17 +461,10 @@ withForeignPtr (repoObj repo) $ \repoPtr -> do r3 <- c'git_treebuilder_write coid' repoPtr builder return (r3,coid)- when (r3 < 0) $ do- errStr <- liftIO $ do- errPtr <- c'giterr_last- err <- peek errPtr- peekCString (c'git_error'message err)- failure (Git.TreeBuilderWriteFailed $ pack $- "c'git_treebuilder_write failed with " ++ show r3- ++ ": " ++ errStr)+ when (r3 < 0) $ lgThrow Git.TreeBuilderWriteFailed return $ Tagged (mkOid coid) -lgCloneBuilder :: Git.MonadGit m+lgCloneBuilder :: MonadLg m => ForeignPtr C'git_treebuilder -> LgRepository m (ForeignPtr C'git_treebuilder) lgCloneBuilder fptr =@@ -453,18 +493,14 @@ failure (Git.BackendError "Could not insert entry in treebuilder") return 0 -lgLookupTree :: Git.MonadGit m => Int -> Tagged (Tree m) Oid- -> LgRepository m (Tree m)-lgLookupTree len (getOid . untag -> oid) = do- str <- liftIO $ withForeignPtr oid $ \oidPtr -> oidToStr oidPtr- if str == unpack Git.emptyTreeId- then return (LgTree Nothing)- else do- -- jww (2013-01-28): Verify the oid here- fptr <- lookupObject' oid len- c'git_tree_lookup c'git_tree_lookup_prefix $- \_coid obj _ -> return obj- return $ LgTree (Just fptr)+lgLookupTree :: MonadLg m => TreeOid m -> LgRepository m (Tree m)+lgLookupTree (untag -> oid)+ | show oid == unpack Git.emptyTreeId = return $ LgTree Nothing+ | otherwise = do+ fptr <- lookupObject' (getOid oid) (getOidLen oid)+ c'git_tree_lookup c'git_tree_lookup_prefix $+ \_ obj _ -> return obj+ return $ LgTree (Just fptr) entryToTreeEntry :: Ptr C'git_tree_entry -> IO (TreeEntry m) entryToTreeEntry entry = do@@ -486,7 +522,7 @@ return $ Git.CommitEntry (Tagged (mkOid oid)) | otherwise -> error "Unexpected" -lgObjToCommit :: Git.MonadGit m+lgObjToCommit :: MonadLg m => CommitOid m -> Ptr C'git_commit -> IO (Commit m) lgObjToCommit oid c = do enc <- c'git_commit_message_encoding c@@ -521,68 +557,44 @@ , Git.commitEncoding = "utf-8" } -lgLookupCommit :: Git.MonadGit m- => Int -> CommitOid m -> LgRepository m (Commit m)-lgLookupCommit len oid =- lookupObject'- (getOid (untag oid))- len- c'git_commit_lookup- c'git_commit_lookup_prefix- $ \_ obj _ -> withForeignPtr obj $ lgObjToCommit oid+lgLookupCommit :: MonadLg m+ => CommitOid m -> LgRepository m (Commit m)+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)) data ObjectPtr = BlobPtr (ForeignPtr C'git_blob) | TreePtr (ForeignPtr C'git_commit) | CommitPtr (ForeignPtr C'git_commit) | TagPtr (ForeignPtr C'git_tag) -lgLookupObject :: Git.MonadGit m+lgLookupObject :: MonadLg m => Oid -> LgRepository m (Git.Object (LgRepository m))-lgLookupObject (Git.renderOid -> str)- | len > 40 = failure (Git.ObjectLookupFailed str len)- | otherwise = do- mfptr <- liftIO $ do- fptr <- mallocForeignPtr- withForeignPtr fptr $ \ptr ->- withCString (unpack str) $ \cstr -> do- r <- if len == 40- then c'git_oid_fromstr ptr cstr- else c'git_oid_fromstrn ptr cstr (fromIntegral len)- return $ if r < 0 then Nothing else Just fptr-- case mfptr of- Nothing -> failure (Git.ObjectLookupFailed str len)- Just fptr -> go fptr- where- len = T.length str- go fptr = do- (oid,typ,fptr) <-- lookupObject' fptr len- (\x y z -> c'git_object_lookup x y z c'GIT_OBJ_ANY)- (\x y z l ->- c'git_object_lookup_prefix x y z l c'GIT_OBJ_ANY)- $ \_ fptr y -> do- coid <- c'git_object_id y- oid <- mkOid <$> coidPtrToOid coid- typ <- c'git_object_type y- return (oid,typ,fptr)- case () of- () | typ == c'GIT_OBJ_BLOB ->- Git.BlobObj <$>- liftIO (withForeignPtr fptr $ \y ->- lgObjToBlob (Tagged oid) (castPtr y))- | typ == c'GIT_OBJ_TREE ->- -- A ForeignPtr C'git_object is bit-wise equivalent to a- -- ForeignPtr C'git_tree.- return $ Git.TreeObj (LgTree (Just (unsafeCoerce fptr)))- | typ == c'GIT_OBJ_COMMIT ->- Git.CommitObj <$>- liftIO (withForeignPtr fptr $ \y ->- lgObjToCommit (Tagged oid) (castPtr y))- | typ == c'GIT_OBJ_TAG -> error "jww (2013-07-08): NYI"- | otherwise -> error $ "Unknown object type: " ++ show typ+lgLookupObject oid = do+ (oid', typ, fptr) <-+ lookupObject' (getOid oid) (getOidLen oid)+ (\x y z -> c'git_object_lookup x y z c'GIT_OBJ_ANY)+ (\x y z l -> c'git_object_lookup_prefix x y z l c'GIT_OBJ_ANY)+ $ \coid fptr y -> do+ typ <- liftIO $ c'git_object_type y+ return (mkOid coid, typ, fptr)+ case () of+ () | typ == c'GIT_OBJ_BLOB ->+ Git.BlobObj <$> lgObjToBlob (Tagged oid') (castForeignPtr fptr)+ | typ == c'GIT_OBJ_TREE ->+ -- A ForeignPtr C'git_object is bit-wise equivalent to a+ -- ForeignPtr C'git_tree.+ return $ Git.TreeObj (LgTree (Just (unsafeCoerce fptr)))+ | typ == c'GIT_OBJ_COMMIT ->+ Git.CommitObj <$>+ liftIO (withForeignPtr fptr $ \y ->+ lgObjToCommit (Tagged oid') (castPtr y))+ | typ == c'GIT_OBJ_TAG -> error "jww (2013-07-08): NYI"+ | otherwise -> error $ "Unknown object type: " ++ show typ -lgExistsObject :: Git.MonadGit m => Oid -> LgRepository m Bool+lgExistsObject :: MonadLg m => Oid -> LgRepository m Bool lgExistsObject oid = do repo <- lgGet result <- liftIO $ withForeignPtr (repoObj repo) $ \repoPtr ->@@ -611,11 +623,11 @@ (flip (c'git_odb_foreach odbPtr) payload) lgSourceObjects- :: Git.MonadGit m+ :: MonadLg m => Maybe (CommitOid m) -> CommitOid m -> Bool- -> Source (LgRepository m) (ObjectOid m)+ -> Producer (LgRepository m) (ObjectOid m) lgSourceObjects mhave need alsoTrees = do- repo <- lift $ lgGet+ repo <- lift lgGet walker <- liftIO $ alloca $ \pptr -> do r <- withForeignPtr (repoObj repo) $ \repoPtr -> c'git_revwalk_new pptr repoPtr@@ -624,17 +636,26 @@ ptr <- peek pptr newForeignPtr p'git_revwalk_free ptr - liftIO $ withForeignPtr (getOid (untag need)) $ \coid -> do+ 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) $- failure (Git.BackendError "Could not push oid on revwalker")+ failure (Git.BackendError $ "Could not push oid "+ <> pack (show oid) <> " onto revwalker") case mhave of Nothing -> return () Just have -> liftIO $ withForeignPtr (getOid (untag have)) $ \coid -> do r2 <- withForeignPtr walker $ flip c'git_revwalk_hide coid when (r2 < 0) $- failure (Git.BackendError "Could not hide commit on revwalker")+ failure (Git.BackendError $ "Could not hide commit "+ <> pack (show (untag have)) <> " from revwalker") liftIO $ withForeignPtr walker $ flip c'git_revwalk_sorting (fromIntegral ((1 :: Int) .|. (4 :: Int)))@@ -649,12 +670,12 @@ let coid = Tagged (mkOid oidPtr) yield $ Git.CommitObjOid coid when alsoTrees $ do- c <- lift $ lgLookupCommit 40 coid+ c <- lift $ lgLookupCommit coid yield $ Git.TreeObjOid (Git.commitTree c) -- | Write out a commit to its repository. If it has already been written, -- nothing will happen.-lgCreateCommit :: Git.MonadGit m+lgCreateCommit :: MonadLg m => [CommitOid m] -> TreeOid m -> Git.Signature@@ -710,7 +731,7 @@ mapM_ touchForeignPtr fos return r -lgLookupRef :: Git.MonadGit m+lgLookupRef :: MonadLg m => Git.RefName -> LgRepository m (Maybe (RefTarget m)) lgLookupRef name = do repo <- lgGet@@ -725,7 +746,7 @@ typ <- c'git_reference_type ref targ <- if typ == c'GIT_REF_OID then do oidPtr <- c'git_reference_target ref- Git.RefObj . Tagged . mkOid+ Git.RefObj . mkOid <$> coidPtrToOid oidPtr else do targName <- c'git_reference_symbolic_target ref Git.RefSymbolic . T.decodeUtf8@@ -733,17 +754,17 @@ c'git_reference_free ref return (Just targ) -lgUpdateRef :: Git.MonadGit m+lgUpdateRef :: MonadLg m => Git.RefName -> Git.RefTarget (LgRepository m) -> LgRepository m () lgUpdateRef name refTarg = do repo <- lgGet r <- liftIO $ alloca $ \ptr -> withForeignPtr (repoObj repo) $ \repoPtr ->- withCString (unpack name) $ \namePtr -> do+ withCString (unpack name) $ \namePtr -> case refTarg of Git.RefObj oid ->- withForeignPtr (getOid (untag oid)) $ \coidPtr ->+ withForeignPtr (getOid oid) $ \coidPtr -> c'git_reference_create ptr repoPtr namePtr coidPtr (fromBool True) @@ -751,18 +772,12 @@ withCString (unpack symName) $ \symPtr -> c'git_reference_symbolic_create ptr repoPtr namePtr symPtr (fromBool True)- when (r < 0) $ do- errStr <- liftIO $ do- errPtr <- c'giterr_last- err <- peek errPtr- peekCString (c'git_error'message err)- failure (Git.ReferenceCreateFailed $ name <> " => "- <> pack (show refTarg) <> ": " <> pack errStr)+ when (r < 0) $ lgThrow Git.ReferenceCreateFailed -- int git_reference_name_to_oid(git_oid *out, git_repository *repo, -- const char *name) -lgResolveRef :: Git.MonadGit m+lgResolveRef :: MonadLg m => Git.RefName -> LgRepository m (Maybe (CommitOid m)) lgResolveRef name = do repo <- lgGet@@ -780,7 +795,7 @@ --renameRef = c'git_reference_rename -lgDeleteRef :: Git.MonadGit m => Git.RefName -> LgRepository m ()+lgDeleteRef :: MonadLg m => Git.RefName -> LgRepository m () lgDeleteRef name = do repo <- lgGet r <- liftIO $ alloca $ \ptr ->@@ -848,7 +863,7 @@ + (if listFlagPacked flags then 4 else 0) + (if listFlagHasPeel flags then 8 else 0) -listRefNames :: Git.MonadGit m => ListFlags -> LgRepository m [Git.RefName]+listRefNames :: MonadLg m => ListFlags -> LgRepository m [Git.RefName] listRefNames flags = do repo <- lgGet refs <- liftIO $ alloca $ \c'refs ->@@ -861,7 +876,7 @@ return (Just refs) maybe (failure Git.ReferenceListingFailed) return refs -lgListRefs :: Git.MonadGit m => LgRepository m [Git.RefName]+lgListRefs :: MonadLg m => LgRepository m [Git.RefName] lgListRefs = listRefNames allRefsFlag -- foreachRefCallback :: CString -> Ptr () -> IO CInt@@ -913,10 +928,231 @@ --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+ errPtr <- c'giterr_last+ if errPtr == nullPtr+ then return ""+ else do+ err <- peek errPtr+ peekCString (c'git_error'message err)+ failure (f (pack errStr))++lgDiffContentsWithTree+ :: MonadLg m+ => Source m (Either Git.TreeFilePath ByteString)+ -> Tree m+ -> Producer (LgRepository 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+ where+ generateDiff repo chan = do+ entries <- M.fromList <$> lgListTreeEntries tree+ paths <- liftIO $ newIORef []+ (src, ()) <- lift $ contents $$+ return ()++ handleEntries entries paths src+ contentsPaths <- liftIO $ readIORef paths++ forM_ (sort (M.keys entries) \\ sort contentsPaths) $ \path ->+ -- File was removed+ case entries M.! path of+ Git.BlobEntry oid _ -> do+ let boid = getOid (untag oid)+ diffBlob path Nothing (Just boid)++ -- jww (2013-11-24): NYI+ Git.CommitEntry _coid -> return ()+ Git.TreeEntry _toid -> return ()+ where+ handleEntries entries paths src = do+ (src', mres) <- lift $ src $$++ do+ mpath <- await+ case mpath of+ Nothing -> return Nothing+ Just path -> Just <$> handlePath path+ case mres of+ Nothing -> return ()+ Just (path, content) -> do+ liftIO $ modifyIORef paths (path:)+ case M.lookup path entries of+ Nothing ->+ -- File is newly added+ diffBlob path (Just content) Nothing++ Just entry -> case entry of+ -- File has been changed+ Git.BlobEntry oid _ -> do+ let boid = getOid (untag oid)+ diffBlob path (Just content) (Just boid)++ -- jww (2013-11-24): NYI+ Git.CommitEntry _coid -> return ()+ Git.TreeEntry _toid -> return ()+ handleEntries entries paths src'++ handlePath (Right _) =+ liftIO $ throwIO $ 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 $+ "Content not provided for " <> T.pack (show path)+ Just x -> handleContent path x++ handleContent _path (Left _) =+ liftIO $ throwIO $ Git.DiffTreeToIndexFailed+ "Received a Left value when a Right ByteString was expected"+ handleContent path (Right content) = return (path, content)++ diffBlob path mcontent mboid = do+ r <- liftIO $ runResourceT $ case mboid of+ Nothing -> go nullPtr+ Just boid -> withBlob boid+ when (r < 0) $ lgThrow Git.DiffBlobFailed+ where+ withBlob boid = do+ (_, eblobp) <- flip allocate freeBlob $+ alloca $ \blobpp ->+ withForeignPtr boid $ \boidPtr ->+ withForeignPtr (repoObj repo) $ \repoPtr -> do+ r <- c'git_blob_lookup blobpp repoPtr boidPtr+ if r < 0+ then return $ Left r+ else Right <$> peek blobpp+ case eblobp of+ Left r -> return r+ Right blobp -> go 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++ 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++ 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+ -> CFloat+ -> Ptr ()+ -> IO CInt+ file_cb deltap _progress _payload = do+ delta <- peek deltap+ atomically $+ 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"+ return 0++ hunk_cb :: Ptr C'git_diff_delta+ -> Ptr C'git_diff_range+ -> CString+ -> CSize+ -> Ptr ()+ -> IO CInt+ hunk_cb deltap _rangep header headerLen _payload = do+ delta <- peek deltap+ unless (isBinary delta) $ do+ bs <- curry B.packCStringLen header (fromIntegral headerLen)+ atomically $ writeTBQueue chan bs+ return 0++ print_cb :: Ptr C'git_diff_delta+ -> Ptr C'git_diff_range+ -> CChar+ -> CString+ -> CSize+ -> Ptr ()+ -> IO CInt+ print_cb deltap _range lineOrigin content contentLen _payload = do+ delta <- peek deltap+ unless (isBinary delta) $ do+ bs <- curry B.packCStringLen content+ (fromIntegral contentLen)+ atomically $ writeTBQueue chan $+ B.cons (fromIntegral lineOrigin) bs+ return 0+ checkResult :: (Eq a, Num a, Failure Git.GitException m) => a -> Text -> m () checkResult r why = when (r /= 0) $ failure (Git.BackendError why) -lgBuildPackFile :: Git.MonadGit m+lgBuildPackFile :: MonadLg m => FilePath -> [Either (CommitOid m) (TreeOid m)] -> LgRepository m FilePath lgBuildPackFile dir oids = do@@ -967,21 +1203,24 @@ r <- f oidPtr checkResult r msg -lgBuildPackIndexWrapper :: Git.MonadGit m+lift_ :: (Monad m, Functor (t m), MonadTrans t) => m a -> t m ()+lift_ = void . lift++lgBuildPackIndexWrapper :: MonadLg m => FilePath- -> B.ByteString+ -> ByteString -> LgRepository m (Text, FilePath, FilePath)-lgBuildPackIndexWrapper = (liftIO .) . lgBuildPackIndex+lgBuildPackIndexWrapper = (lift .) . lgBuildPackIndex -lgBuildPackIndex :: FilePath -> B.ByteString -> IO (Text, FilePath, FilePath)+lgBuildPackIndex :: (MonadLg m, MonadLogger m)+ => FilePath -> ByteString -> m (Text, FilePath, FilePath) lgBuildPackIndex dir bytes = do sha <- go dir bytes- (,,) <$> pure sha- <*> pure (dir </> ("pack-" <> unpack sha <> ".pack"))- <*> pure (dir </> ("pack-" <> unpack sha <> ".idx"))+ return (sha, dir </> ("pack-" <> unpack sha <> ".pack"),+ dir </> ("pack-" <> unpack sha <> ".idx")) where- go dir bytes = alloca $ \idxPtrPtr -> runResourceT $ do- debug "Allocate a new indexer stream"+ go dir bytes = control $ \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 r <- c'git_indexer_stream_new idxPtrPtr dirStr@@ -989,8 +1228,9 @@ checkResult r "c'git_indexer_stream_new failed" peek idxPtrPtr - debug $ "Add the incoming packfile data to the stream ("- ++ show (B.length bytes) ++ " bytes)"+ lift_ . run $+ lgDebug $ "Add the incoming packfile data to the stream ("+ ++ show (B.length bytes) ++ " bytes)" (_,statsPtr) <- allocate calloc free liftIO $ BU.unsafeUseAsCStringLen bytes $ uncurry $ \dataPtr dataLen -> do@@ -998,23 +1238,16 @@ (fromIntegral dataLen) statsPtr checkResult r "c'git_indexer_stream_add failed" - debug "Finalizing the stream"+ lift_ . run $ lgDebug "Finalizing the stream" r <- liftIO $ c'git_indexer_stream_finalize idxPtr statsPtr checkResult r "c'git_indexer_stream_finalize failed" - debug "Discovering the hash used to identify the pack file"+ lift_ . run $+ lgDebug "Discovering the hash used to identify the pack file" sha <- liftIO $ oidToSha =<< c'git_indexer_stream_hash idxPtr- debug $ "The hash used is: " ++ show (Git.shaToText sha)- return (Git.shaToText sha)+ lift_ . run $ lgDebug $ "The hash used is: " ++ show (Git.shaToText sha) -strToOid :: String -> IO (ForeignPtr C'git_oid)-strToOid oidStr = do- ptr <- mallocForeignPtr- withCString oidStr $ \cstr ->- withForeignPtr ptr $ \ptr' -> do- r <- c'git_oid_fromstr ptr' cstr- when (r < 0) $ throwIO Git.OidCopyFailed- return ptr+ lift . run $ return (Git.shaToText sha) oidToSha :: Ptr C'git_oid -> IO Git.SHA oidToSha oidPtr =@@ -1028,7 +1261,7 @@ c'git_oid_fromraw ptr' (castPtr bytes) return ptr -lgCopyPackFile :: Git.MonadGit m => FilePath -> LgRepository m ()+lgCopyPackFile :: MonadLg m => FilePath -> LgRepository 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@@ -1046,20 +1279,21 @@ -- 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- liftIO $ withForeignPtr (repoObj repo) $ \repoPtr ->+ control $ \run -> withForeignPtr (repoObj repo) $ \repoPtr -> alloca $ \odbPtrPtr -> alloca $ \statsPtr ->- alloca $ \writepackPtrPtr ->- runResourceT $ go repoPtr odbPtrPtr writepackPtrPtr statsPtr+ alloca $ \writepackPtrPtr -> do+ runResourceT $ go run repoPtr odbPtrPtr writepackPtrPtr statsPtr+ run $ return () where- go repoPtr odbPtrPtr writepackPtrPtr statsPtr = do- debug "Obtaining odb for repository"+ go run repoPtr odbPtrPtr writepackPtrPtr statsPtr = do+ lift_ . run $ lgDebug "Obtaining odb for repository" (_,odbPtr) <- flip allocate c'git_odb_free $ do r <- c'git_repository_odb odbPtrPtr repoPtr checkResult r "c'git_repository_odb failed" peek odbPtrPtr - debug "Opening pack writer into odb"+ lift_ . run $ lgDebug "Opening pack writer into odb" (_,writepackPtr) <- allocate (do r <- c'git_odb_write_pack writepackPtrPtr odbPtr nullFunPtr nullPtr@@ -1072,8 +1306,10 @@ writepack <- liftIO $ peek writepackPtr bs <- liftIO $ B.readFile packFile- debug $ "Writing pack file " ++ show packFile ++ " into odb"- debug $ "Writing " ++ show (B.length bs) ++ " pack bytes into odb"+ lift_ . run $+ lgDebug $ "Writing pack file " ++ show packFile ++ " into odb"+ lift_ . run $+ lgDebug $ "Writing " ++ show (B.length bs) ++ " pack bytes into odb" liftIO $ BU.unsafeUseAsCStringLen bs $ uncurry $ \dataPtr dataLen -> do r <- mK'git_odb_writepack_add_callback@@ -1082,24 +1318,26 @@ (fromIntegral dataLen) statsPtr checkResult r "c'git_odb_writepack'add failed" - debug "Committing pack into odb"+ lift_ . run $ lgDebug "Committing pack into odb" r <- liftIO $ mK'git_odb_writepack_commit_callback (c'git_odb_writepack'commit writepack) writepackPtr statsPtr checkResult r "c'git_odb_writepack'commit failed" -lgLoadPackFileInMemory :: FilePath+lgLoadPackFileInMemory :: (MonadLg m, MonadUnsafeIO m, MonadThrow m,+ MonadLogger m)+ => FilePath -> Ptr (Ptr C'git_odb_backend) -> Ptr (Ptr C'git_odb)- -> ResourceT IO (Ptr C'git_odb)+ -> ResourceT m (Ptr C'git_odb) lgLoadPackFileInMemory idxPath backendPtrPtr odbPtrPtr = do- debug "Creating temporary, in-memory object database"+ lgDebug "Creating temporary, in-memory object database" (freeKey,odbPtr) <- flip allocate c'git_odb_free $ do r <- c'git_odb_new odbPtrPtr checkResult r "c'git_odb_new failed" peek odbPtrPtr - debug $ "Load pack index " ++ show idxPath ++ " into temporary odb"+ lgDebug $ "Load pack index " ++ show idxPath ++ " into temporary odb" (_,backendPtr) <- allocate (do r <- withCString idxPath $ \idxPathStr -> c'git_odb_backend_one_pack backendPtrPtr idxPathStr@@ -1116,61 +1354,68 @@ -- Associate the new backend containing our single index file with the -- in-memory object database- debug "Associate odb with backend"+ 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 :: FilePath -> (Ptr C'git_odb -> ResourceT IO a) -> IO a-lgWithPackFile idxPath f = alloca $ \odbPtrPtr ->- alloca $ \backendPtrPtr -> runResourceT $ do- debug "Load pack file into an in-memory object database"+lgWithPackFile :: (MonadLg 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- debug "Calling function using in-memory odb"+ lift $ lgDebug "Calling function using in-memory odb" f odbPtr -lgReadFromPack :: FilePath -> Git.SHA -> Bool- -> IO (Maybe (C'git_otype, CSize, B.ByteString))+lgReadFromPack :: (MonadLg m, MonadUnsafeIO m, MonadThrow m, MonadLogger m)+ => FilePath -> Git.SHA -> Bool+ -> m (Maybe (C'git_otype, CSize, ByteString)) lgReadFromPack idxPath sha metadataOnly =- alloca $ \objectPtrPtr ->- lgWithPackFile idxPath $ \odbPtr -> do- foid <- liftIO $ shaToOid sha- if metadataOnly- then liftIO $ alloca $ \sizePtr -> alloca $ \typPtr -> do- r <- withForeignPtr foid $- c'git_odb_read_header sizePtr typPtr odbPtr- if r == 0- then Just <$> ((,,) <$> peek typPtr- <*> peek sizePtr- <*> pure B.empty)- else do- unless (r == c'GIT_ENOTFOUND) $- checkResult r "c'git_odb_read_header failed"- return Nothing+ control $ \run -> alloca $ \objectPtrPtr ->+ run $ lgWithPackFile idxPath $ \odbPtr -> do+ foid <- liftIO $ shaToOid sha+ if metadataOnly+ then readMetadata odbPtr foid+ else readObject odbPtr foid objectPtrPtr+ where+ readMetadata odbPtr foid =+ liftIO $ alloca $ \sizePtr -> alloca $ \typPtr -> do+ r <- withForeignPtr foid $+ c'git_odb_read_header sizePtr typPtr odbPtr+ if r == 0+ then Just <$> ((,,) <$> peek typPtr+ <*> peek sizePtr+ <*> pure B.empty)+ else do+ unless (r == c'GIT_ENOTFOUND) $+ checkResult r "c'git_odb_read_header failed"+ return Nothing++ readObject odbPtr foid objectPtrPtr = do+ r <- liftIO $ withForeignPtr foid $+ c'git_odb_read objectPtrPtr odbPtr+ mr <-+ if r == 0+ then do+ objectPtr <- liftIO $ peek objectPtrPtr+ void $ register $ c'git_odb_object_free objectPtr+ return $ Just objectPtr else do- r <- liftIO $ withForeignPtr foid $- c'git_odb_read objectPtrPtr odbPtr- mr <- if r == 0- then do- objectPtr <- liftIO $ peek objectPtrPtr- void $ register $ c'git_odb_object_free objectPtr- return $ Just objectPtr- else do- unless (r == c'GIT_ENOTFOUND) $- checkResult r "c'git_odb_read failed"- return Nothing- case mr of- Just objectPtr -> liftIO $ do- typ <- c'git_odb_object_type objectPtr- len <- c'git_odb_object_size objectPtr- ptr <- c'git_odb_object_data objectPtr- bytes <- curry B.packCStringLen (castPtr ptr)- (fromIntegral len)- return $ Just (typ,len,bytes)- Nothing -> return Nothing+ unless (r == c'GIT_ENOTFOUND) $+ checkResult r "c'git_odb_read failed"+ return Nothing+ forM mr $ \objectPtr -> liftIO $ do+ typ <- c'git_odb_object_type objectPtr+ len <- c'git_odb_object_size objectPtr+ ptr <- c'git_odb_object_data objectPtr+ bytes <- curry B.packCStringLen (castPtr ptr)+ (fromIntegral len)+ return (typ,len,bytes) -lgRemoteFetch :: Git.MonadGit m => Text -> Text -> LgRepository m ()+lgRemoteFetch :: MonadLg m => Text -> Text -> LgRepository m () lgRemoteFetch uri fetchSpec = do xferRepo <- lgGet liftIO $ withForeignPtr (repoObj xferRepo) $ \repoPtr ->@@ -1192,20 +1437,35 @@ r2 <- liftIO $ c'git_remote_download remotePtr nullFunPtr nullPtr checkResult r2 "c'git_remote_download failed" -lgFactory :: Git.MonadGit m- => Git.RepositoryFactory LgRepository m Repository+lgFactory :: MonadIO m+ => Git.RepositoryFactory+ (LgRepository (NoLoggingT m)) m Repository lgFactory = Git.RepositoryFactory- { Git.openRepository = openLgRepository- , Git.runRepository = runLgRepository- , Git.closeRepository = closeLgRepository- , Git.getRepository = lgGet- , Git.defaultOptions = defaultLgOptions- , Git.startupBackend = startupLgBackend- , Git.shutdownBackend = shutdownLgBackend+ { 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 } -openLgRepository :: Git.MonadGit m => Git.RepositoryOptions -> m Repository+lgFactoryLogger :: (MonadIO m, MonadLogger m)+ => Git.RepositoryFactory (LgRepository m) m Repository+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 openLgRepository opts = do+ startupLgBackend let path = Git.repoPath opts p <- liftIO $ doesDirectoryExist path liftIO $ openRepositoryWith path $@@ -1228,11 +1488,12 @@ , repoExcTrap = excTrap } -runLgRepository :: Repository -> LgRepository m a -> m a-runLgRepository repo action =+runLgRepository :: MonadIO m => Repository -> LgRepository m a -> m a+runLgRepository repo action = do+ startupLgBackend runReaderT (lgRepositoryReaderT action) repo -closeLgRepository :: Git.MonadGit m => Repository -> m ()+closeLgRepository :: Monad m => Repository -> m () closeLgRepository = const (return ()) defaultLgOptions :: Git.RepositoryOptions
Git/Libgit2/Internal.hs view
@@ -11,6 +11,7 @@ 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@@ -63,11 +64,11 @@ => 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 -> IO b)+ -> (ForeignPtr C'git_oid -> ForeignPtr a -> Ptr a -> LgRepository m b) -> LgRepository m b lookupObject' oid len lookupFn lookupPrefixFn createFn = do repo <- lgGet- result <- liftIO $ alloca $ \ptr -> do+ result <- control $ \run -> alloca $ \ptr -> do r <- withForeignPtr (repoObj repo) $ \repoPtr -> withForeignPtr oid $ \oidPtr -> if len == 40@@ -75,12 +76,15 @@ else lookupPrefixFn ptr repoPtr oidPtr (fromIntegral len) if r < 0 then do- err <- c'giterr_last- errmsg <- peekCString . c'git_error'message =<< peek err- oidStr <- withForeignPtr oid oidToStr- return $ Left $- T.concat [ "Could not lookup ", T.pack oidStr- , ": ", T.pack errmsg ]+ oidStr <- withForeignPtr oid (flip oidToStr len)+ let args = ["Could not lookup ", T.pack oidStr]+ err <- c'giterr_last+ if err == nullPtr+ then run $ return $ Left $ T.concat args+ else do+ errmsg <- peekCString . c'git_error'message =<< peek err+ run $ return $ Left $+ T.concat $ args ++ [": ", T.pack errmsg] else do ptr' <- peek ptr coid <- c'git_object_id (castPtr ptr')@@ -88,7 +92,7 @@ withForeignPtr coidCopy $ flip c'git_oid_cpy coid fptr <- newForeignPtr p'git_object_free (castPtr ptr')- Right <$> createFn coidCopy (castForeignPtr fptr) ptr'+ run $ Right <$> createFn coidCopy (castForeignPtr fptr) ptr' either (failure . Git.BackendError) return result -- lgLookupObject :: Text -> LgRepository Dynamic
Git/Libgit2/Trace.hs view
@@ -5,15 +5,15 @@ module Git.Libgit2.Trace where -import Bindings.Libgit2-import Control.Applicative-import Control.Monad-import Foreign.C.String-import Foreign.Marshal.Utils-import Foreign.Ptr-import Foreign.Storable-import Git.Libgit2.Backend-import Prelude hiding ((.), mapM_)+import Bindings.Libgit2+import Control.Applicative+import Control.Monad+import Foreign.C.String+import Foreign.Marshal.Utils+import Foreign.Ptr+import Foreign.Storable+import Git.Libgit2.Backend+import Prelude hiding (mapM_) data TraceBackend = TraceBackend { traceParent :: C'git_odb_backend , traceNext :: Ptr C'git_odb_backend }@@ -31,12 +31,12 @@ pokeByteOff p (sizeOf (undefined :: C'git_odb_backend)) v1 return () -oidToStr :: Ptr C'git_oid -> IO String-oidToStr = c'git_oid_allocfmt >=> peekCString+oidToStr :: Ptr C'git_oid -> Int -> IO String+oidToStr oid len = c'git_oid_allocfmt oid >>= fmap (take len) . peekCString traceBackendReadCallback :: F'git_odb_backend_read_callback traceBackendReadCallback data_p len_p type_p be oid = do- oidStr <- oidToStr oid+ oidStr <- oidToStr oid 40 putStrLn $ "Read " ++ oidStr tb <- peek (castPtr be :: Ptr TraceBackend) tn <- peek (traceNext tb)@@ -50,7 +50,7 @@ traceBackendReadPrefixCallback :: F'git_odb_backend_read_prefix_callback traceBackendReadPrefixCallback out_oid oid_p len_p type_p be oid len = do- oidStr <- oidToStr oid+ oidStr <- oidToStr oid 40 putStrLn $ "Read Prefix " ++ oidStr ++ " " ++ show len tb <- peek (castPtr be :: Ptr TraceBackend) tn <- peek (traceNext tb)@@ -66,7 +66,7 @@ traceBackendReadHeaderCallback :: F'git_odb_backend_read_header_callback traceBackendReadHeaderCallback len_p type_p be oid = do- oidStr <- oidToStr oid+ oidStr <- oidToStr oid 40 putStrLn $ "Read Header " ++ oidStr tb <- peek (castPtr be :: Ptr TraceBackend) tn <- peek (traceNext tb)@@ -82,7 +82,7 @@ r <- c'git_odb_hash oid obj_data len obj_type case r of 0 -> do- oidStr <- oidToStr oid+ oidStr <- oidToStr oid 40 putStrLn $ "Write " ++ oidStr ++ " len " ++ show len tb <- peek (castPtr be :: Ptr TraceBackend) tn <- peek (traceNext tb)@@ -97,7 +97,7 @@ traceBackendExistsCallback :: F'git_odb_backend_exists_callback traceBackendExistsCallback be oid confirmNotExists = do- oidStr <- oidToStr oid+ oidStr <- oidToStr oid 40 putStrLn $ "Exists " ++ oidStr tb <- peek (castPtr be :: Ptr TraceBackend) tn <- peek (traceNext tb)
Git/Libgit2/Types.hs view
@@ -15,7 +15,8 @@ import Control.Monad (liftM) import Control.Monad.Base import Control.Monad.IO.Class-import Control.Monad.Trans.Class+import Control.Monad.Logger+import Control.Monad.Morph import Control.Monad.Trans.Control import Control.Monad.Trans.Reader import Data.Conduit@@ -23,7 +24,6 @@ import Data.Monoid import Foreign.ForeignPtr import qualified Git-import System.IO.Unsafe data Repository = Repository { repoOptions :: Git.RepositoryOptions@@ -48,16 +48,20 @@ => MonadBase IO (LgRepository m) where liftBase = liftIO -instance Monad m => MonadUnsafeIO (LgRepository m) where- unsafeLiftIO = return . unsafePerformIO- 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@@ -88,6 +92,8 @@ type TreeBuilder m = Git.TreeBuilder (LgRepository m) type Options m = Git.Options (LgRepository m)++type MonadLg m = (Git.MonadGit m, MonadLogger m) lgGet :: Monad m => LgRepository m Repository lgGet = LgRepository ask
gitlib-libgit2.cabal view
@@ -1,5 +1,5 @@ Name: gitlib-libgit2-Version: 2.1.0.0+Version: 2.2.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.1.0.0- , gitlib-test >= 2.1.0.0- , gitlib-libgit2 >= 2.1.0.0+ , gitlib >= 2.2.0.0+ , gitlib-test >= 2.2.0.0+ , gitlib-libgit2 >= 2.2.0.0 , HUnit >= 1.2.5 , hspec >= 1.4.4 , hspec-expectations >= 0.3@@ -36,35 +36,31 @@ ghc-options: -Wall build-depends: base >= 3 && < 5- , gitlib >= 2.1.0.0- , hlibgit2 >= 0.18.0.10- , attempt >= 0.4.0- , binary >= 0.5.1.0+ , gitlib >= 2.2.0.0+ , hlibgit2 >= 0.18.0.11 , bytestring >= 0.9.2.1- , base16-bytestring >= 0.1.1.5 , conduit >= 0.5.5- , containers >= 0.4.2+ , containers >= 0.4.2.1 , directory >= 1.1.0.2 , failure >= 0.2.0.1+ , fast-logger , filepath >= 1.3.0- , hashable >= 1.1.2.5- , hex >= 0.1.2+ , lifted-async >= 0.1.0 , lifted-base >= 0.2.0.2 , missing-foreign >= 0.1.1 , monad-control >= 0.3.2+ , monad-logger >= 0.3.1.1 , monad-loops >= 0.3.3.0- , parallel-io >= 0.3.2.1- , pointless-fun >= 1.1.0.1+ , mmorph >= 1.0.0 , resourcet >= 0.4.6+ , stm >= 2.4.2 , tagged >= 0.2.3.1+ , template-haskell , text >= 0.11.2 , text-icu >= 0.6.3- , temporary >= 1.1.2.4 , time >= 1.4 , transformers >= 0.3.0.0 , transformers-base >= 0.4.1- , unix >= 2.5- , unordered-containers >= 0.2.3 exposed-modules: Git.Libgit2 Git.Libgit2.Backend
test/Smoke.hs view
@@ -1,25 +1,11 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ConstraintKinds #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# OPTIONS_GHC -fno-warn-unused-do-bind #-}-{-# OPTIONS_GHC -fno-warn-wrong-do-bind #-}-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}- module Main where -import Control.Exception (finally)-import qualified Git-import qualified Git.Smoke as Git import qualified Git.Libgit2 as Lg-import Test.Hspec.Runner+import qualified Git.Smoke as Git import Test.Hspec.HUnit ()+import Test.Hspec.Runner main :: IO ()-main = do- Git.startupBackend Lg.lgFactory- finally- (hspec $ Git.smokeTestSpec Lg.lgFactory Lg.lgFactory)- (Git.shutdownBackend Lg.lgFactory)+main = hspec $ Git.smokeTestSpec Lg.lgFactory Lg.lgFactory -- Smoke.hs ends here