git 0.1 → 0.2.0

raw patch · 22 files changed

+784/−407 lines, 22 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Data/Git/Diff.hs +37/−30
• Data/Git/Monad.hs +33/−31
• Data/Git/Named.hs +18/−13
• Data/Git/Parser.hs +6/−3
• Data/Git/Path.hs +2/−2
• Data/Git/Ref.hs +28/−16
• Data/Git/Repository.hs +42/−39
• Data/Git/Storage.hs +40/−35
• Data/Git/Storage/FileReader.hs +6/−1
• Data/Git/Storage/FileWriter.hs +7/−7
• Data/Git/Storage/Loose.hs +15/−15
• Data/Git/Storage/Object.hs +35/−34
• Data/Git/Storage/Pack.hs +49/−30
• Data/Git/Storage/PackIndex.hs +111/−99
• Data/Git/Types.hs +11/−11
• Data/Git/WorkTree.hs +39/−17
• Tests/Monad.hs +63/−0
• Tests/Repo.hs +67/−0
• Tests/Tests.hs +139/−0
• git.cabal +5/−4
• tests/Repo.hs +6/−2
• tests/Tests.hs +25/−18

@@ -31,9 +31,11 @@ import Data.Git import Data.Git.Repository import Data.Git.Storage+import Data.Git.Ref import Data.Git.Storage.Object import Data.ByteString.Lazy.Char8 as L +import Data.Typeable import Data.Algorithm.Patience as AP (Item(..), diff)  -- | represents a blob's content (i.e., the content of a file at a given@@ -43,10 +45,10 @@     deriving (Show)  -- | This is a blob description at a given state (revision)-data BlobState = BlobState+data BlobState hash = BlobState     { bsFilename :: EntPath     , bsMode     :: ModePerm-    , bsRef      :: Ref+    , bsRef      :: Ref hash     , bsContent  :: BlobContent     }     deriving (Show)@@ -54,18 +56,20 @@ -- | Two 'BlobState' are equal if they have the same filename, i.e., -- -- > ((BlobState x _ _ _) == (BlobState y _ _ _)) = (x == y)-instance Eq BlobState where+instance Eq (BlobState hash) where     (BlobState f1 _ _ _) == (BlobState f2 _ _ _) = f2 == f1  -- | Represents a file state between two revisions -- A file (a blob) can be present in the first Tree's revision but not in the -- second one, then it has been deleted. If only in the second Tree's revision, -- then it has been created. If it is in the both, maybe it has been changed.-data BlobStateDiff = OnlyOld   BlobState-                   | OnlyNew   BlobState-                   | OldAndNew BlobState BlobState+data BlobStateDiff hash =+      OnlyOld   (BlobState hash)+    | OnlyNew   (BlobState hash)+    | OldAndNew (BlobState hash) (BlobState hash) -buildListForDiff :: Git -> Ref -> IO [BlobState]+buildListForDiff :: (Typeable hash, HashAlgorithm hash)+                 => Git hash -> Ref hash -> IO [BlobState hash] buildListForDiff git ref = do     commit <- getCommit git ref     tree   <- resolveTreeish git $ commitTreeish commit@@ -74,7 +78,7 @@                      buildTreeList htree []         _      -> error "cannot build a tree from this reference"     where-        buildTreeList :: HTree -> EntPath -> IO [BlobState]+        --buildTreeList :: HTree hash -> EntPath -> IO [BlobState hash]         buildTreeList [] _ = return []         buildTreeList ((d,n,TreeFile r):xs) pathPrefix = do             content <- catBlobFile r@@ -88,7 +92,7 @@             l2 <- buildTreeList subTree (entPathAppend pathPrefix n)             return $ l1 ++ l2 -        catBlobFile :: Ref -> IO L.ByteString+        --catBlobFile :: Ref hash -> IO L.ByteString         catBlobFile blobRef = do             mobj <- getObjectRaw git blobRef True             case mobj of@@ -122,18 +126,19 @@ -- > getdiffwith f [] head^ head git -- >     where f (OnlyNew bs) acc = (bsFilename bs):acc -- >           f _            acc = acc-getDiffWith :: (BlobStateDiff -> a -> a) -- ^ diff helper (State -> accumulator -> accumulator)-            -> a                         -- ^ accumulator-            -> Ref                       -- ^ commit reference (the original state)-            -> Ref                       -- ^ commit reference (the new state)-            -> Git                       -- ^ repository+getDiffWith :: (Typeable hash, HashAlgorithm hash)+            => (BlobStateDiff hash -> a -> a) -- ^ diff helper (State -> accumulator -> accumulator)+            -> a                              -- ^ accumulator+            -> Ref hash                       -- ^ commit reference (the original state)+            -> Ref hash                       -- ^ commit reference (the new state)+            -> Git hash                       -- ^ repository             -> IO a getDiffWith f acc ref1 ref2 git = do     commit1 <- buildListForDiff git ref1     commit2 <- buildListForDiff git ref2     return $ Prelude.foldr f acc $ doDiffWith commit1 commit2     where-        doDiffWith :: [BlobState] -> [BlobState] -> [BlobStateDiff]+        doDiffWith :: [BlobState hash] -> [BlobState hash] -> [BlobStateDiff hash]         doDiffWith []        []        = []         doDiffWith [bs1]     []        = [OnlyOld bs1]         doDiffWith []        (bs2:xs2) = (OnlyNew bs2):(doDiffWith [] xs2)@@ -173,10 +178,11 @@                  | ModifiedMode   ModePerm ModePerm                  | UnModifiedMode ModePerm -data GitFileRef = NewRef        Ref-                | OldRef        Ref-                | ModifiedRef   Ref Ref-                | UnModifiedRef Ref+data GitFileRef hash =+      NewRef        (Ref hash)+    | OldRef        (Ref hash)+    | ModifiedRef   (Ref hash) (Ref hash)+    | UnModifiedRef (Ref hash)  -- | This is a proposed diff records for a given file. -- It contains useful information:@@ -184,29 +190,30 @@ --   * a file diff (with the Data.Algorithm.Patience method) --   * the file's mode (i.e. the file priviledge) --   * the file's ref-data GitDiff = GitDiff+data GitDiff hash = GitDiff     { hFileName    :: EntPath     , hFileContent :: GitFileContent     , hFileMode    :: GitFileMode-    , hFileRef     :: GitFileRef+    , hFileRef     :: GitFileRef hash     }  -- | A default Diff getter which returns all diff information (Mode, Content -- and Binary) with a context of 5 lines. -- -- > getDiff = getDiffWith (defaultDiff 5) []-getDiff :: Ref-        -> Ref-        -> Git-        -> IO [GitDiff]+getDiff :: (Typeable hash, HashAlgorithm hash)+        => Ref hash+        -> Ref hash+        -> Git hash+        -> IO [GitDiff hash] getDiff = getDiffWith (defaultDiff 5) []  -- | A default diff helper. It is an example about how you can write your own -- diff helper or you can use it if you want to get all of differences.-defaultDiff :: Int           -- ^ Number of line for context-            -> BlobStateDiff-            -> [GitDiff]     -- ^ Accumulator-            -> [GitDiff]     -- ^ Accumulator with a new content+defaultDiff :: Int                -- ^ Number of line for context+            -> BlobStateDiff hash+            -> [GitDiff hash]     -- ^ Accumulator+            -> [GitDiff hash]     -- ^ Accumulator with a new content defaultDiff _ (OnlyOld   old    ) acc =     let oldMode    = OldMode (bsMode old)         oldRef     = OldRef  (bsRef  old)@@ -229,7 +236,7 @@     in case (mode, ref) of            ((UnModifiedMode _), (UnModifiedRef _)) -> acc            _ -> (GitDiff (bsFilename new) (content ref) mode ref):acc-    where content :: GitFileRef -> GitFileContent+    where content :: GitFileRef hash -> GitFileContent           content (UnModifiedRef _) = UnModifiedFile           content _                 = createDiff (bsContent old) (bsContent new) 

