module Data.Git.Commit
( Commit(..)
, PinnedEntry(..)
, newCommitBase
, createCommit
, lookupCommit
, lookupRefCommit
, addCommitParent
, writeCommit
, getCommitParents
, modifyCommitTree
, removeFromCommitTree
, updateCommit
, commitHistoryFirstParent
, commitEntry
, commitEntryHistory )
where
import Bindings.Libgit2
import qualified Data.ByteString as BS
import Data.ByteString.Unsafe
import Data.Git.Common
import Data.Git.Internal
import Data.Git.Reference
import Data.Git.Tree
import qualified Data.Text as T
import qualified Data.Text.Encoding as E
import qualified Data.Text.ICU.Convert as U
import qualified Foreign.Concurrent as FC
import qualified Foreign.ForeignPtr.Unsafe as FU
import Foreign.Marshal.Array
import qualified Prelude
data Commit = Commit { commitInfo :: Base Commit
, commitAuthor :: Signature
, commitCommitter :: Signature
, commitLog :: Text
, commitEncoding :: Prelude.String
, commitTree :: ObjRef Tree
, commitParents :: [ObjRef Commit]
, commitObj :: ObjPtr C'git_commit }
instance Show Commit where
show x = case gitId (commitInfo x) of
Pending _ -> "Commit..."
Stored y -> "Commit#" ++ show y ++ " <" ++ show (commitTree x) ++ ">"
instance Updatable Commit where
getId x = gitId (commitInfo x)
objectRepo x = gitRepo (commitInfo x)
objectPtr x = gitObj (commitInfo x)
update = flip writeCommit Nothing
lookupFunction = lookupCommit
#if defined(PROFILING)
loadObject' x y =
maybe (throwIO ObjectLookupFailed) return =<< loadObject x y
#endif
newCommitBase :: Commit -> Base Commit
newCommitBase t =
newBase (gitRepo (commitInfo t))
(Pending (flip doWriteCommit Nothing >=> return . snd)) Nothing
createCommit :: Repository -> Signature -> Commit
createCommit repo sig =
Commit { commitInfo =
newBase repo (Pending (flip doWriteCommit Nothing >=> return . snd))
Nothing
, commitAuthor = sig
, commitCommitter = sig
, commitTree = ObjRef (createTree repo)
, commitParents = []
, commitLog = T.empty
, commitEncoding = ""
, commitObj = Nothing }
lookupCommit :: Repository -> Oid -> IO (Maybe Commit)
lookupCommit repo oid =
lookupObject' repo oid c'git_commit_lookup c'git_commit_lookup_prefix $
\coid obj _ ->
withForeignPtr obj $ \cobj -> do
let c = castPtr cobj
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 >>= BS.packCString
auth <- c'git_commit_author c >>= packSignature conv
comm <- c'git_commit_committer c >>= packSignature conv
toid <- c'git_commit_tree_oid c >>= wrapOidPtr
pn <- c'git_commit_parentcount c
poids <- traverse wrapOidPtr
=<< sequence
(zipWith ($) (replicate (fromIntegral (toInteger pn))
(c'git_commit_parent_oid c))
[0..pn])
return Commit { commitInfo = newBase repo (Stored coid) (Just obj)
, commitAuthor = auth
, commitCommitter = comm
, commitTree = toid
, commitParents = poids
, commitLog = U.toUnicode conv msg
, commitEncoding = encs
, commitObj = Just $ unsafeCoerce obj }
lookupRefCommit :: Repository -> Text -> IO (Maybe Commit)
lookupRefCommit repo ref = do
oid <- resolveRef repo ref
maybe (return Nothing) (lookupCommit repo) oid
addCommitParent :: Commit -> Commit -> Commit
addCommitParent co p = co { commitParents = commitParents co ++ [ObjRef p] }
writeCommit :: Commit -> Maybe Text -> IO Commit
writeCommit c@(Commit { commitInfo = Base { gitId = Stored _ } }) _ =
return c
writeCommit c ref = fst <$> doWriteCommit c ref
withForeignPtrs :: [ForeignPtr a] -> ([Ptr a] -> IO b) -> IO b
withForeignPtrs fos io
= do r <- io (map FU.unsafeForeignPtrToPtr fos)
mapM touchForeignPtr fos
return r
doWriteCommit :: Commit -> Maybe Text -> IO (Commit, COid)
doWriteCommit c ref = do
coid <- withForeignPtr (repoObj (gitRepo (commitInfo c))) $ \repoPtr -> do
coid <- mallocForeignPtr
withForeignPtr coid $ \coid' -> do
conv <- U.open (commitEncoding c) (Just True)
BS.useAsCString (U.fromUnicode conv (commitLog c)) $ \message ->
withRef ref $ \update_ref ->
withSignature conv (commitAuthor c) $ \author ->
withSignature conv (commitCommitter c) $ \committer ->
withEncStr (commitEncoding c) $ \message_encoding ->
withGitTree (commitTree c) c $ \commit_tree -> do
parentPtrs <- getCommitParentPtrs c
withForeignPtrs parentPtrs $ \pptrs -> do
parents <- newArray pptrs
r <- c'git_commit_create coid' repoPtr
update_ref author committer
message_encoding message commit_tree
(fromIntegral (length (commitParents c)))
parents
when (r < 0) $ throwIO CommitCreateFailed
return coid
return (c { commitInfo = (commitInfo c) { gitId = Stored (COid coid) } }
, COid coid)
where
withRef Nothing = flip ($) nullPtr
withRef (Just name) = BS.useAsCString (E.encodeUtf8 name)
withEncStr "" = flip ($) nullPtr
withEncStr enc = withCString enc
getCommitParents :: Commit -> IO [Commit]
getCommitParents c =
traverse (\p -> do parent <- loadObject p c
case parent of
Nothing -> error "Cannot find Git commit"
Just p' -> return p')
(commitParents c)
getCommitParentPtrs :: Commit -> IO [ForeignPtr C'git_commit]
getCommitParentPtrs c =
withForeignPtr (repositoryPtr (objectRepo c)) $ \repoPtr ->
for (commitParents c) $ \p ->
case p of
ObjRef (Commit { commitObj = Just obj }) -> return obj
_ -> do
Oid (COid oid) <-
case p of
IdRef coid -> return $ Oid coid
ObjRef x -> objectId x
withForeignPtr oid $ \commit_id ->
alloca $ \ptr -> do
r <- c'git_commit_lookup ptr repoPtr commit_id
when (r < 0) $ throwIO CommitLookupFailed
ptr' <- peek ptr
FC.newForeignPtr ptr' (c'git_commit_free ptr')
modifyCommitTree
:: Commit -> FilePath -> (Maybe TreeEntry -> Either a (Maybe TreeEntry)) -> Bool
-> IO (Either a Commit)
modifyCommitTree c path f createIfNotExist =
withObject (commitTree c) c $ \tr -> do
result <- modifyTree path f createIfNotExist tr
case result of
Left x -> return (Left x)
Right tr' -> return $ Right $ c { commitTree = ObjRef tr' }
removeFromCommitTree :: Commit -> FilePath -> IO Commit
removeFromCommitTree c path =
withObject (commitTree c) c $ \tr -> do
tr' <- removeFromTree path tr
return c { commitTree = ObjRef tr' }
doUpdateCommit :: Commit -> [Text] -> TreeEntry -> IO Commit
doUpdateCommit c xs item = do
t <- loadObject (commitTree c) c
case t of
Nothing -> throwIO CommitLookupFailed
Just t' -> do
newt <- doUpdateTree t' xs item
return c { commitTree = ObjRef newt
, commitInfo =
newBase (objectRepo c)
(Pending (flip doWriteCommit Nothing
>=> return . snd)) Nothing
, commitObj = Nothing }
updateCommit :: Commit -> FilePath -> TreeEntry -> IO Commit
updateCommit c = doUpdateCommit c . splitPath
commitHistoryFirstParent :: Commit -> IO [Commit]
commitHistoryFirstParent c =
case commitParents c of
[] -> return [c]
(p:_) -> do p' <- loadObject' p c
ps <- commitHistoryFirstParent p'
return (c:ps)
commitEntry :: Commit -> FilePath -> IO (Maybe TreeEntry)
commitEntry c path =
flip lookupTreeEntry path =<< loadObject' (commitTree c) c
data PinnedEntry = PinnedEntry { pinnedOid :: Oid
, pinnedCommit :: Commit
, pinnedEntry :: TreeEntry }
deriving Show
identifyEntry :: Commit -> TreeEntry -> IO PinnedEntry
identifyEntry co x = do
oid <- case x of
BlobEntry blob _ -> objectRefId blob
TreeEntry tree -> objectRefId tree
return (PinnedEntry oid co x)
commitEntryHistory :: Commit -> FilePath -> IO [PinnedEntry]
commitEntryHistory c path = map head
. filter (not . null)
. groupBy ((==) `on` pinnedOid) <$> go c
where go co = do
entry <- getEntry co
rest <- case commitParents co of
[] -> return []
(p:_) -> go =<< loadObject' p co
return $ maybe rest (:rest) entry
getEntry co = do
ce <- commitEntry co path
case ce of
Nothing -> return Nothing
Just ce' -> Just <$> identifyEntry co ce'