From b84ee8a414fed46deded08da86946ded40e31b2a Mon Sep 17 00:00:00 2001
From: Eduardo Trujillo <ed@chromabits.com>
Date: Sun, 20 Dec 2020 18:48:06 -0800
Subject: [PATCH] style(src): Reformat all Haskell source files
---
Data/Git.hs | 105 +++--
Data/Git/Config.hs | 97 +++--
Data/Git/Delta.hs | 95 ++---
Data/Git/Diff.hs | 427 +++++++++++---------
Data/Git/Diff/Patience.hs | 111 +++---
Data/Git/Imports.hs | 11 +-
Data/Git/Index.hs | 271 ++++++-------
Data/Git/Internal.hs | 24 +-
Data/Git/Monad.hs | 703 +++++++++++++++++----------------
Data/Git/Named.hs | 249 ++++++------
Data/Git/OS.hs | 101 ++---
Data/Git/Parser.hs | 128 +++---
Data/Git/Path.hs | 20 +-
Data/Git/Ref.hs | 83 ++--
Data/Git/Repository.hs | 459 +++++++++++----------
Data/Git/Revision.hs | 176 +++++----
Data/Git/Storage.hs | 515 +++++++++++++-----------
Data/Git/Storage/CacheFile.hs | 31 +-
Data/Git/Storage/FileReader.hs | 258 ++++++------
Data/Git/Storage/FileWriter.hs | 55 ++-
Data/Git/Storage/Loose.hs | 198 +++++-----
Data/Git/Storage/Object.hs | 419 ++++++++++----------
Data/Git/Storage/Pack.hs | 220 ++++++-----
Data/Git/Storage/PackIndex.hs | 201 +++++-----
Data/Git/Types.hs | 262 ++++++------
Data/Git/WorkTree.hs | 222 ++++++-----
tests/Monad.hs | 63 +--
tests/Repo.hs | 97 +++--
tests/Tests.hs | 172 ++++----
29 files changed, 3013 insertions(+), 2760 deletions(-)
diff --git a/Data/Git.hs b/Data/Git.hs
index 9a12234..66a915a 100644
--- a/Data/Git.hs
+++ b/Data/Git.hs
@@ -4,83 +4,82 @@
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unix
---
module Data.Git
- (
- -- * Basic types
- Ref
- , RefName(..)
- , Commit(..)
- , Person(..)
- , CommitExtra(..)
- , Tree(..)
- , Blob(..)
- , Tag(..)
- , GitTime
- , ModePerm(..)
- , EntName
- , EntPath
- , entName
- , entPathAppend
+ ( -- * Basic types
+ Ref,
+ RefName (..),
+ Commit (..),
+ Person (..),
+ CommitExtra (..),
+ Tree (..),
+ Blob (..),
+ Tag (..),
+ GitTime,
+ ModePerm (..),
+ EntName,
+ EntPath,
+ entName,
+ entPathAppend,
-- * Helper & type related to ModePerm
- , ObjectFileType(..)
- , FilePermissions(..)
- , getPermission
- , getFiletype
+ ObjectFileType (..),
+ FilePermissions (..),
+ getPermission,
+ getFiletype,
-- * Revision
- , Revision
- , resolveRevision
+ Revision,
+ resolveRevision,
-- * Object resolution
- , resolveTreeish
- , resolvePath
+ resolveTreeish,
+ resolvePath,
-- * repo context
- , Git
- , withCurrentRepo
- , withRepo
- , findRepo
+ Git,
+ withCurrentRepo,
+ withRepo,
+ findRepo,
-- * Repository queries and creation
- , initRepo
- , isRepo
+ initRepo,
+ isRepo,
-- * Context operations
- , rewrite
+ rewrite,
-- * Get objects
- , getObject
- , getCommit
- , getTree
+ getObject,
+ getCommit,
+ getTree,
-- * Set objects
- , setObject
- , toObject
+ setObject,
+ toObject,
-- * Work trees
- , WorkTree
- , EntType(..)
- , workTreeNew
- , workTreeFrom
- , workTreeDelete
- , workTreeSet
- , workTreeFlush
+ WorkTree,
+ EntType (..),
+ workTreeNew,
+ workTreeFrom,
+ workTreeDelete,
+ workTreeSet,
+ workTreeFlush,
-- * Named refs
- , branchWrite
- , branchList
- , tagWrite
- , tagList
- , headSet
- , headGet
- ) where
+ branchWrite,
+ branchList,
+ tagWrite,
+ tagList,
+ headSet,
+ headGet,
+ )
+where
import Data.Git.Ref
-import Data.Git.Types
-import Data.Git.Storage
import Data.Git.Repository
import Data.Git.Revision
+import Data.Git.Storage
import Data.Git.Storage.Object (toObject)
+import Data.Git.Types
import Data.Git.WorkTree
diff --git a/Data/Git/Config.hs b/Data/Git/Config.hs
index bf037d9..038668f 100644
--- a/Data/Git/Config.hs
+++ b/Data/Git/Config.hs
@@ -8,59 +8,64 @@
-- Portability : unix
--
-- config related types and methods.
---
module Data.Git.Config
- ( Config(..)
- , Section(..)
+ ( Config (..),
+ Section (..),
+
-- * reading methods
- , readConfig
- , readGlobalConfig
+ readConfig,
+ readGlobalConfig,
+
-- * methods
- , listSections
- , get
- ) where
+ listSections,
+ get,
+ )
+where
-import Data.Git.Path
import Data.Git.Imports
import Data.Git.OS
+import Data.Git.Path
import Data.List (find)
import qualified Data.Set as S
newtype Config = Config [Section]
- deriving (Show,Eq)
+ deriving (Show, Eq)
data Section = Section
- { sectionName :: String
- , sectionKVs :: [(String, String)]
- } deriving (Show,Eq)
+ { sectionName :: String,
+ sectionKVs :: [(String, String)]
+ }
+ deriving (Show, Eq)
parseConfig :: String -> Config
parseConfig = Config . reverse . toSections . foldl accSections ([], Nothing) . lines
- where toSections (l,Nothing) = l
- toSections (l,Just s) = s : l
+ where
+ toSections (l, Nothing) = l
+ toSections (l, Just s) = s : l
- -- a new section in the config file
- accSections (sections, mcurrent) ('[':sectNameE)
- | last sectNameE == ']' =
- let sectName = take (length sectNameE - 1) sectNameE
- in case mcurrent of
- Nothing -> (sections, Just $ Section sectName [])
- Just current -> (sectionFinalize current : sections, Just $ Section sectName [])
- | otherwise =
- (sections, mcurrent)
- -- a normal line without having any section defined yet
- accSections acc@(_, Nothing) _ = acc
- -- potentially a k-v line in an existing section
- accSections (sections, Just current) kvLine =
- case break (== '=') kvLine of
- (k,'=':v) -> (sections, Just $ sectionAppend current (strip k, strip v))
- (_,_) -> (sections, Just current) -- not a k = v line
+ -- a new section in the config file
+ accSections (sections, mcurrent) ('[' : sectNameE)
+ | last sectNameE == ']' =
+ let sectName = take (length sectNameE - 1) sectNameE
+ in case mcurrent of
+ Nothing -> (sections, Just $ Section sectName [])
+ Just current -> (sectionFinalize current : sections, Just $ Section sectName [])
+ | otherwise =
+ (sections, mcurrent)
+ -- a normal line without having any section defined yet
+ accSections acc@(_, Nothing) _ = acc
+ -- potentially a k-v line in an existing section
+ accSections (sections, Just current) kvLine =
+ case break (== '=') kvLine of
+ (k, '=' : v) -> (sections, Just $ sectionAppend current (strip k, strip v))
+ (_, _) -> (sections, Just current) -- not a k = v line
-- append a key-value
- sectionAppend (Section n l) kv = Section n (kv:l)
- sectionFinalize (Section n l) = Section n $ reverse l
+ sectionAppend (Section n l) kv = Section n (kv : l)
+ sectionFinalize (Section n l) = Section n $ reverse l
- strip s = dropSpaces $ reverse $ dropSpaces $ reverse s
- where dropSpaces = dropWhile (\c -> c == ' ' || c == '\t')
+ strip s = dropSpaces $ reverse $ dropSpaces $ reverse s
+ where
+ dropSpaces = dropWhile (\c -> c == ' ' || c == '\t')
readConfigPath :: LocalPath -> IO Config
readConfigPath filepath = parseConfig <$> readTextFile filepath
@@ -73,13 +78,19 @@ readGlobalConfig = getHomeDirectory >>= readConfigPath . (\homeDir -> homeDir </
listSections :: [Config] -> [String]
listSections = S.toList . foldr accSections S.empty
- where accSections (Config sections) set = foldr S.insert set (map sectionName sections)
+ where
+ accSections (Config sections) set = foldr S.insert set (map sectionName sections)
-- | Get a configuration element in a stack of config file, starting from the top.
-get :: [Config] -- ^ stack of config
- -> String -- ^ section name
- -> String -- ^ key name
- -> Maybe String
-get [] _ _ = Nothing
-get (Config c:cs) section key = findOne `mplus` get cs section key
- where findOne = find (\s -> sectionName s == section) c >>= lookup key . sectionKVs
+get ::
+ -- | stack of config
+ [Config] ->
+ -- | section name
+ String ->
+ -- | key name
+ String ->
+ Maybe String
+get [] _ _ = Nothing
+get (Config c : cs) section key = findOne `mplus` get cs section key
+ where
+ findOne = find (\s -> sectionName s == section) c >>= lookup key . sectionKVs
diff --git a/Data/Git/Delta.hs b/Data/Git/Delta.hs
index 5212ced..a601032 100644
--- a/Data/Git/Delta.hs
+++ b/Data/Git/Delta.hs
@@ -6,32 +6,31 @@
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unix
---
module Data.Git.Delta
- ( Delta(..)
- , DeltaCmd(..)
- , deltaParse
- , deltaRead
- , deltaApply
- ) where
+ ( Delta (..),
+ DeltaCmd (..),
+ deltaParse,
+ deltaRead,
+ deltaApply,
+ )
+where
+import Data.Bits
import Data.ByteString (ByteString)
import qualified Data.ByteString.Lazy as L
-import Data.Bits
-import Data.Word
-
+import Data.Git.Imports
import qualified Data.Git.Parser as P
-import Data.Git.Imports
+import Data.Word
-- | a delta is a source size, a destination size and a list of delta cmd
data Delta = Delta !Word64 !Word64 ![DeltaCmd]
- deriving (Show,Eq)
+ deriving (Show, Eq)
-- | possible commands in a delta
-data DeltaCmd =
- DeltaCopy !ByteString -- command to insert this bytestring
- | DeltaSrc !Word64 !Word64 -- command to copy from source (offset, size)
- deriving (Show,Eq)
+data DeltaCmd
+ = DeltaCopy !ByteString -- command to insert this bytestring
+ | DeltaSrc !Word64 !Word64 -- command to copy from source (offset, size)
+ deriving (Show, Eq)
-- | parse a delta.
-- format is 2 variable sizes, followed by delta cmds. for each cmd:
@@ -40,33 +39,33 @@ data DeltaCmd =
-- * extensions are not handled.
deltaParse :: P.Parser Delta
deltaParse = do
- srcSize <- getDeltaHdrSize
- resSize <- getDeltaHdrSize
- dcmds <- many (P.anyByte >>= parseWithCmd)
- return $ Delta srcSize resSize dcmds
+ srcSize <- getDeltaHdrSize
+ resSize <- getDeltaHdrSize
+ dcmds <- many (P.anyByte >>= parseWithCmd)
+ return $ Delta srcSize resSize dcmds
where
- getDeltaHdrSize = unbytes 0 <$> P.vlf
- -- use a foldl ..
- unbytes _ [] = 0
- unbytes sh (x:xs) = (fromIntegral x) `shiftL` sh + unbytes (sh+7) xs
- -- parse one command, either an extension, a copy from src, or a copy from delta.
- parseWithCmd cmd
- | cmd == 0 = error "delta extension not supported"
- | cmd `testBit` 7 = do
- o1 <- word8cond (cmd `testBit` 0) 0
- o2 <- word8cond (cmd `testBit` 1) 8
- o3 <- word8cond (cmd `testBit` 2) 16
- o4 <- word8cond (cmd `testBit` 3) 24
- s1 <- word8cond (cmd `testBit` 4) 0
- s2 <- word8cond (cmd `testBit` 5) 8
- s3 <- word8cond (cmd `testBit` 6) 16
- let offset = o1 .|. o2 .|. o3 .|. o4
- let size = s1 .|. s2 .|. s3
- return $ DeltaSrc offset (if size == 0 then 0x10000 else size)
- | otherwise = DeltaCopy <$> P.take (fromIntegral cmd)
+ getDeltaHdrSize = unbytes 0 <$> P.vlf
+ -- use a foldl ..
+ unbytes _ [] = 0
+ unbytes sh (x : xs) = (fromIntegral x) `shiftL` sh + unbytes (sh + 7) xs
+ -- parse one command, either an extension, a copy from src, or a copy from delta.
+ parseWithCmd cmd
+ | cmd == 0 = error "delta extension not supported"
+ | cmd `testBit` 7 = do
+ o1 <- word8cond (cmd `testBit` 0) 0
+ o2 <- word8cond (cmd `testBit` 1) 8
+ o3 <- word8cond (cmd `testBit` 2) 16
+ o4 <- word8cond (cmd `testBit` 3) 24
+ s1 <- word8cond (cmd `testBit` 4) 0
+ s2 <- word8cond (cmd `testBit` 5) 8
+ s3 <- word8cond (cmd `testBit` 6) 16
+ let offset = o1 .|. o2 .|. o3 .|. o4
+ let size = s1 .|. s2 .|. s3
+ return $ DeltaSrc offset (if size == 0 then 0x10000 else size)
+ | otherwise = DeltaCopy <$> P.take (fromIntegral cmd)
- word8cond False _ = return 0
- word8cond True sh = flip shiftL sh . fromIntegral <$> P.anyByte
+ word8cond False _ = return 0
+ word8cond True sh = flip shiftL sh . fromIntegral <$> P.anyByte
-- | read one delta from a lazy bytestring.
deltaRead :: [ByteString] -> Maybe Delta
@@ -75,9 +74,11 @@ deltaRead = P.maybeParseChunks deltaParse -- . L.toChunks
-- | apply a delta on a lazy bytestring, returning a new bytestring.
deltaApply :: L.ByteString -> Delta -> L.ByteString
deltaApply src (Delta srcSize _ deltaCmds)
- | L.length src /= fromIntegral srcSize = error "source size do not match"
- | otherwise = -- FIXME use a bytestring builder here.
- L.fromChunks $ concatMap resolve deltaCmds
- where resolve (DeltaSrc o s) = L.toChunks $ takeAt (fromIntegral s) (fromIntegral o) src
- resolve (DeltaCopy b) = [b]
- takeAt sz at = L.take sz . L.drop at
+ | L.length src /= fromIntegral srcSize = error "source size do not match"
+ | otherwise -- FIXME use a bytestring builder here.
+ =
+ L.fromChunks $ concatMap resolve deltaCmds
+ where
+ resolve (DeltaSrc o s) = L.toChunks $ takeAt (fromIntegral s) (fromIntegral o) src
+ resolve (DeltaCopy b) = [b]
+ takeAt sz at = L.take sz . L.drop at
diff --git a/Data/Git/Diff.hs b/Data/Git/Diff.hs
index 289922a..622164d 100644
--- a/Data/Git/Diff.hs
+++ b/Data/Git/Diff.hs
@@ -6,112 +6,117 @@
-- Portability : unix
--
-- Basic Git diff methods.
---
-
module Data.Git.Diff
- (
- -- * Basic features
- BlobContent(..)
- , BlobState(..)
- , BlobStateDiff(..)
- , getDiffWith
+ ( -- * Basic features
+ BlobContent (..),
+ BlobState (..),
+ BlobStateDiff (..),
+ getDiffWith,
+
-- * Default helpers
- , GitDiff(..)
- , GitFileContent(..)
- , FilteredDiff(..)
- , GitFileRef(..)
- , GitFileMode(..)
- , TextLine(..)
- , defaultDiff
- , getDiff
- ) where
+ GitDiff (..),
+ GitFileContent (..),
+ FilteredDiff (..),
+ GitFileRef (..),
+ GitFileMode (..),
+ TextLine (..),
+ defaultDiff,
+ getDiff,
+ )
+where
-import Data.List (find, filter)
+import Data.ByteString.Lazy.Char8 as L
import Data.Char (ord)
import Data.Git
+import Data.Git.Diff.Patience (Item (..), diff)
+import Data.Git.Ref
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.List (filter, find)
import Data.Typeable
-import Data.Git.Diff.Patience (Item(..), diff)
-
-- | represents a blob's content (i.e., the content of a file at a given
-- reference).
-data BlobContent = FileContent [L.ByteString] -- ^ Text file's lines
- | BinaryContent L.ByteString -- ^ Binary content
- deriving (Show)
+data BlobContent
+ = -- | Text file's lines
+ FileContent [L.ByteString]
+ | -- | Binary content
+ BinaryContent L.ByteString
+ deriving (Show)
-- | This is a blob description at a given state (revision)
data BlobState hash = BlobState
- { bsFilename :: EntPath
- , bsMode :: ModePerm
- , bsRef :: Ref hash
- , bsContent :: BlobContent
- }
- deriving (Show)
+ { bsFilename :: EntPath,
+ bsMode :: ModePerm,
+ bsRef :: Ref hash,
+ bsContent :: BlobContent
+ }
+ deriving (Show)
-- | Two 'BlobState' are equal if they have the same filename, i.e.,
--
-- > ((BlobState x _ _ _) == (BlobState y _ _ _)) = (x == y)
instance Eq (BlobState hash) where
- (BlobState f1 _ _ _) == (BlobState f2 _ _ _) = f2 == f1
+ (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 hash =
- OnlyOld (BlobState hash)
- | OnlyNew (BlobState hash)
- | OldAndNew (BlobState hash) (BlobState hash)
+data BlobStateDiff hash
+ = OnlyOld (BlobState hash)
+ | OnlyNew (BlobState hash)
+ | OldAndNew (BlobState hash) (BlobState hash)
-buildListForDiff :: (Typeable hash, HashAlgorithm hash)
- => Git hash -> Ref hash -> IO [BlobState hash]
+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
- case tree of
- Just t -> do htree <- buildHTree git t
- buildTreeList htree []
- _ -> error "cannot build a tree from this reference"
- where
- --buildTreeList :: HTree hash -> EntPath -> IO [BlobState hash]
- buildTreeList [] _ = return []
- buildTreeList ((d,n,TreeFile r):xs) pathPrefix = do
- content <- catBlobFile r
- let isABinary = isBinaryFile content
- listTail <- buildTreeList xs pathPrefix
- case isABinary of
- False -> return $ (BlobState (entPathAppend pathPrefix n) d r (FileContent $ L.lines content)) : listTail
- True -> return $ (BlobState (entPathAppend pathPrefix n) d r (BinaryContent content)) : listTail
- buildTreeList ((_,n,TreeDir _ subTree):xs) pathPrefix = do
- l1 <- buildTreeList xs pathPrefix
- l2 <- buildTreeList subTree (entPathAppend pathPrefix n)
- return $ l1 ++ l2
+ commit <- getCommit git ref
+ tree <- resolveTreeish git $ commitTreeish commit
+ case tree of
+ Just t -> do
+ htree <- buildHTree git t
+ buildTreeList htree []
+ _ -> error "cannot build a tree from this reference"
+ where
+ --buildTreeList :: HTree hash -> EntPath -> IO [BlobState hash]
+ buildTreeList [] _ = return []
+ buildTreeList ((d, n, TreeFile r) : xs) pathPrefix = do
+ content <- catBlobFile r
+ let isABinary = isBinaryFile content
+ listTail <- buildTreeList xs pathPrefix
+ case isABinary of
+ False -> return $ (BlobState (entPathAppend pathPrefix n) d r (FileContent $ L.lines content)) : listTail
+ True -> return $ (BlobState (entPathAppend pathPrefix n) d r (BinaryContent content)) : listTail
+ buildTreeList ((_, n, TreeDir _ subTree) : xs) pathPrefix = do
+ l1 <- buildTreeList xs pathPrefix
+ l2 <- buildTreeList subTree (entPathAppend pathPrefix n)
+ return $ l1 ++ l2
- --catBlobFile :: Ref hash -> IO L.ByteString
- catBlobFile blobRef = do
- mobj <- getObjectRaw git blobRef True
- case mobj of
- Nothing -> error "not a valid object"
- Just obj -> return $ oiData obj
- getBinaryStat :: L.ByteString -> Double
- getBinaryStat bs = L.foldl' (\acc w -> acc + if isBin $ ord w then 1 else 0) 0 bs / (fromIntegral $ L.length bs)
- where
- isBin :: Int -> Bool
- isBin i
- | i >= 0 && i <= 8 = True
- | i == 12 = True
- | i >= 14 && i <= 31 = True
- | otherwise = False
+ --catBlobFile :: Ref hash -> IO L.ByteString
+ catBlobFile blobRef = do
+ mobj <- getObjectRaw git blobRef True
+ case mobj of
+ Nothing -> error "not a valid object"
+ Just obj -> return $ oiData obj
+ getBinaryStat :: L.ByteString -> Double
+ getBinaryStat bs = L.foldl' (\acc w -> acc + if isBin $ ord w then 1 else 0) 0 bs / (fromIntegral $ L.length bs)
+ where
+ isBin :: Int -> Bool
+ isBin i
+ | i >= 0 && i <= 8 = True
+ | i == 12 = True
+ | i >= 14 && i <= 31 = True
+ | otherwise = False
- isBinaryFile :: L.ByteString -> Bool
- isBinaryFile file = let bs = L.take 512 file
- in getBinaryStat bs > 0.0
+ isBinaryFile :: L.ByteString -> Bool
+ isBinaryFile file =
+ let bs = L.take 512 file
+ in getBinaryStat bs > 0.0
-- | generate a diff list between two revisions with a given diff helper.
--
@@ -127,63 +132,74 @@ buildListForDiff git ref = do
-- > getdiffwith f [] head^ head git
-- > where f (OnlyNew bs) acc = (bsFilename bs):acc
-- > f _ acc = acc
-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 ::
+ (Typeable hash, HashAlgorithm hash) =>
+ -- | diff helper (State -> accumulator -> accumulator)
+ (BlobStateDiff hash -> a -> a) ->
+ -- | accumulator
+ a ->
+ -- | commit reference (the original state)
+ Ref hash ->
+ -- | commit reference (the new state)
+ Ref hash ->
+ -- | repository
+ Git hash ->
+ 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 hash] -> [BlobState hash] -> [BlobStateDiff hash]
- doDiffWith [] [] = []
- doDiffWith [bs1] [] = [OnlyOld bs1]
- doDiffWith [] (bs2:xs2) = (OnlyNew bs2):(doDiffWith [] xs2)
- doDiffWith (bs1:xs1) xs2 =
- let bs2Maybe = Data.List.find (\x -> x == bs1) xs2
- in case bs2Maybe of
- Just bs2 -> let subxs2 = Data.List.filter (\x -> x /= bs2) xs2
- in (OldAndNew bs1 bs2):(doDiffWith xs1 subxs2)
- Nothing -> (OnlyOld bs1):(doDiffWith xs1 xs2)
+ commit1 <- buildListForDiff git ref1
+ commit2 <- buildListForDiff git ref2
+ return $ Prelude.foldr f acc $ doDiffWith commit1 commit2
+ where
+ doDiffWith :: [BlobState hash] -> [BlobState hash] -> [BlobStateDiff hash]
+ doDiffWith [] [] = []
+ doDiffWith [bs1] [] = [OnlyOld bs1]
+ doDiffWith [] (bs2 : xs2) = (OnlyNew bs2) : (doDiffWith [] xs2)
+ doDiffWith (bs1 : xs1) xs2 =
+ let bs2Maybe = Data.List.find (\x -> x == bs1) xs2
+ in case bs2Maybe of
+ Just bs2 ->
+ let subxs2 = Data.List.filter (\x -> x /= bs2) xs2
+ in (OldAndNew bs1 bs2) : (doDiffWith xs1 subxs2)
+ Nothing -> (OnlyOld bs1) : (doDiffWith xs1 xs2)
data TextLine = TextLine
- { lineNumber :: Integer
- , lineContent :: L.ByteString
- }
+ { lineNumber :: Integer,
+ lineContent :: L.ByteString
+ }
+
instance Eq TextLine where
a == b = (lineContent a) == (lineContent b)
a /= b = not (a == b)
+
instance Ord TextLine where
compare a b = compare (lineContent a) (lineContent b)
- a < b = (lineContent a) < (lineContent b)
- a <= b = (lineContent a) <= (lineContent b)
- a > b = b < a
- a >= b = b <= a
+ a < b = (lineContent a) < (lineContent b)
+ a <= b = (lineContent a) <= (lineContent b)
+ a > b = b < a
+ a >= b = b <= a
data FilteredDiff = NormalLine (Item TextLine) | Separator
-data GitFileContent = NewBinaryFile
- | OldBinaryFile
- | NewTextFile [TextLine]
- | OldTextFile [TextLine]
- | ModifiedBinaryFile
- | ModifiedFile [FilteredDiff]
- | UnModifiedFile
+data GitFileContent
+ = NewBinaryFile
+ | OldBinaryFile
+ | NewTextFile [TextLine]
+ | OldTextFile [TextLine]
+ | ModifiedBinaryFile
+ | ModifiedFile [FilteredDiff]
+ | UnModifiedFile
-data GitFileMode = NewMode ModePerm
- | OldMode ModePerm
- | ModifiedMode ModePerm ModePerm
- | UnModifiedMode ModePerm
+data GitFileMode
+ = NewMode ModePerm
+ | OldMode ModePerm
+ | ModifiedMode ModePerm ModePerm
+ | UnModifiedMode ModePerm
-data GitFileRef hash =
- NewRef (Ref hash)
- | OldRef (Ref hash)
- | ModifiedRef (Ref hash) (Ref hash)
- | UnModifiedRef (Ref hash)
+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:
@@ -192,61 +208,71 @@ data GitFileRef hash =
-- * the file's mode (i.e. the file priviledge)
-- * the file's ref
data GitDiff hash = GitDiff
- { hFileName :: EntPath
- , hFileContent :: GitFileContent
- , hFileMode :: GitFileMode
- , hFileRef :: GitFileRef hash
- }
+ { hFileName :: EntPath,
+ hFileContent :: GitFileContent,
+ hFileMode :: GitFileMode,
+ 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 :: (Typeable hash, HashAlgorithm hash)
- => Ref hash
- -> Ref hash
- -> Git hash
- -> IO [GitDiff hash]
+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 hash
- -> [GitDiff hash] -- ^ Accumulator
- -> [GitDiff hash] -- ^ Accumulator with a new content
-defaultDiff _ (OnlyOld old ) acc =
- let oldMode = OldMode (bsMode old)
- oldRef = OldRef (bsRef old)
- oldContent = case bsContent old of
- BinaryContent _ -> OldBinaryFile
- FileContent l -> OldTextFile (Prelude.zipWith TextLine [1..] l)
- in (GitDiff (bsFilename old) oldContent oldMode oldRef):acc
-defaultDiff _ (OnlyNew new) acc =
- let newMode = NewMode (bsMode new)
- newRef = NewRef (bsRef new)
- newContent = case bsContent new of
- BinaryContent _ -> NewBinaryFile
- FileContent l -> NewTextFile (Prelude.zipWith TextLine [1..] l)
- in (GitDiff (bsFilename new) newContent newMode newRef):acc
+defaultDiff ::
+ -- | Number of line for context
+ Int ->
+ BlobStateDiff hash ->
+ -- | Accumulator
+ [GitDiff hash] ->
+ -- | Accumulator with a new content
+ [GitDiff hash]
+defaultDiff _ (OnlyOld old) acc =
+ let oldMode = OldMode (bsMode old)
+ oldRef = OldRef (bsRef old)
+ oldContent = case bsContent old of
+ BinaryContent _ -> OldBinaryFile
+ FileContent l -> OldTextFile (Prelude.zipWith TextLine [1 ..] l)
+ in (GitDiff (bsFilename old) oldContent oldMode oldRef) : acc
+defaultDiff _ (OnlyNew new) acc =
+ let newMode = NewMode (bsMode new)
+ newRef = NewRef (bsRef new)
+ newContent = case bsContent new of
+ BinaryContent _ -> NewBinaryFile
+ FileContent l -> NewTextFile (Prelude.zipWith TextLine [1 ..] l)
+ in (GitDiff (bsFilename new) newContent newMode newRef) : acc
defaultDiff context (OldAndNew old new) acc =
- let mode = if (bsMode old) /= (bsMode new) then ModifiedMode (bsMode old) (bsMode new)
- else UnModifiedMode (bsMode new)
- ref = if (bsRef old) == (bsRef new) then UnModifiedRef (bsRef new)
- else ModifiedRef (bsRef old) (bsRef new)
- in case (mode, ref) of
- ((UnModifiedMode _), (UnModifiedRef _)) -> acc
- _ -> (GitDiff (bsFilename new) (content ref) mode ref):acc
- where content :: GitFileRef hash -> GitFileContent
- content (UnModifiedRef _) = UnModifiedFile
- content _ = createDiff (bsContent old) (bsContent new)
+ let mode =
+ if (bsMode old) /= (bsMode new)
+ then ModifiedMode (bsMode old) (bsMode new)
+ else UnModifiedMode (bsMode new)
+ ref =
+ if (bsRef old) == (bsRef new)
+ then UnModifiedRef (bsRef new)
+ else ModifiedRef (bsRef old) (bsRef new)
+ in case (mode, ref) of
+ ((UnModifiedMode _), (UnModifiedRef _)) -> acc
+ _ -> (GitDiff (bsFilename new) (content ref) mode ref) : acc
+ where
+ content :: GitFileRef hash -> GitFileContent
+ content (UnModifiedRef _) = UnModifiedFile
+ content _ = createDiff (bsContent old) (bsContent new)
- createDiff :: BlobContent -> BlobContent -> GitFileContent
- createDiff (FileContent a) (FileContent b) =
- let linesA = Prelude.zipWith TextLine [1..] a
- linesB = Prelude.zipWith TextLine [1..] b
- in ModifiedFile $ diffGetContext context (diff linesA linesB)
- createDiff _ _ = ModifiedBinaryFile
+ createDiff :: BlobContent -> BlobContent -> GitFileContent
+ createDiff (FileContent a) (FileContent b) =
+ let linesA = Prelude.zipWith TextLine [1 ..] a
+ linesB = Prelude.zipWith TextLine [1 ..] b
+ in ModifiedFile $ diffGetContext context (diff linesA linesB)
+ createDiff _ _ = ModifiedBinaryFile
-- Used by diffGetContext
data GitAccu = AccuBottom | AccuTop
@@ -255,37 +281,46 @@ data GitAccu = AccuBottom | AccuTop
diffGetContext :: Int -> [Item TextLine] -> [FilteredDiff]
diffGetContext 0 list = fmap NormalLine list
diffGetContext context list =
- let (_, _, filteredDiff) = Prelude.foldr filterContext (0, AccuBottom, []) list
- theList = removeTrailingBoth filteredDiff
- in case Prelude.head theList of
- (NormalLine (Both l _)) -> if lineNumber l > 1 then Separator:theList else theList
+ let (_, _, filteredDiff) = Prelude.foldr filterContext (0, AccuBottom, []) list
+ theList = removeTrailingBoth filteredDiff
+ in case Prelude.head theList of
+ (NormalLine (Both l _)) -> if lineNumber l > 1 then Separator : theList else theList
_ -> theList
- where -- only keep 'context'. The file is annalyzed from the bottom to the top.
- -- The accumulator here is a tuple3 with (the line counter, the
- -- direction and the list of elements)
- filterContext :: (Item TextLine) -> (Int, GitAccu, [FilteredDiff]) -> (Int, GitAccu, [FilteredDiff])
- filterContext b@(Both {}) (c, AccuBottom, acc) =
- if c < context then (c+1, AccuBottom, (NormalLine b):acc)
- else (c , AccuBottom, (NormalLine b)
- :((Prelude.take (context-1) acc)
- ++ [Separator]
- ++ (Prelude.drop (context+1) acc)))
- filterContext b@(Both {}) (c, AccuTop, acc) =
- if c < context then (c+1, AccuTop , (NormalLine b):acc)
- else (0 , AccuBottom, (NormalLine b):acc)
- filterContext element (_, _, acc) =
- (0, AccuTop, (NormalLine element):acc)
+ where
+ -- only keep 'context'. The file is annalyzed from the bottom to the top.
+ -- The accumulator here is a tuple3 with (the line counter, the
+ -- direction and the list of elements)
+ filterContext :: (Item TextLine) -> (Int, GitAccu, [FilteredDiff]) -> (Int, GitAccu, [FilteredDiff])
+ filterContext b@(Both {}) (c, AccuBottom, acc) =
+ if c < context
+ then (c + 1, AccuBottom, (NormalLine b) : acc)
+ else
+ ( c,
+ AccuBottom,
+ (NormalLine b) :
+ ( (Prelude.take (context -1) acc)
+ ++ [Separator]
+ ++ (Prelude.drop (context + 1) acc)
+ )
+ )
+ filterContext b@(Both {}) (c, AccuTop, acc) =
+ if c < context
+ then (c + 1, AccuTop, (NormalLine b) : acc)
+ else (0, AccuBottom, (NormalLine b) : acc)
+ filterContext element (_, _, acc) =
+ (0, AccuTop, (NormalLine element) : acc)
- startWithSeparator :: [FilteredDiff] -> Bool
- startWithSeparator [] = False
- startWithSeparator (Separator:_) = True
- startWithSeparator ((NormalLine l):xs) =
- case l of
- Both {} -> startWithSeparator xs
- _ -> False
+ startWithSeparator :: [FilteredDiff] -> Bool
+ startWithSeparator [] = False
+ startWithSeparator (Separator : _) = True
+ startWithSeparator ((NormalLine l) : xs) =
+ case l of
+ Both {} -> startWithSeparator xs
+ _ -> False
- removeTrailingBoth :: [FilteredDiff] -> [FilteredDiff]
- removeTrailingBoth diffList =
- let test = startWithSeparator diffList
- in if test then Prelude.tail $ Prelude.dropWhile (\a -> not $ startWithSeparator [a]) diffList
- else diffList
+ removeTrailingBoth :: [FilteredDiff] -> [FilteredDiff]
+ removeTrailingBoth diffList =
+ let test = startWithSeparator diffList
+ in if test
+ then Prelude.tail $ Prelude.dropWhile (\a -> not $ startWithSeparator [a]) diffList
+ else diffList
diff --git a/Data/Git/Diff/Patience.hs b/Data/Git/Diff/Patience.hs
index 9aa329a..03b498f 100644
--- a/Data/Git/Diff/Patience.hs
+++ b/Data/Git/Diff/Patience.hs
@@ -3,106 +3,107 @@
-- Copyright (c) Keegan McAllister 2011
--
module Data.Git.Diff.Patience
- ( Item(..)
- , diff
- ) where
+ ( Item (..),
+ diff,
+ )
+where
-import Data.List
-import Data.Function (on)
-import qualified Data.Map as M
-import qualified Data.IntMap as IM
+import Data.Function (on)
+import qualified Data.IntMap as IM
+import Data.List
+import qualified Data.Map as M
data Card a = Card !Int a !(Maybe (Card a))
-- sort using patience making stack of card with the list of elements,
-- then take the highest stack (maxView) and flatten the path back into a list
-- to get the longest increasing path
-longestIncreasing :: [(Int,a)] -> [(Int,a)]
+longestIncreasing :: [(Int, a)] -> [(Int, a)]
longestIncreasing =
- maybe [] (flatten . head . fst)
+ maybe [] (flatten . head . fst)
. IM.maxView
. foldl' ins IM.empty
where
ins :: IM.IntMap [Card a] -> (Int, a) -> IM.IntMap [Card a]
- ins m (x,a) =
- case IM.minViewWithKey gt of
- Nothing -> IM.insert x [new] m
- Just ((k,_),_) ->
- case IM.updateLookupWithKey (\_ _ -> Nothing) k m of
- (Just v, mm) -> IM.insert x (new : v) mm
- (Nothing, _) -> m
+ ins m (x, a) =
+ case IM.minViewWithKey gt of
+ Nothing -> IM.insert x [new] m
+ Just ((k, _), _) ->
+ case IM.updateLookupWithKey (\_ _ -> Nothing) k m of
+ (Just v, mm) -> IM.insert x (new : v) mm
+ (Nothing, _) -> m
where
- (lt, gt) = IM.split x m
- prev = (head . fst) `fmap` IM.maxView lt
- new = Card x a prev
+ (lt, gt) = IM.split x m
+ prev = (head . fst) `fmap` IM.maxView lt
+ new = Card x a prev
flatten :: Card a -> [(Int, a)]
- flatten (Card x a c) = (x,a) : maybe [] flatten c
+ flatten (Card x a c) = (x, a) : maybe [] flatten c
-- Type for decomposing a diff problem. We either have two
-- lines that match, or a recursive subproblem.
-data Piece a =
- Match !a !a
- | Diff [a] [a]
- deriving (Show)
+data Piece a
+ = Match !a !a
+ | Diff [a] [a]
+ deriving (Show)
-- Get the longest common subsequence
lcs :: Ord t => [t] -> [t] -> [Piece t]
lcs ma mb =
- chop ma mb
- $ longestIncreasing
- $ sortBy (compare `on` snd)
- $ M.elems
- $ M.intersectionWith (,) (unique ma) (unique mb)
+ chop ma mb $
+ longestIncreasing $
+ sortBy (compare `on` snd) $
+ M.elems $
+ M.intersectionWith (,) (unique ma) (unique mb)
where
- unique = M.mapMaybe id . foldr ins M.empty . zip [0..]
+ unique = M.mapMaybe id . foldr ins M.empty . zip [0 ..]
where
- ins (a,x) = M.insertWith (\_ _ -> Nothing) x (Just a)
+ ins (a, x) = M.insertWith (\_ _ -> Nothing) x (Just a)
-- Subdivides a diff problem according to the indices of matching lines.
- chop :: [t] -> [t] -> [(Int,Int)] -> [Piece t]
+ chop :: [t] -> [t] -> [(Int, Int)] -> [Piece t]
chop xs ys []
- | null xs && null ys = []
- | otherwise = [Diff xs ys]
- chop xs ys ((nx,ny):ns) =
- let (xsr, (x : xse)) = splitAt nx xs
- (ysr, (y : yse)) = splitAt ny ys
- in Diff xse yse : Match x y : chop xsr ysr ns
+ | null xs && null ys = []
+ | otherwise = [Diff xs ys]
+ chop xs ys ((nx, ny) : ns) =
+ let (xsr, (x : xse)) = splitAt nx xs
+ (ysr, (y : yse)) = splitAt ny ys
+ in Diff xse yse : Match x y : chop xsr ysr ns
-- | An element of a computed difference.
-data Item t =
- Old !t
- | New !t
- | Both !t !t
- deriving (Show,Eq)
+data Item t
+ = Old !t
+ | New !t
+ | Both !t !t
+ deriving (Show, Eq)
instance Functor Item where
- fmap f (Old x) = Old (f x)
- fmap f (New x) = New (f x)
- fmap f (Both x y) = Both (f x) (f y)
+ fmap f (Old x) = Old (f x)
+ fmap f (New x) = New (f x)
+ fmap f (Both x y) = Both (f x) (f y)
-- | The difference between two lists using the patience algorithm
diff :: Ord t => [t] -> [t] -> [Item t]
diff = matchPrefix []
where
-- match the prefix between old and new document
- matchPrefix acc (x:xs) (y:ys)
- | x == y = Both x y : matchPrefix acc xs ys
+ matchPrefix acc (x : xs) (y : ys)
+ | x == y = Both x y : matchPrefix acc xs ys
matchPrefix acc l r = matchSuffix acc (reverse l) (reverse r)
-- match the suffix between old and new document, accumulating the
-- matched item in a reverse accumulator to keep TCO
- matchSuffix acc (x:xs) (y:ys)
- | x == y = matchSuffix (Both x y : acc) xs ys
+ matchSuffix acc (x : xs) (y : ys)
+ | x == y = matchSuffix (Both x y : acc) xs ys
matchSuffix acc l r = diffInner (reverse acc) (reverse l) (reverse r)
-- prefix and suffix are striped, and now do the LCS
diffInner acc l r =
- case lcs l r of
- -- If we fail to subdivide, just record the chunk as is.
- [Diff _ _] -> fmap Old l ++ fmap New r ++ acc
- ps -> recur acc ps
+ case lcs l r of
+ -- If we fail to subdivide, just record the chunk as is.
+ [Diff _ _] -> fmap Old l ++ fmap New r ++ acc
+ ps -> recur acc ps
recur acc [] = acc
- recur acc (Match x y : ps) = recur (Both x y : acc) ps
+ recur acc (Match x y : ps) = recur (Both x y : acc) ps
recur acc (Diff xs ys : ps) = recur [] ps ++ matchPrefix acc xs ys
diff --git a/Data/Git/Imports.hs b/Data/Git/Imports.hs
index fb1787c..a6f5efe 100644
--- a/Data/Git/Imports.hs
+++ b/Data/Git/Imports.hs
@@ -1,7 +1,8 @@
module Data.Git.Imports
- ( module X
- ) where
+ ( module X,
+ )
+where
-import Control.Applicative as X
-import Control.Monad as X
-import Data.Monoid as X
+import Control.Applicative as X
+import Control.Monad as X
+import Data.Monoid as X
diff --git a/Data/Git/Index.hs b/Data/Git/Index.hs
index 8732dec..73ef97b 100644
--- a/Data/Git/Index.hs
+++ b/Data/Git/Index.hs
@@ -1,43 +1,44 @@
-{-# OPTIONS_GHC -fwarn-missing-signatures -fno-warn-unused-binds #-}
-
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fwarn-missing-signatures -fno-warn-unused-binds #-}
module Data.Git.Index
- ( IndexEntry( .. )
- , parseIndex
- , decodeIndex
- , loadIndexFile
- , indexEntryOfFile
- ) where
+ ( IndexEntry (..),
+ parseIndex,
+ decodeIndex,
+ loadIndexFile,
+ indexEntryOfFile,
+ )
+where
-import Prelude hiding ( FilePath, readFile )
-import Filesystem
-import Filesystem.Path hiding (concat)
-import Control.Monad( when
- , replicateM
- )
-import Data.Bits
- ( unsafeShiftL
- , unsafeShiftR
- , testBit
- , (.&.)
- , (.|.)
- )
-import Data.Word( Word8, Word16, Word32 )
-import Data.Git.Ref
import qualified Control.Exception as E
-import qualified Data.Vector as V
+import Control.Monad
+ ( replicateM,
+ when,
+ )
+import Data.Bits
+ ( testBit,
+ unsafeShiftL,
+ unsafeShiftR,
+ (.&.),
+ (.|.),
+ )
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
+import Data.Git.Parser (Parser)
import qualified Data.Git.Parser as P
-import Data.Git.Parser (Parser)
+import Data.Git.Ref
+import qualified Data.Vector as V
+import Data.Word (Word16, Word32, Word8)
+import Filesystem
+import Filesystem.Path hiding (concat)
+import Prelude hiding (FilePath, readFile)
-data IndexHeader = IndexHeader
- { indexFileVersion :: {-# UNPACK #-} !Word32
- , indexEntryCount :: {-# UNPACK #-} !Word32
- }
- deriving (Show, Eq)
+data IndexHeader = IndexHeader
+ { indexFileVersion :: {-# UNPACK #-} !Word32,
+ indexEntryCount :: {-# UNPACK #-} !Word32
+ }
+ deriving (Show, Eq)
-- | Finds an index in a given vector, which must be sorted with respect to the
-- given comparison function, at which the given element could be inserted while
@@ -46,12 +47,12 @@ binarySearchBy :: (e -> a -> Ordering) -> V.Vector e -> a -> Maybe e
{-# INLINE binarySearchBy #-}
binarySearchBy cmp vec e = go 0 (length vec)
where
- go !l !u | u <= l = Nothing
+ go !l !u | u <= l = Nothing
go !l !u =
- let !k = (u + l) `unsafeShiftR` 1
- !e' = V.unsafeIndex vec k in
- case cmp e' e of
- LT -> go (k+1) u
+ let !k = (u + l) `unsafeShiftR` 1
+ !e' = V.unsafeIndex vec k
+ in case cmp e' e of
+ LT -> go (k + 1) u
EQ -> Just e'
GT -> go l k
@@ -69,132 +70,132 @@ decodeIndex = P.eitherParse parseIndex
parseIndex :: HashAlgorithm hash => Parser (V.Vector (IndexEntry hash))
parseIndex = do
- hdr <- parseIndexHeader
- V.replicateM (fromIntegral $ indexEntryCount hdr) parseIndexEntry
+ hdr <- parseIndexHeader
+ V.replicateM (fromIntegral $ indexEntryCount hdr) parseIndexEntry
parseIndexHeader :: Parser IndexHeader
parseIndexHeader = do
- magic <- P.take 4
- when (magic /= "DIRC") $ fail "wrong magic number for index"
- ver <- P.word32
- when (ver `notElem` [2, 3]) $ fail "unsupported packIndex version"
- entries <- P.word32
- return $ IndexHeader ver entries
+ magic <- P.take 4
+ when (magic /= "DIRC") $ fail "wrong magic number for index"
+ ver <- P.word32
+ when (ver `notElem` [2, 3]) $ fail "unsupported packIndex version"
+ entries <- P.word32
+ return $ IndexHeader ver entries
-- Index entries are sorted in ascending order on the name field,
-- interpreted as a string of unsigned bytes (i.e. memcmp() order, no
-- localization, no special casing of directory separator '/'). Entries
-- with the same name are sorted by their stage field.
data IndexEntry hash = IndexEntry
- { -- | 32-bit ctime seconds, the last time a file's metadata changed
- ctime :: !Word32
+ { -- | 32-bit ctime seconds, the last time a file's metadata changed
+ ctime :: !Word32,
-- | 32-bit ctime nanosecond fractions
- , ctimeNano :: !Word32
+ ctimeNano :: !Word32,
-- | 32-bit mtime seconds, the last time a file's data changed
- , mtime :: !Word32
+ mtime :: !Word32,
-- | 32-bit mtime nanosecond fractions
- , mtimeNano :: !Word32
+ mtimeNano :: !Word32,
-- | 32-bit dev
- , dev :: !Word32
+ dev :: !Word32,
-- | 32-bit ino
- , ino :: !Word32
+ ino :: !Word32,
-- | 32-bit mode, split into (high to low bits)
- --
+ --
-- 4-bit object type
-- valid values in binary are 1000 (regular file), 1010 (symbolic link)
-- and 1110 (gitlink)
- --
+ --
-- 3-bit unused
- --
+ --
-- 9-bit unix permission. Only 0755 and 0644 are valid for regular files.
-- Symbolic links and gitlinks have value 0 in this field.
- , mode :: !Word32
+ mode :: !Word32,
-- | 32-bit uid
- , uid :: !Word32
+ uid :: !Word32,
-- | 32-bit gid
- , gid :: !Word32
+ gid :: !Word32,
-- | 32-bit file size This is the on-disk size from stat(2), truncated to 32-bit.
- , fileSize :: !Word32
+ fileSize :: !Word32,
-- | 160-bit SHA-1 for the represented object
- , fileHash :: !(Ref hash)
-
+ fileHash :: !(Ref hash),
-- | A 16-bit 'flags' field
- , flags :: !IndexEntryFlags
+ flags :: !IndexEntryFlags,
-- (Version 3 or later) A 16-bit field, only applicable if the
-- "extended flag" above is 1, split into (high to low bits).
- --
+ --
-- 1-bit reserved for future
- --
+ --
-- 1-bit skip-worktree flag (used by sparse checkout)
- --
+ --
-- 1-bit intent-to-add flag (used by "git add -N")
- --
+ --
-- 13-bit unused, must be zero
- , extended :: !Word16
-
- , fileName :: !B.ByteString
- }
- deriving (Eq, Show)
-
-data IndexEntryFlags = IndexEntryFlags
- { -- | 1-bit assume-valid flag
- iefAssumeValid :: !Bool
- -- | 1-bit extended flag (must be zero in version 2)
- , iefExtended :: !Bool
- -- | 2-bit stage (during merge)
- , iefStage :: {-# UNPACK #-} !Word8
- -- | 12-bit name length if the length is less than 0xFFF;
- -- otherwise 0xFFF is stored in this field.
- , iefNameLength :: {-# UNPACK #-} !Word16
- }
- deriving (Eq, Show)
+ extended :: !Word16,
+ fileName :: !B.ByteString
+ }
+ deriving (Eq, Show)
+
+data IndexEntryFlags = IndexEntryFlags
+ { -- | 1-bit assume-valid flag
+ iefAssumeValid :: !Bool,
+ -- | 1-bit extended flag (must be zero in version 2)
+ iefExtended :: !Bool,
+ -- | 2-bit stage (during merge)
+ iefStage :: {-# UNPACK #-} !Word8,
+ -- | 12-bit name length if the length is less than 0xFFF;
+ -- otherwise 0xFFF is stored in this field.
+ iefNameLength :: {-# UNPACK #-} !Word16
+ }
+ deriving (Eq, Show)
flagsOfWord :: Word16 -> IndexEntryFlags
-flagsOfWord w = IndexEntryFlags
- { iefAssumeValid = w `testBit` 15
- , iefExtended = w `testBit` 14
- , iefStage = fromIntegral $ (w `unsafeShiftR` 13) .&. 0x3
- , iefNameLength = w .&. 0xFFF
+flagsOfWord w =
+ IndexEntryFlags
+ { iefAssumeValid = w `testBit` 15,
+ iefExtended = w `testBit` 14,
+ iefStage = fromIntegral $ (w `unsafeShiftR` 13) .&. 0x3,
+ iefNameLength = w .&. 0xFFF
}
parseIndexEntry :: HashAlgorithm hash => Parser (IndexEntry hash)
parseIndexEntry = do
- vCtime <- P.word32 -- +4 4
- vCtimeNano <- P.word32 -- +4 8
- vMtime <- P.word32 -- +4 12
- vMtimeNano <- P.word32 -- +4 16
- vDev <- P.word32 -- +4 20
- vInode <- P.word32 -- +4 24
- vMode <- P.word32 -- +4 28
- vUid <- P.word32 -- +4 32
- vGid <- P.word32 -- +4 36
- vSize <- P.word32 -- +4 40
- -- TODO ref is variable size now
- vFileHash <- P.ref -- +20 60
- vFlags <- flagsOfWord <$> P.word16 -- +2 62
- vExtended <- if iefExtended vFlags -- +2 64
- then P.word16
- else return 0
- vName <- P.take . fromIntegral $ iefNameLength vFlags
- let padding = 8 - ((62 + iefNameLength vFlags) `mod` 8)
- _ <- replicateM (fromIntegral padding) P.anyByte
- return IndexEntry
- { ctime = vCtime
- , ctimeNano = vCtimeNano
- , mtime = vMtime
- , mtimeNano = vMtimeNano
- , dev = vDev
- , ino = vInode
- , mode = vMode
- , uid = vUid
- , gid = vGid
- , fileSize = vSize
- , fileHash = vFileHash
- , flags = vFlags
- , extended = vExtended
- , fileName = vName
- }
-
+ vCtime <- P.word32 -- +4 4
+ vCtimeNano <- P.word32 -- +4 8
+ vMtime <- P.word32 -- +4 12
+ vMtimeNano <- P.word32 -- +4 16
+ vDev <- P.word32 -- +4 20
+ vInode <- P.word32 -- +4 24
+ vMode <- P.word32 -- +4 28
+ vUid <- P.word32 -- +4 32
+ vGid <- P.word32 -- +4 36
+ vSize <- P.word32 -- +4 40
+ -- TODO ref is variable size now
+ vFileHash <- P.ref -- +20 60
+ vFlags <- flagsOfWord <$> P.word16 -- +2 62
+ vExtended <-
+ if iefExtended vFlags -- +2 64
+ then P.word16
+ else return 0
+ vName <- P.take . fromIntegral $ iefNameLength vFlags
+ let padding = 8 - ((62 + iefNameLength vFlags) `mod` 8)
+ _ <- replicateM (fromIntegral padding) P.anyByte
+ return
+ IndexEntry
+ { ctime = vCtime,
+ ctimeNano = vCtimeNano,
+ mtime = vMtime,
+ mtimeNano = vMtimeNano,
+ dev = vDev,
+ ino = vInode,
+ mode = vMode,
+ uid = vUid,
+ gid = vGid,
+ fileSize = vSize,
+ fileHash = vFileHash,
+ flags = vFlags,
+ extended = vExtended,
+ fileName = vName
+ }
{-
<INDEX_CONTENTS_EXTENSIONS>
@@ -204,15 +205,15 @@ parseIndexEntry = do
parseIndexExtension :: P.Parser (BC.ByteString, BC.ByteString)
parseIndexExtension = do
- -- # 4 byte sequence identifying how the <INDEX_EXTENSION_DATA>
- -- # should be interpreted. If the first byte has a value greater
- -- # than or equal to the ASCII character 'A' (0x41) and less than
- -- # or equal to the ASCII character 'Z' (0x5a), the extension is
- -- # optional and does not affect the interpretation of the other
- -- # contents in the index file. Any non-optional extensions must
- -- # be understood by the reading application to correctly
- -- # interpret the index file contents.
- name <- P.take 4
- dataSize <- P.word32
- data_ <- P.take $ fromIntegral dataSize
- return (name, data_)
+ -- # 4 byte sequence identifying how the <INDEX_EXTENSION_DATA>
+ -- # should be interpreted. If the first byte has a value greater
+ -- # than or equal to the ASCII character 'A' (0x41) and less than
+ -- # or equal to the ASCII character 'Z' (0x5a), the extension is
+ -- # optional and does not affect the interpretation of the other
+ -- # contents in the index file. Any non-optional extensions must
+ -- # be understood by the reading application to correctly
+ -- # interpret the index file contents.
+ name <- P.take 4
+ dataSize <- P.word32
+ data_ <- P.take $ fromIntegral dataSize
+ return (name, data_)
diff --git a/Data/Git/Internal.hs b/Data/Git/Internal.hs
index 735caf2..4b74653 100644
--- a/Data/Git/Internal.hs
+++ b/Data/Git/Internal.hs
@@ -4,22 +4,24 @@
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unix
---
module Data.Git.Internal
- ( be32
- , be16
- ) where
+ ( be32,
+ be16,
+ )
+where
import Data.Bits
-import Data.Word
import qualified Data.ByteString as B
+import Data.Word
be32 :: B.ByteString -> Word32
-be32 b = fromIntegral (B.index b 0) `shiftL` 24
- + fromIntegral (B.index b 1) `shiftL` 16
- + fromIntegral (B.index b 2) `shiftL` 8
- + fromIntegral (B.index b 3)
+be32 b =
+ fromIntegral (B.index b 0) `shiftL` 24
+ + fromIntegral (B.index b 1) `shiftL` 16
+ + fromIntegral (B.index b 2) `shiftL` 8
+ + fromIntegral (B.index b 3)
be16 :: B.ByteString -> Word16
-be16 b = fromIntegral (B.index b 0) `shiftL` 8
- + fromIntegral (B.index b 1)
+be16 b =
+ fromIntegral (B.index b 0) `shiftL` 8
+ + fromIntegral (B.index b 1)
diff --git a/Data/Git/Monad.hs b/Data/Git/Monad.hs
index 6cdd5bb..40a3703 100644
--- a/Data/Git/Monad.hs
+++ b/Data/Git/Monad.hs
@@ -21,71 +21,72 @@
-- from a Commit: see 'CommitAccessMonad' and 'withCommit'.
--
-- You can also easily create a new commit: see 'CommitM' and 'withNewCommit'
---
module Data.Git.Monad
- ( -- * GitMonad
- GitMonad(..)
- , GitM
- , withRepo
- , withCurrentRepo
- -- ** Operations
- , Resolvable(..)
- , branchList
- , branchWrite
- , tagList
- , tagWrite
- , headGet
- , headResolv
- , headSet
- , getCommit
-
- -- * Read a commit
- , CommitAccessM
- , withCommit
- -- ** Operations
- , getAuthor
- , getCommitter
- , getParents
- , getExtras
- , getEncoding
- , getMessage
- , getFile
- , getDir
- -- * Create a new Commit
- , CommitM
- , withNewCommit
- , withBranch
- -- ** Operations
- , setAuthor
- , setCommitter
- , setParents
- , setExtras
- , setEncoding
- , setMessage
- , setFile
- , deleteFile
-
- -- * convenients re-exports
- , Git.Git
- , Git.Ref
- , Git.RefName(..)
- , Git.Commit(..)
- , Git.Person(..)
- ) where
-
+ ( -- * GitMonad
+ GitMonad (..),
+ GitM,
+ withRepo,
+ withCurrentRepo,
+
+ -- ** Operations
+ Resolvable (..),
+ branchList,
+ branchWrite,
+ tagList,
+ tagWrite,
+ headGet,
+ headResolv,
+ headSet,
+ getCommit,
+
+ -- * Read a commit
+ CommitAccessM,
+ withCommit,
+
+ -- ** Operations
+ getAuthor,
+ getCommitter,
+ getParents,
+ getExtras,
+ getEncoding,
+ getMessage,
+ getFile,
+ getDir,
+
+ -- * Create a new Commit
+ CommitM,
+ withNewCommit,
+ withBranch,
+
+ -- ** Operations
+ setAuthor,
+ setCommitter,
+ setParents,
+ setExtras,
+ setEncoding,
+ setMessage,
+ setFile,
+ deleteFile,
+
+ -- * convenients re-exports
+ Git.Git,
+ Git.Ref,
+ Git.RefName (..),
+ Git.Commit (..),
+ Git.Person (..),
+ )
+where
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.Git as Git
-import qualified Data.Git.Revision as Git
+import Data.Git.Imports
+import Data.Git.OS
+import Data.Git.Ref (SHA1)
import qualified Data.Git.Repository as Git
+import qualified Data.Git.Revision as Git
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)
@@ -106,19 +107,22 @@ revisionFromString = Git.fromString
-- > resolve (Ref "2ad98b90...2ca") === Ref "2ad98b90...2ca"
-- > resolve "master"
-- > resolve "HEAD^^^"
---
class Resolvable rev where
- resolve :: GitMonad m => rev -> m (Maybe (Git.Ref SHA1))
+ resolve :: GitMonad m => rev -> m (Maybe (Git.Ref SHA1))
+
instance Resolvable (Git.Ref SHA1) where
- resolve = return . Just
+ resolve = return . Just
+
instance Resolvable Git.Revision where
- resolve rev = do
- git <- getGit
- liftGit $ Git.resolveRevision git rev
+ resolve rev = do
+ git <- getGit
+ liftGit $ Git.resolveRevision git rev
+
instance Resolvable String where
- resolve = resolve . revisionFromString
+ resolve = resolve . revisionFromString
+
instance Resolvable Git.RefName where
- resolve = resolve . Git.refNameRaw
+ resolve = resolve . Git.refNameRaw
-------------------------------------------------------------------------------
-- GitMonad --
@@ -127,65 +131,67 @@ instance Resolvable Git.RefName where
-- | Basic operations common between the different Monads defined in this
-- package.
class (Functor m, Applicative m, Monad m, MonadFail m) => GitMonad m where
- -- | the current Monad must allow access to the current Git
- getGit :: m (Git.Git SHA1)
- liftGit :: IO a -> m a
+ -- | the current Monad must allow access to the current 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 SHA1 -> git ()
branchWrite rn ref = do
- git <- getGit
- liftGit $ Git.branchWrite git rn ref
+ git <- getGit
+ liftGit $ Git.branchWrite git rn ref
tagList :: GitMonad git => git (Set Git.RefName)
tagList = getGit >>= liftGit . Git.tagList
tagWrite :: GitMonad git => Git.RefName -> Git.Ref SHA1 -> git ()
tagWrite rn ref = do
- git <- getGit
- liftGit $ Git.tagWrite git rn ref
+ git <- getGit
+ liftGit $ Git.tagWrite git rn ref
headGet :: GitMonad git => git (Either (Git.Ref SHA1) Git.RefName)
headGet = getGit >>= liftGit . Git.headGet
headResolv :: GitMonad git => git (Maybe (Git.Ref SHA1))
headResolv = do
- e <- headGet
- case e of
- Left ref -> resolve ref
- Right v -> resolve v
+ e <- headGet
+ case e of
+ Left ref -> resolve ref
+ Right v -> resolve v
headSet :: GitMonad git => Either (Git.Ref SHA1) Git.RefName -> git ()
headSet e = do
- git <- getGit
- liftGit $ Git.headSet git e
+ git <- getGit
+ liftGit $ Git.headSet git e
getCommit :: (GitMonad git, Resolvable ref) => ref -> git (Maybe (Git.Commit SHA1))
getCommit r = do
- mRef <- resolve r
- case mRef of
- Nothing -> return Nothing
- Just ref -> do
- git <- getGit
- liftGit $ Git.getCommitMaybe git ref
+ mRef <- resolve r
+ case mRef of
+ Nothing -> return Nothing
+ Just ref -> do
+ git <- getGit
+ liftGit $ Git.getCommitMaybe 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
-
-getObject :: (GitMonad git, Resolvable ref)
- => ref
- -> Bool
- -> git (Maybe (Git.Object SHA1))
+ git <- getGit
+ liftGit $ Git.setObject git $ Git.toObject obj
+
+getObject ::
+ (GitMonad git, Resolvable ref) =>
+ ref ->
+ Bool ->
+ git (Maybe (Git.Object SHA1))
getObject rev resolvDelta = do
- git <- getGit
- mRef <- resolve rev
- case mRef of
- Nothing -> return Nothing
- Just ref -> liftGit $ Git.getObject git ref resolvDelta
+ git <- getGit
+ mRef <- resolve rev
+ case mRef of
+ Nothing -> return Nothing
+ Just ref -> liftGit $ Git.getObject git ref resolvDelta
workTreeNew :: GitMonad git => git (Git.WorkTree hash)
workTreeNew = liftGit Git.workTreeNew
@@ -195,64 +201,66 @@ workTreeFrom ref = liftGit $ Git.workTreeFrom ref
workTreeFlush :: GitMonad git => Git.WorkTree SHA1 -> git (Git.Ref SHA1)
workTreeFlush tree = do
- git <- getGit
- liftGit $ Git.workTreeFlush git tree
-
-resolvPath :: (GitMonad git, Resolvable ref)
- => ref -- ^ the commit Ref, Revision ("master", "HEAD^^" or a ref...)
- -> Git.EntPath
- -> git (Maybe (Git.Ref SHA1))
+ git <- getGit
+ liftGit $ Git.workTreeFlush git tree
+
+resolvPath ::
+ (GitMonad git, Resolvable ref) =>
+ -- | the commit Ref, Revision ("master", "HEAD^^" or a ref...)
+ ref ->
+ Git.EntPath ->
+ git (Maybe (Git.Ref SHA1))
resolvPath commitRev entPath = do
- git <- getGit
- mRef <- resolve commitRev
- case mRef of
- Nothing -> return Nothing
- Just ref -> liftGit $ Git.resolvePath git ref entPath
+ git <- getGit
+ mRef <- resolve commitRev
+ case mRef of
+ Nothing -> return Nothing
+ Just ref -> liftGit $ Git.resolvePath git ref entPath
-------------------------------------------------------------------------------
-- --
-------------------------------------------------------------------------------
data Result ctx a
- = ResultSuccess !ctx !a
- | ResultFailure !String
+ = ResultSuccess !ctx !a
+ | ResultFailure !String
-------------------------------------------------------------------------------
-- GitM --
-------------------------------------------------------------------------------
data GitContext = GitContext
- { gitContextGit :: !(Git.Git SHA1)
- }
+ { gitContextGit :: !(Git.Git SHA1)
+ }
newtype GitM a = GitM
- { runGitM :: GitContext -> IO (Result GitContext a)
- }
+ { runGitM :: GitContext -> IO (Result GitContext a)
+ }
instance Functor GitM where
- fmap = fmapGitM
+ fmap = fmapGitM
instance Applicative GitM where
- pure = returnGitM
- (<*>) = appendGitM
+ pure = returnGitM
+ (<*>) = appendGitM
instance Monad GitM where
- return = returnGitM
- (>>=) = bindGitM
+ return = returnGitM
+ (>>=) = bindGitM
instance MonadFail GitM where
- fail = failGitM
+ fail = failGitM
instance GitMonad GitM where
- getGit = getGitM
- liftGit = liftGitM
+ getGit = getGitM
+ liftGit = liftGitM
fmapGitM :: (a -> b) -> GitM a -> GitM b
fmapGitM f m = GitM $ \ctx -> do
- r <- runGitM m ctx
- return $ case r of
- ResultSuccess ctx' v -> ResultSuccess ctx' (f v)
- ResultFailure err -> ResultFailure err
+ r <- runGitM m ctx
+ return $ case r of
+ ResultSuccess ctx' v -> ResultSuccess ctx' (f v)
+ ResultFailure err -> ResultFailure err
returnGitM :: a -> GitM a
returnGitM v = GitM $ \ctx -> return (ResultSuccess ctx v)
@@ -262,10 +270,10 @@ appendGitM m1f m2 = m1f >>= \f -> m2 >>= \v -> return (f v)
bindGitM :: GitM a -> (a -> GitM b) -> GitM b
bindGitM m fm = GitM $ \ctx -> do
- r <- runGitM m ctx
- case r of
- ResultSuccess ctx' v -> runGitM (fm v) ctx'
- ResultFailure err -> return (ResultFailure err)
+ r <- runGitM m ctx
+ case r of
+ ResultSuccess ctx' v -> runGitM (fm v) ctx'
+ ResultFailure err -> return (ResultFailure err)
failGitM :: String -> GitM a
failGitM msg = GitM $ \_ -> return (ResultFailure msg)
@@ -278,10 +286,10 @@ liftGitM f = GitM $ \ctx -> ResultSuccess ctx <$> f
executeGitM :: Git.Git SHA1 -> GitM a -> IO (Either String a)
executeGitM git m = do
- r <- runGitM m $ GitContext git
- return $ case r of
- ResultSuccess _ v -> Right v
- ResultFailure err -> Left err
+ r <- runGitM m $ GitContext git
+ return $ case r of
+ ResultSuccess _ v -> Right v
+ ResultFailure err -> Left err
withRepo :: LocalPath -> GitM a -> IO (Either String a)
withRepo repoPath m = Git.withRepo repoPath (\git -> executeGitM git m)
@@ -289,45 +297,44 @@ withRepo repoPath m = Git.withRepo repoPath (\git -> executeGitM git m)
withCurrentRepo :: GitM a -> IO (Either String a)
withCurrentRepo m = Git.withCurrentRepo (\git -> executeGitM git m)
-
-------------------------------------------------------------------------------
-- CommitAccessM --
-------------------------------------------------------------------------------
data CommitAccessContext = CommitAccessContext
- { commitAccessContextCommit :: !(Git.Commit SHA1)
- , commitAccessContextRef :: !(Git.Ref SHA1)
- }
+ { commitAccessContextCommit :: !(Git.Commit SHA1),
+ commitAccessContextRef :: !(Git.Ref SHA1)
+ }
-- | ReadOnly operations on a given commit
-newtype CommitAccessM a = CommitAccessM
- { runCommitAccessM :: forall git . GitMonad git => CommitAccessContext -> git (Result CommitAccessContext a)
- }
+newtype CommitAccessM a = CommitAccessM
+ { runCommitAccessM :: forall git. GitMonad git => CommitAccessContext -> git (Result CommitAccessContext a)
+ }
instance Functor CommitAccessM where
- fmap = fmapCommitAccessM
+ fmap = fmapCommitAccessM
instance Applicative CommitAccessM where
- pure = returnCommitAccessM
- (<*>) = appendCommitAccessM
+ pure = returnCommitAccessM
+ (<*>) = appendCommitAccessM
instance Monad CommitAccessM where
- return = returnCommitAccessM
- (>>=) = bindCommitAccessM
+ return = returnCommitAccessM
+ (>>=) = bindCommitAccessM
instance MonadFail CommitAccessM where
- fail = failCommitAccessM
+ fail = failCommitAccessM
instance GitMonad CommitAccessM where
- getGit = getCommitAccessM
- liftGit = liftCommitAccessM
+ getGit = getCommitAccessM
+ liftGit = liftCommitAccessM
fmapCommitAccessM :: (a -> b) -> CommitAccessM a -> CommitAccessM b
fmapCommitAccessM f m = CommitAccessM $ \ctx -> do
- r <- runCommitAccessM m ctx
- return $ case r of
- ResultSuccess ctx' v -> ResultSuccess ctx' (f v)
- ResultFailure err -> ResultFailure err
+ r <- runCommitAccessM m ctx
+ return $ case r of
+ ResultSuccess ctx' v -> ResultSuccess ctx' (f v)
+ ResultFailure err -> ResultFailure err
returnCommitAccessM :: a -> CommitAccessM a
returnCommitAccessM v = CommitAccessM $ \ctx -> return (ResultSuccess ctx v)
@@ -337,10 +344,10 @@ appendCommitAccessM m1f m2 = m1f >>= \f -> m2 >>= \v -> return (f v)
bindCommitAccessM :: CommitAccessM a -> (a -> CommitAccessM b) -> CommitAccessM b
bindCommitAccessM m fm = CommitAccessM $ \ctx -> do
- r <- runCommitAccessM m ctx
- case r of
- ResultSuccess ctx' v -> runCommitAccessM (fm v) ctx'
- ResultFailure err -> return (ResultFailure err)
+ r <- runCommitAccessM m ctx
+ case r of
+ ResultSuccess ctx' v -> runCommitAccessM (fm v) ctx'
+ ResultFailure err -> return (ResultFailure err)
failCommitAccessM :: String -> CommitAccessM a
failCommitAccessM msg = CommitAccessM $ \_ -> return (ResultFailure msg)
@@ -355,7 +362,7 @@ liftCommitAccessM f = CommitAccessM $ \ctx -> ResultSuccess ctx <$> (liftGit f)
withCommitAccessContext :: (CommitAccessContext -> a) -> CommitAccessM a
withCommitAccessContext operation = CommitAccessM $ \ctx ->
- return $ ResultSuccess ctx $ operation ctx
+ return $ ResultSuccess ctx $ operation ctx
getAuthor :: CommitAccessM Git.Person
getAuthor = withCommitAccessContext (Git.commitAuthor . commitAccessContextCommit)
@@ -380,11 +387,11 @@ getContextRef_ = withCommitAccessContext commitAccessContextRef
getContextObject_ :: Git.EntPath -> CommitAccessM (Maybe (Git.Object SHA1))
getContextObject_ fp = do
- commitRef <- getContextRef_
- mRef <- resolvPath commitRef fp
- case mRef of
- Nothing -> return Nothing
- Just ref -> getObject ref True
+ commitRef <- getContextRef_
+ mRef <- resolvPath commitRef fp
+ case mRef of
+ Nothing -> return Nothing
+ Just ref -> getObject ref True
-- | get the content of the file at the given Path
--
@@ -392,12 +399,12 @@ getContextObject_ fp = do
-- the function returns Nothing.
getFile :: Git.EntPath -> CommitAccessM (Maybe BL.ByteString)
getFile fp = do
- mObj <- getContextObject_ fp
- return $ case mObj of
- Nothing -> Nothing
- Just obj -> case Git.objectToBlob obj of
- Nothing -> Nothing
- Just b -> Just $ Git.blobGetContent b
+ mObj <- getContextObject_ fp
+ return $ case mObj of
+ Nothing -> Nothing
+ Just obj -> case Git.objectToBlob obj of
+ Nothing -> Nothing
+ Just b -> Just $ Git.blobGetContent b
-- | list the element present in the Given Directory Path
--
@@ -405,12 +412,12 @@ getFile fp = do
-- the function returns Nothing.
getDir :: Git.EntPath -> CommitAccessM (Maybe [Git.EntName])
getDir fp = do
- mObj <- getContextObject_ fp
- return $ case mObj of
- Nothing -> Nothing
- Just obj -> case Git.objectToTree obj of
- Nothing -> Nothing
- Just tree -> Just $ map (\(_, n, _) -> n) $ Git.treeGetEnts tree
+ mObj <- getContextObject_ fp
+ return $ case mObj of
+ Nothing -> Nothing
+ Just obj -> case Git.objectToTree obj of
+ Nothing -> Nothing
+ Just tree -> Just $ map (\(_, n, _) -> n) $ Git.treeGetEnts tree
-- | open a commit in the current GitMonad
--
@@ -425,72 +432,73 @@ getDir fp = do
-- > -- print the list of files|dirs in the root directory
-- > l <- getDir []
-- > liftGit $ print l
---
-withCommit :: (Resolvable ref, GitMonad git)
- => ref
- -- ^ the commit revision or reference to open
- -> CommitAccessM a
- -> git a
+withCommit ::
+ (Resolvable ref, GitMonad git) =>
+ -- | the commit revision or reference to open
+ ref ->
+ CommitAccessM a ->
+ git a
withCommit rev m = do
- mRef <- resolve rev
- case mRef of
- Nothing -> fail "revision does not exist"
- Just ref -> do
- mCommit <- getCommit ref
- case mCommit of
- Nothing -> fail $ "the given ref does not exist or is not a commit"
- Just commit -> do
- let ctx = CommitAccessContext
- { commitAccessContextCommit = commit
- , commitAccessContextRef = ref
- }
- r <- runCommitAccessM m ctx
- case r of
- ResultFailure err -> fail err
- ResultSuccess _ a -> return a
+ mRef <- resolve rev
+ case mRef of
+ Nothing -> fail "revision does not exist"
+ Just ref -> do
+ mCommit <- getCommit ref
+ case mCommit of
+ Nothing -> fail $ "the given ref does not exist or is not a commit"
+ Just commit -> do
+ let ctx =
+ CommitAccessContext
+ { commitAccessContextCommit = commit,
+ commitAccessContextRef = ref
+ }
+ r <- runCommitAccessM m ctx
+ case r of
+ ResultFailure err -> fail err
+ ResultSuccess _ a -> return a
-------------------------------------------------------------------------------
-- CommitM --
-------------------------------------------------------------------------------
data CommitContext = CommitContext
- { commitContextAuthor :: !Git.Person
- , commitContextCommitter :: !Git.Person
- , commitContextParents :: ![Git.Ref SHA1]
- , commitContextExtras :: ![Git.CommitExtra]
- , commitContextEncoding :: !(Maybe ByteString)
- , commitContextMessage :: !ByteString
- , commitContextTree :: !(Git.WorkTree SHA1)
- }
-
-newtype CommitM a = CommitM
- { runCommitM :: forall git . GitMonad git => CommitContext -> git (Result CommitContext a)
- }
+ { commitContextAuthor :: !Git.Person,
+ commitContextCommitter :: !Git.Person,
+ commitContextParents :: ![Git.Ref SHA1],
+ commitContextExtras :: ![Git.CommitExtra],
+ commitContextEncoding :: !(Maybe ByteString),
+ commitContextMessage :: !ByteString,
+ commitContextTree :: !(Git.WorkTree SHA1)
+ }
+
+newtype CommitM a = CommitM
+ { runCommitM :: forall git. GitMonad git => CommitContext -> git (Result CommitContext a)
+ }
instance Functor CommitM where
- fmap = fmapCommitM
+ fmap = fmapCommitM
instance Applicative CommitM where
- pure = returnCommitM
- (<*>) = appendCommitM
+ pure = returnCommitM
+ (<*>) = appendCommitM
instance Monad CommitM where
- return = returnCommitM
- (>>=) = bindCommitM
+ return = returnCommitM
+ (>>=) = bindCommitM
instance MonadFail CommitM where
- fail = failCommitM
+ fail = failCommitM
instance GitMonad CommitM where
- getGit = getCommitM
- liftGit = liftCommitM
+ getGit = getCommitM
+ liftGit = liftCommitM
fmapCommitM :: (a -> b) -> CommitM a -> CommitM b
fmapCommitM f m = CommitM $ \ctx -> do
- r <- runCommitM m ctx
- return $ case r of
- ResultSuccess ctx' v -> ResultSuccess ctx' (f v)
- ResultFailure err -> ResultFailure err
+ r <- runCommitM m ctx
+ return $ case r of
+ ResultSuccess ctx' v -> ResultSuccess ctx' (f v)
+ ResultFailure err -> ResultFailure err
returnCommitM :: a -> CommitM a
returnCommitM v = CommitM $ \ctx -> return (ResultSuccess ctx v)
@@ -500,10 +508,10 @@ appendCommitM m1f m2 = m1f >>= \f -> m2 >>= \v -> return (f v)
bindCommitM :: CommitM a -> (a -> CommitM b) -> CommitM b
bindCommitM m fm = CommitM $ \ctx -> do
- r <- runCommitM m ctx
- case r of
- ResultSuccess ctx' v -> runCommitM (fm v) ctx'
- ResultFailure err -> return (ResultFailure err)
+ r <- runCommitM m ctx
+ case r of
+ ResultSuccess ctx' v -> runCommitM (fm v) ctx'
+ ResultFailure err -> return (ResultFailure err)
failCommitM :: String -> CommitM a
failCommitM msg = CommitM $ \_ -> return (ResultFailure msg)
@@ -518,57 +526,59 @@ liftCommitM f = CommitM $ \ctx -> ResultSuccess ctx <$> (liftGit f)
commitUpdateContext :: (CommitContext -> IO (CommitContext, a)) -> CommitM a
commitUpdateContext operation = CommitM $ \ctx -> do
- (ctx', r) <- liftGit $ operation ctx
- return (ResultSuccess ctx' r)
+ (ctx', r) <- liftGit $ operation ctx
+ return (ResultSuccess ctx' r)
-- | replace the Commit's Author
setAuthor :: Git.Person -> CommitM ()
-setAuthor p = commitUpdateContext $ \ctx -> return (ctx { commitContextCommitter = p }, ())
+setAuthor p = commitUpdateContext $ \ctx -> return (ctx {commitContextCommitter = p}, ())
-- | replace the Commit's Committer
setCommitter :: Git.Person -> CommitM ()
-setCommitter p = commitUpdateContext $ \ctx -> return (ctx { commitContextCommitter = p }, ())
+setCommitter p = commitUpdateContext $ \ctx -> return (ctx {commitContextCommitter = p}, ())
-- | replace the Commit's Parents
setParents :: [Git.Ref SHA1] -> CommitM ()
-setParents l = commitUpdateContext $ \ctx -> return (ctx { commitContextParents = l }, ())
+setParents l = commitUpdateContext $ \ctx -> return (ctx {commitContextParents = l}, ())
-- | replace the Commit's Extras
setExtras :: [Git.CommitExtra] -> CommitM ()
-setExtras l = commitUpdateContext $ \ctx -> return (ctx { commitContextExtras = l }, ())
+setExtras l = commitUpdateContext $ \ctx -> return (ctx {commitContextExtras = l}, ())
-- | replace the Commit's encoding
setEncoding :: Maybe ByteString -> CommitM ()
-setEncoding e = commitUpdateContext $ \ctx -> return (ctx { commitContextEncoding = e }, ())
+setEncoding e = commitUpdateContext $ \ctx -> return (ctx {commitContextEncoding = e}, ())
-- | replace the Commit's message with the new given message.
setMessage :: ByteString -> CommitM ()
-setMessage msg = commitUpdateContext $ \ctx -> return (ctx { commitContextMessage = msg }, ())
+setMessage msg = commitUpdateContext $ \ctx -> return (ctx {commitContextMessage = msg}, ())
-setContextObject_ :: Git.Objectable object
- => Git.EntPath
- -> (Git.EntType, object SHA1)
- -> CommitM ()
+setContextObject_ ::
+ Git.Objectable object =>
+ Git.EntPath ->
+ (Git.EntType, object SHA1) ->
+ CommitM ()
setContextObject_ path (t, obj) = do
- ref <- setObject obj
- git <- getGit
- commitUpdateContext $ \ctx -> do
- Git.workTreeSet git (commitContextTree ctx) path (t, ref)
- return (ctx, ())
+ ref <- setObject obj
+ git <- getGit
+ commitUpdateContext $ \ctx -> do
+ Git.workTreeSet git (commitContextTree ctx) path (t, ref)
+ return (ctx, ())
-- | add a new file in in the Commit's Working Tree
-setFile :: Git.EntPath
- -> BL.ByteString
- -> CommitM ()
-setFile path bl = setContextObject_ path (Git.EntFile , Git.Blob bl)
+setFile ::
+ Git.EntPath ->
+ BL.ByteString ->
+ CommitM ()
+setFile path bl = setContextObject_ path (Git.EntFile, Git.Blob bl)
-- | delete a file from the Commit's Working Tree.
deleteFile :: Git.EntPath -> CommitM ()
deleteFile path = do
- git <- getGit
- commitUpdateContext $ \ctx -> do
- Git.workTreeDelete git (commitContextTree ctx) path
- return (ctx, ())
+ git <- getGit
+ commitUpdateContext $ \ctx -> do
+ Git.workTreeDelete git (commitContextTree ctx) path
+ return (ctx, ())
-- | create a new commit in the current GitMonad
--
@@ -603,59 +613,61 @@ deleteFile path = do
-- > setMessage "update the README"
-- > setFile ["README.md"] $ readmeContent <> "just add some more description\n"
-- > branchWrite "master" r
---
-withNewCommit :: (GitMonad git, Resolvable rev)
- => Git.Person
- -- ^ by default a commit must have an Author and a Committer.
- --
- -- The given value will be given to both Author and Committer.
- -> Maybe rev
- -- ^ it is possible to prepopulate the Working Tree with a
- -- given Ref's Tree.
- -> CommitM a
- -- ^ the action to perform in the new commit (set files,
- -- Person, encoding or extras)
- -> git (Git.Ref SHA1, a)
+withNewCommit ::
+ (GitMonad git, Resolvable rev) =>
+ -- | by default a commit must have an Author and a Committer.
+ --
+ -- The given value will be given to both Author and Committer.
+ Git.Person ->
+ -- | it is possible to prepopulate the Working Tree with a
+ -- given Ref's Tree.
+ Maybe rev ->
+ -- | the action to perform in the new commit (set files,
+ -- Person, encoding or extras)
+ CommitM a ->
+ git (Git.Ref SHA1, a)
withNewCommit p mPrec m = do
- workTree <- case mPrec of
- Nothing -> workTreeNew
- Just r -> do
- mc <- getCommit r
- case mc of
- Nothing -> fail "the given revision does not exist or is not a commit"
- Just c -> workTreeFrom (Git.commitTreeish c)
- parents <- case mPrec of
- Nothing -> return []
- Just r -> do
- mr <- resolve r
- return $ case mr of
- Nothing -> []
- Just ref -> [ref]
- let ctx = CommitContext
- { commitContextAuthor = p
- , commitContextCommitter = p
- , commitContextParents = parents
- , commitContextExtras = []
- , commitContextEncoding = Nothing
- , commitContextMessage = B.empty
- , commitContextTree = workTree
- }
- r <- runCommitM m ctx
- case r of
- ResultFailure err -> fail err
- ResultSuccess ctx' a -> do
- treeRef <- workTreeFlush (commitContextTree ctx')
- let commit = Git.Commit
- { Git.commitTreeish = treeRef
- , Git.commitParents = commitContextParents ctx'
- , Git.commitAuthor = commitContextAuthor ctx'
- , Git.commitCommitter = commitContextCommitter ctx'
- , Git.commitEncoding = commitContextEncoding ctx'
- , Git.commitExtras = commitContextExtras ctx'
- , Git.commitMessage = commitContextMessage ctx'
- }
- ref <- setObject commit
- return (ref, a)
+ workTree <- case mPrec of
+ Nothing -> workTreeNew
+ Just r -> do
+ mc <- getCommit r
+ case mc of
+ Nothing -> fail "the given revision does not exist or is not a commit"
+ Just c -> workTreeFrom (Git.commitTreeish c)
+ parents <- case mPrec of
+ Nothing -> return []
+ Just r -> do
+ mr <- resolve r
+ return $ case mr of
+ Nothing -> []
+ Just ref -> [ref]
+ let ctx =
+ CommitContext
+ { commitContextAuthor = p,
+ commitContextCommitter = p,
+ commitContextParents = parents,
+ commitContextExtras = [],
+ commitContextEncoding = Nothing,
+ commitContextMessage = B.empty,
+ commitContextTree = workTree
+ }
+ r <- runCommitM m ctx
+ case r of
+ ResultFailure err -> fail err
+ ResultSuccess ctx' a -> do
+ treeRef <- workTreeFlush (commitContextTree ctx')
+ let commit =
+ Git.Commit
+ { Git.commitTreeish = treeRef,
+ Git.commitParents = commitContextParents ctx',
+ Git.commitAuthor = commitContextAuthor ctx',
+ Git.commitCommitter = commitContextCommitter ctx',
+ Git.commitEncoding = commitContextEncoding ctx',
+ Git.commitExtras = commitContextExtras ctx',
+ Git.commitMessage = commitContextMessage ctx'
+ }
+ ref <- setObject commit
+ return (ref, a)
-- | create or continue to work on a branch
--
@@ -674,47 +686,48 @@ withNewCommit p mPrec m = do
-- (\author -> setMessage $ "continue the great work of " ++ show (personName author))
-- )
-- @
---
-withBranch :: GitMonad git
- => Git.Person
- -- ^ the default Author and Committer (see 'withNewCommit')
- -> Git.RefName
- -- ^ the branch to work on
- -> Bool
- -- ^ propopulate the parent's tree (if it exists) in the
- -- new created commit.
- --
- -- In any cases, if the branch already exists, the new commit
- -- parent will be filled with the result of ('resolv' "branchName")
- -> (CommitAccessM a)
- -- ^ the action to performs in the parent's new commit if it exists.
- -> (Maybe a -> CommitM b)
- -- ^ the action to performs in the new commit
- --
- -- the argument is the result of the action on the parent commit.
- --
- -- Nothing if the parent does not exist.
- -> git (Git.Ref SHA1, b)
+withBranch ::
+ GitMonad git =>
+ -- | the default Author and Committer (see 'withNewCommit')
+ Git.Person ->
+ -- | the branch to work on
+ Git.RefName ->
+ -- | propopulate the parent's tree (if it exists) in the
+ -- new created commit.
+ --
+ -- In any cases, if the branch already exists, the new commit
+ -- parent will be filled with the result of ('resolv' "branchName")
+ Bool ->
+ -- | the action to performs in the parent's new commit if it exists.
+ (CommitAccessM a) ->
+ -- | the action to performs in the new commit
+ --
+ -- the argument is the result of the action on the parent commit.
+ --
+ -- Nothing if the parent does not exist.
+ (Maybe a -> CommitM b) ->
+ git (Git.Ref SHA1, b)
withBranch p branchName keepTree actionParent actionNew = do
- -- attempt to resolve the branch
- mRefParent <- resolve branchName
-
- -- configure the precedency of the tree and the action in the new commit
- (mRefTree, actionInCommit) <- case mRefParent of
- -- in the case the branch does not exist already: there is not precedency
- Nothing -> return (Nothing, actionNew Nothing)
- -- if the branch exists
- Just refParent -> do
- -- performs the action in the parent commit
- a <- withCommit refParent actionParent
- return $ if keepTree
- -- if user has choosen to prepopulate the Tree with the
- -- parent's tree we prepopulate the tree.
- then (Just refParent, actionNew $ Just a)
- -- else, we make sure the parent is at least setted
- else (Nothing, setParents [refParent] >> actionNew (Just a))
- -- create the new commit
- (ref, b) <- withNewCommit p (mRefTree) actionInCommit
- -- write the branch
- branchWrite branchName ref
- return (ref, b)
+ -- attempt to resolve the branch
+ mRefParent <- resolve branchName
+
+ -- configure the precedency of the tree and the action in the new commit
+ (mRefTree, actionInCommit) <- case mRefParent of
+ -- in the case the branch does not exist already: there is not precedency
+ Nothing -> return (Nothing, actionNew Nothing)
+ -- if the branch exists
+ Just refParent -> do
+ -- performs the action in the parent commit
+ a <- withCommit refParent actionParent
+ return $
+ if keepTree
+ then -- if user has choosen to prepopulate the Tree with the
+ -- parent's tree we prepopulate the tree.
+ (Just refParent, actionNew $ Just a)
+ else -- else, we make sure the parent is at least setted
+ (Nothing, setParents [refParent] >> actionNew (Just a))
+ -- create the new commit
+ (ref, b) <- withNewCommit p (mRefTree) actionInCommit
+ -- write the branch
+ branchWrite branchName ref
+ return (ref, b)
diff --git a/Data/Git/Named.hs b/Data/Git/Named.hs
index 44bd902..fa0a4c3 100644
--- a/Data/Git/Named.hs
+++ b/Data/Git/Named.hs
@@ -11,146 +11,155 @@
-- Manipulation of named references
-- * reading packed-refs file
-- * reading single heads/tags/remote file
---
module Data.Git.Named
- ( RefSpecTy(..)
- , RefContentTy(..)
- , RefName(..)
- , readPackedRefs
- , PackedRefs(..)
+ ( RefSpecTy (..),
+ RefContentTy (..),
+ RefName (..),
+ readPackedRefs,
+ PackedRefs (..),
+
-- * manipulating loosed name references
- , existsRefFile
- , writeRefFile
- , readRefFile
+ existsRefFile,
+ writeRefFile,
+ readRefFile,
+
-- * listings looses name references
- , looseHeadsList
- , looseTagsList
- , looseRemotesList
- ) where
+ looseHeadsList,
+ looseTagsList,
+ looseRemotesList,
+ )
+where
-import Data.String
-import Data.Git.Path
-import Data.Git.Ref
-import Data.Git.Imports
-import Data.Git.OS
-import Data.List (isPrefixOf)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.UTF8 as UTF8
+import Data.Git.Imports
+import Data.Git.OS
+import Data.Git.Path
+import Data.Git.Ref
+import Data.List (isPrefixOf)
+import Data.String
-- | Represent a named specifier.
-data RefSpecTy = RefHead
- | RefOrigHead
- | RefFetchHead
- | RefBranch RefName
- | RefTag RefName
- | RefRemote RefName
- | RefPatches String
- | RefStash
- | RefOther String
- deriving (Show,Eq,Ord)
+data RefSpecTy
+ = RefHead
+ | RefOrigHead
+ | RefFetchHead
+ | RefBranch RefName
+ | RefTag RefName
+ | RefRemote RefName
+ | RefPatches String
+ | RefStash
+ | RefOther String
+ deriving (Show, Eq, Ord)
-- | content of a ref file.
-data RefContentTy hash =
- RefDirect (Ref hash)
- | 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)
+newtype RefName = RefName {refNameRaw :: String}
+ deriving (Show, Eq, Ord)
instance IsString RefName where
- fromString s
- | isValidRefName s = RefName s
- | otherwise = error ("invalid RefName " ++ show s)
+ fromString s
+ | isValidRefName s = RefName s
+ | otherwise = error ("invalid RefName " ++ show s)
isValidRefName :: String -> Bool
isValidRefName s = not (or $ map isBadChar s)
- where isBadChar :: Char -> Bool
- isBadChar c = c <= ' ' || c >= toEnum 0x7f || c `elem` badAscii
- badAscii = [ '~', '^', ':', '\\', '*', '?', '[' ]
+ where
+ isBadChar :: Char -> Bool
+ isBadChar c = c <= ' ' || c >= toEnum 0x7f || c `elem` badAscii
+ badAscii = ['~', '^', ':', '\\', '*', '?', '[']
toRefTy :: String -> RefSpecTy
toRefTy s
- | "refs/tags/" `isPrefixOf` s = RefTag $ RefName $ drop 10 s
- | "refs/heads/" `isPrefixOf` s = RefBranch $ RefName $ drop 11 s
- | "refs/remotes/" `isPrefixOf` s = RefRemote $ RefName $ drop 13 s
- | "refs/patches/" `isPrefixOf` s = RefPatches $ drop 13 s
- | "refs/stash" == s = RefStash
- | "HEAD" == s = RefHead
- | "ORIG_HEAD" == s = RefOrigHead
- | "FETCH_HEAD" == s = RefFetchHead
- | otherwise = RefOther $ s
+ | "refs/tags/" `isPrefixOf` s = RefTag $ RefName $ drop 10 s
+ | "refs/heads/" `isPrefixOf` s = RefBranch $ RefName $ drop 11 s
+ | "refs/remotes/" `isPrefixOf` s = RefRemote $ RefName $ drop 13 s
+ | "refs/patches/" `isPrefixOf` s = RefPatches $ drop 13 s
+ | "refs/stash" == s = RefStash
+ | "HEAD" == s = RefHead
+ | "ORIG_HEAD" == s = RefOrigHead
+ | "FETCH_HEAD" == s = RefFetchHead
+ | otherwise = RefOther $ s
fromRefTy :: RefSpecTy -> String
-fromRefTy (RefBranch h) = "refs/heads/" ++ refNameRaw h
-fromRefTy (RefTag h) = "refs/tags/" ++ refNameRaw h
-fromRefTy (RefRemote h) = "refs/remotes/" ++ refNameRaw h
+fromRefTy (RefBranch h) = "refs/heads/" ++ refNameRaw h
+fromRefTy (RefTag h) = "refs/tags/" ++ refNameRaw h
+fromRefTy (RefRemote h) = "refs/remotes/" ++ refNameRaw h
fromRefTy (RefPatches h) = "refs/patches/" ++ h
-fromRefTy RefStash = "refs/stash"
-fromRefTy RefHead = "HEAD"
-fromRefTy RefOrigHead = "ORIG_HEAD"
-fromRefTy RefFetchHead = "FETCH_HEAD"
-fromRefTy (RefOther h) = h
+fromRefTy RefStash = "refs/stash"
+fromRefTy RefHead = "HEAD"
+fromRefTy RefOrigHead = "ORIG_HEAD"
+fromRefTy RefFetchHead = "FETCH_HEAD"
+fromRefTy (RefOther h) = h
toPath :: LocalPath -> RefSpecTy -> LocalPath
-toPath gitRepo (RefBranch h) = gitRepo </> "refs" </> "heads" </> fromString (refNameRaw h)
-toPath gitRepo (RefTag h) = gitRepo </> "refs" </> "tags" </> fromString (refNameRaw h)
-toPath gitRepo (RefRemote h) = gitRepo </> "refs" </> "remotes" </> fromString (refNameRaw h)
+toPath gitRepo (RefBranch h) = gitRepo </> "refs" </> "heads" </> fromString (refNameRaw h)
+toPath gitRepo (RefTag h) = gitRepo </> "refs" </> "tags" </> fromString (refNameRaw h)
+toPath gitRepo (RefRemote h) = gitRepo </> "refs" </> "remotes" </> fromString (refNameRaw h)
toPath gitRepo (RefPatches h) = gitRepo </> "refs" </> "patches" </> fromString h
-toPath gitRepo RefStash = gitRepo </> "refs" </> "stash"
-toPath gitRepo RefHead = gitRepo </> "HEAD"
-toPath gitRepo RefOrigHead = gitRepo </> "ORIG_HEAD"
-toPath gitRepo RefFetchHead = gitRepo </> "FETCH_HEAD"
-toPath gitRepo (RefOther h) = gitRepo </> fromString h
+toPath gitRepo RefStash = gitRepo </> "refs" </> "stash"
+toPath gitRepo RefHead = gitRepo </> "HEAD"
+toPath gitRepo RefOrigHead = gitRepo </> "ORIG_HEAD"
+toPath gitRepo RefFetchHead = gitRepo </> "FETCH_HEAD"
+toPath gitRepo (RefOther h) = gitRepo </> fromString h
data PackedRefs a = PackedRefs
- { packedRemotes :: a
- , packedBranchs :: a
- , packedTags :: a
- }
-
-readPackedRefs :: HashAlgorithm hash
- => LocalPath
- -> ([(RefName, Ref hash)] -> a)
- -> IO (PackedRefs a)
+ { packedRemotes :: a,
+ packedBranchs :: a,
+ packedTags :: a
+ }
+
+readPackedRefs ::
+ HashAlgorithm hash =>
+ LocalPath ->
+ ([(RefName, Ref hash)] -> a) ->
+ IO (PackedRefs a)
readPackedRefs gitRepo constr = do
- exists <- isFile (packedRefsPath gitRepo)
- if exists then readLines else return $ finalize emptyPackedRefs
- where emptyPackedRefs = PackedRefs [] [] []
- readLines = finalize . foldl accu emptyPackedRefs . BC.lines <$> readBinaryFile (packedRefsPath gitRepo)
- finalize (PackedRefs a b c) = PackedRefs (constr a) (constr b) (constr c)
- accu a l
- | "#" `BC.isPrefixOf` l = a
- | otherwise =
- 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, 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
+ exists <- isFile (packedRefsPath gitRepo)
+ if exists then readLines else return $ finalize emptyPackedRefs
+ where
+ emptyPackedRefs = PackedRefs [] [] []
+ readLines = finalize . foldl accu emptyPackedRefs . BC.lines <$> readBinaryFile (packedRefsPath gitRepo)
+ finalize (PackedRefs a b c) = PackedRefs (constr a) (constr b) (constr c)
+ accu a l
+ | "#" `BC.isPrefixOf` l = a
+ | otherwise =
+ 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, 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
-- | list all the loose refs available recursively from a directory starting point
listRefs :: LocalPath -> IO [RefName]
listRefs root = listRefsAcc [] root
- where listRefsAcc acc dir = do
- files <- listDirectory dir
- getRefsRecursively dir acc files
- getRefsRecursively _ acc [] = return acc
- getRefsRecursively dir acc (x:xs) = do
- isDir <- isDirectory x
- extra <- if isDir
- then listRefsAcc [] x
- else let r = UTF8.toString $ localPathEncode $ stripRoot x
- in if isValidRefName r
- then return [fromString r]
- else return []
- getRefsRecursively dir (extra ++ acc) xs
- stripRoot p = maybe (error "stripRoot invalid") id $ stripPrefix root p
+ where
+ listRefsAcc acc dir = do
+ files <- listDirectory dir
+ getRefsRecursively dir acc files
+ getRefsRecursively _ acc [] = return acc
+ getRefsRecursively dir acc (x : xs) = do
+ isDir <- isDirectory x
+ extra <-
+ if isDir
+ then listRefsAcc [] x
+ else
+ let r = UTF8.toString $ localPathEncode $ stripRoot x
+ in if isValidRefName r
+ then return [fromString r]
+ else return []
+ getRefsRecursively dir (extra ++ acc) xs
+ stripRoot p = maybe (error "stripRoot invalid") id $ stripPrefix root p
looseHeadsList :: LocalPath -> IO [RefName]
looseHeadsList gitRepo = listRefs (headsPath gitRepo)
@@ -166,20 +175,22 @@ existsRefFile gitRepo specty = isFile $ toPath gitRepo specty
writeRefFile :: LocalPath -> RefSpecTy -> RefContentTy hash -> IO ()
writeRefFile gitRepo specty refcont = do
- createParentDirectory filepath
- writeBinaryFile filepath $ fromRefContent refcont
- where filepath = toPath gitRepo specty
- fromRefContent (RefLink link) = B.concat ["ref: ", UTF8.fromString $ fromRefTy link, B.singleton 0xa]
- fromRefContent (RefDirect ref) = B.concat [toHex ref, B.singleton 0xa]
- fromRefContent (RefContentUnknown c) = c
+ createParentDirectory filepath
+ writeBinaryFile filepath $ fromRefContent refcont
+ where
+ filepath = toPath gitRepo specty
+ fromRefContent (RefLink link) = B.concat ["ref: ", UTF8.fromString $ fromRefTy link, B.singleton 0xa]
+ fromRefContent (RefDirect ref) = B.concat [toHex ref, B.singleton 0xa]
+ fromRefContent (RefContentUnknown c) = c
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 $ fst $ consumeHexRef hashAlg content
- | otherwise = RefContentUnknown content
+ 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 $ 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)
+consumeHexRef alg b = let (b1, b2) = B.splitAt (hashDigestSize alg * 2) b in (fromHex b1, b2)
diff --git a/Data/Git/OS.hs b/Data/Git/OS.hs
index 449d8d7..990af20 100644
--- a/Data/Git/OS.hs
+++ b/Data/Git/OS.hs
@@ -7,64 +7,65 @@
--
-- dealing with operating system / IO related stuff
-- like file on disk
---
module Data.Git.OS
- ( LocalPath
+ ( LocalPath,
+
-- * re-export
- , getHomeDirectory
- , getWorkingDirectory
- , (</>)
- , listDirectoryFilename
- , listDirectory
- , openFile
- , readFile
- , readTextFile
- , writeTextFile
- , readBinaryFile
- , readBinaryFileLazy
- , writeBinaryFile
- , hClose
- , IOMode(..)
- , Handle
- , createParentDirectory
- , createDirectory
- , writeFile
- , isFile
- , isDirectory
- , valid
- , getSize
- , MTime(..)
- , timeZero
- , getMTime
- , withFile
- , rename
- , removeFile
- , getEnvAsPath
- , absolute
- , parent
- , stripPrefix
- , localPathEncode
- , localPathDecode
- ) where
-
-import Data.Git.Imports
-import Filesystem.Path.CurrentOS
-import Filesystem hiding (readTextFile, writeTextFile)
-import qualified Filesystem.Path.Rules as Rules
-import System.PosixCompat.Files (getFileStatus, modificationTime)
-import System.PosixCompat.Types (EpochTime)
-import System.IO (hClose)
-import System.Environment
-import Prelude hiding (FilePath, writeFile, readFile)
-import qualified Prelude
+ getHomeDirectory,
+ getWorkingDirectory,
+ (</>),
+ listDirectoryFilename,
+ listDirectory,
+ openFile,
+ readFile,
+ readTextFile,
+ writeTextFile,
+ readBinaryFile,
+ readBinaryFileLazy,
+ writeBinaryFile,
+ hClose,
+ IOMode (..),
+ Handle,
+ createParentDirectory,
+ createDirectory,
+ writeFile,
+ isFile,
+ isDirectory,
+ valid,
+ getSize,
+ MTime (..),
+ timeZero,
+ getMTime,
+ withFile,
+ rename,
+ removeFile,
+ getEnvAsPath,
+ absolute,
+ parent,
+ stripPrefix,
+ localPathEncode,
+ localPathDecode,
+ )
+where
+
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
+import Data.Git.Imports
+import Filesystem hiding (readTextFile, writeTextFile)
+import Filesystem.Path.CurrentOS
+import qualified Filesystem.Path.Rules as Rules
+import System.Environment
+import System.IO (hClose)
+import System.PosixCompat.Files (getFileStatus, modificationTime)
+import System.PosixCompat.Types (EpochTime)
+import Prelude hiding (FilePath, readFile, writeFile)
+import qualified Prelude
type LocalPath = FilePath
listDirectoryFilename :: LocalPath -> IO [String]
listDirectoryFilename dir =
- map (Rules.encodeString Rules.posix . filename) <$> listDirectory dir
+ map (Rules.encodeString Rules.posix . filename) <$> listDirectory dir
createParentDirectory :: LocalPath -> IO ()
createParentDirectory filepath = createTree $ parent filepath
@@ -75,7 +76,7 @@ readTextFile filepath = Prelude.readFile (encodeString filepath)
writeTextFile :: LocalPath -> String -> IO ()
writeTextFile filepath = Prelude.writeFile (encodeString filepath)
-newtype MTime = MTime EpochTime deriving (Eq,Ord)
+newtype MTime = MTime EpochTime deriving (Eq, Ord)
timeZero :: EpochTime
timeZero = 0
diff --git a/Data/Git/Parser.hs b/Data/Git/Parser.hs
index 93254b5..5331006 100644
--- a/Data/Git/Parser.hs
+++ b/Data/Git/Parser.hs
@@ -1,58 +1,57 @@
module Data.Git.Parser
- (
- Parser
- , P.Result(..)
- , eitherParse
- , eitherParseChunks
- , maybeParse
- , maybeParseChunks
+ ( Parser,
+ P.Result (..),
+ eitherParse,
+ eitherParseChunks,
+ maybeParse,
+ maybeParseChunks,
+
-- * Specific functions
- , word16
- , word32
- , ref
- , referenceBin
- , referenceHex
- , vlf
- , tillEOL
- , skipEOL
- , skipASCII
- , takeUntilASCII
- , decimal
- , takeWhile1
- , string
- -- * Simple re-export
- , P.anyByte
- , P.byte
- , P.bytes
- , P.take
- , P.takeWhile
- , P.parse
- , P.parseFeed
- , P.takeAll
- , P.hasMore
- ) where
+ word16,
+ word32,
+ ref,
+ referenceBin,
+ referenceHex,
+ vlf,
+ tillEOL,
+ skipEOL,
+ skipASCII,
+ takeUntilASCII,
+ decimal,
+ takeWhile1,
+ string,
+ -- * Simple re-export
+ P.anyByte,
+ P.byte,
+ P.bytes,
+ P.take,
+ P.takeWhile,
+ P.parse,
+ P.parseFeed,
+ P.takeAll,
+ P.hasMore,
+ )
+where
+
+import Data.Bits
+import Data.ByteArray (ByteArray)
import qualified Data.ByteArray.Parse as P
-import Data.ByteArray (ByteArray)
-
-import Data.Bits
-import Data.Word (Word8, Word16, Word32)
-import Data.Char (isDigit)
-
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
-
-import Data.Git.Ref
-import Data.Git.Internal
-import Data.Git.Imports
+import Data.Char (isDigit)
+import Data.Git.Imports
+import Data.Git.Internal
+import Data.Git.Ref
+import Data.Word (Word16, Word32, Word8)
type Parser = P.Parser B.ByteString
vlf :: Parser [Word8]
vlf = do
- bs <- P.takeWhile (\w -> w `testBit` 7)
- l <- P.anyByte
- return $ (map (\w -> w `clearBit` 7) $ B.unpack bs) ++ [l]
+ bs <- P.takeWhile (\w -> w `testBit` 7)
+ l <- P.anyByte
+ return $ (map (\w -> w `clearBit` 7) $ B.unpack bs) ++ [l]
word32 :: Parser Word32
word32 = be32 <$> P.take 4
@@ -65,12 +64,13 @@ ref = referenceBin
referenceBin = takeDigestSize hashAlg 1 fromBinary
referenceHex = takeDigestSize hashAlg 2 fromHex
-takeDigestSize :: HashAlgorithm hash => hash -> Int -> (B.ByteString -> Ref hash) -> Parser (Ref hash)
+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))
- where toNum = read . BC.unpack
+ where
+ toNum = read . BC.unpack
string :: B.ByteString -> Parser ()
string = P.bytes
@@ -79,30 +79,30 @@ maybeParse :: Parser a -> B.ByteString -> Maybe a
maybeParse f = toMaybe . P.parse f
maybeParseChunks :: Parser a -> [B.ByteString] -> Maybe a
-maybeParseChunks p [] = toMaybe $ P.parse p B.empty
-maybeParseChunks p (i:is) = loop (P.parse p i) is
+maybeParseChunks p [] = toMaybe $ P.parse p B.empty
+maybeParseChunks p (i : is) = loop (P.parse p i) is
where
- loop (P.ParseOK _ a) [] = Just a
- loop (P.ParseMore c) [] = toMaybe $ c Nothing
- loop (P.ParseMore c) (x:xs) = loop (c $ Just x) xs
- loop _ _ = Nothing
+ loop (P.ParseOK _ a) [] = Just a
+ loop (P.ParseMore c) [] = toMaybe $ c Nothing
+ loop (P.ParseMore c) (x : xs) = loop (c $ Just x) xs
+ loop _ _ = Nothing
toMaybe :: P.Result t a -> Maybe a
toMaybe (P.ParseOK _ a) = Just a
toMaybe (P.ParseMore c) = toMaybe (c Nothing)
-toMaybe _ = Nothing
+toMaybe _ = Nothing
eitherParse :: Parser a -> B.ByteString -> Either String a
eitherParse f = toEither . P.parse f
eitherParseChunks :: Show a => Parser a -> [B.ByteString] -> Either String a
-eitherParseChunks p [] = toEither $ P.parse p B.empty
-eitherParseChunks p (i:is) = loop (P.parse p i) is
+eitherParseChunks p [] = toEither $ P.parse p B.empty
+eitherParseChunks p (i : is) = loop (P.parse p i) is
where
- loop (P.ParseOK _ a) [] = Right a
- loop (P.ParseMore c) [] = toEither $ c Nothing
- loop (P.ParseMore c) (x:xs) = loop (c $ Just x) xs
- loop ps l = Left ("eitherParseChunk: error: " <> show ps <> " : " <> show l)
+ loop (P.ParseOK _ a) [] = Right a
+ loop (P.ParseMore c) [] = toEither $ c Nothing
+ loop (P.ParseMore c) (x : xs) = loop (c $ Just x) xs
+ loop ps l = Left ("eitherParseChunk: error: " <> show ps <> " : " <> show l)
toEither :: P.Result t b -> Either String b
toEither (P.ParseOK _ a) = Right a
@@ -120,8 +120,8 @@ skipEOL = P.byte asciiEOL >> return ()
skipASCII :: Char -> Parser ()
skipASCII c
- | cp < 0x80 = P.byte (fromIntegral cp) >> return ()
- | otherwise = error ("skipASCII: " ++ show c ++ " not a valid ASCII character")
+ | cp < 0x80 = P.byte (fromIntegral cp) >> return ()
+ | otherwise = error ("skipASCII: " ++ show c ++ " not a valid ASCII character")
where
cp = fromEnum c
@@ -130,9 +130,9 @@ asciiEOL = fromIntegral $ fromEnum '\n'
isByte :: ByteArray byteArray => (Word8 -> Bool) -> P.Parser byteArray Word8
isByte predicate = do
- b <- P.anyByte
- if predicate b then return b else fail "isByte"
+ b <- P.anyByte
+ if predicate b then return b else fail "isByte"
takeWhile1 :: (Word8 -> Bool) -> Parser B.ByteString
takeWhile1 predicate =
- B.cons <$> isByte predicate <*> P.takeWhile predicate
+ B.cons <$> isByte predicate <*> P.takeWhile predicate
diff --git a/Data/Git/Path.hs b/Data/Git/Path.hs
index 329f1bb..73ea306 100644
--- a/Data/Git/Path.hs
+++ b/Data/Git/Path.hs
@@ -6,20 +6,18 @@
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unix
---
module Data.Git.Path where
-import System.Random
-import Data.Git.Ref
import Data.Git.Imports
import Data.Git.OS
+import Data.Git.Ref
import Data.String
+import System.Random
configPath, headsPath, tagsPath, remotesPath, packedRefsPath :: LocalPath -> LocalPath
configPath gitRepo = gitRepo </> "config"
-
headsPath gitRepo = gitRepo </> "refs" </> "heads" </> ""
-tagsPath gitRepo = gitRepo </> "refs" </> "tags" </> ""
+tagsPath gitRepo = gitRepo </> "refs" </> "tags" </> ""
remotesPath gitRepo = gitRepo </> "refs" </> "remotes" </> ""
packedRefsPath gitRepo = gitRepo </> "packed-refs"
@@ -37,19 +35,19 @@ packDirPath repoPath = repoPath </> "objects" </> "pack"
indexPath, packPath :: LocalPath -> Ref hash -> LocalPath
indexPath repoPath indexRef =
- packDirPath repoPath </> fromString ("pack-" ++ toHexString indexRef ++ ".idx")
-
+ packDirPath repoPath </> fromString ("pack-" ++ toHexString indexRef ++ ".idx")
packPath repoPath packRef =
- packDirPath repoPath </> fromString ("pack-" ++ toHexString packRef ++ ".pack")
+ packDirPath repoPath </> fromString ("pack-" ++ toHexString packRef ++ ".pack")
objectPath :: LocalPath -> String -> String -> LocalPath
objectPath repoPath d f = repoPath </> "objects" </> fromString d </> fromString f
objectPathOfRef :: HashAlgorithm hash => LocalPath -> Ref hash -> LocalPath
objectPathOfRef repoPath ref = objectPath repoPath d f
- where (d,f) = toFilePathParts ref
+ where
+ (d, f) = toFilePathParts ref
objectTemporaryPath :: LocalPath -> IO LocalPath
objectTemporaryPath repoPath = do
- r <- fst . random <$> getStdGen :: IO Int
- return (repoPath </> "objects" </> fromString ("tmp-" ++ show r ++ ".tmp"))
+ r <- fst . random <$> getStdGen :: IO Int
+ return (repoPath </> "objects" </> fromString ("tmp-" ++ show r ++ ".tmp"))
diff --git a/Data/Git/Ref.hs b/Data/Git/Ref.hs
index 5b7584b..0620fe7 100644
--- a/Data/Git/Ref.hs
+++ b/Data/Git/Ref.hs
@@ -6,67 +6,70 @@
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unix
---
module Data.Git.Ref
- ( Ref
- , SHA1
- , Crypto.Hash.HashAlgorithm
- , Crypto.Hash.hashDigestSize
+ ( Ref,
+ SHA1,
+ Crypto.Hash.HashAlgorithm,
+ Crypto.Hash.hashDigestSize,
+
-- * Exceptions
- , RefInvalid(..)
- , RefNotFound(..)
+ RefInvalid (..),
+ RefNotFound (..),
+
-- * convert from bytestring and string
- , isHex
- , isHexString
- , fromHex
- , fromHexString
- , fromBinary
- , fromDigest
- , toBinary
- , toHex
- , toHexString
+ isHex,
+ isHexString,
+ fromHex,
+ fromHexString,
+ fromBinary,
+ fromDigest,
+ toBinary,
+ toHex,
+ toHexString,
+
-- * Misc function related to ref
- , refPrefix
- , cmpPrefix
- , toFilePathParts
+ refPrefix,
+ cmpPrefix,
+ toFilePathParts,
+
-- * Hash ByteString types to a ref
- , hash
- , hashLBS
- , hashAlg
- , hashAlgFromRef
- ) where
+ hash,
+ hashLBS,
+ hashAlg,
+ hashAlgFromRef,
+ )
+where
+import Control.Exception (Exception, throw)
+import Crypto.Hash (Digest, SHA1, digestFromByteString)
import qualified Crypto.Hash
-import Crypto.Hash (Digest, SHA1, digestFromByteString)
-import Data.ByteString (ByteString)
-import qualified Data.ByteString.Unsafe as B (unsafeIndex)
-import qualified Data.ByteString.Lazy as L
-import qualified Data.ByteString.Char8 as BC
-import Data.ByteArray.Encoding
import qualified Data.ByteArray as B (convert)
-
+import Data.ByteArray.Encoding
+import Data.ByteString (ByteString)
+import qualified Data.ByteString.Char8 as BC
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Unsafe as B (unsafeIndex)
import Data.Char (isHexDigit)
import Data.Data
-import Control.Exception (Exception, throw)
-
-- | represent a git reference (SHA1)
newtype Ref hash = Ref (Digest hash)
- deriving (Eq,Ord,Typeable)
+ deriving (Eq, Ord, Typeable)
instance Show (Ref hash) where
- show = BC.unpack . toHex
+ show = BC.unpack . toHex
-- | Invalid Reference exception raised when
-- using something that is not a ref as a ref.
data RefInvalid = RefInvalid ByteString
- deriving (Show,Eq,Data,Typeable)
+ deriving (Show, Eq, Data, Typeable)
-- | Reference wasn't found
data RefNotFound hash = RefNotFound (Ref hash)
- deriving (Show,Eq,Typeable)
+ deriving (Show, Eq, Typeable)
instance Exception RefInvalid
+
instance Typeable hash => Exception (RefNotFound hash)
isHex :: ByteString -> Bool
@@ -79,9 +82,9 @@ isHexString = and . map isHexDigit
-- and turn into a 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
- Just hsh -> Ref hsh
+ case either (const Nothing) Just (convertFromBase Base16 s :: Either String ByteString) >>= digestFromByteString of
+ Nothing -> throw $ RefInvalid s
+ Just hsh -> Ref hsh
-- | take a hexadecimal string that represent a reference
-- and turn into a ref
diff --git a/Data/Git/Repository.hs b/Data/Git/Repository.hs
index 28d7525..3c4877a 100644
--- a/Data/Git/Repository.hs
+++ b/Data/Git/Repository.hs
@@ -1,6 +1,6 @@
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ViewPatterns #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-- |
-- Module : Data.Git.Repository
@@ -8,77 +8,77 @@
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unix
---
module Data.Git.Repository
- ( Git
+ ( Git,
+
-- * Config
- , configGetAll
- , configGet
- , Config(..)
- , Section(..)
+ configGetAll,
+ configGet,
+ Config (..),
+ Section (..),
+
-- * Trees
- , HTree
- , HTreeEnt(..)
- , RefName(..)
- , getCommitMaybe
- , getCommit
- , getTreeMaybe
- , getTree
- , rewrite
- , buildHTree
- , resolvePath
- , resolveTreeish
- , resolveRevision
- , initRepo
- , isRepo
+ HTree,
+ HTreeEnt (..),
+ RefName (..),
+ getCommitMaybe,
+ getCommit,
+ getTreeMaybe,
+ getTree,
+ rewrite,
+ buildHTree,
+ resolvePath,
+ resolveTreeish,
+ resolveRevision,
+ initRepo,
+ isRepo,
+
-- * named refs manipulation
- , branchWrite
- , branchList
- , tagWrite
- , tagList
- , headSet
- , headGet
- ) where
+ branchWrite,
+ branchList,
+ tagWrite,
+ tagList,
+ headSet,
+ headGet,
+ )
+where
import Control.Exception (Exception, throw)
-
-import Data.Maybe (fromMaybe)
-import Data.List (find, stripPrefix)
import Data.Data
-import Data.IORef
-
-import Data.Git.Named
-import Data.Git.Types
+import Data.Git.Config (Config (..), Section (..))
+import qualified Data.Git.Config as Cfg
import Data.Git.Imports
-import Data.Git.Storage.Object
-import Data.Git.Storage
+import Data.Git.Named
+import Data.Git.Ref
import Data.Git.Revision
-import Data.Git.Storage.Loose
+import Data.Git.Storage
import Data.Git.Storage.CacheFile
-import Data.Git.Ref
-import Data.Git.Config (Config(..), Section(..))
-import qualified Data.Git.Config as Cfg
-
-import Data.Set (Set)
-
+import Data.Git.Storage.Loose
+import Data.Git.Storage.Object
+import Data.Git.Types
+import Data.IORef
+import Data.List (find, stripPrefix)
import qualified Data.Map as M
+import Data.Maybe (fromMaybe)
+import Data.Set (Set)
import qualified Data.Set as Set
-- | hierarchy tree, either a reference to a blob (file) or a tree (directory).
data HTreeEnt hash = TreeDir (Ref hash) (HTree hash) | TreeFile (Ref hash)
-type HTree hash = [(ModePerm,EntName,HTreeEnt 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 hash = InvalidType (Ref hash) ObjectType
- deriving (Show,Eq,Typeable)
+ deriving (Show, Eq, Typeable)
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)
mapJustM f (Just o) = f o
-mapJustM _ Nothing = return Nothing
+mapJustM _ Nothing = return Nothing
-- | get a specified commit
getCommitMaybe :: HashAlgorithm hash => Git hash -> Ref hash -> IO (Maybe (Commit hash))
@@ -87,7 +87,8 @@ 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 :: (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
+ where
+ err = throw $ InvalidType ref TypeCommit
-- | get a specified tree
getTreeMaybe :: HashAlgorithm hash => Git hash -> Ref hash -> IO (Maybe (Tree hash))
@@ -96,89 +97,96 @@ getTreeMaybe git ref = maybe Nothing objectToTree <$> getObject git ref True
-- | get a specified tree but raise
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
+ where
+ err = throw $ InvalidType ref TypeTree
-- | try to resolve a string to a specific commit ref
-- for example: HEAD, HEAD^, master~3, shortRef
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)
+ getCacheVal (packedNamed git) >>= \c -> resolvePrefix c >>= maybe (return Nothing) (modf modifiers)
where
- resolvePrefix lookupCache = tryResolvers
- [resolveNamedPrefix lookupCache namedResolvers
- ,resolvePrePrefix
- ]
-
- resolveNamedPrefix _ [] = return Nothing
- resolveNamedPrefix lookupCache (x:xs) = followToRef (resolveNamedPrefix lookupCache xs) x
- where followToRef onFailure refty = do
- exists <- existsRefFile (gitRepoPath git) refty
- if exists
- then do refcont <- readRefFile (gitRepoPath git) refty
- case refcont of
- RefDirect ref -> return $ Just ref
- RefLink refspecty -> followToRef onFailure refspecty
- _ -> error "cannot handle reference content"
- else case refty of
- RefTag name -> mapLookup name $ packedTags lookupCache
- RefBranch name -> mapLookup name $ packedBranchs lookupCache
- RefRemote name -> mapLookup name $ packedRemotes lookupCache
- _ -> return Nothing
- where mapLookup name m = maybe onFailure (return . Just) $ M.lookup name m
-
- namedResolvers = case prefix of
- "HEAD" -> [ RefHead ]
- "ORIG_HEAD" -> [ RefOrigHead ]
- "FETCH_HEAD" -> [ RefFetchHead ]
- _ ->
- maybe (map (flip ($) (RefName prefix)) [RefTag,RefBranch,RefRemote]) (:[]) $
- (RefBranch . RefName <$> stripPrefix "refs/heads/" prefix)
- <|> (RefTag . RefName <$> stripPrefix "refs/tags/" prefix)
- <|> (RefRemote . RefName <$> stripPrefix "refs/remotes/" prefix)
-
- tryResolvers :: HashAlgorithm hash => [IO (Maybe (Ref hash))] -> IO (Maybe (Ref hash))
- tryResolvers [] = return $ if (isHexString prefix)
- then Just $ fromHexString prefix
- else Nothing
- tryResolvers (resolver:xs) = resolver >>= isResolved
- where isResolved (Just r) = return (Just r)
- isResolved Nothing = tryResolvers xs
-
- --resolvePrePrefix :: HashAlgorithm hash => IO (Maybe (Ref hash))
- resolvePrePrefix
- | not (isHexString prefix) = return Nothing
- | otherwise = do
- refs <- findReferencesWithPrefix git prefix
- case refs of
- [] -> return Nothing
- [r] -> return (Just r)
- _ -> error "multiple references with this prefix"
-
- modf [] ref = return (Just ref)
- modf (RevModParent i:xs) ref = do
- parentRefs <- getParentRefs ref
- case i of
- 0 -> error "revision modifier ^0 is not implemented"
- _ -> case drop (i - 1) parentRefs of
- [] -> error "no such parent"
- (p:_) -> modf xs p
-
- modf (RevModParentFirstN 1:xs) ref = modf (RevModParent 1:xs) ref
- modf (RevModParentFirstN n:xs) ref = do
- parentRefs <- getParentRefs ref
- modf (RevModParentFirstN (n-1):xs) (head parentRefs)
- modf (_:_) _ = error "unimplemented revision modifier"
-
- getParentRefs ref = commitParents <$> getCommit git ref
+ resolvePrefix lookupCache =
+ tryResolvers
+ [ resolveNamedPrefix lookupCache namedResolvers,
+ resolvePrePrefix
+ ]
+
+ resolveNamedPrefix _ [] = return Nothing
+ resolveNamedPrefix lookupCache (x : xs) = followToRef (resolveNamedPrefix lookupCache xs) x
+ where
+ followToRef onFailure refty = do
+ exists <- existsRefFile (gitRepoPath git) refty
+ if exists
+ then do
+ refcont <- readRefFile (gitRepoPath git) refty
+ case refcont of
+ RefDirect ref -> return $ Just ref
+ RefLink refspecty -> followToRef onFailure refspecty
+ _ -> error "cannot handle reference content"
+ else case refty of
+ RefTag name -> mapLookup name $ packedTags lookupCache
+ RefBranch name -> mapLookup name $ packedBranchs lookupCache
+ RefRemote name -> mapLookup name $ packedRemotes lookupCache
+ _ -> return Nothing
+ where
+ mapLookup name m = maybe onFailure (return . Just) $ M.lookup name m
+
+ namedResolvers = case prefix of
+ "HEAD" -> [RefHead]
+ "ORIG_HEAD" -> [RefOrigHead]
+ "FETCH_HEAD" -> [RefFetchHead]
+ _ ->
+ maybe (map (flip ($) (RefName prefix)) [RefTag, RefBranch, RefRemote]) (: []) $
+ (RefBranch . RefName <$> stripPrefix "refs/heads/" prefix)
+ <|> (RefTag . RefName <$> stripPrefix "refs/tags/" prefix)
+ <|> (RefRemote . RefName <$> stripPrefix "refs/remotes/" prefix)
+
+ tryResolvers :: HashAlgorithm hash => [IO (Maybe (Ref hash))] -> IO (Maybe (Ref hash))
+ tryResolvers [] =
+ return $
+ if (isHexString prefix)
+ then Just $ fromHexString prefix
+ else Nothing
+ tryResolvers (resolver : xs) = resolver >>= isResolved
+ where
+ isResolved (Just r) = return (Just r)
+ isResolved Nothing = tryResolvers xs
+
+ --resolvePrePrefix :: HashAlgorithm hash => IO (Maybe (Ref hash))
+ resolvePrePrefix
+ | not (isHexString prefix) = return Nothing
+ | otherwise = do
+ refs <- findReferencesWithPrefix git prefix
+ case refs of
+ [] -> return Nothing
+ [r] -> return (Just r)
+ _ -> error "multiple references with this prefix"
+
+ modf [] ref = return (Just ref)
+ modf (RevModParent i : xs) ref = do
+ parentRefs <- getParentRefs ref
+ case i of
+ 0 -> error "revision modifier ^0 is not implemented"
+ _ -> case drop (i - 1) parentRefs of
+ [] -> error "no such parent"
+ (p : _) -> modf xs p
+ modf (RevModParentFirstN 1 : xs) ref = modf (RevModParent 1 : xs) ref
+ modf (RevModParentFirstN n : xs) ref = do
+ parentRefs <- getParentRefs ref
+ modf (RevModParentFirstN (n -1) : xs) (head parentRefs)
+ modf (_ : _) _ = error "unimplemented revision modifier"
+
+ getParentRefs ref = commitParents <$> getCommit git ref
-- | returns a tree from a ref that might be either a commit, a tree or a tag.
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
- recToTree (objectToTree -> Just t@(Tree _)) = return $ Just t
- recToTree _ = return Nothing
-
+ where
+ recToTree (objectToCommit -> Just (Commit {commitTreeish = tree})) = resolveTreeish git tree
+ recToTree (objectToTag -> Just (Tag tref _ _ _ _)) = resolveTreeish git tref
+ recToTree (objectToTree -> Just t@(Tree _)) = return $ Just t
+ recToTree _ = return Nothing
-- | Rewrite a set of commits from a revision and returns the new ref.
--
@@ -192,117 +200,142 @@ resolveTreeish git ref = getObject git ref True >>= mapJustM recToTree
-- result in the following tree after mapping with f:
--
-- a <-- f(b) <-- f(c) <-- f(d)
---
-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 ::
+ (Typeable hash, HashAlgorithm hash) =>
+ -- | Repository
+ Git hash ->
+ -- | Mapping function
+ (Commit hash -> IO (Commit hash)) ->
+ -- | revision to start from
+ Revision ->
+ -- | the number of parents to map
+ Int ->
+ -- | return the new head REF
+ IO (Ref hash)
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 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
- [parentRef] -> liftM ((ref,commit) :) (resolveParents (n-1) parentRef)
- _ -> return [(ref,commit)]
-
- process [] = error "nothing to rewrite"
- process ((_,commit):next) =
- mapCommit commit >>= looseWrite (gitRepoPath git) . toObject >>= flip rewriteOne next
-
- rewriteOne prevRef [] = return prevRef
- rewriteOne prevRef ((_,commit):next) = do
- newCommit <- mapCommit $ commit { commitParents = [prevRef] }
- ref <- looseWrite (gitRepoPath git) (toObject newCommit)
- rewriteOne ref next
+ ref <- fromMaybe (error "revision cannot be found") <$> resolveRevision git revision
+ resolveParents nbParent ref >>= process . reverse
+ 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
+ [parentRef] -> liftM ((ref, commit) :) (resolveParents (n -1) parentRef)
+ _ -> return [(ref, commit)]
+
+ process [] = error "nothing to rewrite"
+ process ((_, commit) : next) =
+ mapCommit commit >>= looseWrite (gitRepoPath git) . toObject >>= flip rewriteOne next
+
+ rewriteOne prevRef [] = return prevRef
+ rewriteOne prevRef ((_, commit) : next) = do
+ newCommit <- mapCommit $ commit {commitParents = [prevRef]}
+ ref <- looseWrite (gitRepoPath git) (toObject newCommit)
+ rewriteOne ref next
-- | build a hierarchy tree from a tree object
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
- case obj of
- Just TypeBlob -> return (perm, ent, TreeFile ref)
- Just TypeTree -> do ctree <- getTree git ref
- dir <- buildHTree git ctree
- return (perm, ent, TreeDir ref dir)
- Just _ -> error "wrong type embedded in tree object"
- Nothing -> error "unknown reference in tree object"
+ where
+ resolveTree (perm, ent, ref) = do
+ obj <- getObjectType git ref
+ case obj of
+ Just TypeBlob -> return (perm, ent, TreeFile ref)
+ Just TypeTree -> do
+ ctree <- getTree git ref
+ dir <- buildHTree git ctree
+ return (perm, ent, TreeDir ref dir)
+ Just _ -> error "wrong type embedded in tree object"
+ Nothing -> error "unknown reference in tree object"
-- | resolve the ref (tree or blob) related to a path at a specific commit ref
-resolvePath :: (Typeable hash, HashAlgorithm hash)
- => Git hash -- ^ repository
- -> Ref hash -- ^ commit reference
- -> EntPath -- ^ paths
- -> IO (Maybe (Ref hash))
+resolvePath ::
+ (Typeable hash, HashAlgorithm hash) =>
+ -- | repository
+ Git hash ->
+ -- | commit reference
+ Ref hash ->
+ -- | paths
+ EntPath ->
+ IO (Maybe (Ref hash))
resolvePath git commitRef paths =
- getCommit git commitRef >>= \commit -> resolve (commitTreeish commit) paths
- where --resolve :: Ref -> EntPath -> IO (Maybe Ref)
- resolve treeRef [] = return $ Just treeRef
- resolve treeRef (x:xs) = do
- (Tree ents) <- getTree git treeRef
- let cEnt = treeEntRef <$> findEnt x ents
- if xs == []
- then return cEnt
- else maybe (return Nothing) (\z -> resolve z xs) cEnt
-
- findEnt x = find (\(_, b, _) -> b == x)
- treeEntRef (_,_,r) = r
+ getCommit git commitRef >>= \commit -> resolve (commitTreeish commit) paths
+ where
+ --resolve :: Ref -> EntPath -> IO (Maybe Ref)
+ resolve treeRef [] = return $ Just treeRef
+ resolve treeRef (x : xs) = do
+ (Tree ents) <- getTree git treeRef
+ let cEnt = treeEntRef <$> findEnt x ents
+ if xs == []
+ then return cEnt
+ else maybe (return Nothing) (\z -> resolve z xs) cEnt
+
+ findEnt x = find (\(_, b, _) -> b == x)
+ treeEntRef (_, _, r) = r
-- | Write a branch to point to a specific reference
-branchWrite :: Git hash -- ^ repository
- -> RefName -- ^ the name of the branch to write
- -> Ref hash -- ^ the reference to set
- -> IO ()
+branchWrite ::
+ -- | repository
+ Git hash ->
+ -- | the name of the branch to write
+ RefName ->
+ -- | the reference to set
+ Ref hash ->
+ IO ()
branchWrite git branchName ref =
- writeRefFile (gitRepoPath git) (RefBranch branchName) (RefDirect ref)
+ writeRefFile (gitRepoPath git) (RefBranch branchName) (RefDirect ref)
-- | Return the list of branches
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
+ 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 hash -- ^ repository
- -> RefName -- ^ the name of the tag to write
- -> Ref hash -- ^ the reference to set
- -> IO ()
+tagWrite ::
+ -- | repository
+ Git hash ->
+ -- | the name of the tag to write
+ RefName ->
+ -- | the reference to set
+ Ref hash ->
+ IO ()
tagWrite git tagname ref =
- writeRefFile (gitRepoPath git) (RefTag tagname) (RefDirect ref)
+ writeRefFile (gitRepoPath git) (RefTag tagname) (RefDirect ref)
-- | Return the list of branches
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
+ 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 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)
+headSet ::
+ -- | repository
+ Git hash ->
+ -- | either a raw reference or a branch name
+ Either (Ref hash) RefName ->
+ IO ()
+headSet git (Left ref) =
+ writeRefFile (gitRepoPath git) RefHead (RefDirect ref)
headSet git (Right refname) =
- writeRefFile (gitRepoPath git) RefHead (RefLink $ RefBranch refname)
+ writeRefFile (gitRepoPath git) RefHead (RefLink $ RefBranch refname)
-- | Get what the head is pointing to, or the reference otherwise
-headGet :: HashAlgorithm hash
- => Git hash
- -> IO (Either (Ref hash) RefName)
+headGet ::
+ HashAlgorithm hash =>
+ Git hash ->
+ IO (Either (Ref hash) RefName)
headGet git = do
- content <- readRefFile (gitRepoPath git) RefHead
- case content of
- RefLink (RefBranch b) -> return $ Right b
- RefLink spec -> error ("unknown content link in HEAD: " ++ show spec)
- RefDirect r -> return $ Left r
- RefContentUnknown bs -> error ("unknown content in HEAD: " ++ show bs)
+ content <- readRefFile (gitRepoPath git) RefHead
+ case content of
+ RefLink (RefBranch b) -> return $ Right b
+ RefLink spec -> error ("unknown content link in HEAD: " ++ show spec)
+ RefDirect r -> return $ Left r
+ RefContentUnknown bs -> error ("unknown content in HEAD: " ++ show bs)
-- | Read the Config
configGetAll :: Git hash -> IO [Config]
@@ -314,11 +347,15 @@ configGetAll git = readIORef (configs git)
-- for example the equivalent to git config user.name is:
--
-- > configGet git "user" "name"
---
-configGet :: Git hash -- ^ Git context
- -> String -- ^ section name
- -> String -- ^ key name
- -> IO (Maybe String) -- ^ The resulting value if it exists
+configGet ::
+ -- | Git context
+ Git hash ->
+ -- | section name
+ String ->
+ -- | key name
+ String ->
+ -- | The resulting value if it exists
+ IO (Maybe String)
configGet git section key = do
- cfgs <- configGetAll git
- return $ Cfg.get cfgs section key
+ cfgs <- configGetAll git
+ return $ Cfg.get cfgs section key
diff --git a/Data/Git/Revision.hs b/Data/Git/Revision.hs
index c8068f0..da7098c 100644
--- a/Data/Git/Revision.hs
+++ b/Data/Git/Revision.hs
@@ -6,38 +6,43 @@
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unix
---
module Data.Git.Revision
- ( Revision(..)
- , RevModifier(..)
- , RevisionNotFound(..)
- , fromString
- ) where
+ ( Revision (..),
+ RevModifier (..),
+ RevisionNotFound (..),
+ fromString,
+ )
+where
import Control.Applicative
import Control.Arrow (first)
-import Data.String
-import Data.List
-import Data.Data
import Data.Char
+import Data.Data
+import Data.List
+import Data.String
-- | A modifier to a revision, which is
-- a function apply of a revision
-data RevModifier =
- RevModParent Int -- ^ parent accessor ^<n> and ^
- | RevModParentFirstN Int -- ^ parent accessor ~<n>
- | RevModAtType String -- ^ @{type} accessor
- | RevModAtDate String -- ^ @{date} accessor
- | RevModAtN Int -- ^ @{n} accessor
- deriving (Eq,Data,Typeable)
+data RevModifier
+ = -- | parent accessor ^<n> and ^
+ RevModParent Int
+ | -- | parent accessor ~<n>
+ RevModParentFirstN Int
+ | -- | @{type} accessor
+ RevModAtType String
+ | -- | @{date} accessor
+ RevModAtDate String
+ | -- | @{n} accessor
+ RevModAtN Int
+ deriving (Eq, Data, Typeable)
instance Show RevModifier where
- show (RevModParent 1) = "^"
- show (RevModParent n) = "^" ++ show n
- show (RevModParentFirstN n) = "~" ++ show n
- show (RevModAtType s) = "@{" ++ s ++ "}"
- show (RevModAtDate s) = "@{" ++ s ++ "}"
- show (RevModAtN s) = "@{" ++ show s ++ "}"
+ show (RevModParent 1) = "^"
+ show (RevModParent n) = "^" ++ show n
+ show (RevModParentFirstN n) = "~" ++ show n
+ show (RevModAtType s) = "@{" ++ s ++ "}"
+ show (RevModAtDate s) = "@{" ++ s ++ "}"
+ show (RevModAtN s) = "@{" ++ show s ++ "}"
-- | A git revision. this can be many things:
-- * a shorten ref
@@ -48,83 +53,88 @@ instance Show RevModifier where
-- * type
-- * date
data Revision = Revision String [RevModifier]
- deriving (Eq,Data,Typeable)
+ deriving (Eq, Data, Typeable)
-- | Exception when a revision cannot be resolved to a reference
data RevisionNotFound = RevisionNotFound Revision
- deriving (Show,Eq,Data,Typeable)
+ deriving (Show, Eq, Data, Typeable)
instance Show Revision where
- show (Revision s ms) = s ++ concatMap show ms
+ show (Revision s ms) = s ++ concatMap show ms
instance IsString Revision where
- fromString = revFromString
+ fromString = revFromString
revFromString :: String -> Revision
-revFromString s = either (error.show) fst $ runStream parser s
- where parser :: Stream Char Revision
- parser = do
- p <- many (noneOf "^~@")
- mods <- many (parseParent <|> parseFirstParent <|> parseAt)
- return $ Revision p mods
- parseParent = do
- _ <- char '^'
- n <- optional (some digit)
- case n of
- Nothing -> return $ RevModParent 1
- Just d -> return $ RevModParent (read d)
- parseFirstParent =
- RevModParentFirstN . read <$> (char '~' *> some digit)
- parseAt = do
- _ <- char '@' >> char '{'
- at <- parseAtType <|> parseAtDate <|> parseAtN
- _ <- char '}'
- return at
- parseAtType = do
- RevModAtType <$> (string "tree" <|> string "commit" <|> string "blob" <|> string "tag")
- parseAtN = do
- RevModAtN . read <$> some digit
- parseAtDate = do
- RevModAtDate <$> many (noneOf "}")
-
--- combinator
-
- char c = eatRet (\x -> if x == c then Just c else Nothing)
- string str = prefix (\x -> if isPrefixOf str x then Just (str, length str) else Nothing)
- digit = eatRet (\x -> if isDigit x then Just x else Nothing)
- noneOf l = eatRet (\x -> if not (x `elem` l) then Just x else Nothing)
+revFromString s = either (error . show) fst $ runStream parser s
+ where
+ parser :: Stream Char Revision
+ parser = do
+ p <- many (noneOf "^~@")
+ mods <- many (parseParent <|> parseFirstParent <|> parseAt)
+ return $ Revision p mods
+ parseParent = do
+ _ <- char '^'
+ n <- optional (some digit)
+ case n of
+ Nothing -> return $ RevModParent 1
+ Just d -> return $ RevModParent (read d)
+ parseFirstParent =
+ RevModParentFirstN . read <$> (char '~' *> some digit)
+ parseAt = do
+ _ <- char '@' >> char '{'
+ at <- parseAtType <|> parseAtDate <|> parseAtN
+ _ <- char '}'
+ return at
+ parseAtType = do
+ RevModAtType <$> (string "tree" <|> string "commit" <|> string "blob" <|> string "tag")
+ parseAtN = do
+ RevModAtN . read <$> some digit
+ parseAtDate = do
+ RevModAtDate <$> many (noneOf "}")
+
+ -- combinator
+
+ char c = eatRet (\x -> if x == c then Just c else Nothing)
+ string str = prefix (\x -> if isPrefixOf str x then Just (str, length str) else Nothing)
+ digit = eatRet (\x -> if isDigit x then Just x else Nothing)
+ noneOf l = eatRet (\x -> if not (x `elem` l) then Just x else Nothing)
prefix :: ([elem] -> Maybe (a, Int)) -> Stream elem a
prefix predicate = Stream $ \el ->
- case el of
- [] -> Left ("empty stream: prefix")
- _ ->
- case predicate el of
- Just (a,i) -> Right (a, drop i el)
- Nothing -> Left ("unexpected stream")
+ case el of
+ [] -> Left ("empty stream: prefix")
+ _ ->
+ case predicate el of
+ Just (a, i) -> Right (a, drop i el)
+ Nothing -> Left ("unexpected stream")
eatRet :: Show elem => (elem -> Maybe a) -> Stream elem a
eatRet predicate = Stream $ \el ->
- case el of
- [] -> Left ("empty stream: eating")
- x:xs ->
- case predicate x of
- Just a -> Right (a, xs)
- Nothing -> Left ("unexpected atom got: " ++ show x)
-
-newtype Stream elem a = Stream { runStream :: [elem] -> Either String (a, [elem]) }
+ case el of
+ [] -> Left ("empty stream: eating")
+ x : xs ->
+ case predicate x of
+ Just a -> Right (a, xs)
+ Nothing -> Left ("unexpected atom got: " ++ show x)
+
+newtype Stream elem a = Stream {runStream :: [elem] -> Either String (a, [elem])}
+
instance Functor (Stream elem) where
- fmap f s = Stream $ \e1 -> case runStream s e1 of
- Left err -> Left err
- Right (a,e2) -> Right (f a, e2)
+ fmap f s = Stream $ \e1 -> case runStream s e1 of
+ Left err -> Left err
+ Right (a, e2) -> Right (f a, e2)
+
instance Applicative (Stream elem) where
- pure = return
- fab <*> fa = Stream $ \e1 -> case runStream fab e1 of
- Left err -> Left err
- Right (f, e2) -> either Left (Right . first f) $ runStream fa e2
+ pure = return
+ fab <*> fa = Stream $ \e1 -> case runStream fab e1 of
+ Left err -> Left err
+ Right (f, e2) -> either Left (Right . first f) $ runStream fa e2
+
instance Alternative (Stream elem) where
- empty = Stream $ \_ -> Left "empty"
- f1 <|> f2 = Stream $ \e1 -> either (\_ -> runStream f2 e1) Right $ runStream f1 e1
+ empty = Stream $ \_ -> Left "empty"
+ f1 <|> f2 = Stream $ \e1 -> either (\_ -> runStream f2 e1) Right $ runStream f1 e1
+
instance Monad (Stream elem) where
- return a = Stream $ \e1 -> Right (a, e1)
- ma >>= mb = Stream $ \e1 -> either Left (\(a, e2) -> runStream (mb a) e2) $ runStream ma e1
+ return a = Stream $ \e1 -> Right (a, e1)
+ ma >>= mb = Stream $ \e1 -> either Left (\(a, e2) -> runStream (mb a) e2) $ runStream ma e1
diff --git a/Data/Git/Storage.hs b/Data/Git/Storage.hs
index 0ae240b..4ae00d6 100644
--- a/Data/Git/Storage.hs
+++ b/Data/Git/Storage.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
-- |
-- Module : Data.Git.Storage
@@ -7,66 +7,69 @@
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unix
---
module Data.Git.Storage
- ( Git
- , packedNamed
- , gitRepoPath
- , configs
+ ( Git,
+ packedNamed,
+ gitRepoPath,
+ configs,
+
-- * opening repositories
- , openRepo
- , closeRepo
- , withRepo
- , withCurrentRepo
- , findRepoMaybe
- , findRepo
- , isRepo
+ openRepo,
+ closeRepo,
+ withRepo,
+ withCurrentRepo,
+ findRepoMaybe,
+ findRepo,
+ isRepo,
+
-- * creating repositories
- , initRepo
+ initRepo,
+
-- * repository accessors
- , getDescription
- , setDescription
+ getDescription,
+ setDescription,
+
-- * iterators
- , iterateIndexes
- , findReference
- , findReferencesWithPrefix
+ iterateIndexes,
+ findReference,
+ findReferencesWithPrefix,
+
-- * getting objects
- , getObjectRaw
- , getObjectRawAt
- , getObject
- , getObject_
- , getObjectAt
- , getObjectType
+ getObjectRaw,
+ getObjectRawAt,
+ getObject,
+ getObject_,
+ getObjectAt,
+ getObjectType,
+
-- * setting objects
- , setObject
- ) where
+ setObject,
+ )
+where
import Control.Exception
import qualified Control.Exception as E
import Control.Monad
-
-import Data.List ((\\), isPrefixOf)
+import qualified Data.ByteString.Lazy as L
import Data.Either (partitionEithers)
-import Data.IORef
-import Data.Word
-import Data.Typeable
-
-import Data.Git.Named
+import Data.Git.Config
+import Data.Git.Delta
import Data.Git.Imports
+import Data.Git.Named
import Data.Git.OS
import Data.Git.Path (packedRefsPath)
-import Data.Git.Delta
+import Data.Git.Ref
+import Data.Git.Storage.CacheFile
import Data.Git.Storage.FileReader
-import Data.Git.Storage.PackIndex
+import Data.Git.Storage.Loose
import Data.Git.Storage.Object
import Data.Git.Storage.Pack
-import Data.Git.Storage.Loose
-import Data.Git.Storage.CacheFile
-import Data.Git.Ref
-import Data.Git.Config
-import qualified Data.ByteString.Lazy as L
-
+import Data.Git.Storage.PackIndex
+import Data.IORef
+import Data.List (isPrefixOf, (\\))
import qualified Data.Map as M
+import Data.Typeable
+import Data.Word
data PackIndexReader = PackIndexReader PackIndexHeader FileReader
@@ -76,33 +79,38 @@ 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 hash = Git
- { gitRepoPath :: LocalPath
- , indexReaders :: IORef [(Ref hash, PackIndexReader)]
- , packReaders :: IORef [(Ref hash, FileReader)]
- , packedNamed :: CachedPackedRef hash
- , configs :: IORef [Config]
- }
+ { gitRepoPath :: LocalPath,
+ 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 SHA1)
-openRepo path = Git path <$> newIORef []
- <*> newIORef []
- <*> packedRef
- <*> (readConfigs >>= newIORef)
- where packedRef = newCacheVal (packedRefsPath path)
- (readPackedRefs path M.fromList)
- (PackedRefs M.empty M.empty M.empty)
- readConfigs = do
- global <- E.try readGlobalConfig :: IO (Either IOException Config)
- local <- E.try (readConfig path)
- return $ snd $ partitionEithers [local,global]
+openRepo path =
+ Git path <$> newIORef []
+ <*> newIORef []
+ <*> packedRef
+ <*> (readConfigs >>= newIORef)
+ where
+ packedRef =
+ newCacheVal
+ (packedRefsPath path)
+ (readPackedRefs path M.fromList)
+ (PackedRefs M.empty M.empty M.empty)
+ readConfigs = do
+ global <- E.try readGlobalConfig :: IO (Either IOException Config)
+ local <- E.try (readConfig path)
+ return $ snd $ partitionEithers [local, global]
-- | close a git repository context, closing all remaining fileReaders.
closeRepo :: Git hash -> IO ()
-closeRepo (Git { indexReaders = ireaders, packReaders = preaders }) = do
- mapM_ (closeIndexReader . snd) =<< readIORef ireaders
- mapM_ (fileReaderClose . snd) =<< readIORef preaders
- where closeIndexReader (PackIndexReader _ fr) = fileReaderClose fr
+closeRepo (Git {indexReaders = ireaders, packReaders = preaders}) = do
+ mapM_ (closeIndexReader . snd) =<< readIORef ireaders
+ mapM_ (fileReaderClose . snd) =<< readIORef preaders
+ where
+ closeIndexReader (PackIndexReader _ fr) = fileReaderClose fr
-- | Find the git repository from the current directory.
--
@@ -110,16 +118,17 @@ closeRepo (Git { indexReaders = ireaders, packReaders = preaders }) = do
-- otherwise iterate from current directory, up to 128 parents for a .git directory
findRepoMaybe :: IO (Maybe LocalPath)
findRepoMaybe = do
- menvDir <- E.catch (Just <$> getEnvAsPath "GIT_DIR") (\(_:: SomeException) -> return Nothing)
- case menvDir of
- Nothing -> getWorkingDirectory >>= checkDir 0
- Just envDir -> isRepo envDir >>= \e -> return (if e then Just envDir else Nothing)
- where checkDir :: Int -> LocalPath -> IO (Maybe LocalPath)
- checkDir 128 _ = return Nothing
- checkDir n wd = do
- let filepath = wd </> ".git"
- e <- isRepo filepath
- if e then return (Just filepath) else checkDir (n+1) (if absolute wd then parent wd else wd </> "..")
+ menvDir <- E.catch (Just <$> getEnvAsPath "GIT_DIR") (\(_ :: SomeException) -> return Nothing)
+ case menvDir of
+ Nothing -> getWorkingDirectory >>= checkDir 0
+ Just envDir -> isRepo envDir >>= \e -> return (if e then Just envDir else Nothing)
+ where
+ checkDir :: Int -> LocalPath -> IO (Maybe LocalPath)
+ checkDir 128 _ = return Nothing
+ checkDir n wd = do
+ let filepath = wd </> ".git"
+ e <- isRepo filepath
+ if e then return (Just filepath) else checkDir (n + 1) (if absolute wd then parent wd else wd </> "..")
-- | Find the git repository from the current directory.
--
@@ -127,19 +136,20 @@ findRepoMaybe = do
-- otherwise iterate from current directory, up to 128 parents for a .git directory
findRepo :: IO LocalPath
findRepo = do
- menvDir <- E.catch (Just <$> getEnvAsPath "GIT_DIR") (\(_:: SomeException) -> return Nothing)
- case menvDir of
- Nothing -> getWorkingDirectory >>= checkDir 0
- Just envDir -> do
- e <- isRepo envDir
- when (not e) $ error "environment GIT_DIR is not a git repository"
- return envDir
- where checkDir :: Int -> LocalPath -> IO LocalPath
- checkDir 128 _ = error "not a git repository"
- checkDir n wd = do
- let filepath = wd </> ".git"
- e <- isRepo filepath
- if e then return filepath else checkDir (n+1) (if absolute wd then parent wd else wd </> "..")
+ menvDir <- E.catch (Just <$> getEnvAsPath "GIT_DIR") (\(_ :: SomeException) -> return Nothing)
+ case menvDir of
+ Nothing -> getWorkingDirectory >>= checkDir 0
+ Just envDir -> do
+ e <- isRepo envDir
+ when (not e) $ error "environment GIT_DIR is not a git repository"
+ return envDir
+ where
+ checkDir :: Int -> LocalPath -> IO LocalPath
+ checkDir 128 _ = error "not a git repository"
+ checkDir n wd = do
+ let filepath = wd </> ".git"
+ e <- isRepo filepath
+ 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 SHA1 -> IO c) -> IO c
@@ -154,202 +164,243 @@ withCurrentRepo f = findRepo >>= \path -> withRepo path f
-- | basic checks to see if a specific path looks like a git repo.
isRepo :: LocalPath -> IO Bool
isRepo path = do
- dir <- isDirectory path
- subDirs <- mapM (isDirectory . (path </>))
- [ "hooks", "info"
- , "objects", "refs"
- , "refs"</> "heads", "refs"</> "tags"]
- return $ and ([dir] ++ subDirs)
+ dir <- isDirectory path
+ subDirs <-
+ mapM
+ (isDirectory . (path </>))
+ [ "hooks",
+ "info",
+ "objects",
+ "refs",
+ "refs" </> "heads",
+ "refs" </> "tags"
+ ]
+ return $ and ([dir] ++ subDirs)
-- | initialize a new repository at a specific location.
initRepo :: LocalPath -> IO ()
initRepo path = do
- exists <- isDirectory path
- when exists $ error "destination directory already exists"
- createParentDirectory path
- createDirectory False path
- mapM_ (createDirectory False . (path </>))
- [ "branches", "hooks", "info"
- , "logs", "objects", "refs"
- , "refs"</> "heads", "refs"</> "tags"]
+ exists <- isDirectory path
+ when exists $ error "destination directory already exists"
+ createParentDirectory path
+ createDirectory False path
+ mapM_
+ (createDirectory False . (path </>))
+ [ "branches",
+ "hooks",
+ "info",
+ "logs",
+ "objects",
+ "refs",
+ "refs" </> "heads",
+ "refs" </> "tags"
+ ]
-- | read the repository's description
getDescription :: Git hash -> IO (Maybe String)
getDescription git = do
- isdescription <- isFile descriptionPath
- if (isdescription)
- then do
- content <- readTextFile descriptionPath
- return $ Just content
- else return Nothing
- where descriptionPath = (gitRepoPath git) </> "description"
+ isdescription <- isFile descriptionPath
+ if (isdescription)
+ then do
+ content <- readTextFile descriptionPath
+ return $ Just content
+ else return Nothing
+ where
+ descriptionPath = (gitRepoPath git) </> "description"
-- | set the repository's description
setDescription :: Git hash -> String -> IO ()
setDescription git desc = do
- writeTextFile descriptionPath desc
- where descriptionPath = (gitRepoPath git) </> "description"
-
-iterateIndexes :: HashAlgorithm hash
- => Git hash
- -> (b -> (Ref hash, PackIndexReader) -> IO (b, Bool))
- -> b -> IO b
+ writeTextFile descriptionPath desc
+ where
+ descriptionPath = (gitRepoPath git) </> "description"
+
+iterateIndexes ::
+ HashAlgorithm hash =>
+ Git hash ->
+ (b -> (Ref hash, PackIndexReader) -> IO (b, Bool)) ->
+ b ->
+ IO b
iterateIndexes git f initAcc = do
- allIndexes <- packIndexEnumerate (gitRepoPath git)
- readers <- readIORef (indexReaders git)
- (a,terminate) <- loop initAcc readers
- if terminate
- then return a
- else readRemainingIndexes a (allIndexes \\ map fst readers)
- where loop acc [] = return (acc, False)
- loop acc (r:rs) = do
- (nacc, terminate) <- f acc r
- if terminate
- then return (nacc,True)
- else loop nacc rs
-
- readRemainingIndexes acc [] = return acc
- readRemainingIndexes acc (idxref:idxs) = do
- fr <- packIndexOpen (gitRepoPath git) idxref
- idx <- packIndexReadHeader fr
- let idxreader = PackIndexReader idx fr
- let r = (idxref, idxreader)
- modifyIORef (indexReaders git) (\l -> r : l)
- (nacc, terminate) <- f acc r
- if terminate
- then return nacc
- else readRemainingIndexes nacc idxs
+ allIndexes <- packIndexEnumerate (gitRepoPath git)
+ readers <- readIORef (indexReaders git)
+ (a, terminate) <- loop initAcc readers
+ if terminate
+ then return a
+ else readRemainingIndexes a (allIndexes \\ map fst readers)
+ where
+ loop acc [] = return (acc, False)
+ loop acc (r : rs) = do
+ (nacc, terminate) <- f acc r
+ if terminate
+ then return (nacc, True)
+ else loop nacc rs
+
+ readRemainingIndexes acc [] = return acc
+ readRemainingIndexes acc (idxref : idxs) = do
+ fr <- packIndexOpen (gitRepoPath git) idxref
+ idx <- packIndexReadHeader fr
+ let idxreader = PackIndexReader idx fr
+ let r = (idxref, idxreader)
+ modifyIORef (indexReaders git) (\l -> r : l)
+ (nacc, terminate) <- f acc r
+ if terminate
+ then return nacc
+ else readRemainingIndexes nacc idxs
-- | Get the object location of a specific reference
findReference :: HashAlgorithm hash => Git hash -> Ref hash -> IO (ObjectLocation hash)
findReference git ref = maybe NotFound id <$> (findLoose `mplusIO` findInIndexes)
- 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 :: 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
- mloc <- packIndexGetReferenceLocation idxhdr indexreader ref
- case mloc of
- Nothing -> return (acc, False)
- Just loc -> return (Just $ Packed idxref loc, True)
-
- mplusIO :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a)
- mplusIO f g = f >>= \vopt -> case vopt of
- Nothing -> g
- Just v -> return $ Just v
+ 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 :: 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
+ mloc <- packIndexGetReferenceLocation idxhdr indexreader ref
+ case mloc of
+ Nothing -> return (acc, False)
+ Just loc -> return (Just $ Packed idxref loc, True)
+
+ mplusIO :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a)
+ mplusIO f g =
+ f >>= \vopt -> case vopt of
+ Nothing -> g
+ Just v -> return $ Just v
-- | get all the references that start by a specific prefix
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)
- | otherwise = do
- looseRefs <- looseEnumerateWithPrefixFilter (gitRepoPath git) (take 2 pre) matchRef
- packedRefs <- concat <$> iterateIndexes git idxPrefixMatch []
- return (looseRefs ++ packedRefs)
- where -- not very efficient way to do that... will do for now.
- matchRef ref = pre `isPrefixOf` toHexString ref
- invalidLength = length pre < 2 || length pre > 39
-
- idxPrefixMatch acc (_, (PackIndexReader idxhdr indexreader)) = do
- refs <- packIndexGetReferencesWithPrefix idxhdr indexreader pre
- return (refs:acc,False)
+ | invalidLength = error ("not a valid prefix: " ++ show pre)
+ | not (isHexString pre) = error ("reference prefix contains non hexchar: " ++ show pre)
+ | otherwise = do
+ looseRefs <- looseEnumerateWithPrefixFilter (gitRepoPath git) (take 2 pre) matchRef
+ packedRefs <- concat <$> iterateIndexes git idxPrefixMatch []
+ return (looseRefs ++ packedRefs)
+ where
+ -- not very efficient way to do that... will do for now.
+ matchRef ref = pre `isPrefixOf` toHexString ref
+ invalidLength = length pre < 2 || length pre > 39
+
+ idxPrefixMatch acc (_, (PackIndexReader idxhdr indexreader)) = do
+ refs <- packIndexGetReferencesWithPrefix idxhdr indexreader pre
+ return (refs : acc, False)
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
- po <- packReadRawAtOffset reader offset
- return (reader, po)
- where getDefault = do p <- packOpen (gitRepoPath git) pref
- modifyIORef (packReaders git) ((pref, p):)
- return p
+ readers <- readIORef (packReaders git)
+ reader <- maybe getDefault return $ lookup pref readers
+ po <- packReadRawAtOffset reader offset
+ return (reader, po)
+ where
+ getDefault = do
+ p <- packOpen (gitRepoPath git) pref
+ modifyIORef (packReaders git) ((pref, p) :)
+ return p
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 hash -> ObjectInfo hash
- generifyHeader (po, objData) = ObjectInfo { oiHeader = hdr, oiData = objData, oiChains = [] }
- where hdr = (poiType po, poiActualSize po, poiExtra po)
-
- --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
- let delta = deltaRead (L.toChunks objData)
- let noffset = offset - doff
- base <- resolve reader noffset =<< packReadRawAtOffset reader noffset
- return $ addToChain ptr $ applyDelta delta base
- (TypeDeltaRef, Just ptr@(PtrRef bref)) -> do
- let delta = deltaRead (L.toChunks objData)
- base <- getObjectRaw git bref True
- return $ addToChain ptr $ applyDelta delta base
- _ ->
- return $ Just $ generifyHeader (po, objData)
-
- addToChain ptr (Just oi) = Just (oi { oiChains = ptr : oiChains oi })
- addToChain _ Nothing = Nothing
-
- 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
- }
- applyDelta _ _ = Nothing
+ (reader, x) <- readRawFromPack git pref o
+ if resolveDelta then resolve reader o x else return $ Just $ generifyHeader x
+ 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 hash -> IO (Maybe (ObjectInfo hash))
+ resolve reader offset (po, objData) = do
+ case (poiType po, poiExtra po) of
+ (TypeDeltaOff, Just ptr@(PtrOfs doff)) -> do
+ let delta = deltaRead (L.toChunks objData)
+ let noffset = offset - doff
+ base <- resolve reader noffset =<< packReadRawAtOffset reader noffset
+ return $ addToChain ptr $ applyDelta delta base
+ (TypeDeltaRef, Just ptr@(PtrRef bref)) -> do
+ let delta = deltaRead (L.toChunks objData)
+ base <- getObjectRaw git bref True
+ return $ addToChain ptr $ applyDelta delta base
+ _ ->
+ return $ Just $ generifyHeader (po, objData)
+
+ addToChain ptr (Just oi) = Just (oi {oiChains = ptr : oiChains oi})
+ addToChain _ Nothing = Nothing
+
+ 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
+ }
+ applyDelta _ _ = Nothing
-- | get an object from repository
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 _ 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 :: HashAlgorithm hash => Git hash -> Ref hash -> Bool -> IO (Maybe (ObjectInfo hash))
getObjectRaw git ref resolveDelta = do
- loc <- findReference git ref
- getObjectRawAt git loc resolveDelta
+ loc <- findReference git ref
+ getObjectRawAt git loc resolveDelta
-- | get an object type from repository
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
- getObjectTypeAt (Packed pref o) =
- fmap ((\(ty,_,_) -> ty) . oiHeader) <$> readFromPack git pref o True
+ where
+ getObjectTypeAt NotFound = return Nothing
+ getObjectTypeAt (Loose _) = Just . (\(t, _, _) -> t) <$> looseReadHeader (gitRepoPath git) ref
+ getObjectTypeAt (Packed pref o) =
+ fmap ((\(ty, _, _) -> ty) . oiHeader) <$> readFromPack git pref o True
-- | get an object from repository using a location to reference it.
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)
+ where
+ toObj (ObjectInfo {oiHeader = (ty, _, extra), oiData = objData}) = packObjectFromRaw (ty, extra, objData)
-- | get an object from repository using a ref.
-getObject :: HashAlgorithm hash
- => Git hash -- ^ repository
- -> Ref hash -- ^ the object's reference to
- -> Bool -- ^ whether to resolve deltas if found
- -> IO (Maybe (Object hash)) -- ^ returned object if found
+getObject ::
+ HashAlgorithm hash =>
+ -- | repository
+ Git hash ->
+ -- | the object's reference to
+ Ref hash ->
+ -- | whether to resolve deltas if found
+ Bool ->
+ -- | returned object if found
+ IO (Maybe (Object hash))
getObject git ref resolveDelta = maybe Nothing toObj <$> getObjectRaw git ref resolveDelta
- where toObj (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData)
+ 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_ :: (Typeable hash, HashAlgorithm hash)
- => Git hash -- ^ repository
- -> Ref hash -- ^ the object's reference to
- -> Bool -- ^ whether to resolve deltas if found
- -> IO (Object hash) -- ^ returned object if found
-getObject_ git ref resolveDelta = maybe (throwIO $ RefNotFound ref) return
- =<< getObject git ref resolveDelta
+getObject_ ::
+ (Typeable hash, HashAlgorithm hash) =>
+ -- | repository
+ Git hash ->
+ -- | the object's reference to
+ Ref hash ->
+ -- | whether to resolve deltas if found
+ Bool ->
+ -- | returned object if found
+ IO (Object hash)
+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 :: HashAlgorithm hash
- => Git hash
- -> Object hash
- -> IO (Ref hash)
+setObject ::
+ HashAlgorithm hash =>
+ Git hash ->
+ Object hash ->
+ IO (Ref hash)
setObject git obj = looseWrite (gitRepoPath git) obj
diff --git a/Data/Git/Storage/CacheFile.hs b/Data/Git/Storage/CacheFile.hs
index e01bd21..ec71db3 100644
--- a/Data/Git/Storage/CacheFile.hs
+++ b/Data/Git/Storage/CacheFile.hs
@@ -6,33 +6,34 @@
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unix
---
module Data.Git.Storage.CacheFile (CacheFile, newCacheVal, getCacheVal) where
import Control.Concurrent.MVar
import qualified Control.Exception as E
-import Data.Git.Imports
-import Data.Git.OS
+import Data.Git.Imports
+import Data.Git.OS
data CacheFile a = CacheFile
- { cacheFilepath :: LocalPath
- , cacheRefresh :: IO a
- , cacheIniVal :: a
- , cacheLock :: MVar (MTime, a)
- }
+ { cacheFilepath :: LocalPath,
+ cacheRefresh :: IO a,
+ cacheIniVal :: a,
+ cacheLock :: MVar (MTime, a)
+ }
newCacheVal :: LocalPath -> IO a -> a -> IO (CacheFile a)
newCacheVal path refresh initialVal =
- CacheFile path refresh initialVal <$> newMVar (MTime timeZero, initialVal)
+ CacheFile path refresh initialVal <$> newMVar (MTime timeZero, initialVal)
getCacheVal :: CacheFile a -> IO a
getCacheVal cachefile = modifyMVar (cacheLock cachefile) getOrRefresh
- where getOrRefresh s@(mtime, cachedVal) = do
- cMTime <- tryGetMTime $ cacheFilepath cachefile
- case cMTime of
- Nothing -> return ((MTime timeZero, cacheIniVal cachefile), cacheIniVal cachefile)
- Just newMtime | newMtime > mtime -> cacheRefresh cachefile >>= \v -> return ((newMtime, v), v)
- | otherwise -> return (s, cachedVal)
+ where
+ getOrRefresh s@(mtime, cachedVal) = do
+ cMTime <- tryGetMTime $ cacheFilepath cachefile
+ case cMTime of
+ Nothing -> return ((MTime timeZero, cacheIniVal cachefile), cacheIniVal cachefile)
+ Just newMtime
+ | newMtime > mtime -> cacheRefresh cachefile >>= \v -> return ((newMtime, v), v)
+ | otherwise -> return (s, cachedVal)
tryGetMTime :: LocalPath -> IO (Maybe MTime)
tryGetMTime filepath = (Just <$> getMTime filepath) `E.catch` \(_ :: E.SomeException) -> return Nothing
diff --git a/Data/Git/Storage/FileReader.hs b/Data/Git/Storage/FileReader.hs
index c168def..4b3d68d 100644
--- a/Data/Git/Storage/FileReader.hs
+++ b/Data/Git/Storage/FileReader.hs
@@ -6,121 +6,115 @@
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unix
---
module Data.Git.Storage.FileReader
- ( FileReader
- , fileReaderNew
- , fileReaderClose
- , withFileReader
- , withFileReaderDecompress
- , fileReaderGetPos
- , fileReaderGet
- , fileReaderGetLBS
- , fileReaderGetBS
- , fileReaderGetRef
- , fileReaderGetVLF
- , fileReaderSeek
- , fileReaderParse
- , fileReaderInflateToSize
- ) where
-
+ ( FileReader,
+ fileReaderNew,
+ fileReaderClose,
+ withFileReader,
+ withFileReaderDecompress,
+ fileReaderGetPos,
+ fileReaderGet,
+ fileReaderGetLBS,
+ fileReaderGetBS,
+ fileReaderGetRef,
+ fileReaderGetVLF,
+ fileReaderSeek,
+ fileReaderParse,
+ fileReaderInflateToSize,
+ )
+where
+import Codec.Zlib
+import Codec.Zlib.Lowlevel
import Control.Exception (bracket, throwIO)
-
+import qualified Control.Exception as E
+import Crypto.Hash
import Data.ByteString (ByteString)
-import Data.ByteString.Unsafe
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.ByteString.Lazy.Internal (defaultChunkSize)
-import Data.IORef
-
+import Data.ByteString.Unsafe
+import Data.Data
import Data.Git.Imports
import Data.Git.OS
-import Data.Git.Ref
import qualified Data.Git.Parser as P
-
-import Data.Data
+import Data.Git.Ref
+import Data.IORef
import Data.Word
-
-import Codec.Zlib
-import Codec.Zlib.Lowlevel
-import Crypto.Hash
import Foreign.ForeignPtr
-import qualified Control.Exception as E
-
-import System.IO (hSeek, SeekMode(..))
+import System.IO (SeekMode (..), hSeek)
data FileReader = FileReader
- { fbHandle :: Handle
- , fbUseInflate :: Bool
- , fbInflate :: Inflate
- , fbRemaining :: IORef (Maybe ByteString)
- , fbPos :: IORef Word64
- }
+ { fbHandle :: Handle,
+ fbUseInflate :: Bool,
+ fbInflate :: Inflate,
+ fbRemaining :: IORef (Maybe ByteString),
+ fbPos :: IORef Word64
+ }
data InflateException = InflateException Word64 Word64 String
- deriving (Show,Eq,Typeable)
+ deriving (Show, Eq, Typeable)
instance E.Exception InflateException
fileReaderNew :: Bool -> Handle -> IO FileReader
fileReaderNew decompress handle = do
- ref <- newIORef (Just B.empty)
- pos <- newIORef 0
- inflate <- initInflate defaultWindowBits
- return $ FileReader handle decompress inflate ref pos
+ ref <- newIORef (Just B.empty)
+ pos <- newIORef 0
+ inflate <- initInflate defaultWindowBits
+ return $ FileReader handle decompress inflate ref pos
fileReaderClose :: FileReader -> IO ()
fileReaderClose = hClose . fbHandle
withFileReader :: LocalPath -> (FileReader -> IO a) -> IO a
withFileReader path f =
- bracket (openFile path ReadMode) (hClose) $ \handle ->
- bracket (fileReaderNew False handle) (\_ -> return ()) f
+ bracket (openFile path ReadMode) (hClose) $ \handle ->
+ bracket (fileReaderNew False handle) (\_ -> return ()) f
withFileReaderDecompress :: LocalPath -> (FileReader -> IO a) -> IO a
withFileReaderDecompress path f =
- bracket (openFile path ReadMode) (hClose) $ \handle ->
- bracket (fileReaderNew True handle) (\_ -> return ()) f
+ bracket (openFile path ReadMode) (hClose) $ \handle ->
+ bracket (fileReaderNew True handle) (\_ -> return ()) f
fileReaderGetNext :: FileReader -> IO (Maybe ByteString)
fileReaderGetNext fb = do
- bs <- if fbUseInflate fb then inflateTillPop else B.hGet (fbHandle fb) 8192
- modifyIORef (fbPos fb) (\pos -> pos + (fromIntegral $ B.length bs))
- return $ nothingOnNull bs
+ bs <- if fbUseInflate fb then inflateTillPop else B.hGet (fbHandle fb) 8192
+ modifyIORef (fbPos fb) (\pos -> pos + (fromIntegral $ B.length bs))
+ return $ nothingOnNull bs
where
inflateTillPop = do
- b <- B.hGet (fbHandle fb) 4096
- if B.null b
- then finishInflate (fbInflate fb)
- else (>>= maybe inflateTillPop return) =<< feedInflate (fbInflate fb) b
+ b <- B.hGet (fbHandle fb) 4096
+ if B.null b
+ then finishInflate (fbInflate fb)
+ else (>>= maybe inflateTillPop return) =<< feedInflate (fbInflate fb) b
nothingOnNull b
- | B.null b = Nothing
- | otherwise = Just b
+ | B.null b = Nothing
+ | otherwise = Just b
fileReaderGetPos :: FileReader -> IO Word64
fileReaderGetPos fr = do
- storeLeft <- maybe 0 B.length <$> readIORef (fbRemaining fr)
- pos <- readIORef (fbPos fr)
- return (pos - fromIntegral storeLeft)
+ storeLeft <- maybe 0 B.length <$> readIORef (fbRemaining fr)
+ pos <- readIORef (fbPos fr)
+ return (pos - fromIntegral storeLeft)
fileReaderFill :: FileReader -> IO ()
fileReaderFill fb = fileReaderGetNext fb >>= writeIORef (fbRemaining fb)
fileReaderGet :: Int -> FileReader -> IO [ByteString]
-fileReaderGet size fb@(FileReader { fbRemaining = ref }) = loop size
+fileReaderGet size fb@(FileReader {fbRemaining = ref}) = loop size
where
loop left = do
- b <- maybe B.empty id <$> readIORef ref
- if B.length b >= left
- then do
- let (b1, b2) = B.splitAt left b
- writeIORef ref (Just b2)
- return [b1]
- else do
- let nleft = left - B.length b
- fileReaderFill fb
- liftM (b :) (loop nleft)
+ b <- maybe B.empty id <$> readIORef ref
+ if B.length b >= left
+ then do
+ let (b1, b2) = B.splitAt left b
+ writeIORef ref (Just b2)
+ return [b1]
+ else do
+ let nleft = left - B.length b
+ fileReaderFill fb
+ liftM (b :) (loop nleft)
fileReaderGetLBS :: Int -> FileReader -> IO L.ByteString
fileReaderGetLBS size fb = L.fromChunks <$> fileReaderGet size fb
@@ -133,80 +127,84 @@ fileReaderGetRef alg fr = fromBinary <$> fileReaderGetBS (hashDigestSize alg) fr
-- | seek in a handle, and reset the remaining buffer to empty.
fileReaderSeek :: FileReader -> Word64 -> IO ()
-fileReaderSeek (FileReader { fbHandle = handle, fbRemaining = ref, fbPos = pos }) absPos = do
- writeIORef ref (Just B.empty) >> writeIORef pos absPos >> hSeek handle AbsoluteSeek (fromIntegral absPos)
+fileReaderSeek (FileReader {fbHandle = handle, fbRemaining = ref, fbPos = pos}) absPos = do
+ writeIORef ref (Just B.empty) >> writeIORef pos absPos >> hSeek handle AbsoluteSeek (fromIntegral absPos)
-- | parse from a filebuffer
fileReaderParse :: FileReader -> P.Parser a -> IO a
-fileReaderParse fr@(FileReader { fbRemaining = ref }) parseF = do
- initBS <- maybe B.empty id <$> readIORef ref
- result <- P.parseFeed (fileReaderGetNext fr) parseF initBS
- case result of
- P.ParseOK remaining a -> writeIORef ref (Just remaining) >> return a
- P.ParseMore _ -> error "parsing failed: partial with a handle, reached EOF ?"
- P.ParseFail err -> error ("parsing failed: " ++ err)
+fileReaderParse fr@(FileReader {fbRemaining = ref}) parseF = do
+ initBS <- maybe B.empty id <$> readIORef ref
+ result <- P.parseFeed (fileReaderGetNext fr) parseF initBS
+ case result of
+ P.ParseOK remaining a -> writeIORef ref (Just remaining) >> return a
+ P.ParseMore _ -> error "parsing failed: partial with a handle, reached EOF ?"
+ P.ParseFail err -> error ("parsing failed: " ++ err)
-- | get a Variable Length Field. get byte as long as MSB is set, and one byte after
fileReaderGetVLF :: FileReader -> IO [Word8]
fileReaderGetVLF fr = fileReaderParse fr P.vlf
fileReaderInflateToSize :: FileReader -> Word64 -> IO L.ByteString
-fileReaderInflateToSize fb@(FileReader { fbRemaining = ref }) outputSize = do
- --pos <- fileReaderGetPos fb
- --putStrLn ("inflate to size " ++ show outputSize ++ " " ++ show pos)
- inflate <- inflateNew
- l <- loop inflate outputSize
- --posend <- fileReaderGetPos fb
- --putStrLn ("inflated input " ++ show posend)
- return $ L.fromChunks l
- where loop inflate left = do
- rbs <- readIORef ref
- let maxToInflate = min left (16 * 1024)
- let lastBlock = if left == maxToInflate then True else False
- (dbs,remaining) <- inflateToSize inflate (fromIntegral maxToInflate) lastBlock (maybe B.empty id rbs) (maybe B.empty id <$> fileReaderGetNext fb)
- `E.catch` augmentAndRaise left
- writeIORef ref (Just remaining)
- let nleft = left - fromIntegral (B.length dbs)
- if nleft > 0
- then liftM (dbs:) (loop inflate nleft)
- else return [dbs]
- augmentAndRaise :: Word64 -> E.SomeException -> IO a
- augmentAndRaise left exn = throwIO $ InflateException outputSize left (show exn)
+fileReaderInflateToSize fb@(FileReader {fbRemaining = ref}) outputSize = do
+ --pos <- fileReaderGetPos fb
+ --putStrLn ("inflate to size " ++ show outputSize ++ " " ++ show pos)
+ inflate <- inflateNew
+ l <- loop inflate outputSize
+ --posend <- fileReaderGetPos fb
+ --putStrLn ("inflated input " ++ show posend)
+ return $ L.fromChunks l
+ where
+ loop inflate left = do
+ rbs <- readIORef ref
+ let maxToInflate = min left (16 * 1024)
+ let lastBlock = if left == maxToInflate then True else False
+ (dbs, remaining) <-
+ inflateToSize inflate (fromIntegral maxToInflate) lastBlock (maybe B.empty id rbs) (maybe B.empty id <$> fileReaderGetNext fb)
+ `E.catch` augmentAndRaise left
+ writeIORef ref (Just remaining)
+ let nleft = left - fromIntegral (B.length dbs)
+ if nleft > 0
+ then liftM (dbs :) (loop inflate nleft)
+ else return [dbs]
+ augmentAndRaise :: Word64 -> E.SomeException -> IO a
+ augmentAndRaise left exn = throwIO $ InflateException outputSize left (show exn)
-- lowlevel helpers to inflate only to a specific size.
inflateNew :: IO (ForeignPtr ZStreamStruct)
inflateNew = do
- zstr <- zstreamNew
- inflateInit2 zstr defaultWindowBits
- newForeignPtr c_free_z_stream_inflate zstr
+ zstr <- zstreamNew
+ inflateInit2 zstr defaultWindowBits
+ newForeignPtr c_free_z_stream_inflate zstr
inflateToSize :: ForeignPtr ZStreamStruct -> Int -> Bool -> ByteString -> IO ByteString -> IO (ByteString, ByteString)
inflateToSize inflate sz isLastBlock ibs nextBs = withForeignPtr inflate $ \zstr -> do
- let boundSz = min defaultChunkSize sz
- -- create an output buffer
- fbuff <- mallocForeignPtrBytes boundSz
- withForeignPtr fbuff $ \buff -> do
- c_set_avail_out zstr buff (fromIntegral boundSz)
- rbs <- loop zstr ibs
- bs <- B.packCStringLen (buff, boundSz)
- return (bs, rbs)
- where
- loop zstr nbs = do
- (ai, streamEnd) <- inflateOneInput zstr nbs
- ao <- c_get_avail_out zstr
- if (isLastBlock && streamEnd) || (not isLastBlock && ao == 0)
- then return $ bsTakeLast ai nbs
- else do
- --when (ai /= 0) $ error ("input not consumed completly: ai" ++ show ai)
- (if ai == 0
- then nextBs
- else return (bsTakeLast ai nbs)) >>= loop zstr
-
- inflateOneInput zstr bs = unsafeUseAsCStringLen bs $ \(istr, ilen) -> do
- c_set_avail_in zstr istr $ fromIntegral ilen
- r <- c_call_inflate_noflush zstr
- when (r < 0 && r /= (-5)) $ do
- throwIO $ ZlibException $ fromIntegral r
- ai <- c_get_avail_in zstr
- return (ai, r == 1)
- bsTakeLast len bs = B.drop (B.length bs - fromIntegral len) bs
+ let boundSz = min defaultChunkSize sz
+ -- create an output buffer
+ fbuff <- mallocForeignPtrBytes boundSz
+ withForeignPtr fbuff $ \buff -> do
+ c_set_avail_out zstr buff (fromIntegral boundSz)
+ rbs <- loop zstr ibs
+ bs <- B.packCStringLen (buff, boundSz)
+ return (bs, rbs)
+ where
+ loop zstr nbs = do
+ (ai, streamEnd) <- inflateOneInput zstr nbs
+ ao <- c_get_avail_out zstr
+ if (isLastBlock && streamEnd) || (not isLastBlock && ao == 0)
+ then return $ bsTakeLast ai nbs
+ else do
+ --when (ai /= 0) $ error ("input not consumed completly: ai" ++ show ai)
+ ( if ai == 0
+ then nextBs
+ else return (bsTakeLast ai nbs)
+ )
+ >>= loop zstr
+
+ inflateOneInput zstr bs = unsafeUseAsCStringLen bs $ \(istr, ilen) -> do
+ c_set_avail_in zstr istr $ fromIntegral ilen
+ r <- c_call_inflate_noflush zstr
+ when (r < 0 && r /= (-5)) $ do
+ throwIO $ ZlibException $ fromIntegral r
+ ai <- c_get_avail_in zstr
+ return (ai, r == 1)
+ bsTakeLast len bs = B.drop (B.length bs - fromIntegral len) bs
diff --git a/Data/Git/Storage/FileWriter.hs b/Data/Git/Storage/FileWriter.hs
index 15a292e..cb8bf5c 100644
--- a/Data/Git/Storage/FileWriter.hs
+++ b/Data/Git/Storage/FileWriter.hs
@@ -4,17 +4,15 @@
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unix
---
module Data.Git.Storage.FileWriter where
-import Data.Git.Ref
-import Data.Git.OS
-import Data.IORef
-import qualified Data.ByteString as B
import Codec.Zlib
import Control.Exception (bracket)
-
import Crypto.Hash
+import qualified Data.ByteString as B
+import Data.Git.OS
+import Data.Git.Ref
+import Data.IORef
defaultCompression :: Int
defaultCompression = 6
@@ -23,42 +21,43 @@ defaultCompression = 6
-- for older version of base.
modifyIORefStrict :: IORef a -> (a -> a) -> IO ()
modifyIORefStrict ref f = do
- x <- readIORef ref
- let x' = f x
- x' `seq` writeIORef ref x'
+ x <- readIORef ref
+ let x' = f x
+ x' `seq` writeIORef ref x'
data FileWriter hash = FileWriter
- { writerHandle :: Handle
- , writerDeflate :: Deflate
- , writerDigest :: IORef (Context hash)
- }
+ { writerHandle :: Handle,
+ writerDeflate :: Deflate,
+ writerDigest :: IORef (Context hash)
+ }
fileWriterNew :: HashAlgorithm hash => Handle -> IO (FileWriter hash)
fileWriterNew handle = do
- deflate <- initDeflate defaultCompression defaultWindowBits
- digest <- newIORef hashInit
- return $ FileWriter
- { writerHandle = handle
- , writerDeflate = deflate
- , writerDigest = digest
- }
+ deflate <- initDeflate defaultCompression defaultWindowBits
+ digest <- newIORef hashInit
+ return $
+ FileWriter
+ { writerHandle = handle,
+ writerDeflate = deflate,
+ writerDigest = digest
+ }
withFileWriter :: HashAlgorithm hash => LocalPath -> (FileWriter hash -> IO c) -> IO c
withFileWriter path f =
- bracket (openFile path WriteMode) (hClose) $ \handle ->
- bracket (fileWriterNew handle) (fileWriterClose) f
+ bracket (openFile path WriteMode) (hClose) $ \handle ->
+ bracket (fileWriterNew handle) (fileWriterClose) f
postDeflate :: Handle -> Maybe B.ByteString -> IO ()
postDeflate handle = maybe (return ()) (B.hPut handle)
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
+fileWriterOutput (FileWriter {writerHandle = handle, writerDigest = digest, writerDeflate = deflate}) bs = do
+ modifyIORefStrict digest (\ctx -> hashUpdate ctx bs)
+ (>>= postDeflate handle) =<< feedDeflate deflate bs
fileWriterClose :: FileWriter hash -> IO ()
-fileWriterClose (FileWriter { writerHandle = handle, writerDeflate = deflate }) =
- postDeflate handle =<< finishDeflate deflate
+fileWriterClose (FileWriter {writerHandle = handle, writerDeflate = deflate}) =
+ postDeflate handle =<< finishDeflate deflate
fileWriterGetDigest :: HashAlgorithm hash => FileWriter hash -> IO (Ref hash)
-fileWriterGetDigest (FileWriter { writerDigest = digest }) = (fromDigest . hashFinalize) `fmap` readIORef digest
+fileWriterGetDigest (FileWriter {writerDigest = digest}) = (fromDigest . hashFinalize) `fmap` readIORef digest
diff --git a/Data/Git/Storage/Loose.hs b/Data/Git/Storage/Loose.hs
index 026f052..1fad0a9 100644
--- a/Data/Git/Storage/Loose.hs
+++ b/Data/Git/Storage/Loose.hs
@@ -1,4 +1,6 @@
-{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE ViewPatterns #-}
-- |
-- Module : Data.Git.Storage.Loose
@@ -6,51 +8,51 @@
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unix
---
module Data.Git.Storage.Loose
- (
- Zipped(..)
- -- * marshall from and to lazy bytestring
- , looseUnmarshall
- , looseUnmarshallRaw
- , looseUnmarshallZipped
- , looseUnmarshallZippedRaw
- , looseMarshall
- -- * read and check object existence
- , looseRead
- , looseReadHeader
- , looseReadRaw
- , looseExists
- -- * write objects
- , looseWriteBlobFromFile
- , looseWrite
- -- * enumeration of loose objects
- , looseEnumeratePrefixes
- , looseEnumerateWithPrefixFilter
- , looseEnumerateWithPrefix
- ) where
+ ( Zipped (..),
+
+ -- * marshall from and to lazy bytestring
+ looseUnmarshall,
+ looseUnmarshallRaw,
+ looseUnmarshallZipped,
+ looseUnmarshallZippedRaw,
+ looseMarshall,
+
+ -- * read and check object existence
+ looseRead,
+ looseReadHeader,
+ looseReadRaw,
+ looseExists,
+
+ -- * write objects
+ looseWriteBlobFromFile,
+ looseWrite,
+
+ -- * enumeration of loose objects
+ looseEnumeratePrefixes,
+ looseEnumerateWithPrefixFilter,
+ looseEnumerateWithPrefix,
+ )
+where
import Codec.Compression.Zlib
-import Data.Git.Ref
-import Data.Git.Path
+import Control.Exception (SomeException, onException)
+import qualified Control.Exception as E
+import qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
+import Data.Char (isHexDigit)
+import Data.Git.Imports
import Data.Git.Internal
import Data.Git.OS
-import Data.Git.Imports
+import qualified Data.Git.Parser as P
+import Data.Git.Path
+import Data.Git.Ref
import Data.Git.Storage.FileWriter
import Data.Git.Storage.Object
-import qualified Data.Git.Parser as P
-
-import qualified Data.ByteString.Lazy as L
-import qualified Data.ByteString as B
-
-import Control.Exception (onException, SomeException)
-import qualified Control.Exception as E
-
import Data.String
-import Data.Char (isHexDigit)
-newtype Zipped = Zipped { getZippedData :: L.ByteString }
- deriving (Show,Eq)
+newtype Zipped = Zipped {getZippedData :: L.ByteString}
+ deriving (Show, Eq)
readZippedFile :: LocalPath -> IO Zipped
readZippedFile fp = Zipped <$> readBinaryFileLazy fp
@@ -59,24 +61,24 @@ dezip :: Zipped -> L.ByteString
dezip = decompress . getZippedData
isObjectPrefix :: [Char] -> Bool
-isObjectPrefix [a,b] = isHexDigit a && isHexDigit b
-isObjectPrefix _ = False
+isObjectPrefix [a, b] = isHexDigit a && isHexDigit b
+isObjectPrefix _ = False
-- loose object parsing
parseHeader :: P.Parser (ObjectHeader hash)
parseHeader = do
- h <- P.takeWhile1 ((/=) 0x20)
- _ <- P.byte 0x20
- sz <- P.decimal :: P.Parser Int
- return (objectTypeUnmarshall h, fromIntegral sz, Nothing)
+ h <- P.takeWhile1 ((/=) 0x20)
+ _ <- P.byte 0x20
+ sz <- P.decimal :: P.Parser Int
+ return (objectTypeUnmarshall h, fromIntegral sz, Nothing)
data HeaderType = HeaderTree | HeaderTag | HeaderCommit | HeaderBlob
parseTreeHeader, parseTagHeader, parseCommitHeader, parseBlobHeader :: P.Parser HeaderType
-parseTreeHeader = P.string "tree " >> parseLength >> P.byte 0 >> return HeaderTree
-parseTagHeader = P.string "tag " >> parseLength >> P.byte 0 >> return HeaderTag
+parseTreeHeader = P.string "tree " >> parseLength >> P.byte 0 >> return HeaderTree
+parseTagHeader = P.string "tag " >> parseLength >> P.byte 0 >> return HeaderTag
parseCommitHeader = P.string "commit " >> parseLength >> P.byte 0 >> return HeaderCommit
-parseBlobHeader = P.string "blob " >> parseLength >> P.byte 0 >> return HeaderBlob
+parseBlobHeader = P.string "blob " >> parseLength >> P.byte 0 >> return HeaderBlob
parseLength :: P.Parser Int
parseLength = P.decimal
@@ -86,13 +88,12 @@ parseObject = parseSuccess getOne
where
parseSuccess p = either (error . ("parseObject: " ++)) id . P.eitherParseChunks p . L.toChunks
getOne = do
- hdrType <- parseTreeHeader <|> parseBlobHeader <|> parseCommitHeader <|> parseTagHeader
- case hdrType of
- HeaderTree -> objectParseTree
- HeaderTag -> objectParseTag
- HeaderCommit -> objectParseCommit
- HeaderBlob -> objectParseBlob
-
+ hdrType <- parseTreeHeader <|> parseBlobHeader <|> parseCommitHeader <|> parseTagHeader
+ case hdrType of
+ HeaderTree -> objectParseTree
+ HeaderTag -> objectParseTag
+ HeaderCommit -> objectParseCommit
+ HeaderBlob -> objectParseBlob
-- | unmarshall an object (with header) from a bytestring.
looseUnmarshall :: HashAlgorithm hash => L.ByteString -> Object hash
@@ -105,13 +106,13 @@ looseUnmarshallZipped = parseObject . dezip
-- | unmarshall an object as (header, data) tuple from a bytestring
looseUnmarshallRaw :: L.ByteString -> (ObjectHeader hash, ObjectData)
looseUnmarshallRaw stream =
- case L.findIndex ((==) 0) stream of
- Nothing -> error "object not right format. missing 0"
- Just idx ->
- let (h, r) = L.splitAt (idx+1) stream in
- case P.maybeParseChunks parseHeader (L.toChunks h) of
- Nothing -> error "cannot open object"
- Just hdr -> (hdr, r)
+ case L.findIndex ((==) 0) stream of
+ Nothing -> error "object not right format. missing 0"
+ Just idx ->
+ let (h, r) = L.splitAt (idx + 1) stream
+ in case P.maybeParseChunks parseHeader (L.toChunks h) of
+ Nothing -> error "cannot open object"
+ Just hdr -> (hdr, r)
-- | unmarshall an object as (header, data) tuple from a zipped stream
looseUnmarshallZippedRaw :: Zipped -> (ObjectHeader hash, ObjectData)
@@ -142,59 +143,62 @@ looseEnumeratePrefixes repoPath = filter isObjectPrefix <$> getDirectoryContents
-- | enumerate all references available with a specific prefix.
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
+ 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 :: HashAlgorithm hash => LocalPath -> String -> IO [Ref hash]
looseEnumerateWithPrefix repoPath prefix =
- looseEnumerateWithPrefixFilter repoPath prefix (const True)
+ looseEnumerateWithPrefixFilter repoPath prefix (const True)
-- | marshall as lazy bytestring an object except deltas.
looseMarshall :: Object hash -> L.ByteString
looseMarshall obj
- | objectIsDelta obj = error "cannot write delta object loose"
- | otherwise = L.concat [ L.fromChunks [hdrB], objData ]
- where
- objData = objectWrite obj
- hdrB = objectWriteHeader (objectToType obj) (fromIntegral $ L.length objData)
+ | objectIsDelta obj = error "cannot write delta object loose"
+ | otherwise = L.concat [L.fromChunks [hdrB], objData]
+ where
+ objData = objectWrite obj
+ hdrB = objectWriteHeader (objectToType obj) (fromIntegral $ L.length objData)
-- | create a new blob on a temporary location and on success move it to
-- the object store with its digest name.
looseWriteBlobFromFile :: HashAlgorithm hash => LocalPath -> LocalPath -> IO (Ref hash)
looseWriteBlobFromFile repoPath file = do
- fsz <- getSize file
- let hdr = objectWriteHeader TypeBlob (fromIntegral fsz)
- tmpPath <- objectTemporaryPath repoPath
- flip onException (removeFile tmpPath) $ do
- (ref, npath) <- withFileWriter tmpPath $ \fw -> do
- fileWriterOutput fw hdr
- withFile file ReadMode $ \h -> loop h fw
- digest <- fileWriterGetDigest fw
- return (digest, objectPathOfRef repoPath digest)
- exists <- isFile npath
- when exists $ error "destination already exists"
- rename tmpPath npath
- return ref
- where loop h fw = do
- r <- B.hGet h (32*1024)
- if B.null r
- then return ()
- else fileWriterOutput fw r >> loop h fw
+ fsz <- getSize file
+ let hdr = objectWriteHeader TypeBlob (fromIntegral fsz)
+ tmpPath <- objectTemporaryPath repoPath
+ flip onException (removeFile tmpPath) $ do
+ (ref, npath) <- withFileWriter tmpPath $ \fw -> do
+ fileWriterOutput fw hdr
+ withFile file ReadMode $ \h -> loop h fw
+ digest <- fileWriterGetDigest fw
+ return (digest, objectPathOfRef repoPath digest)
+ exists <- isFile npath
+ when exists $ error "destination already exists"
+ rename tmpPath npath
+ return ref
+ where
+ loop h fw = do
+ r <- B.hGet h (32 * 1024)
+ if B.null r
+ then return ()
+ else fileWriterOutput fw r >> loop h fw
-- | write an object to disk as a loose reference.
-- use looseWriteBlobFromFile for efficiently writing blobs when being commited from a file.
looseWrite :: HashAlgorithm hash => LocalPath -> Object hash -> IO (Ref hash)
-looseWrite repoPath obj = createParentDirectory path
- >> isFile path
- >>= \exists -> unless exists (writeFileLazy path $ compress content)
- >> return ref
- where
- path = objectPathOfRef repoPath ref
- content = looseMarshall obj
- ref = hashLBS content
- writeFileLazy p bs = withFile p WriteMode (\h -> L.hPut h bs)
+looseWrite repoPath obj =
+ createParentDirectory path
+ >> isFile path
+ >>= \exists ->
+ unless exists (writeFileLazy path $ compress content)
+ >> return ref
+ where
+ path = objectPathOfRef repoPath ref
+ content = looseMarshall obj
+ ref = hashLBS content
+ writeFileLazy p bs = withFile p WriteMode (\h -> L.hPut h bs)
getDirectoryContents :: LocalPath -> IO [String]
getDirectoryContents p = listDirectoryFilename p
diff --git a/Data/Git/Storage/Object.hs b/Data/Git/Storage/Object.hs
index 2d403fe..ed2a19e 100644
--- a/Data/Git/Storage/Object.hs
+++ b/Data/Git/Storage/Object.hs
@@ -1,5 +1,5 @@
-{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : Data.Git.Storage.Object
@@ -7,50 +7,50 @@
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unix
---
module Data.Git.Storage.Object
- ( ObjectLocation(..)
- , ObjectType(..)
- , ObjectHeader
- , ObjectData
- , ObjectPtr(..)
- , Object(..)
- , ObjectInfo(..)
- , Objectable(..)
- , objectToType
- , objectTypeMarshall
- , objectTypeUnmarshall
- , objectTypeIsDelta
- , objectIsDelta
- , objectToTree
- , objectToCommit
- , objectToTag
- , objectToBlob
- -- * parsing function
- , treeParse
- , commitParse
- , tagParse
- , blobParse
- , objectParseTree
- , objectParseCommit
- , objectParseTag
- , objectParseBlob
- -- * writing function
- , objectWriteHeader
- , objectWrite
- , objectHash
- ) where
-
-import Data.Git.Ref
-import Data.Git.Types
-import Data.Git.Imports
-import qualified Data.Git.Parser as P
+ ( ObjectLocation (..),
+ ObjectType (..),
+ ObjectHeader,
+ ObjectData,
+ ObjectPtr (..),
+ Object (..),
+ ObjectInfo (..),
+ Objectable (..),
+ objectToType,
+ objectTypeMarshall,
+ objectTypeUnmarshall,
+ objectTypeIsDelta,
+ objectIsDelta,
+ objectToTree,
+ objectToCommit,
+ objectToTag,
+ objectToBlob,
+
+ -- * parsing function
+ treeParse,
+ commitParse,
+ tagParse,
+ blobParse,
+ objectParseTree,
+ objectParseCommit,
+ objectParseTag,
+ objectParseBlob,
+
+ -- * writing function
+ objectWriteHeader,
+ objectWrite,
+ objectHash,
+ )
+where
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as L
-
+import Data.Git.Imports
+import qualified Data.Git.Parser as P
+import Data.Git.Ref
+import Data.Git.Types
import Data.List (intersperse)
import Data.Word
import Text.Printf
@@ -73,11 +73,11 @@ toLazyByteString = id
-- | location of an object in the database
data ObjectLocation hash = NotFound | Loose (Ref hash) | Packed (Ref hash) Word64
- deriving (Show,Eq)
+ 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 hash = PtrRef (Ref hash) | PtrOfs Word64 deriving (Show,Eq)
+data ObjectPtr hash = PtrRef (Ref hash) | PtrOfs Word64 deriving (Show, Eq)
type ObjectHeader hash = (ObjectType, Word64, Maybe (ObjectPtr hash))
@@ -86,81 +86,83 @@ 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 hash = ObjectInfo
- { oiHeader :: ObjectHeader hash
- , oiData :: ObjectData
- , oiChains :: [ObjectPtr hash]
- } deriving (Show,Eq)
+ { oiHeader :: ObjectHeader hash,
+ oiData :: ObjectData,
+ 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 hash =
- ObjCommit (Commit hash)
- | ObjTag (Tag hash)
- | ObjBlob (Blob hash)
- | ObjTree (Tree hash)
- | ObjDeltaOfs (DeltaOfs hash)
- | ObjDeltaRef (DeltaRef hash)
- 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 hash -> ObjectType
- getRaw :: a hash -> L.ByteString
- isDelta :: a hash -> Bool
- toObject :: a hash -> Object hash
+ getType :: a hash -> ObjectType
+ getRaw :: a hash -> L.ByteString
+ isDelta :: a hash -> Bool
+ toObject :: a hash -> Object hash
objectToType :: Object hash -> ObjectType
-objectToType (ObjTree _) = TypeTree
-objectToType (ObjBlob _) = TypeBlob
-objectToType (ObjCommit _) = TypeCommit
-objectToType (ObjTag _) = TypeTag
+objectToType (ObjTree _) = TypeTree
+objectToType (ObjBlob _) = TypeBlob
+objectToType (ObjCommit _) = TypeCommit
+objectToType (ObjTag _) = TypeTag
objectToType (ObjDeltaOfs _) = TypeDeltaOff
objectToType (ObjDeltaRef _) = TypeDeltaRef
objectTypeMarshall :: ObjectType -> String
-objectTypeMarshall TypeTree = "tree"
-objectTypeMarshall TypeBlob = "blob"
+objectTypeMarshall TypeTree = "tree"
+objectTypeMarshall TypeBlob = "blob"
objectTypeMarshall TypeCommit = "commit"
-objectTypeMarshall TypeTag = "tag"
-objectTypeMarshall _ = error "deltas cannot be marshalled"
+objectTypeMarshall TypeTag = "tag"
+objectTypeMarshall _ = error "deltas cannot be marshalled"
objectTypeUnmarshall :: ByteString -> ObjectType
-objectTypeUnmarshall "tree" = TypeTree
-objectTypeUnmarshall "blob" = TypeBlob
+objectTypeUnmarshall "tree" = TypeTree
+objectTypeUnmarshall "blob" = TypeBlob
objectTypeUnmarshall "commit" = TypeCommit
-objectTypeUnmarshall "tag" = TypeTag
-objectTypeUnmarshall _ = error "unknown object type"
+objectTypeUnmarshall "tag" = TypeTag
+objectTypeUnmarshall _ = error "unknown object type"
objectTypeIsDelta :: ObjectType -> Bool
objectTypeIsDelta TypeDeltaOff = True
objectTypeIsDelta TypeDeltaRef = True
-objectTypeIsDelta _ = False
+objectTypeIsDelta _ = False
objectIsDelta :: Object hash -> Bool
objectIsDelta (ObjDeltaOfs _) = True
objectIsDelta (ObjDeltaRef _) = True
-objectIsDelta _ = False
+objectIsDelta _ = False
objectToTree :: Object hash -> Maybe (Tree hash)
objectToTree (ObjTree tree) = Just tree
-objectToTree _ = Nothing
+objectToTree _ = Nothing
objectToCommit :: Object hash -> Maybe (Commit hash)
objectToCommit (ObjCommit commit) = Just commit
-objectToCommit _ = Nothing
+objectToCommit _ = Nothing
objectToTag :: Object hash -> Maybe (Tag hash)
objectToTag (ObjTag tag) = Just tag
-objectToTag _ = Nothing
+objectToTag _ = Nothing
objectToBlob :: Object hash -> Maybe (Blob hash)
objectToBlob (ObjBlob blob) = Just blob
-objectToBlob _ = Nothing
+objectToBlob _ = Nothing
octal :: P.Parser Int
octal = B.foldl' step 0 `fmap` P.takeWhile1 isOct
- where isOct w = w >= 0x30 && w <= 0x37
- step a w = a * 8 + fromIntegral (w - 0x30)
+ where
+ isOct w = w >= 0x30 && w <= 0x37
+ step a w = a * 8 + fromIntegral (w - 0x30)
modeperm :: P.Parser ModePerm
modeperm = ModePerm . fromIntegral <$> octal
@@ -168,141 +170,157 @@ modeperm = ModePerm . fromIntegral <$> octal
-- | parse a tree content
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))
+ 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 hash)
-blobParse = (Blob . L.fromChunks . (:[]) <$> P.takeAll)
+blobParse = (Blob . L.fromChunks . (: []) <$> P.takeAll)
-- | parse a commit content
commitParse :: HashAlgorithm hash => P.Parser (Commit hash)
commitParse = do
- tree <- P.string "tree " >> P.referenceHex
- P.skipEOL
- parents <- many parseParentRef
- author <- P.string "author " >> parsePerson
- committer <- P.string "committer " >> parsePerson
- encoding <- optional (P.string "encoding " >> P.tillEOL)
- extras <- many parseExtra
- P.skipEOL
- message <- P.takeAll
- return $ Commit tree parents author committer encoding extras message
- where
- parseParentRef = do
- tree <- P.string "parent " >> P.referenceHex
- P.skipEOL
- return tree
- parseExtra = do
- b <- P.anyByte
- if b == 0xa
- then fail "no extra"
- else do
- r <- P.tillEOL
- P.skipEOL
- v <- concatLines <$> many (P.string " " *> P.tillEOL <* P.skipEOL)
- return $ CommitExtra (b `B.cons` r) v
- concatLines = B.concat . intersperse (B.pack [0xa])
+ tree <- P.string "tree " >> P.referenceHex
+ P.skipEOL
+ parents <- many parseParentRef
+ author <- P.string "author " >> parsePerson
+ committer <- P.string "committer " >> parsePerson
+ encoding <- optional (P.string "encoding " >> P.tillEOL)
+ extras <- many parseExtra
+ P.skipEOL
+ message <- P.takeAll
+ return $ Commit tree parents author committer encoding extras message
+ where
+ parseParentRef = do
+ tree <- P.string "parent " >> P.referenceHex
+ P.skipEOL
+ return tree
+ parseExtra = do
+ b <- P.anyByte
+ if b == 0xa
+ then fail "no extra"
+ else do
+ r <- P.tillEOL
+ P.skipEOL
+ v <- concatLines <$> many (P.string " " *> P.tillEOL <* P.skipEOL)
+ return $ CommitExtra (b `B.cons` r) v
+ concatLines = B.concat . intersperse (B.pack [0xa])
-- | parse a tag content
tagParse :: HashAlgorithm hash => P.Parser (Tag hash)
tagParse = do
- object <- P.string "object " >> P.referenceHex
- P.skipEOL
- type_ <- objectTypeUnmarshall <$> (P.string "type " >> P.tillEOL)
- P.skipEOL
- tag <- P.string "tag " >> P.tillEOL -- PC.takeTill ((==) 0x0a)
- P.skipEOL
- tagger <- P.string "tagger " >> parsePerson
- P.skipEOL
- signature <- P.takeAll
- return $ Tag object type_ tag tagger signature
+ object <- P.string "object " >> P.referenceHex
+ P.skipEOL
+ type_ <- objectTypeUnmarshall <$> (P.string "type " >> P.tillEOL)
+ P.skipEOL
+ tag <- P.string "tag " >> P.tillEOL -- PC.takeTill ((==) 0x0a)
+ P.skipEOL
+ tagger <- P.string "tagger " >> parsePerson
+ P.skipEOL
+ signature <- P.takeAll
+ return $ Tag object type_ tag tagger signature
parsePerson :: P.Parser Person
parsePerson = do
- name <- B.init <$> P.takeUntilASCII '<'
- P.skipASCII '<'
- email <- P.takeUntilASCII '>'
- _ <- P.string "> "
- time <- P.decimal :: P.Parser Integer
- _ <- P.string " "
- timezoneSign <- maybe 1 id <$> optional ((const 1 <$> ascii '+') <|> (const (-1) <$> ascii '-'))
- timezoneFmt <- P.decimal
- let (h,m) = timezoneFmt `divMod` 100
- timezone = timezoneSign * (h * 60 + m)
- P.skipEOL
- return $ Person name email (gitTime time timezone)
+ name <- B.init <$> P.takeUntilASCII '<'
+ P.skipASCII '<'
+ email <- P.takeUntilASCII '>'
+ _ <- P.string "> "
+ time <- P.decimal :: P.Parser Integer
+ _ <- P.string " "
+ timezoneSign <- maybe 1 id <$> optional ((const 1 <$> ascii '+') <|> (const (-1) <$> ascii '-'))
+ timezoneFmt <- P.decimal
+ let (h, m) = timezoneFmt `divMod` 100
+ timezone = timezoneSign * (h * 60 + m)
+ P.skipEOL
+ return $ Person name email (gitTime time timezone)
ascii :: Char -> P.Parser ()
ascii c = P.byte (asciiChar c)
asciiChar :: Char -> Word8
asciiChar c
- | cp < 0x80 = fromIntegral cp
- | otherwise = error ("char " <> show c <> " not valid ASCII")
- where cp = fromEnum c
+ | cp < 0x80 = fromIntegral cp
+ | otherwise = error ("char " <> show c <> " not valid ASCII")
+ where
+ cp = fromEnum c
objectParseTree, objectParseCommit, objectParseTag, objectParseBlob :: HashAlgorithm hash => P.Parser (Object hash)
-objectParseTree = ObjTree <$> treeParse
+objectParseTree = ObjTree <$> treeParse
objectParseCommit = ObjCommit <$> commitParse
-objectParseTag = ObjTag <$> tagParse
-objectParseBlob = ObjBlob <$> blobParse
+objectParseTag = ObjTag <$> tagParse
+objectParseBlob = ObjBlob <$> blobParse
-- header of loose objects, but also useful for any object to determine object's hash
objectWriteHeader :: ObjectType -> Word64 -> ByteString
-objectWriteHeader ty sz = BC.pack (objectTypeMarshall ty ++ " " ++ show sz ++ [ '\0' ])
+objectWriteHeader ty sz = BC.pack (objectTypeMarshall ty ++ " " ++ show sz ++ ['\0'])
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"
+objectWrite (ObjTag tag) = tagWrite tag
+objectWrite (ObjBlob blob) = blobWrite blob
+objectWrite (ObjTree tree) = treeWrite tree
+objectWrite _ = error "delta cannot be marshalled"
treeWrite :: Tree hash -> L.ByteString
treeWrite (Tree ents) = toLazyByteString $ mconcat $ concatMap writeTreeEnt ents
- where writeTreeEnt (ModePerm perm,name,ref) =
- [ string7 (printf "%o" perm)
- , string7 " "
- , byteString $ getEntNameBytes name
- , string7 "\0"
- , byteString $ toBinary ref
- ]
+ where
+ writeTreeEnt (ModePerm perm, name, ref) =
+ [ string7 (printf "%o" perm),
+ string7 " ",
+ byteString $ getEntNameBytes name,
+ string7 "\0",
+ byteString $ toBinary ref
+ ]
commitWrite :: Commit hash -> L.ByteString
commitWrite (Commit tree parents author committer encoding extra msg) =
- toLazyByteString $ mconcat els
- where
- toNamedRef s r = mconcat [string7 s, byteString (toHex r),eol]
- toParent = toNamedRef "parent "
- toCommitExtra (CommitExtra k v) = [byteString k, eol] ++
- (concatMap (\l -> [byteString " ", byteString l, eol]) $ linesLast v)
-
- linesLast b
- | B.length b > 0 && B.last b == 0xa = BC.lines b ++ [ "" ]
- | otherwise = BC.lines b
- els = [toNamedRef "tree " tree ]
- ++ map toParent parents
- ++ [byteString $ writeName "author" author, eol
- ,byteString $ writeName "committer" committer, eol
- ,maybe (byteString B.empty) (byteString) encoding -- FIXME need eol
- ]
- ++ concatMap toCommitExtra extra
- ++ [eol
- ,byteString msg
- ]
+ toLazyByteString $ mconcat els
+ where
+ toNamedRef s r = mconcat [string7 s, byteString (toHex r), eol]
+ toParent = toNamedRef "parent "
+ toCommitExtra (CommitExtra k v) =
+ [byteString k, eol]
+ ++ (concatMap (\l -> [byteString " ", byteString l, eol]) $ linesLast v)
+
+ linesLast b
+ | B.length b > 0 && B.last b == 0xa = BC.lines b ++ [""]
+ | otherwise = BC.lines b
+ els =
+ [toNamedRef "tree " tree]
+ ++ map toParent parents
+ ++ [ byteString $ writeName "author" author,
+ eol,
+ byteString $ writeName "committer" committer,
+ eol,
+ maybe (byteString B.empty) (byteString) encoding -- FIXME need eol
+ ]
+ ++ concatMap toCommitExtra extra
+ ++ [ eol,
+ byteString msg
+ ]
tagWrite :: Tag hash -> L.ByteString
tagWrite (Tag ref ty tag tagger signature) =
- toLazyByteString $ mconcat els
- where els = [ string7 "object ", byteString (toHex ref), eol
- , string7 "type ", string7 (objectTypeMarshall ty), eol
- , string7 "tag ", byteString tag, eol
- , byteString $ writeName "tagger" tagger, eol
- , eol
- , byteString signature
- ]
+ toLazyByteString $ mconcat els
+ where
+ els =
+ [ string7 "object ",
+ byteString (toHex ref),
+ eol,
+ string7 "type ",
+ string7 (objectTypeMarshall ty),
+ eol,
+ string7 "tag ",
+ byteString tag,
+ eol,
+ byteString $ writeName "tagger" tagger,
+ eol,
+ eol,
+ byteString signature
+ ]
eol :: Builder
eol = string7 "\n"
@@ -311,40 +329,40 @@ blobWrite :: Blob hash -> L.ByteString
blobWrite (Blob bData) = bData
instance Objectable Blob where
- getType _ = TypeBlob
- getRaw = blobWrite
- toObject = ObjBlob
- isDelta = const False
+ getType _ = TypeBlob
+ getRaw = blobWrite
+ toObject = ObjBlob
+ isDelta = const False
instance Objectable Commit where
- getType _ = TypeCommit
- getRaw = commitWrite
- toObject = ObjCommit
- isDelta = const False
+ getType _ = TypeCommit
+ getRaw = commitWrite
+ toObject = ObjCommit
+ isDelta = const False
instance Objectable Tag where
- getType _ = TypeTag
- getRaw = tagWrite
- toObject = ObjTag
- isDelta = const False
+ getType _ = TypeTag
+ getRaw = tagWrite
+ toObject = ObjTag
+ isDelta = const False
instance Objectable Tree where
- getType _ = TypeTree
- getRaw = treeWrite
- toObject = ObjTree
- isDelta = const False
+ getType _ = TypeTree
+ getRaw = treeWrite
+ toObject = ObjTree
+ isDelta = const False
instance Objectable DeltaOfs where
- getType _ = TypeDeltaOff
- getRaw = error "delta offset cannot be marshalled"
- toObject = ObjDeltaOfs
- isDelta = const True
+ getType _ = TypeDeltaOff
+ getRaw = error "delta offset cannot be marshalled"
+ toObject = ObjDeltaOfs
+ isDelta = const True
instance Objectable DeltaRef where
- getType _ = TypeDeltaRef
- getRaw = error "delta ref cannot be marshalled"
- toObject = ObjDeltaRef
- isDelta = const True
+ getType _ = TypeDeltaRef
+ getRaw = error "delta ref cannot be marshalled"
+ toObject = ObjDeltaRef
+ isDelta = const True
objectHash :: HashAlgorithm hash => ObjectType -> Word64 -> L.ByteString -> Ref hash
objectHash ty w lbs = hashLBS $ L.fromChunks (objectWriteHeader ty w : L.toChunks lbs)
@@ -352,5 +370,6 @@ objectHash ty w lbs = hashLBS $ L.fromChunks (objectWriteHeader ty w : L.toChunk
-- used for objectWrite for commit and tag
writeName :: ByteString -> Person -> ByteString
writeName label (Person name email locTime) =
- B.concat [label, " ", name, " <", email, "> ", BC.pack timeStr]
- where timeStr = show locTime
+ B.concat [label, " ", name, " <", email, "> ", BC.pack timeStr]
+ where
+ timeStr = show locTime
diff --git a/Data/Git/Storage/Pack.hs b/Data/Git/Storage/Pack.hs
index 2861a5d..db5a9ac 100644
--- a/Data/Git/Storage/Pack.hs
+++ b/Data/Git/Storage/Pack.hs
@@ -6,63 +6,65 @@
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unix
---
module Data.Git.Storage.Pack
- ( PackedObjectInfo(..)
- , PackedObjectRaw
- -- * Enumerators of packs
- , packEnumerate
- -- * Helpers to process packs
- , packOpen
- , packClose
- -- * Command for the content of a pack
- , packReadHeader
- , packReadMapAtOffset
- , packReadAtOffset
- , packReadRawAtOffset
- , packEnumerateObjects
- -- * turn a packed object into a
- , packedObjectToObject
- , packObjectFromRaw
- ) where
+ ( PackedObjectInfo (..),
+ PackedObjectRaw,
-import Control.Arrow (second)
+ -- * Enumerators of packs
+ packEnumerate,
+
+ -- * Helpers to process packs
+ packOpen,
+ packClose,
+
+ -- * Command for the content of a pack
+ packReadHeader,
+ packReadMapAtOffset,
+ packReadAtOffset,
+ packReadRawAtOffset,
+ packEnumerateObjects,
+
+ -- * turn a packed object into a
+ packedObjectToObject,
+ packObjectFromRaw,
+ )
+where
+import Control.Arrow (second)
import Data.Bits
-import Data.List
import qualified Data.ByteString.Lazy as L
-
-import qualified Data.Git.Parser as P
-import Data.Git.Internal
+import Data.Git.Delta
import Data.Git.Imports
+import Data.Git.Internal
+import Data.Git.OS
+import qualified Data.Git.Parser as P
import Data.Git.Path
-import Data.Git.Storage.Object
-import Data.Git.Delta
import Data.Git.Ref
-import Data.Git.Types
-import Data.Git.OS
import Data.Git.Storage.FileReader
-
+import Data.Git.Storage.Object
+import Data.Git.Types
+import Data.List
import Data.Word
type PackedObjectRaw hash = (PackedObjectInfo hash, L.ByteString)
data PackedObjectInfo hash = PackedObjectInfo
- { poiType :: ObjectType
- , poiOffset :: Word64
- , poiSize :: Word64
- , poiActualSize :: Word64
- , poiExtra :: Maybe (ObjectPtr hash)
- } deriving (Show,Eq)
+ { poiType :: ObjectType,
+ poiOffset :: Word64,
+ poiSize :: Word64,
+ poiActualSize :: Word64,
+ poiExtra :: Maybe (ObjectPtr hash)
+ }
+ deriving (Show, Eq)
-- | Enumerate the pack refs available in this repository.
packEnumerate :: HashAlgorithm hash => LocalPath -> IO [Ref hash]
packEnumerate repoPath = map onlyHash . filter isPackFile <$> listDirectoryFilename (repoPath </> "objects" </> "pack")
where
- isPackFile :: String -> Bool
- isPackFile x = ".pack" `isSuffixOf` x
- onlyHash = fromHexString . takebut 5 . drop 5
- takebut n l = take (length l - n) l
+ isPackFile :: String -> Bool
+ isPackFile x = ".pack" `isSuffixOf` x
+ onlyHash = fromHexString . takebut 5 . drop 5
+ takebut n l = take (length l - n) l
-- | open a pack
packOpen :: LocalPath -> Ref hash -> IO FileReader
@@ -75,21 +77,23 @@ packClose = fileReaderClose
-- | return the number of entries in this pack
packReadHeader :: LocalPath -> Ref hash -> IO Word32
packReadHeader repoPath packRef =
- withFileReader (packPath repoPath packRef) $ \filereader ->
- fileReaderParse filereader parseHeader
- where parseHeader = do
- packMagic <- P.word32
- when (packMagic /= 0x5041434b) $ error "not a git packfile"
- ver <- P.word32
- when (ver /= 2) $ error ("pack file version not supported: " ++ show ver)
- P.word32
+ withFileReader (packPath repoPath packRef) $ \filereader ->
+ fileReaderParse filereader parseHeader
+ where
+ parseHeader = do
+ packMagic <- P.word32
+ when (packMagic /= 0x5041434b) $ error "not a git packfile"
+ ver <- P.word32
+ when (ver /= 2) $ error ("pack file version not supported: " ++ show ver)
+ P.word32
-- | read an object at a specific position using a map function on the objectData
-packReadMapAtOffset :: HashAlgorithm hash
- => FileReader
- -> Word64
- -> (L.ByteString -> L.ByteString)
- -> IO (Maybe (Object hash))
+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
@@ -97,78 +101,84 @@ packReadAtOffset :: HashAlgorithm hash => FileReader -> Word64 -> IO (Maybe (Obj
packReadAtOffset fr offset = packReadMapAtOffset fr offset id
-- | read a raw representation at a specific position
-packReadRawAtOffset :: HashAlgorithm hash
- => FileReader
- -> Word64
- -> IO (PackedObjectRaw hash)
+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 :: HashAlgorithm hash
- => LocalPath
- -> Ref hash
- -> Int
- -> (PackedObjectRaw hash -> 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
- parseNext filebuffer entries
- where
- parseNext :: FileReader -> Int -> IO ()
- parseNext _ 0 = return ()
- parseNext fr ents = getNextObjectRaw fr >>= f >> parseNext fr (ents-1)
-
-getNextObject :: HashAlgorithm hash
- => FileReader
- -> (L.ByteString -> L.ByteString)
- -> IO (Maybe (Object hash))
+ withFileReader (packPath repoPath packRef) $ \filebuffer -> do
+ fileReaderSeek filebuffer 12
+ parseNext filebuffer entries
+ where
+ parseNext :: FileReader -> Int -> IO ()
+ parseNext _ 0 = return ()
+ parseNext fr ents = getNextObjectRaw fr >>= f >> parseNext fr (ents -1)
+
+getNextObject ::
+ HashAlgorithm hash =>
+ FileReader ->
+ (L.ByteString -> L.ByteString) ->
+ IO (Maybe (Object hash))
getNextObject fr mapData =
- packedObjectToObject . second mapData <$> getNextObjectRaw fr
-
-packedObjectToObject :: HashAlgorithm hash
- => (PackedObjectInfo hash, L.ByteString)
- -> Maybe (Object hash)
-packedObjectToObject (PackedObjectInfo { poiType = ty, poiExtra = extra }, objData) =
- packObjectFromRaw (ty, extra, objData)
-
-packObjectFromRaw :: HashAlgorithm hash
- => (ObjectType, Maybe (ObjectPtr hash), L.ByteString)
- -> Maybe (Object hash)
+ packedObjectToObject . second mapData <$> getNextObjectRaw fr
+
+packedObjectToObject ::
+ HashAlgorithm hash =>
+ (PackedObjectInfo hash, L.ByteString) ->
+ Maybe (Object hash)
+packedObjectToObject (PackedObjectInfo {poiType = ty, poiExtra = extra}, objData) =
+ packObjectFromRaw (ty, extra, objData)
+
+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)
-packObjectFromRaw (TypeTag, Nothing, objData) = P.maybeParseChunks objectParseTag (L.toChunks objData)
+packObjectFromRaw (TypeTree, Nothing, objData) = P.maybeParseChunks objectParseTree (L.toChunks objData)
+packObjectFromRaw (TypeBlob, Nothing, objData) = P.maybeParseChunks objectParseBlob (L.toChunks objData)
+packObjectFromRaw (TypeTag, Nothing, objData) = P.maybeParseChunks objectParseTag (L.toChunks objData)
packObjectFromRaw (TypeDeltaOff, Just (PtrOfs o), objData) = toObject . DeltaOfs o <$> deltaRead (L.toChunks objData)
packObjectFromRaw (TypeDeltaRef, Just (PtrRef r), objData) = toObject . DeltaRef r <$> deltaRead (L.toChunks objData)
-packObjectFromRaw _ = error "can't happen unless someone change getNextObjectRaw"
+packObjectFromRaw _ = error "can't happen unless someone change getNextObjectRaw"
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 <$> 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)
+ sobj <- fileReaderGetPos fr
+ (ty, size) <- fileReaderParse fr parseObjectHeader
+ extra <- case ty of
+ 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)
+ (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
+ (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)
- deltaOffFromList (x:xs) = foldl' acc (fromIntegral (x `clearBit` 7)) xs
- where acc a w = ((a+1) `shiftL` 7) + fromIntegral (w `clearBit` 7)
+ 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"
diff --git a/Data/Git/Storage/PackIndex.hs b/Data/Git/Storage/PackIndex.hs
index 1e15e73..56a2ba7 100644
--- a/Data/Git/Storage/PackIndex.hs
+++ b/Data/Git/Storage/PackIndex.hs
@@ -1,4 +1,5 @@
-{-# LANGUAGE OverloadedStrings, BangPatterns #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module : Data.Git.Storage.PackIndex
@@ -6,53 +7,51 @@
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unix
---
module Data.Git.Storage.PackIndex
- ( PackIndexHeader(..)
- , PackIndex(..)
+ ( PackIndexHeader (..),
+ PackIndex (..),
-- * handles and enumeration
- , packIndexOpen
- , packIndexClose
- , withPackIndex
- , packIndexEnumerate
+ packIndexOpen,
+ packIndexClose,
+ withPackIndex,
+ packIndexEnumerate,
-- * read from packIndex
- , packIndexHeaderGetNbWithPrefix
- , packIndexGetReferenceLocation
- , packIndexGetReferencesWithPrefix
- , packIndexReadHeader
- , packIndexRead
- , packIndexGetHeader
- ) where
+ packIndexHeaderGetNbWithPrefix,
+ packIndexGetReferenceLocation,
+ packIndexGetReferencesWithPrefix,
+ packIndexReadHeader,
+ packIndexRead,
+ packIndexGetHeader,
+ )
+where
-import Data.List
import Data.Bits
-import Data.Word
import Data.ByteString (ByteString)
-
-import Data.Vector (Vector, (!))
-import qualified Data.Vector as V
-
-import Data.Git.Internal
import Data.Git.Imports
+import Data.Git.Internal
import Data.Git.OS
-import Data.Git.Storage.FileReader
+import qualified Data.Git.Parser as P
import Data.Git.Path
import Data.Git.Ref
-import qualified Data.Git.Parser as P
+import Data.Git.Storage.FileReader
+import Data.List
+import Data.Vector (Vector, (!))
+import qualified Data.Vector as V
+import Data.Word
-- | 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 hash = PackIndex
- { packIndexSha1s :: Vector (Ref hash)
- , packIndexCRCs :: Vector Word32
- , packIndexPackoffs :: Vector Word32
- , packIndexPackChecksum :: Ref hash
- , packIndexChecksum :: Ref hash
- }
+ { 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 :: HashAlgorithm hash => LocalPath -> IO [Ref hash]
@@ -81,89 +80,90 @@ packIndexHeaderGetSize (PackIndexHeader _ indexes) = indexes ! 255
-- | byte size of an packIndex header.
packIndexHeaderByteSize :: Int
-packIndexHeaderByteSize = 2*4 {- header -} + 256*4 {- fanout table -}
+packIndexHeaderByteSize = 2 * 4 {- header -} + 256 * 4 {- fanout table -}
-- | get the number of reference in this index with a specific prefix
packIndexHeaderGetNbWithPrefix :: PackIndexHeader -> Int -> Word32
packIndexHeaderGetNbWithPrefix (PackIndexHeader _ indexes) n
- | n < 0 || n > 255 = 0
- | n == 0 = indexes ! 0
- | otherwise = (indexes ! n) - (indexes ! (n-1))
+ | n < 0 || n > 255 = 0
+ | n == 0 = indexes ! 0
+ | otherwise = (indexes ! n) - (indexes ! (n -1))
-- | fold on refs with a specific prefix
-packIndexHeaderFoldRef :: HashAlgorithm hash
- => PackIndexHeader
- -> FileReader
- -> hash
- -> Int
- -> (a -> Word32 -> Ref hash -> (a, Bool))
- -> a
- -> IO a
+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
+ | 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
+ 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 :: HashAlgorithm hash => PackIndexHeader -> FileReader -> Ref hash -> IO (Maybe Word64)
packIndexGetReferenceLocation idxHdr@(PackIndexHeader _ indexes) fr ref = do
- 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
+ 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
+ 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 :: HashAlgorithm hash => PackIndexHeader -> FileReader -> String -> IO [Ref hash]
packIndexGetReferencesWithPrefix idxHdr fr prefix =
- packIndexHeaderFoldRef idxHdr fr hashAlg refprefix f []
+ 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)
+ 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 :: 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
+ 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
@@ -174,23 +174,24 @@ packIndexGetHeader :: LocalPath -> Ref hash -> IO PackIndexHeader
packIndexGetHeader repoPath indexRef = withPackIndex repoPath indexRef $ packIndexReadHeader
-- | read all index
-packIndexRead :: HashAlgorithm hash
- => LocalPath
- -> Ref hash
- -> IO (PackIndexHeader, (Vector (Ref hash), Vector Word32, Vector Word32, [ByteString], Ref hash, Ref hash))
+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))
+ 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)
+ 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)
diff --git a/Data/Git/Types.hs b/Data/Git/Types.hs
index a4d3d2f..0995d50 100644
--- a/Data/Git/Types.hs
+++ b/Data/Git/Types.hs
@@ -6,140 +6,153 @@
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unix
---
module Data.Git.Types
- (
- -- * Type of types
- ObjectType(..)
+ ( -- * Type of types
+ ObjectType (..),
+
-- * Main git types
- , Tree(..)
- , Commit(..)
- , CommitExtra(..)
- , Blob(..)
- , Tag(..)
- , Person(..)
- , EntName
- , entName
- , getEntNameBytes
- , EntPath
- , entPathAppend
+ Tree (..),
+ Commit (..),
+ CommitExtra (..),
+ Blob (..),
+ Tag (..),
+ Person (..),
+ EntName,
+ entName,
+ getEntNameBytes,
+ EntPath,
+ entPathAppend,
+
-- * modeperm type
- , ModePerm(..)
- , FilePermissions(..)
- , ObjectFileType(..)
- , getPermission
- , getFiletype
+ ModePerm (..),
+ FilePermissions (..),
+ ObjectFileType (..),
+ getPermission,
+ getFiletype,
+
-- * time type
- , GitTime(..)
- , gitTime
- , gitTimeToLocal
+ GitTime (..),
+ gitTime,
+ gitTimeToLocal,
+
-- * Pack delta types
- , DeltaOfs(..)
- , DeltaRef(..)
+ DeltaOfs (..),
+ DeltaRef (..),
+
-- * Basic types part of other bigger types
- , TreeEnt
- ) where
+ TreeEnt,
+ )
+where
-import Data.Word
import Data.Bits
-import Data.String
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
-
-import Data.Git.Ref
+import qualified Data.ByteString.UTF8 as UTF8
+import Data.Data
import Data.Git.Delta
import Data.Git.Imports
-import Data.Hourglass (Elapsed, TimezoneOffset(..)
- , timePrint, timeConvert
- , Time(..), Timeable(..)
- , LocalTime, localTimeSetTimezone, localTimeFromGlobal)
-import Data.Data
-import qualified Data.ByteString.UTF8 as UTF8
+import Data.Git.Ref
+import Data.Hourglass
+ ( Elapsed,
+ LocalTime,
+ Time (..),
+ Timeable (..),
+ TimezoneOffset (..),
+ localTimeFromGlobal,
+ localTimeSetTimezone,
+ timeConvert,
+ timePrint,
+ )
+import Data.String
+import Data.Word
-- | type of a git object.
-data ObjectType =
- TypeTree
- | TypeBlob
- | TypeCommit
- | TypeTag
- | TypeDeltaOff
- | TypeDeltaRef
- deriving (Show,Eq,Data,Typeable)
+data ObjectType
+ = TypeTree
+ | TypeBlob
+ | TypeCommit
+ | TypeTag
+ | TypeDeltaOff
+ | TypeDeltaRef
+ deriving (Show, Eq, Data, Typeable)
-- | Git time is number of seconds since unix epoch in the UTC zone with
-- the current timezone associated
data GitTime = GitTime
- { gitTimeUTC :: !Elapsed
- , gitTimeTimezone :: !TimezoneOffset
- } deriving (Eq)
+ { gitTimeUTC :: !Elapsed,
+ gitTimeTimezone :: !TimezoneOffset
+ }
+ deriving (Eq)
instance Timeable GitTime where
- timeGetNanoSeconds _ = 0
- timeGetElapsedP (GitTime t _) = timeConvert t
- timeGetElapsed (GitTime t _) = t
+ timeGetNanoSeconds _ = 0
+ timeGetElapsedP (GitTime t _) = timeConvert t
+ timeGetElapsed (GitTime t _) = t
+
instance Time GitTime where
- timeFromElapsedP e = GitTime (timeGetElapsed e) (TimezoneOffset 0)
- timeFromElapsed e = GitTime e (TimezoneOffset 0)
+ timeFromElapsedP e = GitTime (timeGetElapsed e) (TimezoneOffset 0)
+ timeFromElapsed e = GitTime e (TimezoneOffset 0)
instance Show GitTime where
- show (GitTime t tz) =
- timePrint "EPOCH" t ++ " " ++ show tz
+ show (GitTime t tz) =
+ timePrint "EPOCH" t ++ " " ++ show tz
gitTime :: Integer -> Int -> GitTime
gitTime seconds tzMins =
- GitTime (fromIntegral seconds) (TimezoneOffset tzMins)
+ GitTime (fromIntegral seconds) (TimezoneOffset tzMins)
gitTimeToLocal :: GitTime -> LocalTime Elapsed
gitTimeToLocal (GitTime t tz) =
- localTimeSetTimezone tz (localTimeFromGlobal t)
+ localTimeSetTimezone tz (localTimeFromGlobal t)
-- | the enum instance is useful when marshalling to pack file.
instance Enum ObjectType where
- fromEnum TypeCommit = 0x1
- fromEnum TypeTree = 0x2
- fromEnum TypeBlob = 0x3
- fromEnum TypeTag = 0x4
- fromEnum TypeDeltaOff = 0x6
- fromEnum TypeDeltaRef = 0x7
-
- toEnum 0x1 = TypeCommit
- toEnum 0x2 = TypeTree
- toEnum 0x3 = TypeBlob
- toEnum 0x4 = TypeTag
- toEnum 0x6 = TypeDeltaOff
- toEnum 0x7 = TypeDeltaRef
- toEnum n = error ("not a valid object: " ++ show n)
+ fromEnum TypeCommit = 0x1
+ fromEnum TypeTree = 0x2
+ fromEnum TypeBlob = 0x3
+ fromEnum TypeTag = 0x4
+ fromEnum TypeDeltaOff = 0x6
+ fromEnum TypeDeltaRef = 0x7
+
+ toEnum 0x1 = TypeCommit
+ toEnum 0x2 = TypeTree
+ toEnum 0x3 = TypeBlob
+ toEnum 0x4 = TypeTag
+ toEnum 0x6 = TypeDeltaOff
+ toEnum 0x7 = TypeDeltaRef
+ toEnum n = error ("not a valid object: " ++ show n)
newtype ModePerm = ModePerm Word32
- deriving (Show,Eq)
+ deriving (Show, Eq)
getPermission :: ModePerm -> FilePermissions
getPermission (ModePerm modeperm) =
- let owner = (modeperm .&. 0x700) `shiftR` 6
- group = (modeperm .&. 0x70) `shiftR` 3
- other = modeperm .&. 0x7
- in FilePermissions (fromIntegral owner) (fromIntegral group) (fromIntegral other)
+ let owner = (modeperm .&. 0x700) `shiftR` 6
+ group = (modeperm .&. 0x70) `shiftR` 3
+ other = modeperm .&. 0x7
+ in FilePermissions (fromIntegral owner) (fromIntegral group) (fromIntegral other)
getFiletype :: ModePerm -> ObjectFileType
getFiletype (ModePerm modeperm) =
- case modeperm `shiftR` 12 of
- _ -> error "filetype unknown"
+ case modeperm `shiftR` 12 of
+ _ -> error "filetype unknown"
-- | Git object file type
-data ObjectFileType =
- FileTypeDirectory
- | FileTypeRegularFile
- | FileTypeSymbolicLink
- | FileTypeGitLink
- deriving (Show,Eq)
+data ObjectFileType
+ = FileTypeDirectory
+ | FileTypeRegularFile
+ | FileTypeSymbolicLink
+ | FileTypeGitLink
+ deriving (Show, Eq)
-- | traditional unix permission for owner, group and permissions
data FilePermissions = FilePermissions
- { getOwnerPerm :: {-# UNPACK #-} !Perm
- , getGroupPerm :: {-# UNPACK #-} !Perm
- , getOtherPerm :: {-# UNPACK #-} !Perm
- } deriving (Show,Eq)
+ { getOwnerPerm :: {-# UNPACK #-} !Perm,
+ getGroupPerm :: {-# UNPACK #-} !Perm,
+ getOtherPerm :: {-# UNPACK #-} !Perm
+ }
+ deriving (Show, Eq)
-- | a bitfield representing a typical unix permission:
-- * bit 0 represents the read permission
@@ -148,18 +161,21 @@ data FilePermissions = FilePermissions
type Perm = Word8
-- | Entity name
-newtype EntName = EntName { getEntNameBytes :: ByteString }
- deriving (Eq,Ord)
+newtype EntName = EntName {getEntNameBytes :: ByteString}
+ deriving (Eq, Ord)
+
instance Show EntName where
- show (EntName e) = UTF8.toString e
+ show (EntName e) = UTF8.toString e
+
instance IsString EntName where
- fromString s = entName $ UTF8.fromString s
+ fromString s = entName $ UTF8.fromString s
entName :: ByteString -> EntName
entName bs
- | B.elem slash bs = error ("entity name " ++ show bs ++ " contains an invalid '/' character")
- | otherwise = EntName bs
- where slash = 47
+ | B.elem slash bs = error ("entity name " ++ show bs ++ " contains an invalid '/' character")
+ | otherwise = EntName bs
+ where
+ slash = 47
entPathAppend :: EntPath -> EntName -> EntPath
entPathAppend l e = l ++ [e]
@@ -169,53 +185,57 @@ 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 hash = (ModePerm,EntName,Ref hash)
+type TreeEnt hash = (ModePerm, EntName, Ref hash)
-- | an author or committer line
-- has the format: name <email> time timezone
-- FIXME: should be a string, but I don't know if the data is stored
-- consistantly in one encoding (UTF8)
data Person = Person
- { personName :: !ByteString
- , personEmail :: !ByteString
- , personTime :: !GitTime
- } deriving (Show,Eq)
+ { personName :: !ByteString,
+ personEmail :: !ByteString,
+ personTime :: !GitTime
+ }
+ deriving (Show, Eq)
-- | Represent a root tree with zero to many tree entries.
-newtype Tree hash = Tree { treeGetEnts :: [TreeEnt hash] } deriving (Show,Eq)
+newtype Tree hash = Tree {treeGetEnts :: [TreeEnt hash]} deriving (Show, Eq)
-- | Represent a binary blob.
-newtype Blob hash = Blob { blobGetContent :: L.ByteString } deriving (Show,Eq)
+newtype Blob hash = Blob {blobGetContent :: L.ByteString} deriving (Show, Eq)
-- | Represent a commit object.
data Commit hash = Commit
- { commitTreeish :: !(Ref hash)
- , commitParents :: [Ref hash]
- , commitAuthor :: !Person
- , commitCommitter :: !Person
- , commitEncoding :: Maybe ByteString
- , commitExtras :: [CommitExtra]
- , commitMessage :: !ByteString
- } deriving (Show,Eq)
+ { commitTreeish :: !(Ref hash),
+ commitParents :: [Ref hash],
+ commitAuthor :: !Person,
+ commitCommitter :: !Person,
+ commitEncoding :: Maybe ByteString,
+ commitExtras :: [CommitExtra],
+ commitMessage :: !ByteString
+ }
+ deriving (Show, Eq)
data CommitExtra = CommitExtra
- { commitExtraKey :: !ByteString
- , commitExtraValue :: !ByteString
- } deriving (Show,Eq)
+ { commitExtraKey :: !ByteString,
+ commitExtraValue :: !ByteString
+ }
+ deriving (Show, Eq)
-- | Represent a signed tag.
data Tag hash = Tag
- { tagRef :: !(Ref hash)
- , tagObjectType :: !ObjectType
- , tagBlob :: !ByteString
- , tagName :: !Person
- , tagS :: !ByteString
- } deriving (Show,Eq)
+ { tagRef :: !(Ref hash),
+ tagObjectType :: !ObjectType,
+ tagBlob :: !ByteString,
+ tagName :: !Person,
+ tagS :: !ByteString
+ }
+ deriving (Show, Eq)
-- | Delta pointing to an offset.
data DeltaOfs hash = DeltaOfs !Word64 !Delta
- deriving (Show,Eq)
+ deriving (Show, Eq)
-- | Delta pointing to a ref.
data DeltaRef hash = DeltaRef !(Ref hash) !Delta
- deriving (Show,Eq)
+ deriving (Show, Eq)
diff --git a/Data/Git/WorkTree.hs b/Data/Git/WorkTree.hs
index 26a24d6..9a0ce40 100644
--- a/Data/Git/WorkTree.hs
+++ b/Data/Git/WorkTree.hs
@@ -8,45 +8,45 @@
-- Portability : unix
--
-- a load-on-demand, write-on-demand working tree.
---
module Data.Git.WorkTree
- ( WorkTree
- , EntType(..)
+ ( WorkTree,
+ EntType (..),
+
-- * Create new work trees
- , workTreeNew
- , workTreeFrom
- -- * Modifications methods
- , workTreeDelete
- , workTreeSet
- , workTreeFlush
- ) where
+ workTreeNew,
+ workTreeFrom,
-import Data.Git.Ref
-import Data.Git.Types
-import Data.Git.Storage.Object
-import Data.Git.Storage
-import Data.Git.Repository
+ -- * Modifications methods
+ workTreeDelete,
+ workTreeSet,
+ workTreeFlush,
+ )
+where
--import qualified Data.ByteString as B
+import Control.Concurrent.MVar
+import Control.Monad
+import Data.Git.Ref
+import Data.Git.Repository
+import Data.Git.Storage
+import Data.Git.Storage.Object
+import Data.Git.Types
import qualified Data.Map as M
-
import Data.Typeable
-import Control.Monad
-import Control.Concurrent.MVar
type Dir hash = M.Map EntName (ModePerm, TreeSt hash)
type TreeVar hash = MVar (Dir hash)
-data TreeSt hash =
- TreeRef (Ref hash)
- | TreeLoaded (TreeVar hash)
+data TreeSt hash
+ = TreeRef (Ref hash)
+ | TreeLoaded (TreeVar hash)
type WorkTree hash = MVar (TreeSt hash)
data EntType = EntDirectory | EntFile | EntExecutable
- deriving (Show,Eq)
+ deriving (Show, Eq)
-- | Create a new worktree
workTreeNew :: IO (WorkTree hash)
@@ -59,42 +59,46 @@ workTreeFrom ref = newMVar (TreeRef ref)
-- | delete a path from a working tree
--
-- if the path doesn't exist, no error is raised
-workTreeDelete :: (Typeable hash, HashAlgorithm hash)
- => Git hash
- -> WorkTree hash
- -> 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)
- dive varCurrent (x:xs) = do
- evarChild <- loadOrGetTree git x varCurrent $ \m -> return (m, Right ())
- case evarChild of
- Left varChild -> dive varChild xs
- Right () -> return ()
+ where
+ dive _ [] = error "internal error: delete: empty dive"
+ dive varCurrent [file] = modifyMVar_ varCurrent (return . M.delete file)
+ dive varCurrent (x : xs) = do
+ evarChild <- loadOrGetTree git x varCurrent $ \m -> return (m, Right ())
+ case evarChild of
+ Left varChild -> dive varChild xs
+ Right () -> return ()
-- | Set a file in this working tree to a specific ref.
--
-- 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 :: (Typeable hash, HashAlgorithm hash)
- => Git hash
- -> WorkTree hash
- -> EntPath
- -> (EntType, Ref hash)
- -> 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 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
- evarChild <- loadOrGetTree git x varCurrent $ \m -> do
- -- create an empty tree
- v <- newMVar M.empty
- return (M.insert x (entTypeToPerm EntDirectory, TreeLoaded v) m, Left v)
- case evarChild of
- Left varChild -> dive varChild xs
- Right () -> return ()
+ 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
+ evarChild <- loadOrGetTree git x varCurrent $ \m -> do
+ -- create an empty tree
+ v <- newMVar M.empty
+ return (M.insert x (entTypeToPerm EntDirectory, TreeLoaded v) m, Left v)
+ case evarChild of
+ Left varChild -> dive varChild xs
+ Right () -> return ()
{-
workTreeFlushAt :: Git -> WorkTree -> EntPath -> IO ()
@@ -106,69 +110,73 @@ workTreeFlushAt git wt path = do
-- and return the root ref of the work tree.
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
- wtVal <- takeMVar wt
- case wtVal of
- TreeRef ref -> putMVar wt wtVal >> return ref
- TreeLoaded var -> do
- ref <- writeTreeRecursively (TreeLoaded var)
- putMVar wt $ TreeRef ref
- return ref
- where writeTreeRecursively (TreeRef ref) = return ref
- writeTreeRecursively (TreeLoaded var) = do
- c <- readMVar var
- ents <- forM (M.toList c) $ \(bs, (mperm, entSt)) -> do
- ref <- writeTreeRecursively entSt
- return (mperm, bs, ref)
- setTree ents
-
- setTree ents = setObject git (toObject $ Tree ents)
+ -- write all the trees that need to be written
+ -- switch to modifyMVar
+ wtVal <- takeMVar wt
+ case wtVal of
+ TreeRef ref -> putMVar wt wtVal >> return ref
+ TreeLoaded var -> do
+ ref <- writeTreeRecursively (TreeLoaded var)
+ putMVar wt $ TreeRef ref
+ return ref
+ where
+ writeTreeRecursively (TreeRef ref) = return ref
+ writeTreeRecursively (TreeLoaded var) = do
+ c <- readMVar var
+ ents <- forM (M.toList c) $ \(bs, (mperm, entSt)) -> do
+ ref <- writeTreeRecursively entSt
+ return (mperm, bs, ref)
+ setTree ents
+
+ setTree ents = setObject git (toObject $ Tree ents)
----- helpers -----
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
- newMVar t
+ (Tree ents) <- getTree git treeRef
+ let t = foldr (\(m, b, r) acc -> M.insert b (m, TreeRef r) acc) M.empty ents
+ newMVar t
entTypeToPerm :: EntType -> ModePerm
-entTypeToPerm EntDirectory = ModePerm 0o040000
+entTypeToPerm EntDirectory = ModePerm 0o040000
entTypeToPerm EntExecutable = ModePerm 0o100755
-entTypeToPerm EntFile = ModePerm 0o100644
-
-loadOrGetTree :: (Typeable hash, HashAlgorithm hash)
- => Git hash
- -> EntName
- -> TreeVar hash
- -> (Dir hash -> IO (Dir hash, Either (TreeVar hash) a))
- -> IO (Either (TreeVar hash) a)
+entTypeToPerm EntFile = ModePerm 0o100644
+
+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
- Nothing -> onMissing m
- Just (_, treeSt) -> -- check perm to see if it is a directory
- case treeSt of
- TreeRef ref -> do
- -- replace the ref by a loaded tree
- var <- loadTreeVar git ref
- return (M.adjust (\(perm,_) -> (perm, TreeLoaded var)) x m, Left var)
- TreeLoaded var -> return (m, Left var)
-
-diveFromRoot :: (Typeable hash, HashAlgorithm hash)
- => Git hash
- -> WorkTree hash
- -> EntPath
- -> (TreeVar hash -> EntPath -> IO ())
- -> IO ()
+ modifyMVar varCurrent $ \m -> do
+ case M.lookup x m of
+ Nothing -> onMissing m
+ Just (_, treeSt) ->
+ -- check perm to see if it is a directory
+ case treeSt of
+ TreeRef ref -> do
+ -- replace the ref by a loaded tree
+ var <- loadTreeVar git ref
+ return (M.adjust (\(perm, _) -> (perm, TreeLoaded var)) x m, Left var)
+ TreeLoaded var -> return (m, Left var)
+
+diveFromRoot ::
+ (Typeable hash, HashAlgorithm hash) =>
+ Git hash ->
+ WorkTree hash ->
+ EntPath ->
+ (TreeVar hash -> EntPath -> IO ()) ->
+ IO ()
diveFromRoot git wt path dive
- | path == [] = return ()
- | otherwise = do
- -- switch to modifyMVar
- wtVal <- takeMVar wt
- current <- case wtVal of
- TreeLoaded var -> return var
- TreeRef ref -> loadTreeVar git ref
- putMVar wt $ TreeLoaded current
- dive current path
+ | path == [] = return ()
+ | otherwise = do
+ -- switch to modifyMVar
+ wtVal <- takeMVar wt
+ current <- case wtVal of
+ TreeLoaded var -> return var
+ TreeRef ref -> loadTreeVar git ref
+ putMVar wt $ TreeLoaded current
+ dive current path
diff --git a/tests/Monad.hs b/tests/Monad.hs
index b6e5fbf..02cd2e8 100644
--- a/tests/Monad.hs
+++ b/tests/Monad.hs
@@ -1,15 +1,15 @@
{-# LANGUAGE OverloadedStrings #-}
module Monad
- ( testGitMonadLocal
- ) where
+ ( testGitMonadLocal,
+ )
+where
import Control.Applicative
import Control.Exception
import Control.Monad
-
import Data.Git.Monad
-import Data.Git.Types (GitTime(..))
+import Data.Git.Types (GitTime (..))
import System.Exit
import qualified System.Hourglass as T
@@ -18,46 +18,49 @@ 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]"
+ 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
+ putStrLn " test/git/monad [FAILED]"
+ putStrLn $ " - " ++ msg
+ exitFailure
testGitMonadLocal :: IO ()
testGitMonadLocal = catchAll (withCurrentRepo testGitMonad)
timeCurrentGit :: GitM GitTime
-timeCurrentGit = liftGit $ GitTime
- <$> T.timeCurrent
- <*> T.timezoneCurrent
+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"
+ 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"
diff --git a/tests/Repo.hs b/tests/Repo.hs
index 14d4982..f27fde5 100644
--- a/tests/Repo.hs
+++ b/tests/Repo.hs
@@ -1,68 +1,63 @@
{-# 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 qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
import Data.Git.Ref
-import Data.Git.Types
import Data.Git.Repository
-
+import Data.Git.Storage
+import Data.Git.Storage.Loose
+import Data.Git.Storage.Object
+import Data.Git.Types
import Data.Maybe
-
-import Text.Bytedump
-import System.Exit
-
import Monad
+import System.Exit
+import Test.Tasty
+import Test.Tasty.QuickCheck
+import Text.Bytedump
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))]]
+ 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
+ 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
+ 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
+ | 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 ()
+ onLocalRepo $ \(git :: Git SHA1) -> do
+ doLocalMarshallEq git >>= printLocalMarshallError . catMaybes . concat
+ testGitMonadLocal
+ return ()
diff --git a/tests/Tests.hs b/tests/Tests.hs
index dd03c18..661b194 100644
--- a/tests/Tests.hs
+++ b/tests/Tests.hs
@@ -1,140 +1,160 @@
{-# 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 qualified Data.ByteString as B
+import qualified Data.ByteString.Lazy as L
import Data.Git.Ref
import Data.Git.Revision
+import Data.Git.Storage.Loose
+import Data.Git.Storage.Object
import Data.Git.Types
import Data.Hourglass
-
import Data.Maybe
+import Test.Tasty
+import Test.Tasty.QuickCheck
-- for arbitrary instance to generate only data that are writable
-- to disk. i.e. no deltas.
data ObjNoDelta hash = ObjNoDelta (Object hash)
- deriving (Eq)
+ deriving (Eq)
instance Show (ObjNoDelta hash) where
- show (ObjNoDelta o) = show o
+ 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)
-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)
+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)
- ]
+ 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")
+ arbitrary = arbitraryRef (error "alg")
arbitraryMsg = arbitraryBSno0 1
-arbitraryLazy = L.fromChunks . (:[]) <$> arbitraryBS 40
+
+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
+
+arbitraryEnts = choose (1, 2) >>= \i -> replicateM i arbitraryEnt
instance Arbitrary TimezoneOffset where
- arbitrary = TimezoneOffset <$> choose (-11*60, 12*60)
+ arbitrary = TimezoneOffset <$> choose (-11 * 60, 12 * 60)
+
instance Arbitrary Elapsed where
- arbitrary = Elapsed . Seconds <$> choose (0,2^32-1)
+ arbitrary = Elapsed . Seconds <$> choose (0, 2 ^ 32 -1)
+
instance Arbitrary GitTime where
- arbitrary = GitTime <$> arbitrary <*> arbitrary
+ arbitrary = GitTime <$> arbitrary <*> arbitrary
+
instance Arbitrary ModePerm where
- arbitrary = ModePerm <$> elements [ 0o644, 0o664, 0o755, 0 ]
+ arbitrary = ModePerm <$> elements [0o644, 0o664, 0o755, 0]
+
instance Arbitrary RevModifier where
- arbitrary = oneof
- [ RevModParent . getPositive <$> arbitrary
- , RevModParentFirstN . getPositive <$> arbitrary
- , RevModAtType <$> arbitraryType
- , RevModAtDate <$> arbitraryDate
+ arbitrary =
+ oneof
+ [ RevModParent . getPositive <$> arbitrary,
+ RevModParentFirstN . getPositive <$> arbitrary,
+ RevModAtType <$> arbitraryType,
+ RevModAtDate <$> arbitraryDate
--, RevModAtN . getPositive <$> arbitrary
- ]
+ ]
+
+arbitraryDate = elements ["yesterday", "29-Jan-1982", "5 days ago"]
-arbitraryDate = elements ["yesterday","29-Jan-1982","5 days ago"]
-arbitraryType = elements ["commit","tree"]
+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
+ 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
+arbitraryName =
+ liftM3
+ Person
+ (arbitraryBSnoangle 16)
+ (arbitraryBSnoangle 16)
+ arbitrary
-arbitraryObjTypeNoDelta = oneof [return TypeTree,return TypeBlob,return TypeCommit,return TypeTag]
+arbitraryObjTypeNoDelta = oneof [return TypeTree, return TypeBlob, return TypeCommit, return TypeTag]
-arbitrarySmallList = frequency [ (2, return []), (1, resize 3 arbitrary) ]
+arbitrarySmallList = frequency [(2, return []), (1, resize 3 arbitrary)]
instance Arbitrary (Commit SHA1) where
- arbitrary = Commit <$> arbitrary <*> arbitraryRefList <*> arbitraryName <*> arbitraryName <*> return Nothing <*> arbitrarySmallList <*> arbitraryMsg
+ arbitrary = Commit <$> arbitrary <*> arbitraryRefList <*> arbitraryName <*> arbitraryName <*> return Nothing <*> arbitrarySmallList <*> arbitraryMsg
instance Arbitrary CommitExtra where
- arbitrary = CommitExtra <$> arbitraryBSasciiNoSpace 80 <*> arbitraryMsg
+ arbitrary = CommitExtra <$> arbitraryBSasciiNoSpace 80 <*> arbitraryMsg
instance Arbitrary (Tree SHA1) where
- arbitrary = Tree <$> arbitraryEnts
+ arbitrary = Tree <$> arbitraryEnts
instance Arbitrary (Blob SHA1) where
- arbitrary = Blob <$> arbitraryLazy
+ arbitrary = Blob <$> arbitraryLazy
instance Arbitrary (Tag SHA1) where
- arbitrary = Tag <$> arbitrary <*> arbitraryObjTypeNoDelta <*> arbitraryBSascii 20 <*> arbitraryName <*> arbitraryMsg
+ 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))
+ 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)
+ 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)
+ [ 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
- ]
+ [ testProperty "unmarshall.marshall==id" prop_object_marshalling_id
+ ]
+
+main =
+ defaultMain $
+ testGroup
+ "hit"
+ [ testGroup "ref marshalling" refTests,
+ testGroup "object marshalling" objTests
+ ]
--
GitLab