@@ -85,6 +85,8 @@ import           Data.Git.Imports import           Data.Git.OS +import           Data.Git.Ref (SHA1)+ --import qualified Filesystem.Path as FP  import Data.Set (Set)@@ -107,8 +109,8 @@ -- > resolve "HEAD^^^" -- class Resolvable rev where-    resolve :: GitMonad m => rev -> m (Maybe Git.Ref)-instance Resolvable Git.Ref where+    resolve :: GitMonad m => rev -> m (Maybe (Git.Ref SHA1))+instance Resolvable (Git.Ref SHA1) where     resolve = return . Just instance Resolvable Git.Revision where     resolve rev = do@@ -127,13 +129,13 @@ -- package. class (Functor m, Applicative m, Monad m) => GitMonad m where     -- | the current Monad must allow access to the current Git-    getGit :: m Git.Git+    getGit :: m (Git.Git SHA1)     liftGit :: IO a -> m a  branchList :: GitMonad git => git (Set Git.RefName) branchList = getGit >>= liftGit . Git.branchList -branchWrite :: GitMonad git => Git.RefName -> Git.Ref -> git ()+branchWrite :: GitMonad git => Git.RefName -> Git.Ref SHA1 -> git () branchWrite rn ref = do     git <- getGit     liftGit $ Git.branchWrite git rn ref@@ -141,27 +143,27 @@ tagList :: GitMonad git => git (Set Git.RefName) tagList = getGit >>= liftGit . Git.tagList -tagWrite :: GitMonad git => Git.RefName -> Git.Ref -> git ()+tagWrite :: GitMonad git => Git.RefName -> Git.Ref SHA1 -> git () tagWrite rn ref = do     git <- getGit     liftGit $ Git.tagWrite git rn ref -headGet :: GitMonad git => git (Either Git.Ref Git.RefName)+headGet :: GitMonad git => git (Either (Git.Ref SHA1) Git.RefName) headGet = getGit >>= liftGit . Git.headGet -headResolv :: GitMonad git => git (Maybe Git.Ref)+headResolv :: GitMonad git => git (Maybe (Git.Ref SHA1)) headResolv = do     e <- headGet     case e of         Left ref -> resolve ref         Right v  -> resolve v -headSet :: GitMonad git => Either Git.Ref Git.RefName -> git ()+headSet :: GitMonad git => Either (Git.Ref SHA1) Git.RefName -> git () headSet e = do     git <- getGit     liftGit $ Git.headSet git e -getCommit :: (GitMonad git, Resolvable ref) => ref -> git (Maybe Git.Commit)+getCommit :: (GitMonad git, Resolvable ref) => ref -> git (Maybe (Git.Commit SHA1)) getCommit r = do     mRef <- resolve r     case mRef of@@ -170,7 +172,7 @@             git <- getGit             liftGit $ Git.getCommitMaybe git ref -setObject :: (GitMonad git, Git.Objectable obj) => obj -> git Git.Ref+setObject :: (GitMonad git, Git.Objectable obj) => obj SHA1 -> git (Git.Ref SHA1) setObject obj = do     git <- getGit     liftGit $ Git.setObject git $ Git.toObject obj@@ -178,7 +180,7 @@ getObject :: (GitMonad git, Resolvable ref)           => ref           -> Bool-          -> git (Maybe Git.Object)+          -> git (Maybe (Git.Object SHA1)) getObject rev resolvDelta = do     git <- getGit     mRef <- resolve rev@@ -186,13 +188,13 @@         Nothing  -> return Nothing         Just ref -> liftGit $ Git.getObject git ref resolvDelta -workTreeNew :: GitMonad git => git Git.WorkTree+workTreeNew :: GitMonad git => git (Git.WorkTree hash) workTreeNew = liftGit Git.workTreeNew -workTreeFrom :: GitMonad git => Git.Ref -> git Git.WorkTree+workTreeFrom :: GitMonad git => Git.Ref hash -> git (Git.WorkTree hash) workTreeFrom ref = liftGit $ Git.workTreeFrom ref -workTreeFlush :: GitMonad git => Git.WorkTree -> git Git.Ref+workTreeFlush :: GitMonad git => Git.WorkTree SHA1 -> git (Git.Ref SHA1) workTreeFlush tree = do     git <- getGit     liftGit $ Git.workTreeFlush git tree@@ -200,7 +202,7 @@ resolvPath :: (GitMonad git, Resolvable ref)            => ref -- ^ the commit Ref, Revision ("master", "HEAD^^" or a ref...)            -> Git.EntPath-           -> git (Maybe Git.Ref)+           -> git (Maybe (Git.Ref SHA1)) resolvPath commitRev entPath = do     git <- getGit     mRef <- resolve commitRev@@ -221,7 +223,7 @@ -------------------------------------------------------------------------------  data GitContext = GitContext-    { gitContextGit  :: !Git.Git+    { gitContextGit  :: !(Git.Git SHA1)     }  newtype GitM a = GitM@@ -267,13 +269,13 @@ failGitM :: String -> GitM a failGitM msg = GitM $ \_ -> return (ResultFailure msg) -getGitM :: GitM Git.Git+getGitM :: GitM (Git.Git SHA1) getGitM = GitM $ \ctx -> return (ResultSuccess ctx (gitContextGit ctx))  liftGitM :: IO a -> GitM a liftGitM f = GitM $ \ctx -> ResultSuccess ctx <$> f -executeGitM :: Git.Git -> GitM a -> IO (Either String a)+executeGitM :: Git.Git SHA1 -> GitM a -> IO (Either String a) executeGitM git m = do     r <- runGitM m $ GitContext git     return $ case r of@@ -292,8 +294,8 @@ -------------------------------------------------------------------------------  data CommitAccessContext = CommitAccessContext-    { commitAccessContextCommit :: !Git.Commit-    , commitAccessContextRef    :: !Git.Ref+    { commitAccessContextCommit :: !(Git.Commit SHA1)+    , commitAccessContextRef    :: !(Git.Ref SHA1)     }  -- | ReadOnly operations on a given commit@@ -340,7 +342,7 @@ failCommitAccessM :: String -> CommitAccessM a failCommitAccessM msg = CommitAccessM $ \_ -> return (ResultFailure msg) -getCommitAccessM :: CommitAccessM Git.Git+getCommitAccessM :: CommitAccessM (Git.Git SHA1) getCommitAccessM = CommitAccessM $ \ctx -> ResultSuccess ctx <$> getGit  liftCommitAccessM :: IO a -> CommitAccessM a@@ -358,7 +360,7 @@ getCommitter :: CommitAccessM Git.Person getCommitter = withCommitAccessContext (Git.commitCommitter . commitAccessContextCommit) -getParents :: CommitAccessM [Git.Ref]+getParents :: CommitAccessM [Git.Ref SHA1] getParents = withCommitAccessContext (Git.commitParents . commitAccessContextCommit)  getExtras :: CommitAccessM [Git.CommitExtra]@@ -370,10 +372,10 @@ getMessage :: CommitAccessM ByteString getMessage = withCommitAccessContext (Git.commitMessage . commitAccessContextCommit) -getContextRef_ :: CommitAccessM Git.Ref+getContextRef_ :: CommitAccessM (Git.Ref SHA1) getContextRef_ = withCommitAccessContext commitAccessContextRef -getContextObject_ :: Git.EntPath -> CommitAccessM (Maybe Git.Object)+getContextObject_ :: Git.EntPath -> CommitAccessM (Maybe (Git.Object SHA1)) getContextObject_ fp = do     commitRef <- getContextRef_     mRef <- resolvPath commitRef fp@@ -451,11 +453,11 @@ data CommitContext = CommitContext     { commitContextAuthor    :: !Git.Person     , commitContextCommitter :: !Git.Person-    , commitContextParents   :: ![Git.Ref]+    , commitContextParents   :: ![Git.Ref SHA1]     , commitContextExtras    :: ![Git.CommitExtra]     , commitContextEncoding  :: !(Maybe ByteString)     , commitContextMessage   :: !ByteString-    , commitContextTree      :: !Git.WorkTree+    , commitContextTree      :: !(Git.WorkTree SHA1)     }  newtype CommitM  a = CommitM@@ -501,7 +503,7 @@ failCommitM :: String -> CommitM a failCommitM msg = CommitM $ \_ -> return (ResultFailure msg) -getCommitM :: CommitM Git.Git+getCommitM :: CommitM (Git.Git SHA1) getCommitM = CommitM $ \ctx -> ResultSuccess ctx <$> getGit  liftCommitM :: IO a -> CommitM a@@ -523,7 +525,7 @@ setCommitter p = commitUpdateContext $ \ctx -> return (ctx { commitContextCommitter = p }, ())  -- | replace the Commit's Parents-setParents :: [Git.Ref] -> CommitM ()+setParents :: [Git.Ref SHA1] -> CommitM () setParents l = commitUpdateContext $ \ctx -> return (ctx { commitContextParents = l }, ())  -- | replace the Commit's Extras@@ -540,7 +542,7 @@  setContextObject_ :: Git.Objectable object                   => Git.EntPath-                  -> (Git.EntType, object)+                  -> (Git.EntType, object SHA1)                   -> CommitM () setContextObject_ path (t, obj) = do     ref <- setObject obj@@ -608,7 +610,7 @@               -> CommitM a                 -- ^ the action to perform in the new commit (set files,                 -- Person, encoding or extras)-              -> git (Git.Ref, a)+              -> git (Git.Ref SHA1, a) withNewCommit p mPrec m = do     workTree <- case mPrec of                     Nothing -> workTreeNew@@ -687,7 +689,7 @@                 -- the argument is the result of the action on the parent commit.                 --                 -- Nothing if the parent does not exist.-           -> git (Git.Ref, b)+           -> git (Git.Ref SHA1, b) withBranch p branchName keepTree actionParent actionNew = do     -- attempt to resolve the branch     mRefParent <- resolve branchName

@@ -49,10 +49,11 @@                deriving (Show,Eq,Ord)  -- | content of a ref file.-data RefContentTy = RefDirect Ref-                  | RefLink   RefSpecTy-                  | RefContentUnknown B.ByteString-                  deriving (Show,Eq)+data RefContentTy hash =+      RefDirect (Ref hash)+    | RefLink   RefSpecTy+    | RefContentUnknown B.ByteString+    deriving (Show,Eq)  newtype RefName = RefName { refNameRaw :: String }     deriving (Show,Eq,Ord)@@ -108,8 +109,9 @@     , packedTags    :: a     } -readPackedRefs :: LocalPath-               -> ([(RefName, Ref)] -> a)+readPackedRefs :: HashAlgorithm hash+               => LocalPath+               -> ([(RefName, Ref hash)] -> a)                -> IO (PackedRefs a) readPackedRefs gitRepo constr = do     exists <- isFile (packedRefsPath gitRepo)@@ -120,13 +122,13 @@         accu a l             | "#" `BC.isPrefixOf` l = a             | otherwise =-                let (ref, r) = B.splitAt 40 l+                let (ref, r) = consumeHexRef hashAlg l                     name     = UTF8.toString $ B.tail r                  in case toRefTy name of                         -- accumulate tag, branch and remotes-                        RefTag refname    -> a { packedTags    = (refname, fromHex ref) : packedTags a }-                        RefBranch refname -> a { packedBranchs = (refname, fromHex ref) : packedBranchs a }-                        RefRemote refname -> a { packedRemotes = (refname, fromHex ref) : packedRemotes a }+                        RefTag refname    -> a { packedTags    = (refname, ref) : packedTags a }+                        RefBranch refname -> a { packedBranchs = (refname, ref) : packedBranchs a }+                        RefRemote refname -> a { packedRemotes = (refname, ref) : packedRemotes a }                         -- anything else that shouldn't be there get dropped on the floor                         _                 -> a @@ -160,7 +162,7 @@ existsRefFile :: LocalPath -> RefSpecTy -> IO Bool existsRefFile gitRepo specty = isFile $ toPath gitRepo specty -writeRefFile :: LocalPath -> RefSpecTy -> RefContentTy -> IO ()+writeRefFile :: LocalPath -> RefSpecTy -> RefContentTy hash -> IO () writeRefFile gitRepo specty refcont = do     createParentDirectory filepath     writeBinaryFile filepath $ fromRefContent refcont@@ -169,10 +171,13 @@           fromRefContent (RefDirect ref)       = B.concat [toHex ref, B.singleton 0xa]           fromRefContent (RefContentUnknown c) = c -readRefFile :: LocalPath -> RefSpecTy -> IO RefContentTy+readRefFile :: HashAlgorithm hash => LocalPath -> RefSpecTy -> IO (RefContentTy hash) readRefFile gitRepo specty = toRefContent <$> readBinaryFile filepath     where filepath = toPath gitRepo specty           toRefContent content             | "ref: " `B.isPrefixOf` content = RefLink $ toRefTy $ UTF8.toString $ head $ BC.lines $ B.drop 5 content-            | B.length content < 42          = RefDirect $ fromHex $ B.take 40 content+            | B.length content < 42          = RefDirect $ fst $ consumeHexRef hashAlg content             | otherwise                      = RefContentUnknown content++consumeHexRef :: HashAlgorithm hash => hash -> B.ByteString -> (Ref hash, B.ByteString)+consumeHexRef alg b = let (b1,b2) = B.splitAt (hashDigestSize alg * 2) b in (fromHex b1, b2)

@@ -56,10 +56,13 @@ word32 :: Parser Word32 word32 = be32 <$> P.take 4 -ref, referenceBin, referenceHex :: Parser Ref+ref, referenceBin, referenceHex :: HashAlgorithm hash => Parser (Ref hash) ref = referenceBin-referenceBin = fromBinary <$> P.take 20-referenceHex = fromHex <$> P.take 40+referenceBin = takeDigestSize hashAlg 1 fromBinary+referenceHex = takeDigestSize hashAlg 2 fromHex++takeDigestSize :: HashAlgorithm hash => hash -> Int -> (B.ByteString -> Ref hash) -> Parser (Ref hash)+takeDigestSize alg modifier constr = constr <$> P.take (modifier * hashDigestSize alg)  decimal :: (Read n, Num n) => Parser n decimal = toNum <$> P.takeWhile (\x -> isDigit $ toEnum (fromIntegral x))

@@ -34,7 +34,7 @@ packDirPath :: LocalPath -> LocalPath packDirPath repoPath = repoPath </> "objects" </> "pack" -indexPath, packPath :: LocalPath -> Ref -> LocalPath+indexPath, packPath :: LocalPath -> Ref hash -> LocalPath indexPath repoPath indexRef =         packDirPath repoPath </> fromString ("pack-" ++ toHexString indexRef ++ ".idx") @@ -44,7 +44,7 @@ objectPath :: LocalPath -> String -> String -> LocalPath objectPath repoPath d f = repoPath </> "objects" </> fromString d </> fromString f -objectPathOfRef :: LocalPath -> Ref -> LocalPath+objectPathOfRef :: HashAlgorithm hash => LocalPath -> Ref hash -> LocalPath objectPathOfRef repoPath ref = objectPath repoPath d f         where (d,f) = toFilePathParts ref 

@@ -8,6 +8,9 @@ {-# LANGUAGE DeriveDataTypeable #-} module Data.Git.Ref     ( Ref+    , SHA1+    , Crypto.Hash.HashAlgorithm+    , Crypto.Hash.hashDigestSize     -- * Exceptions     , RefInvalid(..)     , RefNotFound(..)@@ -28,6 +31,8 @@     -- * Hash ByteString types to a ref     , hash     , hashLBS+    , hashAlg+    , hashAlgFromRef     ) where  import qualified Crypto.Hash@@ -45,10 +50,10 @@ import Control.Exception (Exception, throw)  -- | represent a git reference (SHA1)-newtype Ref = Ref (Digest SHA1)+newtype Ref hash = Ref (Digest hash)     deriving (Eq,Ord,Typeable) -instance Show Ref where+instance Show (Ref hash) where     show = BC.unpack . toHex  -- | Invalid Reference exception raised when@@ -57,11 +62,11 @@     deriving (Show,Eq,Data,Typeable)  -- | Reference wasn't found-data RefNotFound = RefNotFound Ref+data RefNotFound hash = RefNotFound (Ref hash)     deriving (Show,Eq,Typeable)  instance Exception RefInvalid-instance Exception RefNotFound+instance Typeable hash => Exception (RefNotFound hash)  isHex :: ByteString -> Bool isHex = and . map isHexDigit . BC.unpack@@ -71,7 +76,7 @@  -- | take a hexadecimal bytestring that represent a reference -- and turn into a ref-fromHex :: ByteString -> Ref+fromHex :: Crypto.Hash.HashAlgorithm hash => ByteString -> Ref hash fromHex s =     case either (const Nothing) Just (convertFromBase Base16 s :: Either String ByteString) >>= digestFromByteString of         Nothing  -> throw $ RefInvalid s@@ -79,47 +84,54 @@  -- | take a hexadecimal string that represent a reference -- and turn into a ref-fromHexString :: String -> Ref+fromHexString :: Crypto.Hash.HashAlgorithm hash => String -> Ref hash fromHexString = fromHex . BC.pack  -- | transform a ref into an hexadecimal bytestring-toHex :: Ref -> ByteString+toHex :: Ref hash -> ByteString toHex (Ref bs) = convertToBase Base16 bs  -- | transform a ref into an hexadecimal string-toHexString :: Ref -> String+toHexString :: Ref hash -> String toHexString (Ref d) = show d  -- | transform a bytestring that represent a binary bytestring -- and returns a ref.-fromBinary :: ByteString -> Ref+fromBinary :: Crypto.Hash.HashAlgorithm hash => ByteString -> Ref hash fromBinary b = maybe (throw $ RefInvalid b) Ref $ digestFromByteString b  -- | transform a bytestring that represent a binary bytestring -- and returns a ref.-fromDigest :: Digest SHA1 -> Ref+fromDigest :: Crypto.Hash.HashAlgorithm hash => Digest hash -> Ref hash fromDigest = Ref  -- | turn a reference into a binary bytestring-toBinary :: Ref -> ByteString+toBinary :: Ref hash -> ByteString toBinary (Ref b) = B.convert b  -- | returns the prefix (leading byte) of this reference-refPrefix :: Ref -> Int+refPrefix :: Ref hash -> Int refPrefix (Ref b) = fromIntegral $ B.unsafeIndex (B.convert b) 0  -- | compare prefix-cmpPrefix :: String -> Ref -> Ordering+cmpPrefix :: String -> Ref hash -> Ordering cmpPrefix pre ref = pre `compare` (take (length pre) $ toHexString ref)  -- | returns the splitted format "prefix/suffix" for addressing the loose object database-toFilePathParts :: Ref -> (String, String)+toFilePathParts :: Ref hash -> (String, String) toFilePathParts ref = splitAt 2 $ show ref  -- | hash a bytestring into a reference-hash :: ByteString -> Ref+hash :: Crypto.Hash.HashAlgorithm hash => ByteString -> Ref hash hash = Ref . Crypto.Hash.hash  -- | hash a lazy bytestring into a reference-hashLBS :: L.ByteString -> Ref+hashLBS :: Crypto.Hash.HashAlgorithm hash => L.ByteString -> Ref hash hashLBS = Ref . Crypto.Hash.hashlazy++-- | Any hash algorithm+hashAlg :: Crypto.Hash.HashAlgorithm hash => hash+hashAlg = error "polymorphic hash algorithm. only to use with hashDigestSize"++hashAlgFromRef :: Crypto.Hash.HashAlgorithm hash => Ref hash -> hash+hashAlgFromRef _ = hashAlg

@@ -64,15 +64,15 @@ import qualified Data.Set as Set  -- | hierarchy tree, either a reference to a blob (file) or a tree (directory).-data HTreeEnt = TreeDir Ref HTree | TreeFile Ref-type HTree = [(ModePerm,EntName,HTreeEnt)]+data HTreeEnt hash = TreeDir (Ref hash) (HTree hash) | TreeFile (Ref hash)+type HTree hash = [(ModePerm,EntName,HTreeEnt hash)]  -- | Exception when trying to convert an object pointed by 'Ref' to -- a type that is different-data InvalidType = InvalidType Ref ObjectType-                 deriving (Show,Eq,Typeable)+data InvalidType hash = InvalidType (Ref hash) ObjectType+    deriving (Show,Eq,Typeable) -instance Exception InvalidType+instance Typeable hash => Exception (InvalidType hash)  -- should be a standard function that do that... mapJustM :: Monad m => (t -> m (Maybe a)) -> Maybe t -> m (Maybe a)@@ -80,26 +80,26 @@ mapJustM _ Nothing  = return Nothing  -- | get a specified commit-getCommitMaybe :: Git -> Ref -> IO (Maybe Commit)+getCommitMaybe :: HashAlgorithm hash => Git hash -> Ref hash -> IO (Maybe (Commit hash)) getCommitMaybe git ref = maybe Nothing objectToCommit <$> getObject git ref True  -- | get a specified commit but raises an exception if doesn't exists or type is not appropriate-getCommit :: Git -> Ref -> IO Commit+getCommit :: (Typeable hash, HashAlgorithm hash) => Git hash -> Ref hash -> IO (Commit hash) getCommit git ref = maybe err id . objectToCommit <$> getObject_ git ref True   where err = throw $ InvalidType ref TypeCommit  -- | get a specified tree-getTreeMaybe :: Git -> Ref -> IO (Maybe Tree)+getTreeMaybe :: HashAlgorithm hash => Git hash -> Ref hash -> IO (Maybe (Tree hash)) getTreeMaybe git ref = maybe Nothing objectToTree <$> getObject git ref True  -- | get a specified tree but raise-getTree :: Git -> Ref -> IO Tree+getTree :: (Typeable hash, HashAlgorithm hash) => Git hash -> Ref hash -> IO (Tree hash) getTree git ref = maybe err id . objectToTree <$> getObject_ git ref True   where err = throw $ InvalidType ref TypeTree  -- | try to resolve a string to a specific commit ref -- for example: HEAD, HEAD^, master~3, shortRef-resolveRevision :: Git -> Revision -> IO (Maybe Ref)+resolveRevision :: (Typeable hash, HashAlgorithm hash) => Git hash -> Revision -> IO (Maybe (Ref hash)) resolveRevision git (Revision prefix modifiers) =     getCacheVal (packedNamed git) >>= \c -> resolvePrefix c >>= maybe (return Nothing) (modf modifiers)   where@@ -131,7 +131,7 @@                              "FETCH_HEAD" -> [ RefFetchHead ]                              _            -> map (flip ($) (RefName prefix)) [RefTag,RefBranch,RefRemote] -        tryResolvers :: [IO (Maybe Ref)] -> IO (Maybe Ref)+        tryResolvers :: HashAlgorithm hash => [IO (Maybe (Ref hash))] -> IO (Maybe (Ref hash))         tryResolvers []            = return $ if (isHexString prefix)             then Just $ fromHexString prefix             else Nothing@@ -139,7 +139,7 @@            where isResolved (Just r) = return (Just r)                  isResolved Nothing  = tryResolvers xs -        resolvePrePrefix :: IO (Maybe Ref)+        --resolvePrePrefix :: HashAlgorithm hash => IO (Maybe (Ref hash))         resolvePrePrefix             | not (isHexString prefix) = return Nothing             | otherwise = do@@ -167,7 +167,7 @@         getParentRefs ref = commitParents <$> getCommit git ref  -- | returns a tree from a ref that might be either a commit, a tree or a tag.-resolveTreeish :: Git -> Ref -> IO (Maybe Tree)+resolveTreeish :: HashAlgorithm hash => Git hash -> Ref hash -> IO (Maybe (Tree hash)) resolveTreeish git ref = getObject git ref True >>= mapJustM recToTree   where recToTree (objectToCommit -> Just (Commit { commitTreeish = tree })) = resolveTreeish git tree         recToTree (objectToTag    -> Just (Tag tref _ _ _ _))    = resolveTreeish git tref@@ -188,16 +188,17 @@ -- --          a <-- f(b) <-- f(c) <-- f(d) ---rewrite :: Git                   -- ^ Repository-        -> (Commit -> IO Commit) -- ^ Mapping function-        -> Revision              -- ^ revision to start from-        -> Int                   -- ^ the number of parents to map-        -> IO Ref                -- ^ return the new head REF+rewrite :: (Typeable hash, HashAlgorithm hash)+        => Git hash                          -- ^ Repository+        -> (Commit hash -> IO (Commit hash)) -- ^ Mapping function+        -> Revision                          -- ^ revision to start from+        -> Int                               -- ^ the number of parents to map+        -> IO (Ref hash)                     -- ^ return the new head REF rewrite git mapCommit revision nbParent = do     ref <- fromMaybe (error "revision cannot be found") <$> resolveRevision git revision     resolveParents nbParent ref >>= process . reverse -  where resolveParents :: Int -> Ref -> IO [ (Ref, Commit) ]+  where --resolveParents :: Int -> Ref hash -> IO [ (Ref hash, Commit hash) ]         resolveParents 0 ref = (:[]) . (,) ref <$> getCommit git ref         resolveParents n ref = do commit <- getCommit git ref                                   case commitParents commit of@@ -215,7 +216,7 @@                     rewriteOne ref next  -- | build a hierarchy tree from a tree object-buildHTree :: Git -> Tree -> IO HTree+buildHTree :: (Typeable hash, HashAlgorithm hash) => Git hash -> Tree hash -> IO (HTree hash) buildHTree git (Tree ents) = mapM resolveTree ents   where resolveTree (perm, ent, ref) = do             obj <- getObjectType git ref@@ -228,13 +229,14 @@                 Nothing       -> error "unknown reference in tree object"  -- | resolve the ref (tree or blob) related to a path at a specific commit ref-resolvePath :: Git     -- ^ repository-            -> Ref     -- ^ commit reference-            -> EntPath -- ^ paths-            -> IO (Maybe Ref)+resolvePath :: (Typeable hash, HashAlgorithm hash)+            => Git hash  -- ^ repository+            -> Ref hash  -- ^ commit reference+            -> EntPath   -- ^ paths+            -> IO (Maybe (Ref hash)) resolvePath git commitRef paths =     getCommit git commitRef >>= \commit -> resolve (commitTreeish commit) paths-  where resolve :: Ref -> EntPath -> IO (Maybe Ref)+  where --resolve :: Ref -> EntPath -> IO (Maybe Ref)         resolve treeRef []     = return $ Just treeRef         resolve treeRef (x:xs) = do             (Tree ents) <- getTree git treeRef@@ -247,38 +249,38 @@         treeEntRef (_,_,r) = r  -- | Write a branch to point to a specific reference-branchWrite :: Git     -- ^ repository-            -> RefName -- ^ the name of the branch to write-            -> Ref     -- ^ the reference to set+branchWrite :: Git hash -- ^ repository+            -> RefName  -- ^ the name of the branch to write+            -> Ref hash -- ^ the reference to set             -> IO () branchWrite git branchName ref =     writeRefFile (gitRepoPath git) (RefBranch branchName) (RefDirect ref)  -- | Return the list of branches-branchList :: Git -> IO (Set RefName)+branchList :: Git hash -> IO (Set RefName) branchList git = do     ps <- Set.fromList . M.keys . packedBranchs <$> getCacheVal (packedNamed git)     ls <- Set.fromList <$> looseHeadsList (gitRepoPath git)     return $ Set.union ps ls  -- | Write a tag to point to a specific reference-tagWrite :: Git     -- ^ repository-         -> RefName -- ^ the name of the tag to write-         -> Ref     -- ^ the reference to set+tagWrite :: Git hash -- ^ repository+         -> RefName  -- ^ the name of the tag to write+         -> Ref hash -- ^ the reference to set          -> IO () tagWrite git tagname ref =     writeRefFile (gitRepoPath git) (RefTag tagname) (RefDirect ref)  -- | Return the list of branches-tagList :: Git -> IO (Set RefName)+tagList :: Git hash -> IO (Set RefName) tagList git = do     ps <- Set.fromList . M.keys . packedTags <$> getCacheVal (packedNamed git)     ls <- Set.fromList <$> looseTagsList (gitRepoPath git)     return $ Set.union ps ls  -- | Set head to point to either a reference or a branch name.-headSet :: Git                -- ^ repository-        -> Either Ref RefName -- ^ either a raw reference or a branch name+headSet :: Git hash                  -- ^ repository+        -> Either (Ref hash) RefName -- ^ either a raw reference or a branch name         -> IO () headSet git (Left ref)      =     writeRefFile (gitRepoPath git) RefHead (RefDirect ref)@@ -286,8 +288,9 @@     writeRefFile (gitRepoPath git) RefHead (RefLink $ RefBranch refname)  -- | Get what the head is pointing to, or the reference otherwise-headGet :: Git-        -> IO (Either Ref RefName)+headGet :: HashAlgorithm hash+        => Git hash+        -> IO (Either (Ref hash) RefName) headGet git = do     content <- readRefFile (gitRepoPath git) RefHead     case content of@@ -297,7 +300,7 @@         RefContentUnknown bs  -> error ("unknown content in HEAD: " ++ show bs)  -- | Read the Config-configGetAll :: Git -> IO [Config]+configGetAll :: Git hash -> IO [Config] configGetAll git = readIORef (configs git)  -- | Get a configuration element from the config file, starting from the@@ -307,7 +310,7 @@ -- -- > configGet git "user" "name" ---configGet :: Git               -- ^ Git context+configGet :: Git hash          -- ^ Git context           -> String            -- ^ section name           -> String            -- ^ key name           -> IO (Maybe String) -- ^ The resulting value if it exists

@@ -49,6 +49,7 @@ import Data.Either (partitionEithers) import Data.IORef import Data.Word+import Data.Typeable  import Data.Git.Named import Data.Git.Imports@@ -70,20 +71,20 @@ data PackIndexReader = PackIndexReader PackIndexHeader FileReader  -- | this is a cache representation of the packed-ref file-type CachedPackedRef = CacheFile (PackedRefs (M.Map RefName Ref))+type CachedPackedRef hash = CacheFile (PackedRefs (M.Map RefName (Ref hash)))  -- | represent a git repo, with possibly already opened filereaders -- for indexes and packs-data Git = Git+data Git hash = Git     { gitRepoPath  :: LocalPath-    , indexReaders :: IORef [(Ref, PackIndexReader)]-    , packReaders  :: IORef [(Ref, FileReader)]-    , packedNamed  :: CachedPackedRef+    , indexReaders :: IORef [(Ref hash, PackIndexReader)]+    , packReaders  :: IORef [(Ref hash, FileReader)]+    , packedNamed  :: CachedPackedRef hash     , configs      :: IORef [Config]     }  -- | open a new git repository context-openRepo :: LocalPath -> IO Git+openRepo :: LocalPath -> IO (Git SHA1) openRepo path = Git path <$> newIORef []                          <*> newIORef []                          <*> packedRef@@ -97,7 +98,7 @@             return $ snd $ partitionEithers [local,global]  -- | close a git repository context, closing all remaining fileReaders.-closeRepo :: Git -> IO ()+closeRepo :: Git hash -> IO () closeRepo (Git { indexReaders = ireaders, packReaders = preaders }) = do     mapM_ (closeIndexReader . snd) =<< readIORef ireaders     mapM_ (fileReaderClose . snd) =<< readIORef preaders@@ -141,13 +142,13 @@             if e then return filepath else checkDir (n+1) (if absolute wd then parent wd else wd </> "..")  -- | execute a function f with a git context.-withRepo :: LocalPath -> (Git -> IO c) -> IO c+withRepo :: LocalPath -> (Git SHA1 -> IO c) -> IO c withRepo path f = bracket (openRepo path) closeRepo f  -- | execute a function on the current repository. -- -- check findRepo to see how the git repository is found.-withCurrentRepo :: (Git -> IO a) -> IO a+withCurrentRepo :: (Git SHA1 -> IO a) -> IO a withCurrentRepo f = findRepo >>= \path -> withRepo path f  -- | basic checks to see if a specific path looks like a git repo.@@ -172,7 +173,7 @@         , "refs"</> "heads", "refs"</> "tags"]  -- | read the repository's description-getDescription :: Git -> IO (Maybe String)+getDescription :: Git hash -> IO (Maybe String) getDescription git = do     isdescription <- isFile descriptionPath     if (isdescription)@@ -183,13 +184,14 @@   where descriptionPath = (gitRepoPath git) </> "description"  -- | set the repository's description-setDescription :: Git -> String -> IO ()+setDescription :: Git hash -> String -> IO () setDescription git desc = do     writeTextFile descriptionPath desc   where descriptionPath = (gitRepoPath git) </> "description" -iterateIndexes :: Git-               -> (b -> (Ref, PackIndexReader) -> IO (b, Bool))+iterateIndexes :: HashAlgorithm hash+               => Git hash+               -> (b -> (Ref hash, PackIndexReader) -> IO (b, Bool))                -> b -> IO b iterateIndexes git f initAcc = do     allIndexes    <- packIndexEnumerate (gitRepoPath git)@@ -218,14 +220,14 @@                 else readRemainingIndexes nacc idxs  -- | Get the object location of a specific reference-findReference :: Git -> Ref -> IO ObjectLocation+findReference :: HashAlgorithm hash => Git hash -> Ref hash -> IO (ObjectLocation hash) findReference git ref = maybe NotFound id <$> (findLoose `mplusIO` findInIndexes)-  where findLoose :: IO (Maybe ObjectLocation)+  where --findLoose :: HashAlgorithm hash => IO (Maybe (ObjectLocation hash))         findLoose = do             isLoose <- looseExists (gitRepoPath git) ref             if isLoose then return (Just $ Loose ref) else return Nothing -        findInIndexes :: IO (Maybe ObjectLocation)+        --findInIndexes :: HashAlgorithm hash => IO (Maybe (ObjectLocation hash))         findInIndexes = iterateIndexes git isinIndex Nothing --f -> (a -> IndexReader -> IO (a,Bool)) -> a -> IO a          isinIndex acc (idxref, (PackIndexReader idxhdr indexreader)) = do@@ -240,7 +242,7 @@             Just v  -> return $ Just v  -- | get all the references that start by a specific prefix-findReferencesWithPrefix :: Git -> String -> IO [Ref]+findReferencesWithPrefix :: HashAlgorithm hash => Git hash -> String -> IO [Ref hash] findReferencesWithPrefix git pre     | invalidLength         = error ("not a valid prefix: " ++ show pre)     | not (isHexString pre) = error ("reference prefix contains non hexchar: " ++ show pre)@@ -256,7 +258,7 @@             refs <- packIndexGetReferencesWithPrefix idxhdr indexreader pre             return (refs:acc,False) -readRawFromPack :: Git -> Ref -> Word64 -> IO (FileReader, PackedObjectRaw)+readRawFromPack :: HashAlgorithm hash => Git hash -> Ref hash -> Word64 -> IO (FileReader, (PackedObjectRaw hash)) readRawFromPack git pref offset = do     readers <- readIORef (packReaders git)     reader  <- maybe getDefault return $ lookup pref readers@@ -266,15 +268,15 @@                         modifyIORef (packReaders git) ((pref, p):)                         return p -readFromPack :: Git -> Ref -> Word64 -> Bool -> IO (Maybe ObjectInfo)+readFromPack :: HashAlgorithm hash => Git hash -> Ref hash -> Word64 -> Bool -> IO (Maybe (ObjectInfo hash)) readFromPack git pref o resolveDelta = do     (reader, x) <- readRawFromPack git pref o     if resolveDelta then resolve reader o x else return $ Just $ generifyHeader x-  where generifyHeader :: PackedObjectRaw -> ObjectInfo+  where generifyHeader :: PackedObjectRaw hash -> ObjectInfo hash         generifyHeader (po, objData) = ObjectInfo { oiHeader = hdr, oiData = objData, oiChains = [] }           where hdr = (poiType po, poiActualSize po, poiExtra po) -        resolve :: FileReader -> Word64 -> PackedObjectRaw -> IO (Maybe ObjectInfo)+        --resolve :: FileReader -> Word64 -> PackedObjectRaw hash -> IO (Maybe (ObjectInfo hash))         resolve reader offset (po, objData) = do             case (poiType po, poiExtra po) of                 (TypeDeltaOff, Just ptr@(PtrOfs doff)) -> do@@ -292,7 +294,7 @@         addToChain ptr (Just oi) = Just (oi { oiChains = ptr : oiChains oi })         addToChain _   Nothing   = Nothing -        applyDelta :: Maybe Delta -> Maybe ObjectInfo -> Maybe ObjectInfo+        applyDelta :: Maybe Delta -> Maybe (ObjectInfo hash) -> Maybe (ObjectInfo hash)         applyDelta (Just delta@(Delta _ rSize _)) (Just objInfo) = Just $ objInfo             { oiHeader = (\(a,_,c) -> (a,rSize,c)) $ oiHeader objInfo             , oiData   = deltaApply (oiData objInfo) delta@@ -300,19 +302,19 @@         applyDelta _ _                                      = Nothing  -- | get an object from repository-getObjectRawAt :: Git -> ObjectLocation -> Bool -> IO (Maybe ObjectInfo)+getObjectRawAt :: HashAlgorithm hash => Git hash -> ObjectLocation hash -> Bool -> IO (Maybe (ObjectInfo hash)) getObjectRawAt _   NotFound    _ = return Nothing getObjectRawAt git (Loose ref) _ = Just . (\(h,d)-> ObjectInfo h d[]) <$> looseReadRaw (gitRepoPath git) ref getObjectRawAt git (Packed pref o) resolveDelta = readFromPack git pref o resolveDelta  -- | get an object from repository-getObjectRaw :: Git -> Ref -> Bool -> IO (Maybe ObjectInfo)+getObjectRaw :: HashAlgorithm hash => Git hash -> Ref hash -> Bool -> IO (Maybe (ObjectInfo hash)) getObjectRaw git ref resolveDelta = do     loc <- findReference git ref     getObjectRawAt git loc resolveDelta  -- | get an object type from repository-getObjectType :: Git -> Ref -> IO (Maybe ObjectType)+getObjectType :: HashAlgorithm hash => Git hash -> Ref hash -> IO (Maybe ObjectType) getObjectType git ref = findReference git ref >>= getObjectTypeAt   where getObjectTypeAt NotFound        = return Nothing         getObjectTypeAt (Loose _)       = Just . (\(t,_,_) -> t) <$> looseReadHeader (gitRepoPath git) ref@@ -320,30 +322,33 @@             fmap ((\(ty,_,_) -> ty) . oiHeader) <$> readFromPack git pref o True  -- | get an object from repository using a location to reference it.-getObjectAt :: Git -> ObjectLocation -> Bool -> IO (Maybe Object)+getObjectAt :: HashAlgorithm hash => Git hash -> ObjectLocation hash -> Bool -> IO (Maybe (Object hash)) getObjectAt git loc resolveDelta = maybe Nothing toObj <$> getObjectRawAt git loc resolveDelta   where toObj (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData)  -- | get an object from repository using a ref.-getObject :: Git               -- ^ repository-          -> Ref               -- ^ the object's reference to+getObject :: HashAlgorithm hash+          => Git hash          -- ^ repository+          -> Ref hash          -- ^ the object's reference to           -> Bool              -- ^ whether to resolve deltas if found-          -> IO (Maybe Object) -- ^ returned object if found+          -> IO (Maybe (Object hash)) -- ^ returned object if found getObject git ref resolveDelta = maybe Nothing toObj <$> getObjectRaw git ref resolveDelta   where toObj (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData)  -- | Just like 'getObject' but will raise a RefNotFound exception if the -- reference cannot be found.-getObject_ :: Git       -- ^ repository-           -> Ref       -- ^ the object's reference to+getObject_ :: (Typeable hash, HashAlgorithm hash)+           => Git hash  -- ^ repository+           -> Ref hash  -- ^ the object's reference to            -> Bool      -- ^ whether to resolve deltas if found-           -> IO Object -- ^ returned object if found+           -> IO (Object hash) -- ^ returned object if found getObject_ git ref resolveDelta = maybe (throwIO $ RefNotFound ref) return                               =<< getObject git ref resolveDelta  -- | set an object in the store and returns the new ref -- this is always going to create a loose object.-setObject :: Git-          -> Object-          -> IO Ref+setObject :: HashAlgorithm hash+          => Git hash+          -> Object hash+          -> IO (Ref hash) setObject git obj = looseWrite (gitRepoPath git) obj

@@ -16,10 +16,10 @@         , fileReaderGet         , fileReaderGetLBS         , fileReaderGetBS+        , fileReaderGetRef         , fileReaderGetVLF         , fileReaderSeek         , fileReaderParse-         , fileReaderInflateToSize         ) where @@ -35,6 +35,7 @@  import Data.Git.Imports import Data.Git.OS+import Data.Git.Ref import qualified Data.Git.Parser as P  import Data.Data@@ -42,6 +43,7 @@  import Codec.Zlib import Codec.Zlib.Lowlevel+import Crypto.Hash import Foreign.ForeignPtr import qualified Control.Exception as E @@ -124,6 +126,9 @@  fileReaderGetBS :: Int -> FileReader -> IO ByteString fileReaderGetBS size fb = B.concat <$> fileReaderGet size fb++fileReaderGetRef :: HashAlgorithm hash => hash -> FileReader -> IO (Ref hash)+fileReaderGetRef alg fr = fromBinary <$> fileReaderGetBS (hashDigestSize alg) fr  -- | seek in a handle, and reset the remaining buffer to empty. fileReaderSeek :: FileReader -> Word64 -> IO ()

@@ -27,13 +27,13 @@     let x' = f x     x' `seq` writeIORef ref x' -data FileWriter = FileWriter+data FileWriter hash = FileWriter         { writerHandle  :: Handle         , writerDeflate :: Deflate-        , writerDigest  :: IORef (Context SHA1)+        , writerDigest  :: IORef (Context hash)         } -fileWriterNew :: Handle -> IO FileWriter+fileWriterNew :: HashAlgorithm hash => Handle -> IO (FileWriter hash) fileWriterNew handle = do         deflate <- initDeflate defaultCompression defaultWindowBits         digest  <- newIORef hashInit@@ -43,7 +43,7 @@                 , writerDigest  = digest                 } -withFileWriter :: LocalPath -> (FileWriter -> IO c) -> IO c+withFileWriter :: HashAlgorithm hash => LocalPath -> (FileWriter hash -> IO c) -> IO c withFileWriter path f =         bracket (openFile path WriteMode) (hClose) $ \handle ->                 bracket (fileWriterNew handle) (fileWriterClose) f@@ -51,14 +51,14 @@ postDeflate :: Handle -> Maybe B.ByteString -> IO () postDeflate handle = maybe (return ()) (B.hPut handle) -fileWriterOutput :: FileWriter -> B.ByteString -> IO ()+fileWriterOutput :: HashAlgorithm hash => FileWriter hash -> B.ByteString -> IO () fileWriterOutput (FileWriter { writerHandle = handle, writerDigest = digest, writerDeflate = deflate }) bs = do         modifyIORefStrict digest (\ctx -> hashUpdate ctx bs)         (>>= postDeflate handle) =<< feedDeflate deflate bs -fileWriterClose :: FileWriter -> IO ()+fileWriterClose :: FileWriter hash -> IO () fileWriterClose (FileWriter { writerHandle = handle, writerDeflate = deflate }) =         postDeflate handle =<< finishDeflate deflate -fileWriterGetDigest :: FileWriter -> IO Ref+fileWriterGetDigest :: HashAlgorithm hash => FileWriter hash -> IO (Ref hash) fileWriterGetDigest (FileWriter { writerDigest = digest }) = (fromDigest . hashFinalize) `fmap` readIORef digest

@@ -62,7 +62,7 @@ isObjectPrefix _     = False  -- loose object parsing-parseHeader :: P.Parser ObjectHeader+parseHeader :: P.Parser (ObjectHeader hash) parseHeader = do         h <- P.takeWhile1 ((/=) 0x20)         _ <- P.byte 0x20@@ -80,7 +80,7 @@ parseLength :: P.Parser Int parseLength = P.decimal -parseObject :: L.ByteString -> Object+parseObject :: HashAlgorithm hash => L.ByteString -> Object hash parseObject = parseSuccess getOne   where     parseSuccess p = either (error . ("parseObject: " ++)) id . P.eitherParseChunks p . L.toChunks@@ -94,15 +94,15 @@   -- | unmarshall an object (with header) from a bytestring.-looseUnmarshall :: L.ByteString -> Object+looseUnmarshall :: HashAlgorithm hash => L.ByteString -> Object hash looseUnmarshall = parseObject  -- | unmarshall an object (with header) from a zipped stream.-looseUnmarshallZipped :: Zipped -> Object+looseUnmarshallZipped :: HashAlgorithm hash => Zipped -> Object hash looseUnmarshallZipped = parseObject . dezip  -- | unmarshall an object as (header, data) tuple from a bytestring-looseUnmarshallRaw :: L.ByteString -> (ObjectHeader, ObjectData)+looseUnmarshallRaw :: L.ByteString -> (ObjectHeader hash, ObjectData) looseUnmarshallRaw stream =         case L.findIndex ((==) 0) stream of                 Nothing  -> error "object not right format. missing 0"@@ -113,25 +113,25 @@                                 Just hdr -> (hdr, r)  -- | unmarshall an object as (header, data) tuple from a zipped stream-looseUnmarshallZippedRaw :: Zipped -> (ObjectHeader, ObjectData)+looseUnmarshallZippedRaw :: Zipped -> (ObjectHeader hash, ObjectData) looseUnmarshallZippedRaw = looseUnmarshallRaw . dezip  -- | read a specific ref from a loose object and returns an header and data.-looseReadRaw :: LocalPath -> Ref -> IO (ObjectHeader, ObjectData)+looseReadRaw :: HashAlgorithm hash => LocalPath -> Ref hash -> IO (ObjectHeader hash, ObjectData) looseReadRaw repoPath ref = looseUnmarshallZippedRaw <$> readZippedFile (objectPathOfRef repoPath ref)  -- | read only the header of a loose object.-looseReadHeader :: LocalPath -> Ref -> IO ObjectHeader+looseReadHeader :: HashAlgorithm hash => LocalPath -> Ref hash -> IO (ObjectHeader hash) looseReadHeader repoPath ref = toHeader <$> readZippedFile (objectPathOfRef repoPath ref)   where     toHeader = either (error . ("parseHeader: " ++)) id . P.eitherParseChunks parseHeader . L.toChunks . dezip  -- | read a specific ref from a loose object and returns an object-looseRead :: LocalPath -> Ref -> IO Object+looseRead :: HashAlgorithm hash => LocalPath -> Ref hash -> IO (Object hash) looseRead repoPath ref = looseUnmarshallZipped <$> readZippedFile (objectPathOfRef repoPath ref)  -- | check if a specific ref exists as loose object-looseExists :: LocalPath -> Ref -> IO Bool+looseExists :: HashAlgorithm hash => LocalPath -> Ref hash -> IO Bool looseExists repoPath ref = isFile (objectPathOfRef repoPath ref)  -- | enumarate all prefixes available in the object store.@@ -139,19 +139,19 @@ looseEnumeratePrefixes repoPath = filter isObjectPrefix <$> getDirectoryContents (repoPath </> fromString "objects")  -- | enumerate all references available with a specific prefix.-looseEnumerateWithPrefixFilter :: LocalPath -> String -> (Ref -> Bool) -> IO [Ref]+looseEnumerateWithPrefixFilter :: HashAlgorithm hash => LocalPath -> String -> (Ref hash -> Bool) -> IO [Ref hash] looseEnumerateWithPrefixFilter repoPath prefix filterF =         filter filterF . map (fromHexString . (prefix ++)) . filter isRef <$> getDir (repoPath </> fromString "objects" </> fromString prefix)         where                 getDir p = E.catch (getDirectoryContents p) (\(_::SomeException) -> return [])                 isRef l = length l == 38 -looseEnumerateWithPrefix :: LocalPath -> String -> IO [Ref]+looseEnumerateWithPrefix :: HashAlgorithm hash => LocalPath -> String -> IO [Ref hash] looseEnumerateWithPrefix repoPath prefix =         looseEnumerateWithPrefixFilter repoPath prefix (const True)  -- | marshall as lazy bytestring an object except deltas.-looseMarshall :: Object -> L.ByteString+looseMarshall :: Object hash -> L.ByteString looseMarshall obj         | objectIsDelta obj = error "cannot write delta object loose"         | otherwise         = L.concat [ L.fromChunks [hdrB], objData ]@@ -161,7 +161,7 @@  -- | create a new blob on a temporary location and on success move it to -- the object store with its digest name.-looseWriteBlobFromFile :: LocalPath -> LocalPath -> IO Ref+looseWriteBlobFromFile :: HashAlgorithm hash => LocalPath -> LocalPath -> IO (Ref hash) looseWriteBlobFromFile repoPath file = do         fsz <- getSize file         let hdr = objectWriteHeader TypeBlob (fromIntegral fsz)@@ -184,7 +184,7 @@  -- | write an object to disk as a loose reference. -- use looseWriteBlobFromFile for efficiently writing blobs when being commited from a file.-looseWrite :: LocalPath -> Object -> IO Ref+looseWrite :: HashAlgorithm hash => LocalPath -> Object hash -> IO (Ref hash) looseWrite repoPath obj = createParentDirectory path                        >> isFile path                        >>= \exists -> unless exists (writeFileLazy path $ compress content)

@@ -72,43 +72,44 @@ #endif  -- | location of an object in the database-data ObjectLocation = NotFound | Loose Ref | Packed Ref Word64+data ObjectLocation hash = NotFound | Loose (Ref hash) | Packed (Ref hash) Word64         deriving (Show,Eq)  -- | Delta objects points to some others objects in the database -- either as offset in the pack or as a direct reference.-data ObjectPtr = PtrRef Ref | PtrOfs Word64 deriving (Show,Eq)+data ObjectPtr hash = PtrRef (Ref hash) | PtrOfs Word64 deriving (Show,Eq) -type ObjectHeader = (ObjectType, Word64, Maybe ObjectPtr)+type ObjectHeader hash = (ObjectType, Word64, Maybe (ObjectPtr hash))  type ObjectData = L.ByteString  -- | Raw objects infos have an header (type, size, ptr), -- the data and a pointers chains to parents for resolved objects.-data ObjectInfo = ObjectInfo-        { oiHeader :: ObjectHeader+data ObjectInfo hash = ObjectInfo+        { oiHeader :: ObjectHeader hash         , oiData   :: ObjectData-        , oiChains :: [ObjectPtr]+        , oiChains :: [ObjectPtr hash]         } deriving (Show,Eq)  -- | describe a git object, that could of 6 differents types: -- tree, blob, commit, tag and deltas (offset or ref). -- the deltas one are only available in packs.-data Object = ObjCommit   Commit-            | ObjTag      Tag-            | ObjBlob     Blob-            | ObjTree     Tree-            | ObjDeltaOfs DeltaOfs-            | ObjDeltaRef DeltaRef-            deriving (Show,Eq)+data Object hash =+      ObjCommit   (Commit hash)+    | ObjTag      (Tag hash)+    | ObjBlob     (Blob hash)+    | ObjTree     (Tree hash)+    | ObjDeltaOfs (DeltaOfs hash)+    | ObjDeltaRef (DeltaRef hash)+    deriving (Show,Eq)  class Objectable a where-        getType  :: a -> ObjectType-        getRaw   :: a -> L.ByteString-        isDelta  :: a -> Bool-        toObject :: a -> Object+        getType  :: a hash -> ObjectType+        getRaw   :: a hash -> L.ByteString+        isDelta  :: a hash -> Bool+        toObject :: a hash -> Object hash -objectToType :: Object -> ObjectType+objectToType :: Object hash -> ObjectType objectToType (ObjTree _)     = TypeTree objectToType (ObjBlob _)     = TypeBlob objectToType (ObjCommit _)   = TypeCommit@@ -135,24 +136,24 @@ objectTypeIsDelta TypeDeltaRef = True objectTypeIsDelta _            = False -objectIsDelta :: Object -> Bool+objectIsDelta :: Object hash -> Bool objectIsDelta (ObjDeltaOfs _) = True objectIsDelta (ObjDeltaRef _) = True objectIsDelta _               = False -objectToTree :: Object -> Maybe Tree+objectToTree :: Object hash -> Maybe (Tree hash) objectToTree (ObjTree tree) = Just tree objectToTree _              = Nothing -objectToCommit :: Object -> Maybe Commit+objectToCommit :: Object hash -> Maybe (Commit hash) objectToCommit (ObjCommit commit) = Just commit objectToCommit _                  = Nothing -objectToTag :: Object -> Maybe Tag+objectToTag :: Object hash -> Maybe (Tag hash) objectToTag (ObjTag tag) = Just tag objectToTag _            = Nothing -objectToBlob :: Object -> Maybe Blob+objectToBlob :: Object hash -> Maybe (Blob hash) objectToBlob (ObjBlob blob) = Just blob objectToBlob _              = Nothing @@ -165,18 +166,18 @@ modeperm = ModePerm . fromIntegral <$> octal  -- | parse a tree content-treeParse :: P.Parser Tree+treeParse :: HashAlgorithm hash => P.Parser (Tree hash) treeParse = Tree <$> parseEnts     where parseEnts = P.hasMore >>= \b -> if b then liftM2 (:) parseEnt parseEnts else return []           parseEnt = liftM3 (,,) modeperm parseEntName (P.byte 0 >> P.referenceBin)           parseEntName = entName <$> (P.skipASCII ' ' >> P.takeWhile (/= 0))  -- | parse a blob content-blobParse :: P.Parser Blob+blobParse :: P.Parser (Blob hash) blobParse = (Blob . L.fromChunks . (:[]) <$> P.takeAll)  -- | parse a commit content-commitParse :: P.Parser Commit+commitParse :: HashAlgorithm hash => P.Parser (Commit hash) commitParse = do         tree <- P.string "tree " >> P.referenceHex         P.skipEOL@@ -205,7 +206,7 @@                 concatLines = B.concat . intersperse (B.pack [0xa])  -- | parse a tag content-tagParse :: P.Parser Tag+tagParse :: HashAlgorithm hash => P.Parser (Tag hash) tagParse = do         object <- P.string "object " >> P.referenceHex         P.skipEOL@@ -242,7 +243,7 @@     | otherwise = error ("char " <> show c <> " not valid ASCII")   where cp = fromEnum c -objectParseTree, objectParseCommit, objectParseTag, objectParseBlob :: P.Parser Object+objectParseTree, objectParseCommit, objectParseTag, objectParseBlob :: HashAlgorithm hash => P.Parser (Object hash) objectParseTree   = ObjTree <$> treeParse objectParseCommit = ObjCommit <$> commitParse objectParseTag    = ObjTag <$> tagParse@@ -252,14 +253,14 @@ objectWriteHeader :: ObjectType -> Word64 -> ByteString objectWriteHeader ty sz = BC.pack (objectTypeMarshall ty ++ " " ++ show sz ++ [ '\0' ]) -objectWrite :: Object -> L.ByteString+objectWrite :: Object hash -> L.ByteString objectWrite (ObjCommit commit) = commitWrite commit objectWrite (ObjTag tag)       = tagWrite tag objectWrite (ObjBlob blob)     = blobWrite blob objectWrite (ObjTree tree)     = treeWrite tree objectWrite _                  = error "delta cannot be marshalled" -treeWrite :: Tree -> L.ByteString+treeWrite :: Tree hash -> L.ByteString treeWrite (Tree ents) = toLazyByteString $ mconcat $ concatMap writeTreeEnt ents     where writeTreeEnt (ModePerm perm,name,ref) =                 [ string7 (printf "%o" perm)@@ -269,7 +270,7 @@                 , byteString $ toBinary ref                 ] -commitWrite :: Commit -> L.ByteString+commitWrite :: Commit hash -> L.ByteString commitWrite (Commit tree parents author committer encoding extra msg) =     toLazyByteString $ mconcat els     where@@ -292,7 +293,7 @@                 ,byteString msg                 ] -tagWrite :: Tag -> L.ByteString+tagWrite :: Tag hash -> L.ByteString tagWrite (Tag ref ty tag tagger signature) =     toLazyByteString $ mconcat els     where els = [ string7 "object ", byteString (toHex ref), eol@@ -306,7 +307,7 @@ eol :: Builder eol = string7 "\n" -blobWrite :: Blob -> L.ByteString+blobWrite :: Blob hash -> L.ByteString blobWrite (Blob bData) = bData  instance Objectable Blob where@@ -345,7 +346,7 @@         toObject  = ObjDeltaRef         isDelta   = const True -objectHash :: ObjectType -> Word64 -> L.ByteString -> Ref+objectHash :: HashAlgorithm hash => ObjectType -> Word64 -> L.ByteString -> Ref hash objectHash ty w lbs = hashLBS $ L.fromChunks (objectWriteHeader ty w : L.toChunks lbs)  -- used for objectWrite for commit and tag

@@ -44,18 +44,18 @@  import Data.Word -type PackedObjectRaw = (PackedObjectInfo, L.ByteString)+type PackedObjectRaw hash = (PackedObjectInfo hash, L.ByteString) -data PackedObjectInfo = PackedObjectInfo+data PackedObjectInfo hash = PackedObjectInfo         { poiType       :: ObjectType         , poiOffset     :: Word64         , poiSize       :: Word64         , poiActualSize :: Word64-        , poiExtra      :: Maybe ObjectPtr+        , poiExtra      :: Maybe (ObjectPtr hash)         } deriving (Show,Eq)  -- | Enumerate the pack refs available in this repository.-packEnumerate :: LocalPath -> IO [Ref]+packEnumerate :: HashAlgorithm hash => LocalPath -> IO [Ref hash] packEnumerate repoPath = map onlyHash . filter isPackFile <$> listDirectoryFilename (repoPath </> "objects" </> "pack")   where         isPackFile :: String -> Bool@@ -64,7 +64,7 @@         takebut n l = take (length l - n) l  -- | open a pack-packOpen :: LocalPath -> Ref -> IO FileReader+packOpen :: LocalPath -> Ref hash -> IO FileReader packOpen repoPath packRef = openFile (packPath repoPath packRef) ReadMode >>= fileReaderNew False  -- | close a pack@@ -72,7 +72,7 @@ packClose = fileReaderClose  -- | return the number of entries in this pack-packReadHeader :: LocalPath -> Ref -> IO Word32+packReadHeader :: LocalPath -> Ref hash -> IO Word32 packReadHeader repoPath packRef =         withFileReader (packPath repoPath packRef) $ \filereader ->                 fileReaderParse filereader parseHeader@@ -84,19 +84,31 @@                 P.word32  -- | read an object at a specific position using a map function on the objectData-packReadMapAtOffset :: FileReader -> Word64 -> (L.ByteString -> L.ByteString) -> IO (Maybe Object)+packReadMapAtOffset :: HashAlgorithm hash+                    => FileReader+                    -> Word64+                    -> (L.ByteString -> L.ByteString)+                    -> IO (Maybe (Object hash)) packReadMapAtOffset fr offset mapData = fileReaderSeek fr offset >> getNextObject fr mapData  -- | read an object at a specific position-packReadAtOffset :: FileReader -> Word64 -> IO (Maybe Object)+packReadAtOffset :: HashAlgorithm hash => FileReader -> Word64 -> IO (Maybe (Object hash)) packReadAtOffset fr offset = packReadMapAtOffset fr offset id  -- | read a raw representation at a specific position-packReadRawAtOffset :: FileReader -> Word64 -> IO (PackedObjectRaw)+packReadRawAtOffset :: HashAlgorithm hash+                    => FileReader+                    -> Word64+                    -> IO (PackedObjectRaw hash) packReadRawAtOffset fr offset = fileReaderSeek fr offset >> getNextObjectRaw fr  -- | enumerate all objects in this pack and callback to f for reach raw objects-packEnumerateObjects :: LocalPath -> Ref -> Int -> (PackedObjectRaw -> IO a) -> IO ()+packEnumerateObjects :: HashAlgorithm hash+                     => LocalPath+                     -> Ref hash+                     -> Int+                     -> (PackedObjectRaw hash -> IO a)+                     -> IO () packEnumerateObjects repoPath packRef entries f =         withFileReader (packPath repoPath packRef) $ \filebuffer -> do                 fileReaderSeek filebuffer 12@@ -106,15 +118,22 @@                 parseNext _  0    = return ()                 parseNext fr ents = getNextObjectRaw fr >>= f >> parseNext fr (ents-1) -getNextObject :: FileReader -> (L.ByteString -> L.ByteString) -> IO (Maybe Object)+getNextObject :: HashAlgorithm hash+              => FileReader+              -> (L.ByteString -> L.ByteString)+              -> IO (Maybe (Object hash)) getNextObject fr mapData =         packedObjectToObject . second mapData <$> getNextObjectRaw fr -packedObjectToObject :: (PackedObjectInfo, L.ByteString) -> Maybe Object+packedObjectToObject :: HashAlgorithm hash+                     => (PackedObjectInfo hash, L.ByteString)+                     -> Maybe (Object hash) packedObjectToObject (PackedObjectInfo { poiType = ty, poiExtra = extra }, objData) =         packObjectFromRaw (ty, extra, objData) -packObjectFromRaw :: (ObjectType, Maybe ObjectPtr, L.ByteString) -> Maybe Object+packObjectFromRaw :: HashAlgorithm hash+                  => (ObjectType, Maybe (ObjectPtr hash), L.ByteString)+                  -> Maybe (Object hash) packObjectFromRaw (TypeCommit, Nothing, objData) = P.maybeParseChunks objectParseCommit (L.toChunks objData) packObjectFromRaw (TypeTree, Nothing, objData)   = P.maybeParseChunks objectParseTree (L.toChunks objData) packObjectFromRaw (TypeBlob, Nothing, objData)   = P.maybeParseChunks objectParseBlob (L.toChunks objData)@@ -123,32 +142,32 @@ packObjectFromRaw (TypeDeltaRef, Just (PtrRef r), objData) = toObject . DeltaRef r <$> deltaRead (L.toChunks objData) packObjectFromRaw _                              = error "can't happen unless someone change getNextObjectRaw" -getNextObjectRaw :: FileReader -> IO PackedObjectRaw+getNextObjectRaw :: HashAlgorithm hash => FileReader -> IO (PackedObjectRaw hash) getNextObjectRaw fr = do         sobj       <- fileReaderGetPos fr         (ty, size) <- fileReaderParse fr parseObjectHeader         extra      <- case ty of-                TypeDeltaRef -> Just . PtrRef . fromBinary <$> fileReaderGetBS 20 fr+                TypeDeltaRef -> Just . PtrRef <$> fileReaderGetRef hashAlg fr                 TypeDeltaOff -> Just . PtrOfs . deltaOffFromList <$> fileReaderGetVLF fr                 _            -> return Nothing         objData    <- fileReaderInflateToSize fr size         eobj       <- fileReaderGetPos fr          return (PackedObjectInfo ty sobj (eobj - sobj) size extra, objData)-        where-                parseObjectHeader = do-                        (m, ty, sz) <- splitFirst <$> P.anyByte-                        size <- if m then (sz +) <$> getNextSize 4 else return sz-                        return (ty, size)-                        where-                                getNextSize n = do-                                        (c, sz) <- splitOther n <$> P.anyByte-                                        if c then (sz +) <$> getNextSize (n+7) else return sz+  where+    parseObjectHeader = do+        (m, ty, sz) <- splitFirst <$> P.anyByte+        size <- if m then (sz +) <$> getNextSize 4 else return sz+        return (ty, size)+      where+        getNextSize n = do+            (c, sz) <- splitOther n <$> P.anyByte+            if c then (sz +) <$> getNextSize (n+7) else return sz -                                splitFirst :: Word8 -> (Bool, ObjectType, Word64)-                                splitFirst w = (w `testBit` 7, toEnum $ fromIntegral ((w `shiftR` 4) .&. 0x7), fromIntegral (w .&. 0xf))-                                splitOther n w = (w `testBit` 7, fromIntegral (w .&. 0x7f) `shiftL` n)+        splitFirst :: Word8 -> (Bool, ObjectType, Word64)+        splitFirst w = (w `testBit` 7, toEnum $ fromIntegral ((w `shiftR` 4) .&. 0x7), fromIntegral (w .&. 0xf))+        splitOther n w = (w `testBit` 7, fromIntegral (w .&. 0x7f) `shiftL` n) -                deltaOffFromList (x:xs) = foldl' acc (fromIntegral (x `clearBit` 7)) xs-                        where acc a w = ((a+1) `shiftL` 7) + fromIntegral (w `clearBit` 7)-                deltaOffFromList [] = error "cannot happen"+    deltaOffFromList (x:xs) = foldl' acc (fromIntegral (x `clearBit` 7)) xs+      where acc a w = ((a+1) `shiftL` 7) + fromIntegral (w `clearBit` 7)+    deltaOffFromList [] = error "cannot happen"

@@ -7,23 +7,23 @@ -- {-# LANGUAGE OverloadedStrings, BangPatterns #-} module Data.Git.Storage.PackIndex-        ( PackIndexHeader(..)-        , PackIndex(..)+    ( PackIndexHeader(..)+    , PackIndex(..) -        -- * handles and enumeration-        , packIndexOpen-        , packIndexClose-        , withPackIndex-        , packIndexEnumerate+    -- * handles and enumeration+    , packIndexOpen+    , packIndexClose+    , withPackIndex+    , packIndexEnumerate -        -- * read from packIndex-        , packIndexHeaderGetNbWithPrefix-        , packIndexGetReferenceLocation-        , packIndexGetReferencesWithPrefix-        , packIndexReadHeader-        , packIndexRead-        , packIndexGetHeader-        ) where+    -- * read from packIndex+    , packIndexHeaderGetNbWithPrefix+    , packIndexGetReferenceLocation+    , packIndexGetReferencesWithPrefix+    , packIndexReadHeader+    , packIndexRead+    , packIndexGetHeader+    ) where  import Data.List import Data.Bits@@ -43,27 +43,27 @@  -- | represent an packIndex header with the version and the fanout table data PackIndexHeader = PackIndexHeader !Word32 !(Vector Word32)-        deriving (Show,Eq)+    deriving (Show,Eq) -data PackIndex = PackIndex-        { packIndexSha1s        :: Vector Ref-        , packIndexCRCs         :: Vector Word32-        , packIndexPackoffs     :: Vector Word32-        , packIndexPackChecksum :: Ref-        , packIndexChecksum     :: Ref-        }+data PackIndex hash = PackIndex+    { packIndexSha1s        :: Vector (Ref hash)+    , packIndexCRCs         :: Vector Word32+    , packIndexPackoffs     :: Vector Word32+    , packIndexPackChecksum :: Ref hash+    , packIndexChecksum     :: Ref hash+    }  -- | enumerate every indexes file in the pack directory-packIndexEnumerate :: LocalPath -> IO [Ref]+packIndexEnumerate :: HashAlgorithm hash => LocalPath -> IO [Ref hash] packIndexEnumerate repoPath = map onlyHash . filter isPackFile <$> listDirectoryFilename (repoPath </> "objects" </> "pack")   where-        isPackFile :: String -> Bool-        isPackFile x = ".idx" `isSuffixOf` x && "pack-" `isPrefixOf` x-        onlyHash = fromHexString . takebut 4 . drop 5-        takebut n l = take (length l - n) l+    isPackFile :: String -> Bool+    isPackFile x = ".idx" `isSuffixOf` x && "pack-" `isPrefixOf` x+    onlyHash = fromHexString . takebut 4 . drop 5+    takebut n l = take (length l - n) l  -- | open an index-packIndexOpen :: LocalPath -> Ref -> IO FileReader+packIndexOpen :: LocalPath -> Ref hash -> IO FileReader packIndexOpen repoPath indexRef = openFile (indexPath repoPath indexRef) ReadMode >>= fileReaderNew False  -- | close an index@@ -71,7 +71,7 @@ packIndexClose = fileReaderClose  -- | variant of withFile on the index file and with a FileReader-withPackIndex :: LocalPath -> Ref -> (FileReader -> IO a) -> IO a+withPackIndex :: LocalPath -> Ref hash -> (FileReader -> IO a) -> IO a withPackIndex repoPath indexRef = withFileReader (indexPath repoPath indexRef)  -- | returns the number of references, referenced in this index.@@ -90,94 +90,106 @@         | otherwise        = (indexes ! n) - (indexes ! (n-1))  -- | fold on refs with a specific prefix-packIndexHeaderFoldRef :: PackIndexHeader -> FileReader -> Int -> (a -> Word32 -> Ref -> (a, Bool)) -> a -> IO a-packIndexHeaderFoldRef idxHdr@(PackIndexHeader _ indexes) fr refprefix f initAcc-        | nb == 0   = return initAcc-        | otherwise = do-                let spos = (indexes ! refprefix) - nb-                fileReaderSeek fr (fromIntegral (sha1Offset + spos * 20))-                loop nb initAcc-        where-                loop 0 acc = return acc-                loop n acc = do-                        b <- fromBinary <$> fileReaderGetBS 20 fr-                        let (!nacc, terminate) = f acc (nb-n) b-                        if terminate-                                then return nacc-                                else loop (n-1) nacc-                nb         = packIndexHeaderGetNbWithPrefix idxHdr refprefix-                (sha1Offset,_,_) = packIndexOffsets idxHdr+packIndexHeaderFoldRef :: HashAlgorithm hash+                       => PackIndexHeader+                       -> FileReader+                       -> hash+                       -> Int+                       -> (a -> Word32 -> Ref hash -> (a, Bool))+                       -> a+                       -> IO a+packIndexHeaderFoldRef idxHdr@(PackIndexHeader _ indexes) fr alg refprefix f initAcc+    | nb == 0   = return initAcc+    | otherwise = do+        let spos     = (indexes ! refprefix) - nb+            hashSize = hashDigestSize alg+        fileReaderSeek fr (fromIntegral (sha1Offset + spos * fromIntegral hashSize))+        loop nb initAcc+  where+    loop 0 acc = return acc+    loop n acc = do+        b <- fileReaderGetRef alg fr+        let (!nacc, terminate) = f acc (nb-n) b+        if terminate+            then return nacc+            else loop (n-1) nacc+    nb         = packIndexHeaderGetNbWithPrefix idxHdr refprefix+    (sha1Offset,_,_) = packIndexOffsets alg idxHdr  -- | return the reference offset in the packfile if found-packIndexGetReferenceLocation :: PackIndexHeader -> FileReader -> Ref -> IO (Maybe Word64)+packIndexGetReferenceLocation :: HashAlgorithm hash => PackIndexHeader -> FileReader -> Ref hash -> IO (Maybe Word64) packIndexGetReferenceLocation idxHdr@(PackIndexHeader _ indexes) fr ref = do-        mrpos <- packIndexHeaderFoldRef idxHdr fr refprefix f Nothing-        case mrpos of-                Nothing   -> return Nothing-                Just rpos -> do-                        let spos = (indexes ! refprefix) - nb-                        fileReaderSeek fr (fromIntegral (packOffset + 4 * (spos+rpos)))-                        Just . fromIntegral . be32 <$> fileReaderGetBS 4 fr-        where-                f acc rpos rref = if ref == rref then (Just rpos,True) else (acc,False)-                refprefix  = refPrefix ref-                nb         = packIndexHeaderGetNbWithPrefix idxHdr refprefix-                (_,_,packOffset) = packIndexOffsets idxHdr+    mrpos <- packIndexHeaderFoldRef idxHdr fr (hashAlgFromRef ref) refprefix f Nothing+    case mrpos of+        Nothing   -> return Nothing+        Just rpos -> do+            let spos = (indexes ! refprefix) - nb+            fileReaderSeek fr (fromIntegral (packOffset + 4 * (spos+rpos)))+            Just . fromIntegral . be32 <$> fileReaderGetBS 4 fr+  where+    f acc rpos rref = if ref == rref then (Just rpos,True) else (acc,False)+    refprefix  = refPrefix ref+    nb         = packIndexHeaderGetNbWithPrefix idxHdr refprefix+    (_,_,packOffset) = packIndexOffsets (hashAlgFromRef ref) idxHdr  -- | get all references that start by prefix.-packIndexGetReferencesWithPrefix :: PackIndexHeader -> FileReader -> String -> IO [Ref]+packIndexGetReferencesWithPrefix :: HashAlgorithm hash => PackIndexHeader -> FileReader -> String -> IO [Ref hash] packIndexGetReferencesWithPrefix idxHdr fr prefix =-        packIndexHeaderFoldRef idxHdr fr refprefix f []-        where-                f acc _ ref = case cmpPrefix prefix ref of-                        GT -> (acc    ,False)-                        EQ -> (ref:acc,False)-                        LT -> (acc    ,True)-                refprefix   = read ("0x" ++ take 2 prefix)+    packIndexHeaderFoldRef idxHdr fr hashAlg refprefix f []+  where+    f acc _ ref = case cmpPrefix prefix ref of+        GT -> (acc    ,False)+        EQ -> (ref:acc,False)+        LT -> (acc    ,True)+    refprefix   = read ("0x" ++ take 2 prefix)  -- | returns absolute offset in the index file of the sha1s, the crcs and the packfiles offset.-packIndexOffsets :: PackIndexHeader -> (Word32, Word32, Word32)-packIndexOffsets idx = (packIndexSha1sOffset, packIndexCRCsOffset, packIndexPackOffOffset)-        where-                packIndexPackOffOffset = packIndexCRCsOffset + crcsTableSz-                packIndexCRCsOffset    = packIndexSha1sOffset + sha1TableSz-                packIndexSha1sOffset   = fromIntegral packIndexHeaderByteSize-                crcsTableSz        = 4 * sz-                sha1TableSz        = 20 * sz-                sz                 = packIndexHeaderGetSize idx+packIndexOffsets :: HashAlgorithm hash => hash -> PackIndexHeader -> (Word32, Word32, Word32)+packIndexOffsets alg idx = (packIndexSha1sOffset, packIndexCRCsOffset, packIndexPackOffOffset)+  where+    packIndexPackOffOffset = packIndexCRCsOffset + crcsTableSz+    packIndexCRCsOffset    = packIndexSha1sOffset + sha1TableSz+    packIndexSha1sOffset   = fromIntegral packIndexHeaderByteSize+    crcsTableSz        = 4 * sz+    sha1TableSz        = (fromIntegral $ hashDigestSize alg) * sz+    sz                 = packIndexHeaderGetSize idx  -- | parse index header parsePackIndexHeader :: P.Parser PackIndexHeader parsePackIndexHeader = do-        magic   <- P.word32-        when (magic /= 0xff744f63) $ error "wrong magic number for packIndex"-        ver     <- P.word32-        when (ver /= 2) $ error "unsupported packIndex version"-        fanouts <- V.replicateM 256 P.word32-        return $ PackIndexHeader ver fanouts+    magic   <- P.word32+    when (magic /= 0xff744f63) $ error "wrong magic number for packIndex"+    ver     <- P.word32+    when (ver /= 2) $ error "unsupported packIndex version"+    fanouts <- V.replicateM 256 P.word32+    return $ PackIndexHeader ver fanouts  -- | read index header from an index filereader packIndexReadHeader :: FileReader -> IO PackIndexHeader packIndexReadHeader fr = fileReaderSeek fr 0 >> fileReaderParse fr parsePackIndexHeader  -- | get index header from an index reference-packIndexGetHeader :: LocalPath -> Ref -> IO PackIndexHeader+packIndexGetHeader :: LocalPath -> Ref hash -> IO PackIndexHeader packIndexGetHeader repoPath indexRef = withPackIndex repoPath indexRef $ packIndexReadHeader  -- | read all index-packIndexRead :: LocalPath -> Ref -> IO (PackIndexHeader, (Vector Ref, Vector Word32, Vector Word32, [ByteString], Ref, Ref))+packIndexRead :: HashAlgorithm hash+              => LocalPath+              -> Ref hash+              -> IO (PackIndexHeader, (Vector (Ref hash), Vector Word32, Vector Word32, [ByteString], Ref hash, Ref hash)) packIndexRead repoPath indexRef = do-        withPackIndex repoPath indexRef $ \fr -> do-                idx <- fileReaderParse fr parsePackIndexHeader-                liftM2 (,) (return idx) (fileReaderParse fr (parsePackIndex $ packIndexHeaderGetSize idx))-        where parsePackIndex sz = do-                sha1s     <- V.replicateM (fromIntegral sz) P.referenceBin-                crcs      <- V.replicateM (fromIntegral sz) P.word32-                packoffs  <- V.replicateM (fromIntegral sz) P.word32-                let nbLarge = length $ filter (== True) $ map (\packoff -> packoff `testBit` 31) $ V.toList packoffs-                largeoffs <- replicateM nbLarge (P.take 4)-                packfileChecksum <- P.referenceBin-                idxfileChecksum  <- P.referenceBin-                -- large packfile offsets-                -- trailer-                return (sha1s, crcs, packoffs, largeoffs, packfileChecksum, idxfileChecksum)+    withPackIndex repoPath indexRef $ \fr -> do+        idx <- fileReaderParse fr parsePackIndexHeader+        liftM2 (,) (return idx) (fileReaderParse fr (parsePackIndex $ packIndexHeaderGetSize idx))+  where+    parsePackIndex sz = do+        sha1s     <- V.replicateM (fromIntegral sz) P.referenceBin+        crcs      <- V.replicateM (fromIntegral sz) P.word32+        packoffs  <- V.replicateM (fromIntegral sz) P.word32+        let nbLarge = length $ filter (== True) $ map (\packoff -> packoff `testBit` 31) $ V.toList packoffs+        largeoffs <- replicateM nbLarge (P.take 4)+        packfileChecksum <- P.referenceBin+        idxfileChecksum  <- P.referenceBin+        -- large packfile offsets+        -- trailer+        return (sha1s, crcs, packoffs, largeoffs, packfileChecksum, idxfileChecksum)

@@ -170,7 +170,7 @@ -- | represent one entry in the tree -- (permission,file or directory name,blob or tree ref) -- name should maybe a filepath, but not sure about the encoding.-type TreeEnt = (ModePerm,EntName,Ref)+type TreeEnt hash = (ModePerm,EntName,Ref hash)  -- | an author or committer line -- has the format: name <email> time timezone@@ -183,20 +183,20 @@     } deriving (Show,Eq)  -- | Represent a root tree with zero to many tree entries.-data Tree = Tree { treeGetEnts :: [TreeEnt] } deriving (Show,Eq)+data Tree hash = Tree { treeGetEnts :: [TreeEnt hash] } deriving (Show,Eq) -instance Monoid Tree where+instance Monoid (Tree hash) where     mempty                      = Tree []     mappend (Tree e1) (Tree e2) = Tree (e1 ++ e2)     mconcat trees               = Tree $ concatMap treeGetEnts trees  -- | Represent a binary blob.-data Blob = Blob { blobGetContent :: L.ByteString } deriving (Show,Eq)+data Blob hash = Blob { blobGetContent :: L.ByteString } deriving (Show,Eq)  -- | Represent a commit object.-data Commit = Commit-    { commitTreeish   :: Ref-    , commitParents   :: [Ref]+data Commit hash = Commit+    { commitTreeish   :: Ref hash+    , commitParents   :: [Ref hash]     , commitAuthor    :: Person     , commitCommitter :: Person     , commitEncoding  :: Maybe ByteString@@ -210,8 +210,8 @@     } deriving (Show,Eq)  -- | Represent a signed tag.-data Tag = Tag-    { tagRef        :: Ref+data Tag hash = Tag+    { tagRef        :: Ref hash     , tagObjectType :: ObjectType     , tagBlob       :: ByteString     , tagName       :: Person@@ -219,9 +219,9 @@     } deriving (Show,Eq)  -- | Delta pointing to an offset.-data DeltaOfs = DeltaOfs Word64 Delta+data DeltaOfs hash = DeltaOfs Word64 Delta     deriving (Show,Eq)  -- | Delta pointing to a ref.-data DeltaRef = DeltaRef Ref Delta+data DeltaRef hash = DeltaRef (Ref hash) Delta     deriving (Show,Eq)

@@ -30,29 +30,39 @@  import qualified Data.Map as M +import Data.Typeable import Control.Monad import Control.Concurrent.MVar -type Dir = M.Map EntName (ModePerm, TreeSt)-type TreeVar = MVar Dir-data TreeSt = TreeRef Ref | TreeLoaded TreeVar-type WorkTree = MVar TreeSt+type Dir hash = M.Map EntName (ModePerm, TreeSt hash) +type TreeVar hash = MVar (Dir hash)++data TreeSt hash =+      TreeRef (Ref hash)+    | TreeLoaded (TreeVar hash)++type WorkTree hash = MVar (TreeSt hash)+ data EntType = EntDirectory | EntFile | EntExecutable     deriving (Show,Eq)  -- | Create a new worktree-workTreeNew :: IO WorkTree+workTreeNew :: IO (WorkTree hash) workTreeNew = newMVar M.empty >>= newMVar . TreeLoaded  -- | Create a worktree from a tree reference.-workTreeFrom :: Ref -> IO WorkTree+workTreeFrom :: Ref hash -> IO (WorkTree hash) workTreeFrom ref = newMVar (TreeRef ref)  -- | delete a path from a working tree -- -- if the path doesn't exist, no error is raised-workTreeDelete :: Git -> WorkTree -> EntPath -> IO ()+workTreeDelete :: (Typeable hash, HashAlgorithm hash)+               => Git hash+               -> WorkTree hash+               -> EntPath+               -> IO () workTreeDelete git wt path = diveFromRoot git wt path dive   where dive _          []     = error "internal error: delete: empty dive"         dive varCurrent [file] = modifyMVar_ varCurrent (return . M.delete file)@@ -66,9 +76,14 @@ -- -- The ref should point to a valid blob or tree object, and -- it's safer to write the referenced tree or blob object first.-workTreeSet :: Git -> WorkTree -> EntPath -> (EntType, Ref) -> IO ()+workTreeSet :: (Typeable hash, HashAlgorithm hash)+            => Git hash+            -> WorkTree hash+            -> EntPath+            -> (EntType, Ref hash)+            -> IO () workTreeSet git wt path (entType, entRef) = diveFromRoot git wt path dive-  where dive :: TreeVar -> EntPath -> IO ()+  where --dive :: TreeVar hash -> EntPath -> IO ()         dive _          []     = error "internal error: set: empty dive"         dive varCurrent [file] = modifyMVar_ varCurrent (return . M.insert file (entTypeToPerm entType, TreeRef entRef))         dive varCurrent (x:xs) = do@@ -88,7 +103,7 @@  -- | Flush the worktree by creating all the necessary trees in the git store -- and return the root ref of the work tree.-workTreeFlush :: Git -> WorkTree -> IO Ref+workTreeFlush :: HashAlgorithm hash => Git hash -> WorkTree hash -> IO (Ref hash) workTreeFlush git wt = do     -- write all the trees that need to be written     -- switch to modifyMVar@@ -111,7 +126,7 @@  ----- helpers ----- -loadTreeVar :: Git -> Ref -> IO TreeVar+loadTreeVar :: (Typeable hash, HashAlgorithm hash) => Git hash -> Ref hash -> IO (TreeVar hash) loadTreeVar git treeRef = do     (Tree ents) <- getTree git treeRef     let t = foldr (\(m,b,r) acc -> M.insert b (m,TreeRef r) acc) M.empty ents@@ -119,10 +134,15 @@  entTypeToPerm :: EntType -> ModePerm entTypeToPerm EntDirectory  = ModePerm 0o040000-entTypeToPerm EntExecutable = ModePerm 0o100755 +entTypeToPerm EntExecutable = ModePerm 0o100755 entTypeToPerm EntFile       = ModePerm 0o100644 -loadOrGetTree :: Git -> EntName -> TreeVar -> (Dir -> IO (Dir, Either TreeVar a)) -> IO (Either TreeVar a)+loadOrGetTree :: (Typeable hash, HashAlgorithm hash)+              => Git hash+              -> EntName+              -> TreeVar hash+              -> (Dir hash -> IO (Dir hash, Either (TreeVar hash) a))+              -> IO (Either (TreeVar hash) a) loadOrGetTree git x varCurrent onMissing =     modifyMVar varCurrent $ \m -> do         case M.lookup x m of@@ -135,9 +155,12 @@                         return (M.adjust (\(perm,_) -> (perm, TreeLoaded var)) x m, Left var)                     TreeLoaded var -> return (m, Left var) -diveFromRoot :: Git -> WorkTree -> EntPath-             -> (TreeVar -> EntPath -> IO ())-             -> IO () +diveFromRoot :: (Typeable hash, HashAlgorithm hash)+             => Git hash+             -> WorkTree hash+             -> EntPath+             -> (TreeVar hash -> EntPath -> IO ())+             -> IO () diveFromRoot git wt path dive     | path == [] = return ()     | otherwise    = do@@ -148,4 +171,3 @@                     TreeRef ref      -> loadTreeVar git ref         putMVar wt $ TreeLoaded current         dive current path-

@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++module Monad+    ( testGitMonadLocal+    ) where++import Control.Applicative+import Control.Exception+import Control.Monad++import Data.Git.Monad+import Data.Git.Types (GitTime(..))+import System.Exit+import qualified System.Hourglass as T++testBranch :: RefName+testBranch = "test/not/push"++catchAll :: IO (Either String a) -> IO ()+catchAll f = do+    r <- catchAll' f+    case r of+        Left  err        -> failWith $ show err+        Right (Left err) -> failWith err+        Right (Right _)  -> putStrLn " test/git/monad [OK]"+  where+    catchAll' :: IO a -> IO (Either SomeException a)+    catchAll' f = try f++    failWith :: String -> IO ()+    failWith msg = do+        putStrLn " test/git/monad [FAILED]"+        putStrLn $ " - " ++ msg+        exitFailure++testGitMonadLocal :: IO ()+testGitMonadLocal = catchAll (withCurrentRepo testGitMonad)++timeCurrentGit :: GitM GitTime+timeCurrentGit = liftGit $ GitTime +    <$> T.timeCurrent+    <*> T.timezoneCurrent++step :: String -> GitM ()+step = liftGit . putStrLn++testGitMonad :: GitM ()+testGitMonad = do+    t <- timeCurrentGit+    let person = Person+            { personName  = "Hit Test Machinery"+            , personEmail = "hit@snarc.org"+            , personTime  = t+            }+    withBranch person testBranch True (return ()) $ \isFirstCommit -> case isFirstCommit of+        Nothing -> setMessage "Initial commit"+        Just _  -> setMessage "add new commit"+    step " + new branch created"+    withCommit testBranch $ do+        author <- getAuthor+        when (t /= personTime author)+            $ fail "master's commit is not the last commit performed"+    step " + branch has been verified"

@@ -0,0 +1,67 @@+{-# LANGUAGE ScopedTypeVariables #-}+import Test.Tasty+import Test.Tasty.QuickCheck++import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as B++import Control.Applicative+import Control.Monad++import Data.Git.Storage.Object+import Data.Git.Storage.Loose+import Data.Git.Storage+import Data.Git.Ref+import Data.Git.Types+import Data.Git.Repository++import Data.Maybe++import Text.Bytedump+import System.Exit++import Monad++onLocalRepo f = do+    fpath <- findRepoMaybe+    case fpath of+        Nothing -> putStrLn "cannot run this test without repository. clone the original repository for test"+        Just _  -> withCurrentRepo f++doLocalMarshallEq+    :: Git SHA1+    -> IO [[Maybe (Ref SHA1, Ref SHA1, (ObjectHeader SHA1, L.ByteString), (ObjectHeader SHA1, L.ByteString))]]+doLocalMarshallEq git = do+     prefixes <- looseEnumeratePrefixes (gitRepoPath git)+     forM prefixes $ \prefix -> do+         refs <- looseEnumerateWithPrefix (gitRepoPath git) prefix+         forM refs $ \ref -> do+             raw <- looseReadRaw (gitRepoPath git) ref+             obj <- looseRead (gitRepoPath git) ref+             let content = looseMarshall obj+             let raw2 = looseUnmarshallRaw content+             let hashed = hashLBS content+             if ref /= hashed+                  then return $ Just (ref, hashed, raw, raw2)+                  else return Nothing++printDiff (actualRef, gotRef, (actualHeader, actualRaw), (gotHeader, gotRaw)) = do+    putStrLn "=========== difference found"+    putStrLn ("ref expected: " ++ show actualRef)+    putStrLn ("ref got     : " ++ show gotRef)+    putStrLn ("header expected: " ++ show actualHeader)+    putStrLn ("header got     : " ++ show gotHeader)+    putStrLn "raw diff:"+    putStrLn $ dumpDiffLBS actualRaw gotRaw++printLocalMarshallError l+    | null l    = putStrLn "local marshall:   [OK]"+    | otherwise = putStrLn ("local marshall: [" ++ show (length l) ++ " errors]")+               >> mapM_ printDiff l+               >> exitFailure++main = do+    onLocalRepo $ \(git :: Git SHA1) -> do+        doLocalMarshallEq git >>= printLocalMarshallError . catMaybes . concat+        testGitMonadLocal+        return ()

@@ -0,0 +1,139 @@+{-# LANGUAGE FlexibleInstances #-}+import Test.Tasty.QuickCheck+import Test.Tasty++import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as B++import Control.Applicative+import Control.Monad++import Data.Git.Storage.Object+import Data.Git.Storage.Loose+import Data.Git.Ref+import Data.Git.Revision+import Data.Git.Types+import Data.Hourglass++import Data.Maybe++-- for arbitrary instance to generate only data that are writable+-- to disk. i.e. no deltas.+data ObjNoDelta hash = ObjNoDelta (Object hash)+    deriving (Eq)++instance Show (ObjNoDelta hash) where+    show (ObjNoDelta o) = show o++arbitraryBS size = B.pack . map fromIntegral <$> replicateM size (choose (0,255) :: Gen Int)+arbitraryBSno0 size = B.pack . map fromIntegral <$> replicateM size (choose (1,255) :: Gen Int)+arbitraryBSasciiNoSpace size = B.pack . map fromIntegral <$> replicateM size (choose (0x21,0x7f) :: Gen Int)+arbitraryBSascii size = B.pack . map fromIntegral <$> replicateM size (choose (0x20,0x7f) :: Gen Int)+arbitraryBSnoangle size = B.pack . map fromIntegral <$> replicateM size (choose (0x40,0x7f) :: Gen Int)++arbitraryEntname size = entName . B.pack . map fromIntegral <$> replicateM size range+  where range :: Gen Int+        range = oneof [ choose (0x21, 0x2e) -- remove 0x2f (slash)+                      , choose (0x30, 0x7f)+                      ]++arbitraryRef :: HashAlgorithm hash => hash -> Gen (Ref hash)+arbitraryRef alg = fromBinary <$> arbitraryBS (hashDigestSize alg)++instance HashAlgorithm hash => Arbitrary (Ref hash) where+    arbitrary = arbitraryRef (error "alg")++arbitraryMsg = arbitraryBSno0 1+arbitraryLazy = L.fromChunks . (:[]) <$> arbitraryBS 40++arbitraryRefList :: Gen [Ref SHA1]+arbitraryRefList = replicateM 2 arbitrary++arbitraryEnt :: Gen (TreeEnt SHA1)+arbitraryEnt = liftM3 (,,) arbitrary (arbitraryEntname 23) arbitrary+arbitraryEnts = choose (1,2) >>= \i -> replicateM i arbitraryEnt++instance Arbitrary TimezoneOffset where+    arbitrary = TimezoneOffset <$> choose (-11*60, 12*60)+instance Arbitrary Elapsed where+    arbitrary = Elapsed . Seconds <$> choose (0,2^32-1)+instance Arbitrary GitTime where+    arbitrary = GitTime <$> arbitrary <*> arbitrary+instance Arbitrary ModePerm where+    arbitrary = ModePerm <$> elements [ 0o644, 0o664, 0o755, 0 ]+instance Arbitrary RevModifier where+    arbitrary = oneof+        [ RevModParent . getPositive <$> arbitrary+        , RevModParentFirstN . getPositive <$> arbitrary+        , RevModAtType <$> arbitraryType+        , RevModAtDate <$> arbitraryDate+        --, RevModAtN . getPositive <$> arbitrary+        ]++arbitraryDate = elements ["yesterday","29-Jan-1982","5 days ago"]+arbitraryType = elements ["commit","tree"]++instance Arbitrary Revision where+    arbitrary = do+        s   <- choose (1,40) >>= flip replicateM (elements ['a'..'z'])+        rms <- choose (1,4) >>= flip replicateM arbitrary+        return $ Revision s rms++arbitraryName = liftM3 Person (arbitraryBSnoangle 16)+                              (arbitraryBSnoangle 16)+                              arbitrary++arbitraryObjTypeNoDelta = oneof [return TypeTree,return TypeBlob,return TypeCommit,return TypeTag]++arbitrarySmallList = frequency [ (2, return []), (1, resize 3 arbitrary) ]++instance Arbitrary (Commit SHA1) where+    arbitrary = Commit <$> arbitrary <*> arbitraryRefList <*> arbitraryName <*> arbitraryName <*> return Nothing <*> arbitrarySmallList <*> arbitraryMsg++instance Arbitrary CommitExtra where+    arbitrary = CommitExtra <$> arbitraryBSasciiNoSpace 80 <*> arbitraryMsg++instance Arbitrary (Tree SHA1) where+    arbitrary = Tree <$> arbitraryEnts++instance Arbitrary (Blob SHA1) where+    arbitrary = Blob <$> arbitraryLazy++instance Arbitrary (Tag SHA1) where+    arbitrary = Tag <$> arbitrary <*> arbitraryObjTypeNoDelta <*> arbitraryBSascii 20 <*> arbitraryName <*> arbitraryMsg++instance Arbitrary (ObjNoDelta SHA1) where+    arbitrary = ObjNoDelta <$> oneof+        [ toObject <$> (arbitrary :: Gen (Commit SHA1))+        , toObject <$> (arbitrary :: Gen (Tree SHA1))+        , toObject <$> (arbitrary :: Gen (Blob SHA1))+        , toObject <$> (arbitrary :: Gen (Tag SHA1))+        ]++prop_object_marshalling_id :: ObjNoDelta SHA1 -> Bool+prop_object_marshalling_id (ObjNoDelta obj) =+    let unmarshall = looseUnmarshall :: L.ByteString -> Object SHA1+     in obj `assertEq` (unmarshall $ looseMarshall obj)+    where assertEq a b+            | show a == show b    = True+            | otherwise = error ("not equal:\n"  ++ show a ++ "\ngot: " ++ show b)++refTests =+    [ testProperty "hexadecimal" (marshEqual (fromHex . toHex :: Ref SHA1 -> Ref SHA1))+    , testProperty "binary" (marshEqual (fromBinary . toBinary :: Ref SHA1 -> Ref SHA1))+    , testProperty "ref" $ marshEqual (fromString . show :: Revision -> Revision)+    ]+    where+        marshEqual t ref = ref `assertEq` t ref+        assertEq a b+            | a == b    = True+            | otherwise = error ("expecting: " ++ show a ++ " got: " ++ show b)++objTests =+    [ testProperty "unmarshall.marshall==id" prop_object_marshalling_id+    ]++main = defaultMain $ testGroup "hit"+    [ testGroup "ref marshalling" refTests+    , testGroup "object marshalling" objTests+    ]

@@ -1,14 +1,14 @@ Name:                git-Version:             0.1+Version:             0.2.0 Synopsis:            Git operations in haskell Description:     .-    An haskell implementation of git storage operations, allowing users+    A Haskell implementation of git storage operations, allowing users     to manipulate git repositories (read and write).     .     This implementation is fully interoperable with the main C implementation.     .-    This is stricly only manipulating the git store (what's inside the .git directory),+    This is strictly only manipulating the git store (what's inside the .git directory),     and doesn't do anything with the index or your working directory files.     . License:             BSD3@@ -19,7 +19,7 @@ Category:            Development Stability:           experimental Build-Type:          Simple-Homepage:            https://github.com/vincenthz/hit+Homepage:            https://github.com/vincenthz/hs-git tested-with:         GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 Cabal-Version:       >=1.8 data-files:          README.md@@ -95,6 +95,7 @@   type:              exitcode-stdio-1.0   hs-source-dirs:    tests   Main-Is:           Repo.hs+  other-modules:     Monad   Build-depends:     base >= 3 && < 7                    , bytestring                    , tasty

@@ -1,3 +1,4 @@+{-# LANGUAGE ScopedTypeVariables #-} import Test.Tasty import Test.Tasty.QuickCheck @@ -27,6 +28,9 @@         Nothing -> putStrLn "cannot run this test without repository. clone the original repository for test"         Just _  -> withCurrentRepo f +doLocalMarshallEq+    :: Git SHA1+    -> IO [[Maybe (Ref SHA1, Ref SHA1, (ObjectHeader SHA1, L.ByteString), (ObjectHeader SHA1, L.ByteString))]] doLocalMarshallEq git = do      prefixes <- looseEnumeratePrefixes (gitRepoPath git)      forM prefixes $ \prefix -> do@@ -57,7 +61,7 @@                >> exitFailure  main = do-    onLocalRepo $ \git -> do+    onLocalRepo $ \(git :: Git SHA1) -> do         doLocalMarshallEq git >>= printLocalMarshallError . catMaybes . concat+        testGitMonadLocal         return ()-    testGitMonadLocal

@@ -1,3 +1,4 @@+{-# LANGUAGE FlexibleInstances #-} import Test.Tasty.QuickCheck import Test.Tasty @@ -18,10 +19,10 @@  -- for arbitrary instance to generate only data that are writable -- to disk. i.e. no deltas.-data ObjNoDelta = ObjNoDelta Object+data ObjNoDelta hash = ObjNoDelta (Object hash)     deriving (Eq) -instance Show ObjNoDelta where+instance Show (ObjNoDelta hash) where     show (ObjNoDelta o) = show o  arbitraryBS size = B.pack . map fromIntegral <$> replicateM size (choose (0,255) :: Gen Int)@@ -36,16 +37,19 @@                       , choose (0x30, 0x7f)                       ] -instance Arbitrary Ref where-    arbitrary = fromBinary <$> arbitraryBS 20+arbitraryRef :: HashAlgorithm hash => hash -> Gen (Ref hash)+arbitraryRef alg = fromBinary <$> arbitraryBS (hashDigestSize alg) +instance HashAlgorithm hash => Arbitrary (Ref hash) where+    arbitrary = arbitraryRef (error "alg")+ arbitraryMsg = arbitraryBSno0 1 arbitraryLazy = L.fromChunks . (:[]) <$> arbitraryBS 40 -arbitraryRefList :: Gen [Ref]+arbitraryRefList :: Gen [Ref SHA1] arbitraryRefList = replicateM 2 arbitrary -arbitraryEnt :: Gen TreeEnt+arbitraryEnt :: Gen (TreeEnt SHA1) arbitraryEnt = liftM3 (,,) arbitrary (arbitraryEntname 23) arbitrary arbitraryEnts = choose (1,2) >>= \i -> replicateM i arbitraryEnt @@ -83,37 +87,40 @@  arbitrarySmallList = frequency [ (2, return []), (1, resize 3 arbitrary) ] -instance Arbitrary Commit where+instance Arbitrary (Commit SHA1) where     arbitrary = Commit <$> arbitrary <*> arbitraryRefList <*> arbitraryName <*> arbitraryName <*> return Nothing <*> arbitrarySmallList <*> arbitraryMsg  instance Arbitrary CommitExtra where     arbitrary = CommitExtra <$> arbitraryBSasciiNoSpace 80 <*> arbitraryMsg -instance Arbitrary Tree where+instance Arbitrary (Tree SHA1) where     arbitrary = Tree <$> arbitraryEnts -instance Arbitrary Blob where+instance Arbitrary (Blob SHA1) where     arbitrary = Blob <$> arbitraryLazy -instance Arbitrary Tag where+instance Arbitrary (Tag SHA1) where     arbitrary = Tag <$> arbitrary <*> arbitraryObjTypeNoDelta <*> arbitraryBSascii 20 <*> arbitraryName <*> arbitraryMsg -instance Arbitrary ObjNoDelta where+instance Arbitrary (ObjNoDelta SHA1) where     arbitrary = ObjNoDelta <$> oneof-        [ toObject <$> (arbitrary :: Gen Commit)-        , toObject <$> (arbitrary :: Gen Tree)-        , toObject <$> (arbitrary :: Gen Blob)-        , toObject <$> (arbitrary :: Gen Tag)+        [ toObject <$> (arbitrary :: Gen (Commit SHA1))+        , toObject <$> (arbitrary :: Gen (Tree SHA1))+        , toObject <$> (arbitrary :: Gen (Blob SHA1))+        , toObject <$> (arbitrary :: Gen (Tag SHA1))         ] -prop_object_marshalling_id (ObjNoDelta obj) = obj `assertEq` (looseUnmarshall $ looseMarshall obj)+prop_object_marshalling_id :: ObjNoDelta SHA1 -> Bool+prop_object_marshalling_id (ObjNoDelta obj) =+    let unmarshall = looseUnmarshall :: L.ByteString -> Object SHA1+     in obj `assertEq` (unmarshall $ looseMarshall obj)     where assertEq a b             | show a == show b    = True             | otherwise = error ("not equal:\n"  ++ show a ++ "\ngot: " ++ show b)  refTests =-    [ testProperty "hexadecimal" (marshEqual (fromHex . toHex))-    , testProperty "binary" (marshEqual (fromBinary . toBinary))+    [ testProperty "hexadecimal" (marshEqual (fromHex . toHex :: Ref SHA1 -> Ref SHA1))+    , testProperty "binary" (marshEqual (fromBinary . toBinary :: Ref SHA1 -> Ref SHA1))     , testProperty "ref" $ marshEqual (fromString . show :: Revision -> Revision)     ]     where