From e5cac60232f047c73a4318d34c0214e4386e2fa8 Mon Sep 17 00:00:00 2001
From: Vincent Hanquez <vincent@snarc.org>
Date: Sat, 28 May 2016 08:02:27 +0100
Subject: [PATCH] parametrize the Hash algorithm
---
Data/Git/Diff.hs | 67 +++++++++++++++-------------
Data/Git/Monad.hs | 64 ++++++++++++++-------------
Data/Git/Named.hs | 18 ++++----
Data/Git/Parser.hs | 9 ++--
Data/Git/Path.hs | 4 +-
Data/Git/Ref.hs | 35 ++++++++-------
Data/Git/Repository.hs | 81 ++++++++++++++++++----------------
Data/Git/Storage.hs | 75 ++++++++++++++++---------------
Data/Git/Storage/FileWriter.hs | 14 +++---
Data/Git/Storage/Loose.hs | 30 ++++++-------
Data/Git/Storage/Object.hs | 69 +++++++++++++++--------------
Data/Git/Storage/Pack.hs | 47 ++++++++++++++------
Data/Git/Storage/PackIndex.hs | 33 +++++++++-----
Data/Git/Types.hs | 22 ++++-----
Data/Git/WorkTree.hs | 56 ++++++++++++++++-------
tests/Repo.hs | 6 ++-
tests/Tests.hs | 38 +++++++++-------
17 files changed, 376 insertions(+), 292 deletions(-)
diff --git a/Data/Git/Diff.hs b/Data/Git/Diff.hs
index d176343..ad81d8e 100644
--- a/Data/Git/Diff.hs
+++ b/Data/Git/Diff.hs
@@ -31,9 +31,11 @@ import Data.Char (ord)
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 @@ data BlobContent = FileContent [L.ByteString] -- ^ Text file's lines
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 @@ data BlobState = BlobState
-- | 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 @@ buildListForDiff git ref = do
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 @@ buildListForDiff git ref = do
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 @@ buildListForDiff git ref = do
-- > 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 @@ data GitFileMode = NewMode ModePerm
| 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 @@ data GitFileRef = NewRef Ref
-- * 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 @@ defaultDiff context (OldAndNew old new) acc =
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)
diff --git a/Data/Git/Monad.hs b/Data/Git/Monad.hs
index d82136e..08a9ae4 100644
--- a/Data/Git/Monad.hs
+++ b/Data/Git/Monad.hs
@@ -85,6 +85,8 @@ import qualified Data.Git.Storage.Object as Git
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 @@ revisionFromString = Git.fromString
-- > 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 @@ instance Resolvable Git.RefName where
-- 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 @@ branchWrite rn ref = do
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 @@ getCommit r = do
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 @@ setObject obj = do
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 @@ getObject rev resolvDelta = do
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 @@ workTreeFlush tree = do
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 Result ctx a
-------------------------------------------------------------------------------
data GitContext = GitContext
- { gitContextGit :: !Git.Git
+ { gitContextGit :: !(Git.Git SHA1)
}
newtype GitM a = GitM
@@ -267,13 +269,13 @@ bindGitM m fm = GitM $ \ctx -> do
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 @@ withCurrentRepo m = Git.withCurrentRepo (\git -> executeGitM git m)
-------------------------------------------------------------------------------
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 @@ bindCommitAccessM m fm = CommitAccessM $ \ctx -> do
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 @@ getAuthor = withCommitAccessContext (Git.commitAuthor . commitAccessContextCommi
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 @@ getEncoding = withCommitAccessContext (Git.commitEncoding . commitAccessContextC
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 @@ withCommit rev m = do
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 @@ bindCommitM m fm = CommitM $ \ctx -> do
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 :: Git.Person -> CommitM ()
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 @@ setMessage msg = commitUpdateContext $ \ctx -> return (ctx { commitContextMessag
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 @@ withNewCommit :: (GitMonad git, Resolvable rev)
-> 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 @@ withBranch :: GitMonad git
-- 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
diff --git a/Data/Git/Named.hs b/Data/Git/Named.hs
index 983ff6f..7fbbfd6 100644
--- a/Data/Git/Named.hs
+++ b/Data/Git/Named.hs
@@ -49,10 +49,11 @@ data RefSpecTy = RefHead
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 @@ data PackedRefs a = PackedRefs
, 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)
@@ -160,7 +162,7 @@ looseRemotesList gitRepo = listRefs (remotesPath gitRepo)
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,7 +171,7 @@ writeRefFile gitRepo specty refcont = do
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
diff --git a/Data/Git/Parser.hs b/Data/Git/Parser.hs
index 095705b..3f4f617 100644
--- a/Data/Git/Parser.hs
+++ b/Data/Git/Parser.hs
@@ -56,10 +56,13 @@ vlf = do
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 (error "referenceBin") 1 fromBinary
+referenceHex = takeDigestSize (error "referenceHex") 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))
diff --git a/Data/Git/Path.hs b/Data/Git/Path.hs
index 277cf63..dc5c662 100644
--- a/Data/Git/Path.hs
+++ b/Data/Git/Path.hs
@@ -34,7 +34,7 @@ remoteEntPath gitRepo name ent = remotePath gitRepo name </> fromString ent
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 @@ packPath repoPath packRef =
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
diff --git a/Data/Git/Ref.hs b/Data/Git/Ref.hs
index 53ebcce..f0f884c 100644
--- a/Data/Git/Ref.hs
+++ b/Data/Git/Ref.hs
@@ -8,6 +8,9 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Data.Git.Ref
( Ref
+ , SHA1
+ , Crypto.Hash.HashAlgorithm
+ , Crypto.Hash.hashDigestSize
-- * Exceptions
, RefInvalid(..)
, RefNotFound(..)
@@ -45,10 +48,10 @@ import Data.Data
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 +60,11 @@ data RefInvalid = RefInvalid ByteString
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 +74,7 @@ isHexString = and . map isHexDigit
-- | 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 +82,47 @@ fromHex s =
-- | 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
diff --git a/Data/Git/Repository.hs b/Data/Git/Repository.hs
index 244ae1d..2ba1141 100644
--- a/Data/Git/Repository.hs
+++ b/Data/Git/Repository.hs
@@ -64,15 +64,15 @@ import qualified Data.Map as M
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 f (Just o) = f o
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 @@ resolveRevision git (Revision prefix modifiers) =
"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 @@ resolveRevision git (Revision prefix modifiers) =
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 @@ resolveRevision git (Revision prefix modifiers) =
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 @@ resolveTreeish git ref = getObject git ref True >>= mapJustM recToTree
--
-- 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 @@ rewrite git mapCommit revision nbParent = do
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 @@ buildHTree git (Tree ents) = mapM resolveTree ents
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 @@ resolvePath git commitRef paths =
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 @@ headSet git (Right refname) =
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 @@ headGet git = do
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 @@ configGetAll git = readIORef (configs git)
--
-- > 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
diff --git a/Data/Git/Storage.hs b/Data/Git/Storage.hs
index f5cbad8..7ef2c9e 100644
--- a/Data/Git/Storage.hs
+++ b/Data/Git/Storage.hs
@@ -49,6 +49,7 @@ import Data.List ((\\), isPrefixOf)
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 @@ import qualified Data.Map as M
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 @@ openRepo path = Git path <$> newIORef []
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 @@ findRepo = do
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 @@ initRepo path = do
, "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 @@ getDescription git = do
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 @@ iterateIndexes git f initAcc = do
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 @@ findReference git ref = maybe NotFound id <$> (findLoose `mplusIO` findInIndexes
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 @@ findReferencesWithPrefix git pre
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 @@ readRawFromPack git pref offset = do
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 @@ readFromPack git pref o resolveDelta = do
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 @@ readFromPack git pref o resolveDelta = do
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 @@ getObjectType git ref = findReference git ref >>= getObjectTypeAt
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
diff --git a/Data/Git/Storage/FileWriter.hs b/Data/Git/Storage/FileWriter.hs
index 4eda473..15a292e 100644
--- a/Data/Git/Storage/FileWriter.hs
+++ b/Data/Git/Storage/FileWriter.hs
@@ -27,13 +27,13 @@ modifyIORefStrict ref f = do
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 @@ fileWriterNew handle = do
, 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 @@ withFileWriter path f =
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
diff --git a/Data/Git/Storage/Loose.hs b/Data/Git/Storage/Loose.hs
index ed7137f..084d33a 100644
--- a/Data/Git/Storage/Loose.hs
+++ b/Data/Git/Storage/Loose.hs
@@ -62,7 +62,7 @@ isObjectPrefix [a,b] = isHexDigit a && isHexDigit b
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 @@ parseBlobHeader = P.string "blob " >> parseLength >> P.byte 0 >> return Header
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 @@ parseObject = parseSuccess getOne
-- | 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 @@ looseUnmarshallRaw stream =
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 :: LocalPath -> IO [[Char]]
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 @@ looseMarshall obj
-- | 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 @@ looseWriteBlobFromFile repoPath file = do
-- | 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)
diff --git a/Data/Git/Storage/Object.hs b/Data/Git/Storage/Object.hs
index 38f067a..42b77eb 100644
--- a/Data/Git/Storage/Object.hs
+++ b/Data/Git/Storage/Object.hs
@@ -72,43 +72,44 @@ toLazyByteString = id
#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 TypeDeltaOff = True
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 :: P.Parser ModePerm
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 @@ commitParse = do
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 @@ asciiChar c
| 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 @@ objectParseBlob = ObjBlob <$> blobParse
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 @@ treeWrite (Tree ents) = toLazyByteString $ mconcat $ concatMap writeTreeEnt ents
, 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 @@ commitWrite (Commit tree parents author committer encoding extra msg) =
,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 @@ tagWrite (Tag ref ty tag tagger signature) =
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 @@ instance Objectable DeltaRef where
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
diff --git a/Data/Git/Storage/Pack.hs b/Data/Git/Storage/Pack.hs
index 2a0b996..1dbd47d 100644
--- a/Data/Git/Storage/Pack.hs
+++ b/Data/Git/Storage/Pack.hs
@@ -44,18 +44,18 @@ import Data.Git.Storage.FileReader
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 @@ packEnumerate repoPath = map onlyHash . filter isPackFile <$> listDirectoryFilen
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 :: FileReader -> IO ()
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 @@ packReadHeader repoPath packRef =
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 @@ packEnumerateObjects repoPath packRef entries f =
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,7 +142,7 @@ packObjectFromRaw (TypeDeltaOff, Just (PtrOfs o), objData) = toObject . DeltaOfs
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
diff --git a/Data/Git/Storage/PackIndex.hs b/Data/Git/Storage/PackIndex.hs
index 3982a35..4ada28e 100644
--- a/Data/Git/Storage/PackIndex.hs
+++ b/Data/Git/Storage/PackIndex.hs
@@ -45,16 +45,16 @@ import qualified Data.Git.Parser as P
data PackIndexHeader = PackIndexHeader !Word32 !(Vector Word32)
deriving (Show,Eq)
-data PackIndex = PackIndex
- { packIndexSha1s :: Vector Ref
+data PackIndex hash = PackIndex
+ { packIndexSha1s :: Vector (Ref hash)
, packIndexCRCs :: Vector Word32
, packIndexPackoffs :: Vector Word32
- , packIndexPackChecksum :: Ref
- , packIndexChecksum :: Ref
+ , 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
@@ -63,7 +63,7 @@ packIndexEnumerate repoPath = map onlyHash . filter isPackFile <$> listDirectory
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 :: FileReader -> IO ()
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,7 +90,13 @@ packIndexHeaderGetNbWithPrefix (PackIndexHeader _ indexes) n
| 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 :: HashAlgorithm hash
+ => PackIndexHeader
+ -> FileReader
+ -> Int
+ -> (a -> Word32 -> Ref hash -> (a, Bool))
+ -> a
+ -> IO a
packIndexHeaderFoldRef idxHdr@(PackIndexHeader _ indexes) fr refprefix f initAcc
| nb == 0 = return initAcc
| otherwise = do
@@ -109,7 +115,7 @@ packIndexHeaderFoldRef idxHdr@(PackIndexHeader _ indexes) fr refprefix f initAcc
(sha1Offset,_,_) = packIndexOffsets 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
@@ -125,7 +131,7 @@ packIndexGetReferenceLocation idxHdr@(PackIndexHeader _ indexes) fr ref = do
(_,_,packOffset) = packIndexOffsets 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
@@ -161,11 +167,14 @@ 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
diff --git a/Data/Git/Types.hs b/Data/Git/Types.hs
index c4c6646..599909b 100644
--- a/Data/Git/Types.hs
+++ b/Data/Git/Types.hs
@@ -170,7 +170,7 @@ type EntPath = [EntName]
-- | 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 @@ data Person = Person
} 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 @@ data CommitExtra = CommitExtra
} 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 @@ data Tag = Tag
} 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)
diff --git a/Data/Git/WorkTree.hs b/Data/Git/WorkTree.hs
index 3af8884..d3631d1 100644
--- a/Data/Git/WorkTree.hs
+++ b/Data/Git/WorkTree.hs
@@ -30,29 +30,39 @@ import Data.Git.Repository
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 @@ workTreeDelete git wt path = diveFromRoot git wt path dive
--
-- 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 @@ workTreeFlushAt git wt path = do
-- | 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 @@ workTreeFlush git wt = do
----- 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 @@ loadTreeVar git treeRef = do
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 @@ loadOrGetTree git x varCurrent onMissing =
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 @@ diveFromRoot git wt path dive
TreeRef ref -> loadTreeVar git ref
putMVar wt $ TreeLoaded current
dive current path
-
diff --git a/tests/Repo.hs b/tests/Repo.hs
index 73e5201..5b16bad 100644
--- a/tests/Repo.hs
+++ b/tests/Repo.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE ScopedTypeVariables #-}
import Test.Tasty
import Test.Tasty.QuickCheck
@@ -27,6 +28,9 @@ onLocalRepo f = do
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 @@ printLocalMarshallError l
>> exitFailure
main = do
- onLocalRepo $ \git -> do
+ onLocalRepo $ \(git :: Git SHA1) -> do
doLocalMarshallEq git >>= printLocalMarshallError . catMaybes . concat
return ()
testGitMonadLocal
diff --git a/tests/Tests.hs b/tests/Tests.hs
index 75c3020..27d0c68 100644
--- a/tests/Tests.hs
+++ b/tests/Tests.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE FlexibleInstances #-}
import Test.Tasty.QuickCheck
import Test.Tasty
@@ -18,10 +19,10 @@ import Data.Maybe
-- 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,16 @@ arbitraryEntname size = entName . B.pack . map fromIntegral <$> replicateM size
, choose (0x30, 0x7f)
]
-instance Arbitrary Ref where
+instance Arbitrary (Ref SHA1) where
arbitrary = fromBinary <$> arbitraryBS 20
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 +84,40 @@ arbitraryObjTypeNoDelta = oneof [return TypeTree,return TypeBlob,return TypeComm
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
--
GitLab