diff --git a/Data/Git.hs b/Data/Git.hs --- a/Data/Git.hs +++ b/Data/Git.hs @@ -6,7 +6,7 @@ module Data.Git.Commit, -- module Data.Git.Index, module Data.Git.Blob, - module Data.Git.Errors, + module Data.Git.Error, module Data.Git.Oid, module Data.Git.Tree, module Data.Git.Reference, @@ -22,7 +22,7 @@ import Data.Git.Commit -- import Data.Git.Index import Data.Git.Blob -import Data.Git.Errors +import Data.Git.Error import Data.Git.Oid import Data.Git.Tree import Data.Git.Reference diff --git a/Data/Git/Backend.hs b/Data/Git/Backend.hs new file mode 100644 --- /dev/null +++ b/Data/Git/Backend.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Data.Git.Backend + ( odbBackendAdd + + , F'git_odb_backend_read_callback + , F'git_odb_backend_read_prefix_callback + , F'git_odb_backend_readstream_callback + , F'git_odb_backend_read_header_callback + , F'git_odb_backend_write_callback + , F'git_odb_backend_writestream_callback + , F'git_odb_backend_exists_callback + , F'git_odb_backend_free_callback + ) + where + +import Data.Git.Error +import Data.Git.Internal +import qualified Prelude + +default (Text) + +type F'git_odb_backend_read_callback = + Ptr (Ptr ()) -> Ptr CSize -> Ptr C'git_otype -> Ptr C'git_odb_backend + -> Ptr C'git_oid -> IO CInt +type F'git_odb_backend_read_prefix_callback = + Ptr C'git_oid -> Ptr (Ptr ()) -> Ptr CSize -> Ptr C'git_otype + -> Ptr C'git_odb_backend -> Ptr C'git_oid -> CUInt -> IO CInt +type F'git_odb_backend_readstream_callback = + Ptr (Ptr C'git_odb_stream) -> Ptr C'git_odb_backend -> Ptr C'git_oid + -> IO CInt +type F'git_odb_backend_read_header_callback = + Ptr CSize -> Ptr C'git_otype -> Ptr C'git_odb_backend -> Ptr C'git_oid + -> IO CInt +type F'git_odb_backend_write_callback = + Ptr C'git_oid -> Ptr C'git_odb_backend -> Ptr () -> CSize -> C'git_otype + -> IO CInt +type F'git_odb_backend_writestream_callback = + Ptr (Ptr C'git_odb_stream) -> Ptr C'git_odb_backend -> CSize + -> C'git_otype -> IO CInt +type F'git_odb_backend_exists_callback = + Ptr C'git_odb_backend -> Ptr C'git_oid -> IO CInt +type F'git_odb_backend_free_callback = Ptr C'git_odb_backend -> IO () + +odbBackendAdd :: Repository -> Ptr C'git_odb_backend -> Int + -> IO (Result Repository) +odbBackendAdd repo' backend priority = + withForeignPtr repo $ \repoPtr -> + alloca $ \odbPtr -> do + r <- c'git_repository_odb odbPtr repoPtr + if r < 0 + then return (Left "Cannot get repository ODB") + else do + odb <- peek odbPtr + r2 <- c'git_odb_add_backend odb backend (fromIntegral priority) + if r2 < 0 + then return (Left "Cannot add backend to repository ODB") + else return (Right repo') + + where + repo = fromMaybe (throw RepositoryInvalid) (repoObj repo') + +-- Backend.hs diff --git a/Data/Git/Backend/Trace.hs b/Data/Git/Backend/Trace.hs new file mode 100644 --- /dev/null +++ b/Data/Git/Backend/Trace.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE LiberalTypeSynonyms #-} +{-# LANGUAGE ImpredicativeTypes #-} + +module Data.Git.Backend.Trace ( traceBackend ) where + +import Data.ByteString.Unsafe +import Data.Git.Backend +import Data.Git.Error +import Data.Git.Internal +import Data.Git.Oid +import Debug.Trace (trace) +import Prelude hiding ((.), mapM_) + +data TraceBackend = TraceBackend { traceParent :: C'git_odb_backend + , traceNext :: Ptr C'git_odb_backend } + +instance Storable TraceBackend where + sizeOf p = sizeOf (undefined :: C'git_odb_backend) + + sizeOf (undefined :: Ptr C'git_odb_backend) + alignment p = alignment (traceParent p) + peek p = do + v0 <- peekByteOff p 0 + v1 <- peekByteOff p (sizeOf (undefined :: C'git_odb_backend)) + return (TraceBackend v0 v1) + poke p (TraceBackend v0 v1) = do + pokeByteOff p 0 v0 + pokeByteOff p (sizeOf (undefined :: C'git_odb_backend)) v1 + return () + +traceBackendReadCallback :: F'git_odb_backend_read_callback +traceBackendReadCallback data_p len_p type_p be oid = do + oidStr <- oidToStr oid + putStrLn $ "Read " ++ oidStr + tb <- peek (castPtr be :: Ptr TraceBackend) + tn <- peek (traceNext tb) + (mK'git_odb_backend_read_callback (c'git_odb_backend'read tn)) + data_p len_p type_p (traceNext tb) oid + +traceBackendReadPrefixCallback :: F'git_odb_backend_read_prefix_callback +traceBackendReadPrefixCallback out_oid oid_p len_p type_p be oid len = do + oidStr <- oidToStr oid + putStrLn $ "Read Prefix " ++ oidStr ++ " " ++ show len + tb <- peek (castPtr be :: Ptr TraceBackend) + tn <- peek (traceNext tb) + (mK'git_odb_backend_read_prefix_callback (c'git_odb_backend'read_prefix tn)) + out_oid oid_p len_p type_p (traceNext tb) oid len + +traceBackendReadHeaderCallback :: F'git_odb_backend_read_header_callback +traceBackendReadHeaderCallback len_p type_p be oid = do + oidStr <- oidToStr oid + putStrLn $ "Read Header " ++ oidStr + tb <- peek (castPtr be :: Ptr TraceBackend) + tn <- peek (traceNext tb) + (mK'git_odb_backend_read_header_callback (c'git_odb_backend'read_header tn)) + len_p type_p (traceNext tb) oid + +traceBackendWriteCallback :: F'git_odb_backend_write_callback +traceBackendWriteCallback oid be obj_data len obj_type = do + r <- c'git_odb_hash oid obj_data len obj_type + case r of + 0 -> do + oidStr <- oidToStr oid + putStrLn $ "Write " ++ oidStr ++ " len " ++ show len + tb <- peek (castPtr be :: Ptr TraceBackend) + tn <- peek (traceNext tb) + (mK'git_odb_backend_write_callback (c'git_odb_backend'write tn)) + oid (traceNext tb) obj_data len obj_type + n -> return n + +traceBackendExistsCallback :: F'git_odb_backend_exists_callback +traceBackendExistsCallback be oid = do + oidStr <- oidToStr oid + putStrLn $ "Exists " ++ oidStr + tb <- peek (castPtr be :: Ptr TraceBackend) + tn <- peek (traceNext tb) + (mK'git_odb_backend_exists_callback (c'git_odb_backend'exists tn)) + (traceNext tb) oid + +traceBackendFreeCallback :: F'git_odb_backend_free_callback +traceBackendFreeCallback be = do + backend <- peek be + freeHaskellFunPtr (c'git_odb_backend'read backend) + freeHaskellFunPtr (c'git_odb_backend'read_prefix backend) + freeHaskellFunPtr (c'git_odb_backend'read_header backend) + freeHaskellFunPtr (c'git_odb_backend'write backend) + freeHaskellFunPtr (c'git_odb_backend'exists backend) + +foreign export ccall "traceBackendFreeCallback" + traceBackendFreeCallback :: F'git_odb_backend_free_callback +foreign import ccall "&traceBackendFreeCallback" + traceBackendFreeCallbackPtr :: FunPtr F'git_odb_backend_free_callback + +traceBackend :: Ptr C'git_odb_backend -> IO (Ptr C'git_odb_backend) +traceBackend be = do + readFun <- mk'git_odb_backend_read_callback traceBackendReadCallback + readPrefixFun <- + mk'git_odb_backend_read_prefix_callback traceBackendReadPrefixCallback + readHeaderFun <- + mk'git_odb_backend_read_header_callback traceBackendReadHeaderCallback + writeFun <- mk'git_odb_backend_write_callback traceBackendWriteCallback + existsFun <- mk'git_odb_backend_exists_callback traceBackendExistsCallback + + castPtr <$> new TraceBackend { + traceParent = C'git_odb_backend { + c'git_odb_backend'odb = nullPtr + , c'git_odb_backend'read = readFun + , c'git_odb_backend'read_prefix = readPrefixFun + , c'git_odb_backend'readstream = nullFunPtr + , c'git_odb_backend'read_header = readHeaderFun + , c'git_odb_backend'write = writeFun + , c'git_odb_backend'writestream = nullFunPtr + , c'git_odb_backend'exists = existsFun + , c'git_odb_backend'free = traceBackendFreeCallbackPtr } + , traceNext = be } + +-- Trace.hs diff --git a/Data/Git/Blob.hs b/Data/Git/Blob.hs --- a/Data/Git/Blob.hs +++ b/Data/Git/Blob.hs @@ -1,24 +1,42 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternGuards #-} module Data.Git.Blob ( Blob(..) + , BlobContents(..) , newBlobBase , createBlob , getBlobContents + , blobSourceToString , writeBlob ) where import Data.ByteString as B hiding (map) import Data.ByteString.Unsafe +import Data.Conduit import Data.Git.Common -import Data.Git.Errors +import Data.Git.Error import Data.Git.Internal import qualified Prelude default (Text) +data BlobContents = BlobEmpty + | BlobString B.ByteString + | BlobStream ByteSource + +blobSourceToString :: BlobContents -> IO (Maybe B.ByteString) +blobSourceToString BlobEmpty = return Nothing +blobSourceToString (BlobString bs) = return (Just bs) +blobSourceToString (BlobStream bs) = do str <- bs $$ await + case str of + Nothing -> return Nothing + Just str' -> return (Just str') + data Blob = Blob { blobInfo :: Base Blob - , blobContents :: B.ByteString } + , blobContents :: BlobContents } instance Show Blob where show x = case gitId (blobInfo x) of @@ -45,38 +63,37 @@ | text == B.empty = error "Cannot create an empty blob" | otherwise = Blob { blobInfo = newBase repo (Pending doWriteBlob) Nothing - , blobContents = text } + , blobContents = BlobString text } lookupBlob :: Oid -> Repository -> IO (Maybe Blob) lookupBlob oid repo = lookupObject' oid repo c'git_blob_lookup c'git_blob_lookup_prefix $ \coid obj _ -> return Blob { blobInfo = newBase repo (Stored coid) (Just obj) - , blobContents = B.empty } + , blobContents = BlobEmpty } -getBlobContents :: Blob -> IO (Blob, B.ByteString) -getBlobContents b = - case gitId (blobInfo b) of - Pending _ -> return (b, contents) - Stored hash -> - if contents /= B.empty - then return (b, contents) - else - case gitObj (blobInfo b) of - Just blobPtr -> - withForeignPtr blobPtr $ \ptr -> do - size <- c'git_blob_rawsize (castPtr ptr) - buf <- c'git_blob_rawcontent (castPtr ptr) - bstr <- curry unsafePackCStringLen (castPtr buf) - (fromIntegral size) - return (b { blobContents = bstr }, bstr) +getBlobContents :: Blob -> IO (Blob, BlobContents) +getBlobContents b@(gitId . blobInfo -> Pending _) = return (b, blobContents b) +getBlobContents b@(gitId . blobInfo -> Stored hash) + | BlobEmpty <- contents = + case gitObj (blobInfo b) of + Just blobPtr -> + withForeignPtr blobPtr $ \ptr -> do + size <- c'git_blob_rawsize (castPtr ptr) + buf <- c'git_blob_rawcontent (castPtr ptr) + bstr <- curry unsafePackCStringLen (castPtr buf) + (fromIntegral size) + let contents' = BlobString bstr + return (b { blobContents = contents' }, contents' ) - Nothing -> do - b' <- lookupBlob (Oid hash) repo - case b' of - Just blobPtr' -> getBlobContents blobPtr' - Nothing -> return (b, B.empty) + Nothing -> do + b' <- lookupBlob (Oid hash) repo + case b' of + Just blobPtr' -> getBlobContents blobPtr' + Nothing -> return (b, BlobEmpty) + | otherwise = return (b, contents) + where repo = gitRepo (blobInfo b) contents = blobContents b @@ -86,8 +103,9 @@ writeBlob b@(Blob { blobInfo = Base { gitId = Stored _ } }) = return b writeBlob b = do hash <- doWriteBlob b return b { blobInfo = (blobInfo b) { gitId = Stored hash } - , blobContents = B.empty } + , blobContents = BlobEmpty } +-- jww (2012-12-14): Have the write functions return Either instead doWriteBlob :: Blob -> IO COid doWriteBlob b = do ptr <- mallocForeignPtr @@ -99,11 +117,17 @@ repo = fromMaybe (error "Repository invalid") (repoObj (gitRepo (blobInfo b))) - createFromBuffer ptr repoPtr = - unsafeUseAsCStringLen (blobContents b) $ - uncurry (\cstr len -> - withForeignPtr ptr $ \ptr' -> - c'git_blob_create_frombuffer - ptr' repoPtr (castPtr cstr) (fromIntegral len)) + createFromBuffer ptr repoPtr = do + str <- blobSourceToString (blobContents b) + case str of + Nothing -> throw BlobCreateFailed + Just str' -> createBlobFromByteString ptr repoPtr str' + + createBlobFromByteString ptr repoPtr bs = + unsafeUseAsCStringLen bs $ + uncurry (\cstr len -> + withForeignPtr ptr $ \ptr' -> + c'git_blob_create_frombuffer + ptr' repoPtr (castPtr cstr) (fromIntegral len)) -- Blob.hs diff --git a/Data/Git/Error.hs b/Data/Git/Error.hs new file mode 100644 --- /dev/null +++ b/Data/Git/Error.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Error types which may be thrown during Git operations, using +-- 'Control.Exception.throwIO'. +module Data.Git.Error + ( GitException(..), Result ) + where + +import Control.Exception +import Data.Typeable +import Data.Text +import Prelude hiding (FilePath) + +-- | There is a separate 'GitException' for each possible failure when +-- interacting with the Git repository. +data GitException = RepositoryNotExist String + | RepositoryInvalid + | BlobCreateFailed + | BlobEmptyCreateFailed + | TreeCreateFailed + | TreeBuilderCreateFailed + | TreeBuilderInsertFailed + | TreeBuilderWriteFailed + | TreeLookupFailed + | TreeCannotTraverseBlob + | TreeEntryLookupFailed + | CommitCreateFailed + | CommitLookupFailed + | ReferenceCreateFailed + | RefCannotCreateFromPartialOid + | ReferenceLookupFailed + | ObjectLookupFailed + | ObjectIdTooLong + | ObjectRefRequiresFullOid + | OidCopyFailed + deriving (Show, Typeable) + +type Result = Either Text + +instance Exception GitException + +-- Error.hs diff --git a/Data/Git/Errors.hs b/Data/Git/Errors.hs deleted file mode 100644 --- a/Data/Git/Errors.hs +++ /dev/null @@ -1,38 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} - --- | Error types which may be thrown during Git operations, using --- 'Control.Exception.throwIO'. -module Data.Git.Errors - ( GitException(..) ) - where - -import Control.Exception -import Data.Typeable -import Prelude hiding (FilePath) - --- | There is a separate 'GitException' for each possible failure when --- interacting with the Git repository. -data GitException = RepositoryNotExist String - | RepositoryInvalid - | BlobCreateFailed - | TreeCreateFailed - | TreeBuilderCreateFailed - | TreeBuilderInsertFailed - | TreeBuilderWriteFailed - | TreeLookupFailed - | TreeCannotTraverseBlob - | TreeEntryLookupFailed - | CommitCreateFailed - | CommitLookupFailed - | ReferenceCreateFailed - | RefCannotCreateFromPartialOid - | ReferenceLookupFailed - | ObjectLookupFailed - | ObjectIdTooLong - | ObjectRefRequiresFullOid - | OidCopyFailed - deriving (Show, Typeable) - -instance Exception GitException - --- Errors.hs diff --git a/Data/Git/Internal.hs b/Data/Git/Internal.hs --- a/Data/Git/Internal.hs +++ b/Data/Git/Internal.hs @@ -1,10 +1,12 @@ {-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} module Data.Git.Internal ( ObjPtr + , ByteSource , Updatable(..) @@ -30,10 +32,12 @@ import Control.Monad as X hiding (mapM, mapM_, sequence, sequence_, forM, forM_, msum) import Data.Bool as X +import Data.ByteString as B hiding (map) +import Data.Conduit import Data.Either as X hiding (lefts, rights) import Data.Foldable as X import Data.Function as X hiding ((.), id) -import Data.Git.Errors as X +import Data.Git.Error as X import Data.Git.Oid as X import Data.List as X hiding (foldl, foldl', foldl1, foldr1, foldl1', foldr, concat, maximum, minimum, @@ -58,13 +62,15 @@ import Foreign.StablePtr as X import Foreign.Storable as X import Prelude as X (undefined, error, otherwise, IO, Show, show, - Enum, Eq, Ord, (<), (==), (/=), round, + Enum, Eq, Ord, (<), (==), (/=), round, Int, Integer, fromIntegral, fromInteger, toInteger) import Unsafe.Coerce as X default (Text) type ObjPtr a = Maybe (ForeignPtr a) + +type ByteSource = GSource IO B.ByteString class Updatable a where getId :: a -> Ident a diff --git a/Data/Git/Object.hs b/Data/Git/Object.hs --- a/Data/Git/Object.hs +++ b/Data/Git/Object.hs @@ -2,6 +2,7 @@ module Data.Git.Object ( Object(..) + , ObjectType(..) , NamedRef(..) , revParse , lookupObject ) @@ -15,6 +16,8 @@ import Data.Git.Tree import qualified Data.Map as M +data ObjectType = BlobType | TreeType | CommitType | TagType + data Object = BlobObj Blob | TreeObj Tree | CommitObj Commit @@ -50,7 +53,7 @@ | typ == c'GIT_OBJ_BLOB = return $ BlobObj Blob { blobInfo = newBase repo (Stored coid) (Just obj) - , blobContents = B.empty } + , blobContents = BlobEmpty } | typ == c'GIT_OBJ_TREE = return $ TreeObj Tree { treeInfo = diff --git a/Data/Git/Oid.hs b/Data/Git/Oid.hs --- a/Data/Git/Oid.hs +++ b/Data/Git/Oid.hs @@ -6,6 +6,7 @@ module Data.Git.Oid ( Oid(..) , COid(..) + , oidToStr , ObjRef(..) , Ident(..) , wrapOidPtr @@ -15,24 +16,28 @@ , stringToOid ) where -import Bindings.Libgit2.Oid -import Control.Exception -import Control.Monad -import Data.ByteString.Unsafe -import Data.Git.Errors -import Data.Stringable as S -import Foreign.Ptr -import Foreign.ForeignPtr -import System.IO.Unsafe +import Bindings.Libgit2.Oid +import Control.Applicative +import Control.Exception +import Control.Monad +import qualified Data.ByteString.Char8 as BC +import Data.ByteString.Unsafe +import Data.Git.Error +import Data.Stringable as S +import Foreign.C.String +import Foreign.ForeignPtr +import Foreign.Ptr +import System.IO.Unsafe -- | 'COid' is a type wrapper for a foreign pointer to libgit2's 'git_oid' -- structure. Users should not have to deal with this type. newtype COid = COid (ForeignPtr C'git_oid) +oidToStr :: Ptr C'git_oid -> IO String +oidToStr = c'git_oid_allocfmt >=> peekCString + instance Show COid where - show (COid x) = - toString $ unsafePerformIO $ - withForeignPtr x (unsafePackMallocCString <=< c'git_oid_allocfmt) + show (COid coid) = unsafePerformIO $ withForeignPtr coid oidToStr -- | 'ObjRef' refers to either a Git object of a particular type (if it has -- already been loaded into memory), or it refers to the 'COid' of that diff --git a/Data/Git/Reference.hs b/Data/Git/Reference.hs --- a/Data/Git/Reference.hs +++ b/Data/Git/Reference.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} module Data.Git.Reference ( RefTarget(..) @@ -7,20 +8,28 @@ , createRef , lookupRef , listRefNames - , listAll + , allRefsFlag + , oidRefsFlag + , looseOidRefsFlag + , symbolicRefsFlag + , mapRefs + , mapAllRefs + , mapOidRefs + , mapLooseOidRefs + , mapSymbolicRefs , lookupId , writeRef , writeRef_ ) where import Bindings.Libgit2 -import Data.Git.Common +import Data.ByteString.Unsafe import Data.Git.Internal -import Data.Git.Object -import qualified Prelude -import Prelude ((+),(-)) import qualified Data.Text as T +import qualified Data.Text.Encoding as E import Foreign.Marshal.Array +import qualified Prelude +import Prelude ((+),(-)) default (Text) @@ -152,21 +161,42 @@ --packallRefs = c'git_reference_packall -data ListFlags = ListFlags { invalid :: Bool - , oid :: Bool - , symbolic :: Bool - , packed :: Bool - , hasPeel :: Bool } - deriving Show +data ListFlags = ListFlags { listFlagInvalid :: Bool + , listFlagOid :: Bool + , listFlagSymbolic :: Bool + , listFlagPacked :: Bool + , listFlagHasPeel :: Bool } + deriving (Show, Eq) -listAll :: ListFlags -listAll = ListFlags { invalid = False - , oid = True - , symbolic = True - , packed = True - , hasPeel = False } +allRefsFlag :: ListFlags +allRefsFlag = ListFlags { listFlagInvalid = False + , listFlagOid = True + , listFlagSymbolic = True + , listFlagPacked = True + , listFlagHasPeel = False } -gitStrArray2List :: Ptr C'git_strarray -> IO [ Text ] +symbolicRefsFlag :: ListFlags +symbolicRefsFlag = ListFlags { listFlagInvalid = False + , listFlagOid = False + , listFlagSymbolic = True + , listFlagPacked = False + , listFlagHasPeel = False } + +oidRefsFlag :: ListFlags +oidRefsFlag = ListFlags { listFlagInvalid = False + , listFlagOid = True + , listFlagSymbolic = False + , listFlagPacked = True + , listFlagHasPeel = False } + +looseOidRefsFlag :: ListFlags +looseOidRefsFlag = ListFlags { listFlagInvalid = False + , listFlagOid = True + , listFlagSymbolic = False + , listFlagPacked = False + , 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 @@ -175,15 +205,17 @@ r1 <- sequence $ fmap peekCString r0 return $ fmap T.pack r1 -listRefNames :: Repository -> ListFlags -> IO [ Text ] +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) + +listRefNames :: Repository -> ListFlags -> IO [Text] listRefNames repo flags = - let intFlags = (if oid flags then 1 else 0) - + (if symbolic flags then 2 else 0) - + (if packed flags then 4 else 0) - + (if hasPeel flags then 8 else 0) - in alloca $ \c'refs -> + alloca $ \c'refs -> withForeignPtr (repositoryPtr repo) $ \repoPtr -> do - r <- c'git_reference_list c'refs repoPtr intFlags + r <- c'git_reference_list c'refs repoPtr (flagsToInt flags) when (r < 0) $ throwIO ReferenceLookupFailed refs <- gitStrArray2List c'refs @@ -195,7 +227,52 @@ -- int git_reference_foreach(git_repository *repo, unsigned int list_flags, -- int (*callback)(const char *, void *), void *payload) ---foreachRef = c'git_reference_foreach +type ForeachRefCallback = Text -> IO () + +foreachRefCallbackThunk :: ForeachRefCallback -> CString -> Ptr () -> IO CInt +foreachRefCallbackThunk callback name _ = do + nameText <- E.decodeUtf8 <$> unsafePackCString name + callback nameText + return 0 + +mapRefs :: Repository -> ListFlags -> ForeachRefCallback -> IO () +mapRefs repo flags cb = + withForeignPtr (repositoryPtr repo) $ \repoPtr -> do + fun <- mk'git_reference_foreach_callback (foreachRefCallbackThunk cb) + r <- c'git_reference_foreach repoPtr (flagsToInt flags) fun nullPtr + -- jww (2012-12-14): Does the return type mean anything here? + when (r < 0) $ return () + return () + +mapAllRefs :: Repository -> ForeachRefCallback -> IO () +mapAllRefs repo = mapRefs repo allRefsFlag +mapOidRefs :: Repository -> ForeachRefCallback -> IO () +mapOidRefs repo = mapRefs repo oidRefsFlag +mapLooseOidRefs :: Repository -> ForeachRefCallback -> IO () +mapLooseOidRefs repo = mapRefs repo looseOidRefsFlag +mapSymbolicRefs :: Repository -> ForeachRefCallback -> IO () +mapSymbolicRefs repo = mapRefs repo symbolicRefsFlag + +{- +foreachRefCallbackThunk :: Storable a => + ForeachRefCallback a -> CString -> Ptr () -> IO CInt +foreachRefCallbackThunk callback name payload = do + nameText <- E.decodeUtf8 <$> unsafePackCString name + payloadValue <- peek (castPtr payload) + maybe (-1) (const 0) <$> callback nameText payloadValue + +mapRefsWith :: + Storable a => Repository -> ListFlags -> a -> ForeachRefCallback a -> IO () +mapRefsWith repo flags payload cb = + withForeignPtr (repositoryPtr repo) $ \repoPtr -> do + fun <- mk'git_reference_foreach_callback (foreachRefCallbackThunk cb) + with payload $ \payloadPtr -> do + r <- c'git_reference_foreach repoPtr (flagsToInt flags) fun + (castPtr payloadPtr) + -- jww (2012-12-14): Does the return type mean anything here? + when (r < 0) $ return () + return () +-} -- int git_reference_is_packed(git_reference *ref) diff --git a/Data/Git/Tree.hs b/Data/Git/Tree.hs --- a/Data/Git/Tree.hs +++ b/Data/Git/Tree.hs @@ -9,7 +9,7 @@ import Control.Concurrent.ParallelIO import Data.Git.Blob import Data.Git.Common -import Data.Git.Errors +import Data.Git.Error import Data.Git.Internal import qualified Data.Map as M import qualified Data.Text as T diff --git a/gitlib.cabal b/gitlib.cabal --- a/gitlib.cabal +++ b/gitlib.cabal @@ -1,5 +1,5 @@ Name: gitlib -Version: 0.5.0 +Version: 0.5.1 Synopsis: Higher-level types for working with hlibgit2 Description: Higher-level types for working with hlibgit2 License-file: LICENSE @@ -19,9 +19,9 @@ Type: exitcode-stdio-1.0 Main-is: Smoke.hs Hs-source-dirs: test - Ghc-options: -Wall -Werror Build-depends: base >=3 , gitlib + , hlibgit2 >= 0.17 , HUnit >= 1.2.5 , bytestring >= 0.9.2.1 , containers >= 0.4.2 @@ -38,7 +38,6 @@ Type: exitcode-stdio-1.0 Main-is: Doctest.hs Hs-source-dirs: test - Ghc-options: -Wall -Werror Build-depends: base == 4.* , directory >= 1.0 && < 1.3 , doctest >= 0.8 && <= 0.10 @@ -60,6 +59,7 @@ base >= 3 && < 5 , hlibgit2 >= 0.17 , bytestring >= 0.9.2.1 + , conduit >= 0.5.5 , containers >= 0.4.2 , lens >= 2.8 , parallel-io >= 0.3.2.1 @@ -71,15 +71,18 @@ , time >= 1.4 exposed-modules: Data.Git + Data.Git.Backend + Data.Git.Backend.Trace Data.Git.Blob Data.Git.Commit Data.Git.Common - Data.Git.Errors + Data.Git.Error Data.Git.Object Data.Git.Oid Data.Git.Repository Data.Git.Tag Data.Git.Tree Data.Git.Reference - other-modules: Data.Git.Internal + -- other-modules: + -- Data.Git.Internal diff --git a/test/Smoke.hs b/test/Smoke.hs --- a/test/Smoke.hs +++ b/test/Smoke.hs @@ -5,10 +5,13 @@ module Main where +import Bindings.Libgit2.OdbBackend import Control.Applicative import Control.Concurrent.ParallelIO import Control.Monad import Data.Git +import Data.Git.Backend +import Data.Git.Backend.Trace import Data.Maybe import Data.Text as T hiding (map) import qualified Data.Text.Encoding as E @@ -16,7 +19,12 @@ import Data.Traversable import Filesystem (removeTree, isDirectory) import Filesystem.Path.CurrentOS +import Foreign.C.String +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable import qualified Prelude +import Prelude (putStrLn) import Prelude hiding (FilePath, putStr, putStrLn) import System.Exit import Test.HUnit @@ -41,7 +49,10 @@ case obj of Just (BlobObj b) -> do (_, contents) <- getBlobContents b - return (E.decodeUtf8 contents) + str <- blobSourceToString contents + case str of + Nothing -> return T.empty + Just str' -> return (E.decodeUtf8 str') Just _ -> error "Found something else..." Nothing -> error "Didn't find anything :(" @@ -79,10 +90,10 @@ update_ $ createBlob (E.encodeUtf8 "Hello, world!\n") repo x <- catBlob repo "af5626b4a114abcb82d63db7c8082c3c4756e51b" - (@?=) x (Just "Hello, world!\n") + x @?= (Just "Hello, world!\n") x <- catBlob repo "af5626b" - (@?=) x (Just "Hello, world!\n") + x @?= (Just "Hello, world!\n") return () @@ -92,7 +103,7 @@ let hello = createBlob (E.encodeUtf8 "Hello, world!\n") repo tr <- updateTree "hello/world.txt" (blobRef hello) (createTree repo) x <- oid tr - (@?=) x "c0c848a2737a6a8533a18e6bd4d04266225e0271" + x @?= "c0c848a2737a6a8533a18e6bd4d04266225e0271" return() @@ -102,12 +113,12 @@ let hello = createBlob (E.encodeUtf8 "Hello, world!\n") repo tr <- updateTree "hello/world.txt" (blobRef hello) (createTree repo) x <- oid tr - (@?=) x "c0c848a2737a6a8533a18e6bd4d04266225e0271" + x @?= "c0c848a2737a6a8533a18e6bd4d04266225e0271" let goodbye = createBlob (E.encodeUtf8 "Goodbye, world!\n") repo tr <- updateTree "goodbye/files/world.txt" (blobRef goodbye) tr x <- oid tr - (@?=) x "98c3f387f63c08e1ea1019121d623366ff04de7a" + x @?= "98c3f387f63c08e1ea1019121d623366ff04de7a" return() @@ -117,19 +128,19 @@ let hello = createBlob (E.encodeUtf8 "Hello, world!\n") repo tr <- updateTree "hello/world.txt" (blobRef hello) (createTree repo) x <- oid tr - (@?=) x "c0c848a2737a6a8533a18e6bd4d04266225e0271" + x @?= "c0c848a2737a6a8533a18e6bd4d04266225e0271" let goodbye = createBlob (E.encodeUtf8 "Goodbye, world!\n") repo tr <- updateTree "goodbye/files/world.txt" (blobRef goodbye) tr x <- oid tr - (@?=) x "98c3f387f63c08e1ea1019121d623366ff04de7a" + x @?= "98c3f387f63c08e1ea1019121d623366ff04de7a" -- Confirm that deleting world.txt also deletes the now-empty subtree -- goodbye/files, which also deletes the then-empty subtree goodbye, -- returning us back the original tree. tr <- removeFromTree "goodbye/files/world.txt" tr x <- oid tr - (@?=) x "c0c848a2737a6a8533a18e6bd4d04266225e0271" + x @?= "c0c848a2737a6a8533a18e6bd4d04266225e0271" return() @@ -142,7 +153,7 @@ let goodbye = createBlob (E.encodeUtf8 "Goodbye, world!\n") repo tr <- updateTree "goodbye/files/world.txt" (blobRef goodbye) tr x <- oid tr - (@?=) x "98c3f387f63c08e1ea1019121d623366ff04de7a" + x @?= "98c3f387f63c08e1ea1019121d623366ff04de7a" -- The Oid has been cleared in tr, so this tests that it gets written as -- needed. @@ -152,20 +163,27 @@ , signatureWhen = posixSecondsToUTCTime 1348980883 } x <- oid $ sampleCommit repo tr sig - (@?=) x "44381a5e564d19893d783a5d5c59f9c745155b56" + x @?= "44381a5e564d19893d783a5d5c59f9c745155b56" return() , "createTwoCommits" ~: - withRepository "createTwoCommits.git" $ \repo -> do + withRepository "createTwoCommits.git" $ \repo -> alloca $ \loosePtr -> do + withCString "createTwoCommits.git/objects" $ \objectsDir -> 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' + odbBackendAdd repo backend 3 + let hello = createBlob (E.encodeUtf8 "Hello, world!\n") repo tr <- updateTree "hello/world.txt" (blobRef hello) (createTree repo) let goodbye = createBlob (E.encodeUtf8 "Goodbye, world!\n") repo tr <- updateTree "goodbye/files/world.txt" (blobRef goodbye) tr x <- oid tr - (@?=) x "98c3f387f63c08e1ea1019121d623366ff04de7a" + x @?= "98c3f387f63c08e1ea1019121d623366ff04de7a" -- The Oid has been cleared in tr, so this tests that it gets written as -- needed. @@ -175,12 +193,12 @@ , signatureWhen = posixSecondsToUTCTime 1348980883 } c = sampleCommit repo tr sig x <- oid c - (@?=) x "44381a5e564d19893d783a5d5c59f9c745155b56" + x @?= "44381a5e564d19893d783a5d5c59f9c745155b56" let goodbye2 = createBlob (E.encodeUtf8 "Goodbye, world again!\n") repo tr <- updateTree "goodbye/files/world.txt" (blobRef goodbye2) tr x <- oid tr - (@?=) x "f2b42168651a45a4b7ce98464f09c7ec7c06d706" + x @?= "f2b42168651a45a4b7ce98464f09c7ec7c06d706" let sig = Signature { signatureName = "John Wiegley" @@ -190,14 +208,16 @@ commitLog = "Second sample log message." , commitParents = [ObjRef c] } x <- oid c2 - (@?=) x "2506e7fcc2dbfe4c083e2bd741871e2e14126603" + x @?= "2506e7fcc2dbfe4c083e2bd741871e2e14126603" cid <- objectId c2 writeRef $ createRef "refs/heads/master" (RefTargetId cid) repo writeRef $ createRef "HEAD" (RefTargetSymbolic "refs/heads/master") repo x <- oidToText <$> lookupId "refs/heads/master" repo - (@?=) x "2506e7fcc2dbfe4c083e2bd741871e2e14126603" + x @?= "2506e7fcc2dbfe4c083e2bd741871e2e14126603" + + mapAllRefs repo (\name -> Prelude.putStrLn $ "Ref: " ++ unpack name) return()