module Git.Libgit2
( MonadLg
, LgRepo(..)
, BlobOid()
, Commit()
, CommitOid()
, Git.Oid
, OidPtr(..)
, mkOid
, Tree()
, TreeOid()
, lgRepoPath
, addTracingBackend
, checkResult
, lgBuildPackIndex
, lgFactory
, lgFactoryLogger
, lgForEachObject
, lgExcTrap
, lgBuildPackFile
, lgReadFromPack
, lgOpenPackFile
, lgClosePackFile
, lgWithPackFile
, lgCopyPackFile
, lgDiffContentsWithTree
, lgWrap
, oidToSha
, shaToCOid
, shaToOid
, openLgRepository
, runLgRepository
, lgDebug
, lgWarn
) where
import Bindings.Libgit2
import Conduit
import Control.Applicative
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async.Lifted
import Control.Concurrent.STM
import Control.Monad hiding (forM, forM_, mapM, mapM_, sequence)
import Control.Monad.Catch
import Control.Monad.Logger
import Control.Monad.Loops
import Control.Monad.Reader.Class
import Control.Monad.Trans.Control
import Control.Monad.Trans.Reader (ReaderT, runReaderT)
import Control.Monad.Trans.Resource
import Data.Bits ((.|.), (.&.))
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Unsafe as BU
import Data.Conduit.Async
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
import Data.Text (Text, pack, unpack)
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
import Foreign.ForeignPtr
import qualified Foreign.ForeignPtr.Unsafe as FU
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Marshal.MissingAlloc
import Foreign.Marshal.Utils
import Foreign.Ptr
import Foreign.Storable
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 Unsafe.Coerce
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
, getOidLen :: Int
}
instance Git.IsOid OidPtr where
renderOid = lgRenderOid
mkOid :: ForeignPtr C'git_oid -> OidPtr
mkOid fptr = OidPtr fptr 40
lgParseOidIO :: Text -> Int -> IO (Maybe Oid)
lgParseOidIO str len = do
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)
return $ if r < 0
then Nothing
else Just (OidPtr oid len)
lgParseOid :: MonadLg m => Text -> m Oid
lgParseOid str
| len > 40 = throwM (Git.OidParseFailed str)
| otherwise = do
moid <- liftIO $ lgParseOidIO str len
case moid of
Nothing -> throwM (Git.OidParseFailed str)
Just oid -> return oid
where
len = T.length str
lgRenderOid :: Oid -> Text
lgRenderOid = pack . show
instance Show OidPtr where
show OidPtr {..} = SU.unsafePerformIO $
withForeignPtr getOid (`oidToStr` getOidLen)
instance Ord OidPtr where
(getOid -> coid1) `compare` (getOid -> coid2) =
SU.unsafePerformIO $
withForeignPtr coid1 $ \coid1Ptr ->
withForeignPtr coid2 $ fmap (`compare` 0) . c'git_oid_cmp coid1Ptr
instance Eq OidPtr where
oid1 == oid2 = oid1 `compare` oid2 == EQ
instance (Applicative m, MonadExcept m,
MonadBaseControl IO m, MonadIO m, MonadLogger m)
=> Git.MonadGit LgRepo (ReaderT LgRepo m) where
type Oid LgRepo = OidPtr
data Tree LgRepo =
LgTree { lgTreePtr :: Maybe (ForeignPtr C'git_tree) }
data Options LgRepo = Options
facts = return Git.RepositoryFacts { Git.hasSymbolicReferences = True }
getRepository = ask
closeRepository = return ()
deleteRepository =
Git.getRepository >>= liftIO . removeDirectoryRecursive . lgRepoPath
parseOid = lgParseOid
lookupReference = lgLookupRef
createReference = lgUpdateRef
updateReference = lgUpdateRef
deleteReference = lgDeleteRef
sourceReferences = lgSourceRefs
lookupCommit = lgLookupCommit
lookupTree = lgLookupTree
lookupBlob = lgLookupBlob
lookupTag = error "Not implemented: LgRepository.lookupTag"
readIndex = lgReadIndex
lookupObject = lgLookupObject
existsObject = lgExistsObject
sourceObjects = lgSourceObjects
newTreeBuilder = lgNewTreeBuilder
treeEntry = lgTreeEntry
treeOid = lgTreeOid
sourceTreeEntries = lgSourceTreeEntries
hashContents = lgHashContents
createBlob = lgWrap . lgCreateBlob
createTag = error "Not implemented: LgRepository.createTag"
createCommit p t a c l r = lgWrap $ lgCreateCommit p t a c l r
diffContentsWithTree = error "Not implemented: lgDiffContentsWithTree"
lgExcTrap :: MonadLg m => ReaderT LgRepo m (IORef (Maybe Git.GitException))
lgExcTrap = repoExcTrap `liftM` Git.getRepository
lgWrap :: MonadLg m => ReaderT LgRepo m a -> ReaderT LgRepo m a
lgWrap f = f `catch` \e -> do
etrap <- lgExcTrap
mexc <- liftIO $ readIORef etrap
liftIO $ writeIORef etrap Nothing
maybe (throwM (e :: SomeException)) throwM mexc
lgHashContents :: MonadLg m
=> Git.BlobContents (ReaderT LgRepo m)
-> ReaderT LgRepo m BlobOid
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) $ lgThrow Git.BlobCreateFailed
return $ Tagged (mkOid ptr)
lgCreateBlob :: MonadLg m
=> Git.BlobContents (ReaderT LgRepo m)
-> ReaderT LgRepo m BlobOid
lgCreateBlob b = do
repo <- Git.getRepository
ptr <- liftIO mallocForeignPtr
r <- case b of
Git.BlobString bs -> createBlob repo ptr bs
Git.BlobStringLazy bs ->
createBlob repo ptr (B.concat (BL.toChunks bs))
Git.BlobStream src -> readFromSource repo ptr src
Git.BlobSizedStream src _ -> readFromSource repo ptr src
when (r < 0) $ lgThrow Git.BlobCreateFailed
return $ Tagged (mkOid ptr)
where
createBlob repo ptr bs = liftIO $ withForeignPtr ptr $ \coid' ->
withForeignPtr (repoObj repo) $ \repoPtr ->
BU.unsafeUseAsCStringLen bs $ uncurry $ \cstr len ->
c'git_blob_create_frombuffer coid' repoPtr
(castPtr cstr) (fromIntegral len)
readFromSource repo ptr src =
src $$ drainTo 2 $ \queue ->
liftIO $ withForeignPtr ptr $ \coid' ->
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)
chunk_cb :: TBQueue (Maybe ByteString)
-> CString
-> CSize
-> Ptr ()
-> 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
lgObjToBlob :: MonadLg m
=> BlobOid
-> ForeignPtr C'git_blob
-> ReaderT LgRepo m (Git.Blob LgRepo (ReaderT LgRepo m))
lgObjToBlob oid fptr = do
bs <- liftIO $ withForeignPtr fptr $ \ptr -> do
size <- c'git_blob_rawsize ptr
buf <- c'git_blob_rawcontent ptr
B.packCStringLen (castPtr buf, fromIntegral size)
return $ Git.Blob oid $ Git.BlobString bs
lgLookupBlob :: MonadLg m
=> BlobOid
-> ReaderT LgRepo m (Git.Blob LgRepo (ReaderT LgRepo m))
lgLookupBlob oid =
lookupObject' (getOid (untag oid)) (getOidLen (untag oid))
c'git_blob_lookup c'git_blob_lookup_prefix
$ \boid obj _ -> lgObjToBlob (Tagged (mkOid boid)) obj
lgTreeEntry :: MonadLg m
=> Tree -> Git.TreeFilePath -> ReaderT LgRepo m (Maybe TreeEntry)
lgTreeEntry (LgTree Nothing) _ = return Nothing
lgTreeEntry (LgTree (Just tree)) fp = liftIO $ alloca $ \entryPtr ->
withFilePath fp $ \pathStr ->
withForeignPtr tree $ \treePtr -> do
r <- c'git_tree_entry_bypath entryPtr treePtr pathStr
if r < 0
then return Nothing
else Just <$> (entryToTreeEntry =<< peek entryPtr)
lgTreeOid :: MonadLg m => Tree -> ReaderT LgRepo m TreeOid
lgTreeOid (LgTree Nothing) =
liftIO $ Tagged . fromJust <$> lgParseOidIO Git.emptyTreeId 40
lgTreeOid (LgTree (Just tree)) = liftIO $ do
toid <- withForeignPtr tree c'git_tree_id
ftoid <- coidPtrToOid toid
return $ Tagged (mkOid ftoid)
gatherFrom' :: (MonadIO m, MonadBaseControl IO m, MonadExcept m)
=> Int
-> (TBQueue o -> m ())
-> Producer m o
gatherFrom' size scatter = do
chan <- liftIO $ newTBQueueIO size
worker <- lift $ async (scatter chan)
lift . restoreM =<< gather worker chan
where
gather worker chan = do
(xs, mres) <- liftIO $ atomically $ do
xs <- whileM (not <$> isEmptyTBQueue chan) (readTBQueue chan)
(xs,) <$> pollSTM worker
liftIO $ threadDelay 1
mapM_ yield xs
case mres of
Just (Left e) -> throwM (e :: SomeException)
Just (Right r) -> return r
Nothing -> gather worker chan
lgSourceTreeEntries
:: MonadLg m
=> Tree
-> Producer (ReaderT LgRepo m) (Git.TreeFilePath, TreeEntry)
lgSourceTreeEntries (LgTree Nothing) = return ()
lgSourceTreeEntries (LgTree (Just tree)) = gatherFrom' 16 $ \queue -> do
liftIO $ withForeignPtr tree $ \tr -> do
r <- bracket
(mk'git_treewalk_cb (callback queue))
freeHaskellFunPtr
(\callback ->
c'git_tree_walk tr c'GIT_TREEWALK_PRE callback nullPtr)
when (r < 0) $ lgThrow Git.TreeWalkFailed
where
callback queue root te _payload = do
fp <- peekFilePath root
cname <- c'git_tree_entry_name te
name <- (fp <>) <$> peekFilePath cname
entry <- entryToTreeEntry te
atomically $
writeTBQueue queue $ name `seq` entry `seq` (name,entry)
return 0
lgMakeBuilder :: MonadLg m
=> ForeignPtr C'git_treebuilder -> TreeBuilder (ReaderT LgRepo m)
lgMakeBuilder builder = Git.TreeBuilder
{ Git.mtbBaseTreeOid = Nothing
, Git.mtbPendingUpdates = mempty
, Git.mtbNewBuilder = lgNewTreeBuilder
, Git.mtbWriteContents = \tb -> (,) <$> pure (Git.BuilderUnchanged tb)
<*> lgWriteBuilder builder
, Git.mtbLookupEntry = lgLookupBuilderEntry builder
, Git.mtbEntryCount = lgBuilderEntryCount builder
, Git.mtbPutEntry = \tb name ent ->
Git.BuilderUnchanged tb <$ lgPutEntry builder name ent
, Git.mtbDropEntry = \tb name ->
Git.BuilderUnchanged tb <$ lgDropEntry builder name
}
lgNewTreeBuilder :: MonadLg m
=> Maybe Tree
-> ReaderT LgRepo m (TreeBuilder (ReaderT LgRepo m))
lgNewTreeBuilder mtree = do
mfptr <- liftIO $ alloca $ \pptr -> do
r <- case mtree of
Nothing -> c'git_treebuilder_create pptr nullPtr
Just (LgTree Nothing) ->
c'git_treebuilder_create pptr nullPtr
Just (LgTree (Just tree)) ->
withForeignPtr tree $ \treePtr ->
c'git_treebuilder_create pptr treePtr
if r < 0
then return Nothing
else do
builder <- peek pptr
fptr <- FC.newForeignPtr builder
(c'git_treebuilder_free builder)
return $ Just fptr
case mfptr of
Nothing ->
throwM (Git.TreeCreateFailed "Failed to create new tree builder")
Just fptr -> do
toid <- mapM Git.treeOid mtree
return (lgMakeBuilder fptr) { Git.mtbBaseTreeOid = toid }
lgPutEntry :: MonadLg m
=> ForeignPtr C'git_treebuilder -> Git.TreeFilePath -> TreeEntry
-> ReaderT LgRepo m ()
lgPutEntry builder key (treeEntryToOid -> (oid, mode)) = do
r2 <- liftIO $ withForeignPtr (getOid oid) $ \coid ->
withForeignPtr builder $ \ptr ->
withFilePath key $ \name ->
c'git_treebuilder_insert nullPtr ptr name coid
(fromIntegral mode)
when (r2 < 0) $ throwM (Git.TreeBuilderInsertFailed key)
treeEntryToOid :: TreeEntry -> (Oid, CUInt)
treeEntryToOid (Git.BlobEntry oid kind) =
(untag oid, case kind of
Git.PlainBlob -> 0o100644
Git.ExecutableBlob -> 0o100755
Git.SymlinkBlob -> 0o120000)
treeEntryToOid (Git.CommitEntry coid) =
(untag coid, 0o160000)
treeEntryToOid (Git.TreeEntry toid) =
(untag toid, 0o040000)
lgDropEntry :: MonadLg m
=> ForeignPtr C'git_treebuilder -> Git.TreeFilePath
-> ReaderT LgRepo m ()
lgDropEntry builder key =
void $ liftIO $ withForeignPtr builder $ \ptr ->
withFilePath key $ c'git_treebuilder_remove ptr
lgLookupBuilderEntry :: MonadLg m
=> ForeignPtr C'git_treebuilder
-> Git.TreeFilePath
-> ReaderT LgRepo m (Maybe TreeEntry)
lgLookupBuilderEntry builderPtr name = do
entry <- liftIO $ withForeignPtr builderPtr $ \builder ->
withFilePath name $ c'git_treebuilder_get builder
if entry == nullPtr
then return Nothing
else Just <$> liftIO (entryToTreeEntry entry)
lgBuilderEntryCount :: MonadLg m
=> ForeignPtr C'git_treebuilder -> ReaderT LgRepo m Int
lgBuilderEntryCount tb =
fromIntegral <$> liftIO (withForeignPtr tb c'git_treebuilder_entrycount)
lgTreeEntryCount :: MonadLg m => Tree -> ReaderT LgRepo m Int
lgTreeEntryCount (LgTree Nothing) = return 0
lgTreeEntryCount (LgTree (Just tree)) =
fromIntegral <$> liftIO (withForeignPtr tree c'git_tree_entrycount)
lgWriteBuilder :: MonadLg m
=> ForeignPtr C'git_treebuilder -> ReaderT LgRepo m TreeOid
lgWriteBuilder tb = do
repo <- Git.getRepository
(r3,coid) <- liftIO $ do
coid <- mallocForeignPtr
withForeignPtr coid $ \coid' ->
withForeignPtr tb $ \builder ->
withForeignPtr (repoObj repo) $ \repoPtr -> do
r3 <- c'git_treebuilder_write coid' repoPtr builder
return (r3,coid)
when (r3 < 0) $ lgThrow Git.TreeBuilderWriteFailed
return $ Tagged (mkOid coid)
lgCloneBuilder :: MonadLg m
=> ForeignPtr C'git_treebuilder
-> ReaderT LgRepo m (ForeignPtr C'git_treebuilder)
lgCloneBuilder fptr =
liftIO $ withForeignPtr fptr $ \builder -> alloca $ \pptr -> do
r <- c'git_treebuilder_create pptr nullPtr
when (r < 0) $
throwM (Git.BackendError "Could not create new treebuilder")
builder' <- peek pptr
bracket
(mk'git_treebuilder_filter_cb (callback builder'))
freeHaskellFunPtr
(flip (c'git_treebuilder_filter builder) nullPtr)
FC.newForeignPtr builder' (c'git_treebuilder_free builder')
where
callback builder te _ = do
cname <- c'git_tree_entry_name te
coid <- c'git_tree_entry_id te
fmode <- c'git_tree_entry_filemode te
r <- c'git_treebuilder_insert
nullPtr
builder
cname
coid
fmode
when (r < 0) $
throwM (Git.BackendError "Could not insert entry in treebuilder")
return 0
lgLookupTree :: MonadLg m => TreeOid -> ReaderT LgRepo m Tree
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
entryToTreeEntry entry = do
coid <- c'git_tree_entry_id entry
oid <- coidPtrToOid coid
typ <- c'git_tree_entry_type entry
case () of
() | typ == c'GIT_OBJ_BLOB ->
do mode <- c'git_tree_entry_filemode entry
Git.BlobEntry (Tagged (mkOid oid)) <$>
case mode of
0o100644 -> return Git.PlainBlob
0o100755 -> return Git.ExecutableBlob
0o120000 -> return Git.SymlinkBlob
_ -> throwM $ Git.BackendError $
"Unknown blob mode: " <> T.pack (show mode)
| typ == c'GIT_OBJ_TREE ->
return $ Git.TreeEntry (Tagged (mkOid oid))
| typ == c'GIT_OBJ_COMMIT ->
return $ Git.CommitEntry (Tagged (mkOid oid))
| otherwise -> error "Unexpected"
lgObjToCommit :: CommitOid -> Ptr C'git_commit -> IO Commit
lgObjToCommit oid c = do
enc <- c'git_commit_message_encoding c
encs <- if enc == nullPtr
then return "UTF-8"
else peekCString enc
conv <- U.open encs (Just False)
msg <- c'git_commit_message c >>= B.packCString
auth <- c'git_commit_author c >>= packSignature conv
comm <- c'git_commit_committer c >>= packSignature conv
toid <- c'git_commit_tree_id c
toid' <- coidPtrToOid toid
pn <- c'git_commit_parentcount c
poids <- zipWithM ($)
(replicate (fromIntegral (toInteger pn))
(c'git_commit_parent_id c))
[0..pn]
poids' <- mapM (\x -> Tagged . mkOid <$> coidPtrToOid x) poids
return Git.Commit
{
Git.commitOid = oid
, Git.commitTree = Tagged (mkOid toid')
, Git.commitParents = poids'
, Git.commitAuthor = auth
, Git.commitCommitter = comm
, Git.commitLog = U.toUnicode conv msg
, Git.commitEncoding = "utf-8"
}
lgLookupCommit :: MonadLg m => CommitOid -> ReaderT LgRepo m Commit
lgLookupCommit oid =
lookupObject' (getOid (untag oid)) (getOidLen (untag oid))
c'git_commit_lookup c'git_commit_lookup_prefix
$ \coid obj _ -> liftIO $ withForeignPtr obj $
lgObjToCommit (Tagged (mkOid coid))
lgReadIndex :: MonadLg m => Git.TreeT LgRepo (ReaderT LgRepo m) ()
lgReadIndex = do
repo <- lift Git.getRepository
xs <- liftIO $ withForeignPtr (repoObj repo) $ \repoPtr ->
alloca $ \indexPp -> do
r <- c'git_repository_index indexPp repoPtr
idx <- if r < 0
then lgThrow Git.BackendError
else peek indexPp
cnt <- c'git_index_entrycount idx
fmap Prelude.concat $ forM [0..pred cnt] $ \i -> do
entryPtr <- c'git_index_get_byindex idx i
entry <- peek entryPtr
let oid = c'git_index_entry'oid entry
mode = c'git_index_entry'mode entry
path = c'git_index_entry'path entry
flags = c'git_index_entry'flags entry
if 0 /= flags .&. 2
then return []
else do
oid' <- new oid
foid' <- newForeignPtr_ oid'
path' <- peekFilePath path
return
[(path',
if 0 /= mode .&. 16384
then Git.TreeEntry (Tagged (mkOid foid'))
else Git.BlobEntry (Tagged (mkOid foid')) $
if (0 /= mode .&. 64
)
then Git.ExecutableBlob
else Git.PlainBlob
)]
forM_ xs $ uncurry Git.putEntry
data ObjectPtr = BlobPtr (ForeignPtr C'git_blob)
| TreePtr (ForeignPtr C'git_commit)
| CommitPtr (ForeignPtr C'git_commit)
| TagPtr (ForeignPtr C'git_tag)
lgLookupObject :: MonadLg m
=> Oid
-> ReaderT LgRepo m (Git.Object LgRepo (ReaderT LgRepo m))
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 ->
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 :: MonadLg m => Oid -> ReaderT LgRepo m Bool
lgExistsObject oid = do
repo <- Git.getRepository
result <- liftIO $ withForeignPtr (repoObj repo) $ \repoPtr ->
alloca $ \pptr -> do
r <- c'git_repository_odb pptr repoPtr
if r < 0
then return Nothing
else
withForeignPtr (getOid oid) $ \coid -> do
ptr <- peek pptr
r1 <- c'git_odb_exists ptr coid 0
c'git_odb_free ptr
return (Just (r1 == 0))
maybe (throwM Git.RepositoryInvalid) return result
lgForEachObject :: Ptr C'git_odb
-> (Ptr C'git_oid -> Ptr () -> IO CInt)
-> Ptr ()
-> IO CInt
lgForEachObject odbPtr f payload =
bracket
(mk'git_odb_foreach_cb f)
freeHaskellFunPtr
(flip (c'git_odb_foreach odbPtr) payload)
lgSourceObjects :: MonadLg m
=> Maybe CommitOid -> CommitOid -> Bool
-> Producer (ReaderT LgRepo m) ObjectOid
lgSourceObjects mhave need alsoTrees = do
repo <- lift Git.getRepository
walker <- liftIO $ alloca $ \pptr -> do
r <- withForeignPtr (repoObj repo) $ \repoPtr ->
c'git_revwalk_new pptr repoPtr
when (r < 0) $
throwM (Git.BackendError "Could not create revwalker")
ptr <- peek pptr
FC.newForeignPtr ptr (c'git_revwalk_free ptr)
c <- lift $ lgLookupCommit need
let oid = untag (Git.commitOid c)
liftIO $ withForeignPtr (getOid oid) $ \coid -> do
r2 <- withForeignPtr walker $ flip c'git_revwalk_push coid
when (r2 < 0) $
throwM (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) $
throwM (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)))
coidPtr <- liftIO mallocForeignPtr
whileM_ ((==) <$> pure 0
<*> liftIO (withForeignPtr walker $ \walker' ->
withForeignPtr coidPtr $ \coidPtr' ->
c'git_revwalk_next coidPtr' walker')) $ do
oidPtr <- liftIO $ withForeignPtr coidPtr coidPtrToOid
do
let coid = Tagged (mkOid oidPtr)
yield $ Git.CommitObjOid coid
when alsoTrees $ do
c <- lift $ lgLookupCommit coid
yield $ Git.TreeObjOid (Git.commitTree c)
lgCreateCommit :: MonadLg m
=> [CommitOid]
-> TreeOid
-> Git.Signature
-> Git.Signature
-> Git.CommitMessage
-> Maybe Git.RefName
-> ReaderT LgRepo m Commit
lgCreateCommit pptrs tree author committer logText ref = do
repo <- Git.getRepository
let toid = getOid . untag $ tree
coid <- liftIO $ withForeignPtr (repoObj repo) $ \repoPtr -> do
coid <- mallocForeignPtr
conv <- U.open "utf-8" (Just True)
withForeignPtr coid $ \coid' ->
withForeignPtr toid $ \toid' ->
withForeignPtrs (map (getOid . untag) pptrs) $ \pptrs' ->
B.useAsCString (U.fromUnicode conv logText) $ \message ->
withRef ref $ \update_ref ->
withSignature conv author $ \author' ->
withSignature conv committer $ \committer' ->
withEncStr "utf-8" $ \_ -> do
parents' <- newArray pptrs'
r <- c'git_commit_create_oid coid' repoPtr
update_ref author' committer'
nullPtr message toid'
(fromIntegral (L.length pptrs)) parents'
when (r < 0) $ throwM Git.CommitCreateFailed
return coid
return Git.Commit
{
Git.commitOid = Tagged (mkOid coid)
, Git.commitTree = tree
, Git.commitParents = pptrs
, Git.commitAuthor = author
, Git.commitCommitter = committer
, Git.commitLog = logText
, Git.commitEncoding = "utf-8"
}
where
withRef Nothing = flip ($) nullPtr
withRef (Just name) = B.useAsCString (T.encodeUtf8 name)
withEncStr "" = flip ($) nullPtr
withEncStr enc = withCString enc
withForeignPtrs :: [ForeignPtr a] -> ([Ptr a] -> IO b) -> IO b
withForeignPtrs fos io = do
r <- io (map FU.unsafeForeignPtrToPtr fos)
mapM_ touchForeignPtr fos
return r
lgLookupRef :: MonadLg m => Git.RefName -> ReaderT LgRepo m (Maybe RefTarget)
lgLookupRef name = do
repo <- Git.getRepository
liftIO $ alloca $ \ptr -> do
r <- withForeignPtr (repoObj repo) $ \repoPtr ->
withCString (unpack name) $ \namePtr ->
c'git_reference_lookup ptr repoPtr namePtr
if r < 0
then return Nothing
else do
ref <- peek ptr
typ <- c'git_reference_type ref
targ <- if typ == c'GIT_REF_OID
then do oidPtr <- c'git_reference_target ref
Git.RefObj . mkOid
<$> coidPtrToOid oidPtr
else do targName <- c'git_reference_symbolic_target ref
Git.RefSymbolic . T.decodeUtf8
<$> B.packCString targName
c'git_reference_free ref
return (Just targ)
lgUpdateRef :: MonadLg m
=> Git.RefName -> Git.RefTarget LgRepo -> ReaderT LgRepo m ()
lgUpdateRef name refTarg = do
repo <- Git.getRepository
r <- liftIO $ alloca $ \ptr ->
withForeignPtr (repoObj repo) $ \repoPtr ->
withCString (unpack name) $ \namePtr ->
case refTarg of
Git.RefObj oid ->
withForeignPtr (getOid oid) $ \coidPtr ->
c'git_reference_create ptr repoPtr namePtr
coidPtr (fromBool True)
Git.RefSymbolic symName ->
withCString (unpack symName) $ \symPtr ->
c'git_reference_symbolic_create ptr repoPtr namePtr
symPtr (fromBool True)
when (r < 0) $ lgThrow Git.ReferenceCreateFailed
lgResolveRef :: MonadLg m => Git.RefName -> ReaderT LgRepo m (Maybe CommitOid)
lgResolveRef name = do
repo <- Git.getRepository
oid <- liftIO $ alloca $ \ptr ->
withCString (unpack name) $ \namePtr ->
withForeignPtr (repoObj repo) $ \repoPtr -> do
r <- c'git_reference_name_to_id ptr repoPtr namePtr
if r < 0
then return Nothing
else Just <$> coidPtrToOid ptr
return $ Tagged . mkOid <$> oid
lgDeleteRef :: MonadLg m => Git.RefName -> ReaderT LgRepo m ()
lgDeleteRef name = do
repo <- Git.getRepository
r <- liftIO $ alloca $ \ptr ->
withCString (unpack name) $ \namePtr ->
withForeignPtr (repoObj repo) $ \repoPtr -> do
r <- c'git_reference_lookup ptr repoPtr namePtr
if r < 0
then return r
else do
ref <- peek ptr
c'git_reference_delete ref
when (r < 0) $ throwM (Git.ReferenceDeleteFailed name)
data ListFlags = ListFlags { listFlagInvalid :: Bool
, listFlagOid :: Bool
, listFlagSymbolic :: Bool
, listFlagPacked :: Bool
, listFlagHasPeel :: Bool }
deriving (Show, Eq)
allRefsFlag :: ListFlags
allRefsFlag = ListFlags { listFlagInvalid = False
, listFlagOid = True
, listFlagSymbolic = True
, listFlagPacked = True
, listFlagHasPeel = False }
gitStrArray2List :: Ptr C'git_strarray -> IO [Text]
gitStrArray2List gitStrs = do
count <- fromIntegral <$> peek (p'git_strarray'count gitStrs)
strings <- peek $ p'git_strarray'strings gitStrs
r0 <- Foreign.Marshal.Array.peekArray count strings
r1 <- sequence $ fmap peekCString r0
return $ fmap pack r1
flagsToInt :: ListFlags -> CUInt
flagsToInt flags = (if listFlagOid flags then 1 else 0)
+ (if listFlagSymbolic flags then 2 else 0)
+ (if listFlagPacked flags then 4 else 0)
+ (if listFlagHasPeel flags then 8 else 0)
lgSourceRefs :: MonadLg m => Producer (ReaderT LgRepo m) Git.RefName
lgSourceRefs =
gatherFrom' 16 $ \queue -> do
repo <- Git.getRepository
r <- liftIO $ bracket
(mk'git_reference_foreach_cb (callback queue))
freeHaskellFunPtr
(\callback -> withForeignPtr (repoObj repo) $ \repoPtr ->
c'git_reference_foreach repoPtr
(flagsToInt allRefsFlag) callback nullPtr)
when (r < 0) $ lgThrow Git.ReferenceListingFailed
where
callback :: TBQueue Text
-> CString
-> Ptr ()
-> IO CInt
callback queue cname _payload = do
name <- peekCString cname
atomically $ writeTBQueue queue (pack name)
return 0
lgThrow :: (MonadIO m, MonadExcept m, Exception e) => (Text -> e) -> m a
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)
throwM (f (pack errStr))
lgDiffContentsWithTree
:: MonadLg m
=> Source (ReaderT LgRepo m)
(Either Git.TreeFilePath (Either Git.SHA ByteString))
-> Tree
-> Producer (ReaderT LgRepo m) ByteString
lgDiffContentsWithTree _contents (LgTree Nothing) =
liftIO $ throwM $
Git.DiffTreeToIndexFailed "Cannot diff against an empty tree"
lgDiffContentsWithTree contents tree = do
repo <- lift Git.getRepository
gatherFrom' 16 $ generateDiff repo
where
generateDiff repo chan = do
entries <- M.fromList <$> Git.listTreeEntries tree
paths <- liftIO $ newIORef []
(src, ()) <- contents $$+ return ()
handleEntries entries paths src
contentsPaths <- liftIO $ readIORef paths
forM_ (sort (M.keys entries) \\ sort contentsPaths) $ \path ->
case entries M.! path of
Git.BlobEntry oid _ -> do
let boid = getOid (untag oid)
diffBlob path Nothing (Just boid)
Git.CommitEntry _coid -> return ()
Git.TreeEntry _toid -> return ()
where
handleEntries entries paths src = do
(src', mres) <- 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 ->
diffBlob path (Just content) Nothing
Just entry -> case entry of
Git.BlobEntry oid _ -> do
let boid = getOid (untag oid)
diffBlob path (Just content) (Just boid)
Git.CommitEntry _coid -> return ()
Git.TreeEntry _toid -> return ()
handleEntries entries paths src'
handlePath (Right _) =
lift $ throwM $ Git.DiffTreeToIndexFailed
"Received a Right value when a Left RawFilePath was expected"
handlePath (Left path) = do
mcontent <- await
case mcontent of
Nothing ->
lift $ throwM $ Git.DiffTreeToIndexFailed $
"Content not provided for " <> T.pack (show path)
Just x -> handleContent path x
handleContent _path (Left _) =
lift $ throwM $ 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 $ do
fileHeader <- liftIO $ newIORef Nothing
let f = flip allocate freeHaskellFunPtr
(_, fcb) <- f $ mk'git_diff_file_cb (file_cb fileHeader)
(_, hcb) <- f $ mk'git_diff_hunk_cb (hunk_cb fileHeader)
(_, pcb) <- f $ mk'git_diff_data_cb print_cb
let db b o = diffBlobs fcb hcb pcb b o
dbb b = diffBlobToBuffer fcb hcb pcb b
case mboid of
Nothing -> liftIO $ dbb nullPtr
Just boid -> withBlob boid $ \blobp ->
case mcontent of
Just (Left sha) -> do
boid2 <- liftIO $ shaToCOid sha
if boid == boid2
then withBlob boid2 $
liftIO . db blobp
else return 0
_ -> liftIO $ dbb blobp
when (r < 0) $ lgThrow Git.DiffBlobFailed
where
withBlob :: ForeignPtr C'git_oid
-> (Ptr C'git_blob -> ResourceT IO CInt)
-> ResourceT IO CInt
withBlob boid f = do
(_, eblobp) <- flip allocate freeBlob $
alloca $ \blobpp ->
withForeignPtr boid $ \boidPtr ->
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 -> f blobp
where
freeBlob (Left _) = return ()
freeBlob (Right blobp) = c'git_blob_free blobp
diffBlobToBuffer fcb hcb pcb blobp = do
let diff s l =
c'git_diff_blob_to_buffer blobp s (fromIntegral l)
nullPtr fcb hcb pcb nullPtr
case mcontent of
Just (Right c) -> BU.unsafeUseAsCStringLen c $ uncurry diff
_ -> diff nullPtr 0
diffBlobs fcb hcb pcb blobp otherp =
c'git_diff_blobs blobp otherp nullPtr fcb hcb pcb nullPtr
isBinary :: C'git_diff_delta -> Bool
isBinary delta =
c'git_diff_delta'flags delta .&. c'GIT_DIFF_FLAG_BINARY /= 0
file_cb :: IORef (Maybe ByteString)
-> Ptr C'git_diff_delta
-> CFloat
-> Ptr ()
-> IO CInt
file_cb fh deltap _progress _payload = do
delta <- peek deltap
writeIORef fh $ Just $
if isBinary delta
then "Binary files a/" <> path <> " and b/" <> path
<> " differ\n"
else "--- a/" <> path <> "\n" <> "+++ b/" <> path <> "\n"
return 0
hunk_cb :: IORef (Maybe ByteString)
-> Ptr C'git_diff_delta
-> Ptr C'git_diff_range
-> CString
-> CSize
-> Ptr ()
-> IO CInt
hunk_cb fh deltap _rangep header headerLen _payload = do
delta <- peek deltap
mfh <- readIORef fh
forM_ mfh $ \h -> do
atomically $ writeTBQueue chan h
writeIORef fh Nothing
unless (isBinary delta) $ do
bs <- curry B.packCStringLen header
(fromIntegral headerLen)
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, MonadExcept m) => a -> Text -> m ()
checkResult r why = when (r /= 0) $ throwM (Git.BackendError why)
lgBuildPackFile :: MonadLg m
=> FilePath -> [Either CommitOid TreeOid]
-> ReaderT LgRepo m FilePath
lgBuildPackFile dir oids = do
repo <- Git.getRepository
liftIO $ do
(filePath, fHandle) <- openBinaryTempFile dir "pack"
hClose fHandle
go repo filePath
return filePath
where
go repo path = runResourceT $ do
delKey <- register $ removeFile path
(_,bPtrPtr) <- allocate malloc free
(_,bPtr) <- flip allocate c'git_packbuilder_free $
liftIO $ withForeignPtr (repoObj repo) $ \repoPtr -> do
r <- c'git_packbuilder_new bPtrPtr repoPtr
checkResult r "c'git_packbuilder_new failed"
peek bPtrPtr
forM_ oids $ \oid -> case oid of
Left coid ->
actOnOid
(flip (c'git_packbuilder_insert bPtr) nullPtr)
(untag coid)
"c'git_packbuilder_insert failed"
Right toid ->
actOnOid
(c'git_packbuilder_insert_tree bPtr)
(untag toid)
"c'git_packbuilder_insert_tree failed"
liftIO $ do
r1 <- c'git_packbuilder_set_threads bPtr 0
checkResult r1 "c'git_packbuilder_set_threads failed"
withCString path $ \cstr -> do
r2 <- c'git_packbuilder_write bPtr cstr
checkResult r2 "c'git_packbuilder_write failed"
void $ unprotect delKey
actOnOid f oid msg =
liftIO $ withForeignPtr (getOid oid) $ \oidPtr -> do
r <- f oidPtr
checkResult r msg
lift_ :: (Monad m, Functor (t m), MonadTrans t) => m a -> t m ()
lift_ = void . lift
lgBuildPackIndex :: (MonadIO m, MonadBaseControl IO m, MonadLogger m)
=> FilePath -> BL.ByteString -> m (Text, FilePath, FilePath)
lgBuildPackIndex dir bytes = do
sha <- go dir bytes
return (sha, dir </> ("pack-" <> unpack sha <> ".pack"),
dir </> ("pack-" <> unpack sha <> ".idx"))
where
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
nullFunPtr nullPtr
checkResult r "c'git_indexer_stream_new failed"
peek idxPtrPtr
lift_ . run $
lgDebug $ "Add the incoming packfile data to the stream ("
++ show (BL.length bytes) ++ " bytes)"
(_,statsPtr) <- allocate calloc free
liftIO $ forM_ (BL.toChunks bytes) $ \chunk ->
BU.unsafeUseAsCStringLen chunk $ uncurry $ \dataPtr dataLen -> do
r <- c'git_indexer_stream_add idxPtr (castPtr dataPtr)
(fromIntegral dataLen) statsPtr
checkResult r "c'git_indexer_stream_add failed"
lift_ . run $ lgDebug "Finalizing the stream"
r <- liftIO $ c'git_indexer_stream_finalize idxPtr statsPtr
checkResult r "c'git_indexer_stream_finalize failed"
lift_ . run $
lgDebug "Discovering the hash used to identify the pack file"
sha <- liftIO $ oidToSha =<< c'git_indexer_stream_hash idxPtr
lift_ . run $ lgDebug $ "The hash used is: " ++ show (Git.shaToText sha)
lift . run $ return (Git.shaToText sha)
oidToSha :: Ptr C'git_oid -> IO Git.SHA
oidToSha oidPtr =
Git.SHA <$> B.packCStringLen
(castPtr oidPtr, sizeOf (undefined :: C'git_oid))
shaToCOid :: Git.SHA -> IO (ForeignPtr C'git_oid)
shaToCOid (Git.SHA bs) = BU.unsafeUseAsCString bs $ \bytes -> do
ptr <- mallocForeignPtr
withForeignPtr ptr $ \ptr' -> do
c'git_oid_fromraw ptr' (castPtr bytes)
return ptr
shaToOid :: Git.SHA -> IO OidPtr
shaToOid = fmap mkOid . shaToCOid
lgCopyPackFile :: MonadLg m => FilePath -> ReaderT LgRepo m ()
lgCopyPackFile packFile = do
repo <- Git.getRepository
control $ \run -> withForeignPtr (repoObj repo) $ \repoPtr ->
alloca $ \odbPtrPtr ->
alloca $ \statsPtr ->
alloca $ \writepackPtrPtr -> do
runResourceT $ go run repoPtr odbPtrPtr writepackPtrPtr statsPtr
run $ return ()
where
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
lift_ . run $ lgDebug "Opening pack writer into odb"
writepackPtr <- liftIO $ do
r <- c'git_odb_write_pack writepackPtrPtr odbPtr
nullFunPtr nullPtr
checkResult r "c'git_odb_write_pack failed"
peek writepackPtrPtr
writepack <- liftIO $ peek writepackPtr
bs <- liftIO $ B.readFile packFile
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
(c'git_odb_writepack'add writepack)
writepackPtr (castPtr dataPtr)
(fromIntegral dataLen) statsPtr
checkResult r "c'git_odb_writepack'add failed"
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
:: (MonadBaseControl IO m, MonadIO m, MonadLogger m,
MonadExcept m)
=> FilePath
-> Ptr (Ptr C'git_odb_backend)
-> Ptr (Ptr C'git_odb)
-> m (Ptr C'git_odb)
lgLoadPackFileInMemory idxPath backendPtrPtr odbPtrPtr = do
lgDebug "Create temporary, in-memory object database"
odbPtr <- liftIO $ do
r <- c'git_odb_new odbPtrPtr
checkResult r "c'git_odb_new failed"
peek odbPtrPtr
lgDebug $ "Load pack index " ++ show idxPath ++ " into temporary odb"
bracketOnError
(do r <- liftIO $ withCString idxPath $ \idxPathStr ->
c'git_odb_backend_one_pack backendPtrPtr idxPathStr
checkResult r "c'git_odb_backend_one_pack failed"
liftIO $ peek backendPtrPtr)
(\backendPtr -> liftIO $ do
backend <- peek backendPtr
mK'git_odb_backend_free_callback
(c'git_odb_backend'free backend) backendPtr)
(\backendPtr -> do
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
lgOpenPackFile :: (MonadBaseControl IO m, MonadIO m, MonadLogger m,
MonadExcept m)
=> FilePath -> m (Ptr C'git_odb)
lgOpenPackFile idxPath = control $ \run ->
alloca $ \odbPtrPtr ->
alloca $ \backendPtrPtr -> run $
lgLoadPackFileInMemory idxPath backendPtrPtr odbPtrPtr
lgClosePackFile :: (MonadBaseControl IO m, MonadIO m, MonadLogger m,
MonadExcept m)
=> Ptr C'git_odb -> m ()
lgClosePackFile = liftIO . c'git_odb_free
lgWithPackFile :: (MonadBaseControl IO m, MonadIO m, MonadLogger m,
MonadExcept m)
=> FilePath -> (Ptr C'git_odb -> m a) -> m a
lgWithPackFile idxPath = bracket (lgOpenPackFile idxPath) lgClosePackFile
lgReadFromPack :: (MonadBaseControl IO m, MonadIO m, MonadLogger m,
MonadExcept m)
=> Ptr C'git_odb -> Git.SHA -> Bool
-> m (Maybe (C'git_otype, CSize, ByteString))
lgReadFromPack odbPtr sha metadataOnly = liftIO $ do
foid <- shaToCOid sha
if metadataOnly
then readMetadata odbPtr foid
else readObject odbPtr foid
where
readMetadata odbPtr foid = 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 = alloca $ \objectPtrPtr -> do
r <- withForeignPtr foid $
c'git_odb_read objectPtrPtr odbPtr
mr <- if r == 0
then Just <$> peek objectPtrPtr
else do
unless (r == c'GIT_ENOTFOUND) $
checkResult r "c'git_odb_read failed"
return Nothing
forM mr $ \objectPtr -> 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)
c'git_odb_object_free objectPtr
return (typ,len,bytes)
lgRemoteFetch :: MonadLg m => Text -> Text -> ReaderT LgRepo m ()
lgRemoteFetch uri fetchSpec = do
xferRepo <- Git.getRepository
liftIO $ withForeignPtr (repoObj xferRepo) $ \repoPtr ->
withCString (unpack uri) $ \uriStr ->
withCString (unpack fetchSpec) $ \fetchStr ->
alloca $ runResourceT . go repoPtr uriStr fetchStr
where
go repoPtr uriStr fetchStr remotePtrPtr = do
(_,remotePtr) <- flip allocate c'git_remote_free $ do
r <- c'git_remote_create_inmemory remotePtrPtr repoPtr
fetchStr uriStr
checkResult r "c'git_remote_create_inmemory failed"
peek remotePtrPtr
r1 <- liftIO $ c'git_remote_connect remotePtr c'GIT_DIRECTION_FETCH
checkResult r1 "c'git_remote_connect failed"
void $ register $ c'git_remote_disconnect remotePtr
r2 <- liftIO $ c'git_remote_download remotePtr nullFunPtr nullPtr
checkResult r2 "c'git_remote_download failed"
lgFactory :: MonadIO m
=> Git.RepositoryFactory
(ReaderT LgRepo (NoLoggingT m)) m LgRepo
lgFactory = Git.RepositoryFactory
{ Git.openRepository = runNoLoggingT . openLgRepository
, Git.runRepository = \c m ->
runNoLoggingT $ runLgRepository c m
}
lgFactoryLogger :: (MonadIO m, MonadLogger m)
=> Git.RepositoryFactory (ReaderT LgRepo m) m LgRepo
lgFactoryLogger = Git.RepositoryFactory
{ Git.openRepository = openLgRepository
, Git.runRepository = runLgRepository
}
runLgRepository :: LgRepo -> ReaderT LgRepo m a -> m a
runLgRepository = flip runReaderT
openLgRepository :: MonadIO m => Git.RepositoryOptions -> m LgRepo
openLgRepository opts = do
startupLgBackend
let path = Git.repoPath opts
p <- liftIO $ doesDirectoryExist path
liftIO $ openRepositoryWith path $
if not (Git.repoAutoCreate opts) || p
then c'git_repository_open
else \x y -> c'git_repository_init x y
(fromBool (Git.repoIsBare opts))
where
openRepositoryWith path fn = do
fptr <- alloca $ \ptr ->
withCString path $ \str -> do
r <- fn ptr str
when (r < 0) $
error $ "Could not open repository " ++ show path
ptr' <- peek ptr
FC.newForeignPtr ptr' (c'git_repository_free ptr')
excTrap <- newIORef Nothing
return LgRepo
{ repoOptions = opts
, repoObj = fptr
, repoExcTrap = excTrap
}
startupLgBackend :: MonadIO m => m ()
startupLgBackend = liftIO (void c'git_threads_init)
shutdownLgBackend :: MonadIO m => m ()
shutdownLgBackend = liftIO c'git_threads_shutdown