module Git.Libgit2.Internal (module Git.Libgit2.Internal, oidToStr) where
import Bindings.Libgit2
import Control.Applicative
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Trans.Control
import Data.ByteString
import qualified Data.Text as T
import qualified Data.Text.ICU.Convert as U
import Data.Time
import Data.Time.Clock.POSIX (posixSecondsToUTCTime,
utcTimeToPOSIXSeconds)
import Foreign.C.String
import Foreign.C.Types
import qualified Foreign.Concurrent as FC
import Foreign.ForeignPtr
import Foreign.Marshal.Alloc
import Foreign.Ptr
import Foreign.Storable
import qualified Git
import Git.Libgit2.Backend
import Git.Libgit2.Trace
import Git.Libgit2.Types
import System.FilePath.Posix
addTracingBackend :: LgRepo -> IO ()
addTracingBackend repo =
withCString (lgRepoPath repo </> "objects") $ \objectsDir ->
alloca $ \loosePtr -> do
r <- c'git_odb_backend_loose loosePtr objectsDir (1) 0
when (r < 0) $
error "Failed to create loose objects backend"
loosePtr' <- peek loosePtr
backend <- traceBackend loosePtr'
void $ odbBackendAdd repo backend 3
return ()
coidPtrToOid :: Ptr C'git_oid -> IO (ForeignPtr C'git_oid)
coidPtrToOid coidptr = do
fptr <- mallocForeignPtr
withForeignPtr fptr $ \ptr ->
c'git_oid_cpy ptr coidptr
return fptr
lookupObject'
:: (Git.MonadGit LgRepo m, MonadBaseControl IO m)
=> ForeignPtr C'git_oid -> Int
-> (Ptr (Ptr a) -> Ptr C'git_repository -> Ptr C'git_oid -> IO CInt)
-> (Ptr (Ptr a) -> Ptr C'git_repository -> Ptr C'git_oid -> CSize -> IO CInt)
-> (ForeignPtr C'git_oid -> ForeignPtr a -> Ptr a -> m b)
-> m b
lookupObject' oid len lookupFn lookupPrefixFn createFn = do
repo <- Git.getRepository
result <- liftBaseWith $ \run -> alloca $ \ptr -> do
r <- withForeignPtr (repoObj repo) $ \repoPtr ->
withForeignPtr oid $ \oidPtr ->
if len == 40
then lookupFn ptr repoPtr oidPtr
else lookupPrefixFn ptr repoPtr oidPtr (fromIntegral len)
if r < 0
then do
oidStr <- withForeignPtr oid (flip oidToStr len)
let args = ["Could not lookup ", T.pack oidStr]
err <- c'giterr_last
if err == nullPtr
then return $ Left $ T.concat args
else do
errmsg <- peekCString . c'git_error'message =<< peek err
return $ Left $
T.concat $ args ++ [": ", T.pack errmsg]
else do
ptr' <- peek ptr
coid <- c'git_object_id (castPtr ptr')
coidCopy <- mallocForeignPtr
withForeignPtr coidCopy $ flip c'git_oid_cpy coid
let p = castPtr ptr'
fptr <- FC.newForeignPtr p (c'git_object_free p)
Right <$> run (createFn coidCopy (castForeignPtr fptr) ptr')
either (throwM . Git.BackendError) restoreM result
peekGitTime :: Ptr C'git_time -> IO ZonedTime
peekGitTime tptr = do
moment <- peek tptr
return (utcToZonedTime
(minutesToTimeZone (fromIntegral (c'git_time'offset moment)))
(posixSecondsToUTCTime (fromIntegral (c'git_time'time moment))))
packGitTime :: ZonedTime -> C'git_time
packGitTime zt = C'git_time
{ c'git_time'time =
floor (utcTimeToPOSIXSeconds (zonedTimeToUTC zt))
, c'git_time'offset = fromIntegral (timeZoneMinutes (zonedTimeZone zt))
}
packSignature :: U.Converter -> Ptr C'git_signature -> IO Git.Signature
packSignature conv sig = do
name <- peek (p'git_signature'name sig) >>= packCString
email <- peek (p'git_signature'email sig) >>= packCString
time <- peekGitTime (p'git_signature'when sig)
return Git.Signature
{ Git.signatureName = U.toUnicode conv name
, Git.signatureEmail = U.toUnicode conv email
, Git.signatureWhen = time
}
withSignature :: U.Converter -> Git.Signature
-> (Ptr C'git_signature -> IO a) -> IO a
withSignature conv sig f =
useAsCString (U.fromUnicode conv (Git.signatureName sig)) $ \nameCStr ->
useAsCString (U.fromUnicode conv (Git.signatureEmail sig)) $ \emailCStr ->
alloca $ \ptr -> do
poke ptr (C'git_signature nameCStr emailCStr
(packGitTime (Git.signatureWhen sig)))
f ptr