diff --git a/Git/Libgit2.hs b/Git/Libgit2.hs --- a/Git/Libgit2.hs +++ b/Git/Libgit2.hs @@ -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 "" "" "" (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 diff --git a/Git/Libgit2/Internal.hs b/Git/Libgit2/Internal.hs --- a/Git/Libgit2/Internal.hs +++ b/Git/Libgit2/Internal.hs @@ -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 diff --git a/Git/Libgit2/Trace.hs b/Git/Libgit2/Trace.hs --- a/Git/Libgit2/Trace.hs +++ b/Git/Libgit2/Trace.hs @@ -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) diff --git a/Git/Libgit2/Types.hs b/Git/Libgit2/Types.hs --- a/Git/Libgit2/Types.hs +++ b/Git/Libgit2/Types.hs @@ -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 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.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 diff --git a/test/Smoke.hs b/test/Smoke.hs --- a/test/Smoke.hs +++ b/test/Smoke.hs @@ -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