git (empty) → 0.1
raw patch · 31 files changed
+4653/−0 lines, 31 filesdep +basedep +byteabledep +bytedumpsetup-changed
Dependencies added: base, byteable, bytedump, bytestring, containers, cryptonite, git, hourglass, memory, mtl, patience, random, system-fileio, system-filepath, tasty, tasty-quickcheck, unix-compat, utf8-string, vector, zlib, zlib-bindings
Files
- Data/Git.hs +86/−0
- Data/Git/Config.hs +84/−0
- Data/Git/Delta.hs +80/−0
- Data/Git/Diff.hs +284/−0
- Data/Git/Imports.hs +7/−0
- Data/Git/Internal.hs +25/−0
- Data/Git/Monad.hs +713/−0
- Data/Git/Named.hs +178/−0
- Data/Git/OS.hs +101/−0
- Data/Git/Parser.hs +131/−0
- Data/Git/Path.hs +54/−0
- Data/Git/Ref.hs +125/−0
- Data/Git/Repository.hs +316/−0
- Data/Git/Revision.hs +129/−0
- Data/Git/Storage.hs +349/−0
- Data/Git/Storage/CacheFile.hs +37/−0
- Data/Git/Storage/FileReader.hs +206/−0
- Data/Git/Storage/FileWriter.hs +64/−0
- Data/Git/Storage/Loose.hs +199/−0
- Data/Git/Storage/Object.hs +355/−0
- Data/Git/Storage/Pack.hs +154/−0
- Data/Git/Storage/PackIndex.hs +183/−0
- Data/Git/Types.hs +227/−0
- Data/Git/WorkTree.hs +151/−0
- LICENSE +28/−0
- README.md +19/−0
- Setup.hs +2/−0
- git.cabal +108/−0
- tests/Monad.hs +63/−0
- tests/Repo.hs +63/−0
- tests/Tests.hs +132/−0
+ Data/Git.hs view
@@ -0,0 +1,86 @@+-- |+-- Module : Data.Git+-- License : BSD-style+-- 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++ -- * Helper & type related to ModePerm+ , ObjectFileType(..)+ , FilePermissions(..)+ , getPermission+ , getFiletype++ -- * Revision+ , Revision+ , resolveRevision++ -- * Object resolution+ , resolveTreeish+ , resolvePath++ -- * repo context+ , Git+ , withCurrentRepo+ , withRepo+ , findRepo++ -- * Repository queries and creation+ , initRepo+ , isRepo++ -- * Context operations+ , rewrite++ -- * Get objects+ , getObject+ , getCommit+ , getTree++ -- * Set objects+ , setObject+ , toObject++ -- * Work trees+ , WorkTree+ , EntType(..)+ , workTreeNew+ , workTreeFrom+ , workTreeDelete+ , workTreeSet+ , workTreeFlush++ -- * Named refs+ , 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.Object (toObject)+import Data.Git.WorkTree
+ Data/Git/Config.hs view
@@ -0,0 +1,84 @@+-- |+-- Module : Data.Git.Config+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unix+--+-- config related types and methods.+--+{-# LANGUAGE OverloadedStrings #-}+module Data.Git.Config+ ( Config(..)+ , Section(..)+ -- * reading methods+ , readConfig+ , readGlobalConfig+ -- * methods+ , listSections+ , get+ ) where++import Data.Git.Path+import Data.Git.Imports+import Data.Git.OS+import Data.List (find)+import qualified Data.Set as S++newtype Config = Config [Section]+ deriving (Show,Eq)++data Section = Section+ { 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++ -- 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++ strip s = dropSpaces $ reverse $ dropSpaces $ reverse s+ where dropSpaces = dropWhile (\c -> c == ' ' || c == '\t')++readConfigPath :: LocalPath -> IO Config+readConfigPath filepath = parseConfig <$> readTextFile filepath++readConfig :: LocalPath -> IO Config+readConfig gitRepo = readConfigPath (configPath gitRepo)++readGlobalConfig :: IO Config+readGlobalConfig = getHomeDirectory >>= readConfigPath . (\homeDir -> homeDir </> ".gitconfig")++listSections :: [Config] -> [String]+listSections = S.toList . foldr accSections S.empty+ 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
+ Data/Git/Delta.hs view
@@ -0,0 +1,80 @@+-- |+-- Module : Data.Git.Delta+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unix+--+module Data.Git.Delta+ ( Delta(..)+ , DeltaCmd(..)+ , deltaParse+ , deltaRead+ , deltaApply+ ) where++import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as L+import Data.Bits+import Data.Word++import qualified Data.Git.Parser as P+import Data.Git.Imports++-- | a delta is a source size, a destination size and a list of delta cmd+data Delta = Delta Word64 Word64 [DeltaCmd]+ 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)++-- | parse a delta.+-- format is 2 variable sizes, followed by delta cmds. for each cmd:+-- * if first byte MSB is set, we copy from source.+-- * otherwise, we copy from delta.+-- * extensions are not handled.+deltaParse :: P.Parser Delta+deltaParse = do+ 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)+ word8cond cond sh =+ if cond then (flip shiftL sh . fromIntegral) <$> P.anyByte else return 0++-- | read one delta from a lazy bytestring.+deltaRead :: [ByteString] -> Maybe Delta+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
+ Data/Git/Diff.hs view
@@ -0,0 +1,284 @@+-- |+-- Module : Data.Git.Diff+-- License : BSD-style+-- Maintainer : Nicolas DI PRIMA <nicolas@di-prima.fr>+-- Stability : experimental+-- Portability : unix+--+-- Basic Git diff methods.+--++module Data.Git.Diff+ (+ -- * Basic features+ BlobContent(..)+ , BlobState(..)+ , BlobStateDiff(..)+ , getDiffWith+ -- * Default helpers+ , GitDiff(..)+ , GitFileContent(..)+ , FilteredDiff(..)+ , GitFileRef(..)+ , GitFileMode(..)+ , TextLine(..)+ , defaultDiff+ , getDiff+ ) where++import Data.List (find, filter)+import Data.Char (ord)+import Data.Git+import Data.Git.Repository+import Data.Git.Storage+import Data.Git.Storage.Object+import Data.ByteString.Lazy.Char8 as L++import Data.Algorithm.Patience as AP (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)++-- | This is a blob description at a given state (revision)+data BlobState = BlobState+ { bsFilename :: EntPath+ , bsMode :: ModePerm+ , bsRef :: Ref+ , 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 where+ (BlobState f1 _ _ _) == (BlobState f2 _ _ _) = f2 == f1++-- | Represents a file state between two revisions+-- A file (a blob) can be present in the first Tree's revision but not in the+-- second one, then it has been deleted. If only in the second Tree's revision,+-- then it has been created. If it is in the both, maybe it has been changed.+data BlobStateDiff = OnlyOld BlobState+ | OnlyNew BlobState+ | OldAndNew BlobState BlobState++buildListForDiff :: Git -> Ref -> IO [BlobState]+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 -> EntPath -> IO [BlobState]+ 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 -> 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++-- | generate a diff list between two revisions with a given diff helper.+--+-- Useful to extract any kind of information from two different revisions.+-- For example you can get the number of deleted files:+--+-- > getdiffwith f 0 head^ head git+-- > where f (OnlyOld _) acc = acc+1+-- > f _ acc = acc+--+-- Or save the list of new files:+--+-- > getdiffwith f [] head^ head git+-- > where f (OnlyNew bs) acc = (bsFilename bs):acc+-- > f _ acc = acc+getDiffWith :: (BlobStateDiff -> a -> a) -- ^ diff helper (State -> accumulator -> accumulator)+ -> a -- ^ accumulator+ -> Ref -- ^ commit reference (the original state)+ -> Ref -- ^ commit reference (the new state)+ -> Git -- ^ repository+ -> IO a+getDiffWith f acc ref1 ref2 git = do+ commit1 <- buildListForDiff git ref1+ commit2 <- buildListForDiff git ref2+ return $ Prelude.foldr f acc $ doDiffWith commit1 commit2+ where+ doDiffWith :: [BlobState] -> [BlobState] -> [BlobStateDiff]+ doDiffWith [] [] = []+ 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+ }+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++data FilteredDiff = NormalLine (Item TextLine) | Separator++data GitFileContent = NewBinaryFile+ | OldBinaryFile+ | NewTextFile [TextLine]+ | OldTextFile [TextLine]+ | ModifiedBinaryFile+ | ModifiedFile [FilteredDiff]+ | UnModifiedFile++data GitFileMode = NewMode ModePerm+ | OldMode ModePerm+ | ModifiedMode ModePerm ModePerm+ | UnModifiedMode ModePerm++data GitFileRef = NewRef Ref+ | OldRef Ref+ | ModifiedRef Ref Ref+ | UnModifiedRef Ref++-- | This is a proposed diff records for a given file.+-- It contains useful information:+-- * the filename (with its path in the root project)+-- * a file diff (with the Data.Algorithm.Patience method)+-- * the file's mode (i.e. the file priviledge)+-- * the file's ref+data GitDiff = GitDiff+ { hFileName :: EntPath+ , hFileContent :: GitFileContent+ , hFileMode :: GitFileMode+ , hFileRef :: GitFileRef+ }++-- | A default Diff getter which returns all diff information (Mode, Content+-- and Binary) with a context of 5 lines.+--+-- > getDiff = getDiffWith (defaultDiff 5) []+getDiff :: Ref+ -> Ref+ -> Git+ -> IO [GitDiff]+getDiff = getDiffWith (defaultDiff 5) []++-- | A default diff helper. It is an example about how you can write your own+-- diff helper or you can use it if you want to get all of differences.+defaultDiff :: Int -- ^ Number of line for context+ -> BlobStateDiff+ -> [GitDiff] -- ^ Accumulator+ -> [GitDiff] -- ^ Accumulator with a new content+defaultDiff _ (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 -> 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++-- Used by diffGetContext+data GitAccu = AccuBottom | AccuTop++-- Context filter+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 l1 _)) -> if (lineNumber l1) > 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 (Both l1 l2) (c, AccuBottom, acc) =+ if c < context then (c+1, AccuBottom, (NormalLine (Both l1 l2)):acc)+ else (c , AccuBottom, (NormalLine (Both l1 l2))+ :((Prelude.take (context-1) acc)+ ++ [Separator]+ ++ (Prelude.drop (context+1) acc)))+ filterContext (Both l1 l2) (c, AccuTop, acc) =+ if c < context then (c+1, AccuTop , (NormalLine (Both l1 l2)):acc)+ else (0 , AccuBottom, (NormalLine (Both l1 l2)):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++ removeTrailingBoth :: [FilteredDiff] -> [FilteredDiff]+ removeTrailingBoth diffList =+ let test = startWithSeparator diffList+ in if test then Prelude.tail $ Prelude.dropWhile (\a -> not $ startWithSeparator [a]) diffList+ else diffList
+ Data/Git/Imports.hs view
@@ -0,0 +1,7 @@+module Data.Git.Imports+ ( module X+ ) where++import Control.Applicative as X+import Control.Monad as X+import Data.Monoid as X
+ Data/Git/Internal.hs view
@@ -0,0 +1,25 @@+-- |+-- Module : Data.Git.Internal+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unix+--+module Data.Git.Internal+ ( be32+ , be16+ ) where++import Data.Bits+import Data.Word+import qualified Data.ByteString as B++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)++be16 :: B.ByteString -> Word16+be16 b = fromIntegral (B.index b 0) `shiftL` 8+ + fromIntegral (B.index b 1)
+ Data/Git/Monad.hs view
@@ -0,0 +1,713 @@+-- |+-- Module : Data.Git.Monad+-- License : BSD-style+-- Maintainer : Nicolas DI PRIMA <nicolas@di-prima.fr>+-- Stability : experimental+-- Portability : unix+--+-- Simplifies the Git operation presents in this package.+--+-- You can easily access to the usual Git general informations:+--+-- * access to Head, Branches or Tags+-- * direct access to a Commit+--+-- This module also defines a convenient Monad to access the whole information+-- from a Commit: see 'CommitAccessMonad' and 'withCommit'.+--+-- You can also easily create a new commit: see 'CommitM' and 'withNewCommit'+--++{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE TypeSynonymInstances #-}++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+++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 qualified Data.Git.Repository as Git+import qualified Data.Git.Storage.Object as Git+import Data.Git.Imports+import Data.Git.OS++--import qualified Filesystem.Path as FP++import Data.Set (Set)++-------------------------------------------------------------------------------+-- Revision helper --+-------------------------------------------------------------------------------++revisionFromString :: String -> Git.Revision+revisionFromString = Git.fromString++-- | this is a convenient class to allow a common interface for what user may+-- need to optain a Ref from a given Resolvable object.+--+-- each of this instances is a convenient implementation of what a user would+-- have to do in order to resolve a branch, a tag or a String.+--+-- > resolve (Ref "2ad98b90...2ca") === Ref "2ad98b90...2ca"+-- > resolve "master"+-- > resolve "HEAD^^^"+--+class Resolvable rev where+ resolve :: GitMonad m => rev -> m (Maybe Git.Ref)+instance Resolvable Git.Ref where+ resolve = return . Just+instance Resolvable Git.Revision where+ resolve rev = do+ git <- getGit+ liftGit $ Git.resolveRevision git rev+instance Resolvable String where+ resolve = resolve . revisionFromString+instance Resolvable Git.RefName where+ resolve = resolve . Git.refNameRaw++-------------------------------------------------------------------------------+-- GitMonad --+-------------------------------------------------------------------------------++-- | Basic operations common between the different Monads defined in this+-- package.+class (Functor m, Applicative m, Monad m) => GitMonad m where+ -- | the current Monad must allow access to the current Git+ getGit :: m Git.Git+ liftGit :: IO a -> m a++branchList :: GitMonad git => git (Set Git.RefName)+branchList = getGit >>= liftGit . Git.branchList++branchWrite :: GitMonad git => Git.RefName -> Git.Ref -> git ()+branchWrite rn ref = do+ 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 -> git ()+tagWrite rn ref = do+ git <- getGit+ liftGit $ Git.tagWrite git rn ref++headGet :: GitMonad git => git (Either Git.Ref Git.RefName)+headGet = getGit >>= liftGit . Git.headGet++headResolv :: GitMonad git => git (Maybe Git.Ref)+headResolv = do+ e <- headGet+ case e of+ Left ref -> resolve ref+ Right v -> resolve v++headSet :: GitMonad git => Either Git.Ref Git.RefName -> git ()+headSet e = do+ git <- getGit+ liftGit $ Git.headSet git e++getCommit :: (GitMonad git, Resolvable ref) => ref -> git (Maybe Git.Commit)+getCommit r = do+ 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 -> git Git.Ref+setObject obj = do+ git <- getGit+ liftGit $ Git.setObject git $ Git.toObject obj++getObject :: (GitMonad git, Resolvable ref)+ => ref+ -> Bool+ -> git (Maybe Git.Object)+getObject rev resolvDelta = do+ 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+workTreeNew = liftGit Git.workTreeNew++workTreeFrom :: GitMonad git => Git.Ref -> git Git.WorkTree+workTreeFrom ref = liftGit $ Git.workTreeFrom ref++workTreeFlush :: GitMonad git => Git.WorkTree -> git Git.Ref+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)+resolvPath commitRev entPath = do+ 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++-------------------------------------------------------------------------------+-- GitM --+-------------------------------------------------------------------------------++data GitContext = GitContext+ { gitContextGit :: !Git.Git+ }++newtype GitM a = GitM+ { runGitM :: GitContext -> IO (Result GitContext a)+ }++instance Functor GitM where+ fmap = fmapGitM++instance Applicative GitM where+ pure = returnGitM+ (<*>) = appendGitM++instance Monad GitM where+ return = returnGitM+ (>>=) = bindGitM+ fail = failGitM++instance GitMonad GitM where+ 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++returnGitM :: a -> GitM a+returnGitM v = GitM $ \ctx -> return (ResultSuccess ctx v)++appendGitM :: GitM (a -> b) -> GitM a -> GitM b+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)++failGitM :: String -> GitM a+failGitM msg = GitM $ \_ -> return (ResultFailure msg)++getGitM :: GitM Git.Git+getGitM = GitM $ \ctx -> return (ResultSuccess ctx (gitContextGit ctx))++liftGitM :: IO a -> GitM a+liftGitM f = GitM $ \ctx -> ResultSuccess ctx <$> f++executeGitM :: Git.Git -> GitM a -> IO (Either String a)+executeGitM git m = do+ 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)++withCurrentRepo :: GitM a -> IO (Either String a)+withCurrentRepo m = Git.withCurrentRepo (\git -> executeGitM git m)+++-------------------------------------------------------------------------------+-- CommitAccessM --+-------------------------------------------------------------------------------++data CommitAccessContext = CommitAccessContext+ { commitAccessContextCommit :: !Git.Commit+ , commitAccessContextRef :: !Git.Ref+ }++-- | ReadOnly operations on a given commit+newtype CommitAccessM a = CommitAccessM+ { runCommitAccessM :: forall git . GitMonad git => CommitAccessContext -> git (Result CommitAccessContext a)+ }++instance Functor CommitAccessM where+ fmap = fmapCommitAccessM++instance Applicative CommitAccessM where+ pure = returnCommitAccessM+ (<*>) = appendCommitAccessM++instance Monad CommitAccessM where+ return = returnCommitAccessM+ (>>=) = bindCommitAccessM+ fail = failCommitAccessM++instance GitMonad CommitAccessM where+ 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++returnCommitAccessM :: a -> CommitAccessM a+returnCommitAccessM v = CommitAccessM $ \ctx -> return (ResultSuccess ctx v)++appendCommitAccessM :: CommitAccessM (a -> b) -> CommitAccessM a -> CommitAccessM b+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)++failCommitAccessM :: String -> CommitAccessM a+failCommitAccessM msg = CommitAccessM $ \_ -> return (ResultFailure msg)++getCommitAccessM :: CommitAccessM Git.Git+getCommitAccessM = CommitAccessM $ \ctx -> ResultSuccess ctx <$> getGit++liftCommitAccessM :: IO a -> CommitAccessM a+liftCommitAccessM f = CommitAccessM $ \ctx -> ResultSuccess ctx <$> (liftGit f)++-- Operations -----------------------------------------------------------------++withCommitAccessContext :: (CommitAccessContext -> a) -> CommitAccessM a+withCommitAccessContext operation = CommitAccessM $ \ctx ->+ return $ ResultSuccess ctx $ operation ctx++getAuthor :: CommitAccessM Git.Person+getAuthor = withCommitAccessContext (Git.commitAuthor . commitAccessContextCommit)++getCommitter :: CommitAccessM Git.Person+getCommitter = withCommitAccessContext (Git.commitCommitter . commitAccessContextCommit)++getParents :: CommitAccessM [Git.Ref]+getParents = withCommitAccessContext (Git.commitParents . commitAccessContextCommit)++getExtras :: CommitAccessM [Git.CommitExtra]+getExtras = withCommitAccessContext (Git.commitExtras . commitAccessContextCommit)++getEncoding :: CommitAccessM (Maybe ByteString)+getEncoding = withCommitAccessContext (Git.commitEncoding . commitAccessContextCommit)++getMessage :: CommitAccessM ByteString+getMessage = withCommitAccessContext (Git.commitMessage . commitAccessContextCommit)++getContextRef_ :: CommitAccessM Git.Ref+getContextRef_ = withCommitAccessContext commitAccessContextRef++getContextObject_ :: Git.EntPath -> CommitAccessM (Maybe Git.Object)+getContextObject_ fp = do+ 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+--+-- if the given Path is not a file or does not exist,+-- 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++-- | list the element present in the Given Directory Path+--+-- if the given Path is not a directory or does not exist,+-- 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++-- | open a commit in the current GitMonad+--+-- Read commit's info (Author, Committer, message...) or Commit's Tree.+--+-- > withCurrentRepo $+-- > withCommit "master" $ do+-- > -- print the commit's author information+-- > author <- getAuthor+-- > liftGit $ print author+-- >+-- > -- 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 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++-------------------------------------------------------------------------------+-- CommitM --+-------------------------------------------------------------------------------++data CommitContext = CommitContext+ { commitContextAuthor :: !Git.Person+ , commitContextCommitter :: !Git.Person+ , commitContextParents :: ![Git.Ref]+ , commitContextExtras :: ![Git.CommitExtra]+ , commitContextEncoding :: !(Maybe ByteString)+ , commitContextMessage :: !ByteString+ , commitContextTree :: !Git.WorkTree+ }++newtype CommitM a = CommitM+ { runCommitM :: forall git . GitMonad git => CommitContext -> git (Result CommitContext a)+ }++instance Functor CommitM where+ fmap = fmapCommitM++instance Applicative CommitM where+ pure = returnCommitM+ (<*>) = appendCommitM++instance Monad CommitM where+ return = returnCommitM+ (>>=) = bindCommitM+ fail = failCommitM++instance GitMonad CommitM where+ 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++returnCommitM :: a -> CommitM a+returnCommitM v = CommitM $ \ctx -> return (ResultSuccess ctx v)++appendCommitM :: CommitM (a -> b) -> CommitM a -> CommitM b+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)++failCommitM :: String -> CommitM a+failCommitM msg = CommitM $ \_ -> return (ResultFailure msg)++getCommitM :: CommitM Git.Git+getCommitM = CommitM $ \ctx -> ResultSuccess ctx <$> getGit++liftCommitM :: IO a -> CommitM a+liftCommitM f = CommitM $ \ctx -> ResultSuccess ctx <$> (liftGit f)++-- Operations -----------------------------------------------------------------++commitUpdateContext :: (CommitContext -> IO (CommitContext, a)) -> CommitM a+commitUpdateContext operation = CommitM $ \ctx -> do+ (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 }, ())++-- | replace the Commit's Committer+setCommitter :: Git.Person -> CommitM ()+setCommitter p = commitUpdateContext $ \ctx -> return (ctx { commitContextCommitter = p }, ())++-- | replace the Commit's Parents+setParents :: [Git.Ref] -> CommitM ()+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 }, ())++-- | replace the Commit's encoding+setEncoding :: Maybe ByteString -> CommitM ()+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 }, ())++setContextObject_ :: Git.Objectable object+ => Git.EntPath+ -> (Git.EntType, object)+ -> CommitM ()+setContextObject_ path (t, obj) = do+ 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)++-- | 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, ())++-- | create a new commit in the current GitMonad+--+-- The commit is pre-filled with the following default values:+--+-- * author and committer are the same+-- * the commit's parents is an empty list+-- * there is no commit encoding+-- * the commit's extras is an empty list+-- * the commit message is an empty ByteString+-- * the working tree is a new empty Tree or the Tree associated to the+-- given Revision or Ref.+--+-- You can update these values with the commit setters (setFile, setAuthor...)+--+-- Example:+--+-- > withCurrentRepo $+-- > (r, ()) <- withNewCommit person Nothing $ do+-- > setMessage "inital commit"+-- > setFile ["README.md"] "# My awesome project\n\nthis is a new project\n"+-- > branchWrite "master" r+-- >+--+-- you can also continue the work on a same branch. In this case the commit's+-- parent is already set to the Reference associated to the revision.+-- You can, change the parents if you wish to erase, or replace, this value.+--+-- > withCurrentRepo $+-- > readmeContent <- withCommit (Just "master") $ getFile ["README.md"]+-- > (r, ()) <- withNewCommit person (Just "master") $ 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, 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)++-- | create or continue to work on a branch+--+-- This is a convenient function to create or to linearily work on a branch.+-- This function applies a first Collect of information on the parent commit+-- (the actual branch's commit). Then it creates a new commit and update+-- the branch to point to this commit.+--+-- for example:+--+-- @+-- withCurrentRepo $+-- withBranch person "master" True+-- (getAuthor)+-- (maybe (setMessage "initial commit on this branch")+-- (\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, 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)
+ Data/Git/Named.hs view
@@ -0,0 +1,178 @@+-- |+-- Module : Data.Git.Named+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unix+--+-- Manipulation of named references+-- * reading packed-refs file+-- * reading single heads/tags/remote file+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Data.Git.Named+ ( RefSpecTy(..)+ , RefContentTy(..)+ , RefName(..)+ , readPackedRefs+ , PackedRefs(..)+ -- * manipulating loosed name references+ , existsRefFile+ , writeRefFile+ , readRefFile+ -- * listings looses name references+ , 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++-- | Represent a named specifier.+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 = RefDirect Ref+ | RefLink RefSpecTy+ | RefContentUnknown B.ByteString+ deriving (Show,Eq)++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)++isValidRefName :: String -> Bool+isValidRefName s = not (or $ map isBadChar s)+ 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++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 (RefPatches h) = "refs/patches/" ++ 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 (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++data PackedRefs a = PackedRefs+ { packedRemotes :: a+ , packedBranchs :: a+ , packedTags :: a+ }++readPackedRefs :: LocalPath+ -> ([(RefName, Ref)] -> 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) = B.splitAt 40 l+ name = UTF8.toString $ B.tail r+ in case toRefTy name of+ -- accumulate tag, branch and remotes+ RefTag refname -> a { packedTags = (refname, fromHex ref) : packedTags a }+ RefBranch refname -> a { packedBranchs = (refname, fromHex ref) : packedBranchs a }+ RefRemote refname -> a { packedRemotes = (refname, fromHex ref) : packedRemotes a }+ -- 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 [] dir+ 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)++looseTagsList :: LocalPath -> IO [RefName]+looseTagsList gitRepo = listRefs (tagsPath gitRepo)++looseRemotesList :: LocalPath -> IO [RefName]+looseRemotesList gitRepo = listRefs (remotesPath gitRepo)++existsRefFile :: LocalPath -> RefSpecTy -> IO Bool+existsRefFile gitRepo specty = isFile $ toPath gitRepo specty++writeRefFile :: LocalPath -> RefSpecTy -> RefContentTy -> 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++readRefFile :: LocalPath -> RefSpecTy -> IO RefContentTy+readRefFile gitRepo specty = toRefContent <$> readBinaryFile filepath+ where filepath = toPath gitRepo specty+ toRefContent content+ | "ref: " `B.isPrefixOf` content = RefLink $ toRefTy $ UTF8.toString $ head $ BC.lines $ B.drop 5 content+ | B.length content < 42 = RefDirect $ fromHex $ B.take 40 content+ | otherwise = RefContentUnknown content
+ Data/Git/OS.hs view
@@ -0,0 +1,101 @@+-- |+-- Module : Data.Git.OS+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unix+--+-- dealing with operating system / IO related stuff+-- like file on disk+module Data.Git.OS+ ( 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+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L++type LocalPath = FilePath++listDirectoryFilename :: LocalPath -> IO [String]+listDirectoryFilename dir =+ map (Rules.encodeString Rules.posix . filename) <$> listDirectory dir++createParentDirectory :: LocalPath -> IO ()+createParentDirectory filepath = createTree $ parent filepath++readTextFile :: LocalPath -> IO String+readTextFile filepath = Prelude.readFile (encodeString filepath)++writeTextFile :: LocalPath -> String -> IO ()+writeTextFile filepath = Prelude.writeFile (encodeString filepath)++newtype MTime = MTime EpochTime deriving (Eq,Ord)++timeZero :: EpochTime+timeZero = 0++getMTime :: LocalPath -> IO MTime+getMTime filepath = MTime . modificationTime <$> getFileStatus (encodeString filepath)++getEnvAsPath :: String -> IO LocalPath+getEnvAsPath envName = Rules.decodeString Rules.posix <$> getEnv envName++localPathDecode :: B.ByteString -> LocalPath+localPathDecode = Rules.decode Rules.posix++localPathEncode :: LocalPath -> B.ByteString+localPathEncode = Rules.encode Rules.posix++readBinaryFile :: LocalPath -> IO B.ByteString+readBinaryFile lp = readFile lp++writeBinaryFile :: LocalPath -> B.ByteString -> IO ()+writeBinaryFile = writeFile++readBinaryFileLazy :: LocalPath -> IO L.ByteString+readBinaryFileLazy lp = L.readFile (encodeString lp)
+ Data/Git/Parser.hs view
@@ -0,0 +1,131 @@+module Data.Git.Parser+ (+ Parser+ , P.Result(..)+ , eitherParse+ , eitherParseChunks+ , maybeParse+ , maybeParseChunks+ -- * Specific functions+ , 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 qualified Data.ByteArray.Parse as P+import Data.ByteArray (ByteArray)++import Data.Bits+import Data.Word (Word8, 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++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]++word32 :: Parser Word32+word32 = be32 <$> P.take 4++ref, referenceBin, referenceHex :: Parser Ref+ref = referenceBin+referenceBin = fromBinary <$> P.take 20+referenceHex = fromHex <$> P.take 40++decimal :: (Read n, Num n) => Parser n+decimal = toNum <$> P.takeWhile (\x -> isDigit $ toEnum (fromIntegral x))+ where toNum = read . BC.unpack++string :: B.ByteString -> Parser ()+string = P.bytes++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+ 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++toMaybe :: P.Result t a -> Maybe a+toMaybe (P.ParseOK _ a) = Just a+toMaybe (P.ParseMore c) = toMaybe (c 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+ 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)++toEither :: P.Result t b -> Either String b+toEither (P.ParseOK _ a) = Right a+toEither (P.ParseFail e) = Left e+toEither (P.ParseMore c) = toEither (c Nothing)++takeUntilASCII :: ByteArray byteArray => Char -> P.Parser byteArray byteArray+takeUntilASCII char = P.takeWhile (\c -> if fromEnum c < 0x80 then fromEnum c /= fromEnum char else True)++tillEOL :: Parser B.ByteString+tillEOL = P.takeWhile (/= asciiEOL)++skipEOL :: Parser ()+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")+ where+ cp = fromEnum c++asciiEOL :: Word8+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"++takeWhile1 :: (Word8 -> Bool) -> Parser B.ByteString+takeWhile1 predicate =+ B.cons <$> isByte predicate <*> P.takeWhile predicate
+ Data/Git/Path.hs view
@@ -0,0 +1,54 @@+-- |+-- Module : Data.Git.Path+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unix+--+{-# LANGUAGE OverloadedStrings #-}+module Data.Git.Path where++import System.Random+import Data.Git.Ref+import Data.Git.Imports+import Data.Git.OS+import Data.String++configPath, headsPath, tagsPath, remotesPath, packedRefsPath :: LocalPath -> LocalPath+configPath gitRepo = gitRepo </> "config"++headsPath gitRepo = gitRepo </> "refs" </> "heads" </> ""+tagsPath gitRepo = gitRepo </> "refs" </> "tags" </> ""+remotesPath gitRepo = gitRepo </> "refs" </> "remotes" </> ""+packedRefsPath gitRepo = gitRepo </> "packed-refs"++headPath, tagPath, remotePath, specialPath :: LocalPath -> String -> LocalPath+headPath gitRepo name = headsPath gitRepo </> fromString name+tagPath gitRepo name = tagsPath gitRepo </> fromString name+remotePath gitRepo name = remotesPath gitRepo </> fromString name+specialPath gitRepo name = gitRepo </> fromString name++remoteEntPath :: LocalPath -> String -> String -> LocalPath+remoteEntPath gitRepo name ent = remotePath gitRepo name </> fromString ent++packDirPath :: LocalPath -> LocalPath+packDirPath repoPath = repoPath </> "objects" </> "pack"++indexPath, packPath :: LocalPath -> Ref -> LocalPath+indexPath repoPath indexRef =+ packDirPath repoPath </> fromString ("pack-" ++ toHexString indexRef ++ ".idx")++packPath repoPath packRef =+ packDirPath repoPath </> fromString ("pack-" ++ toHexString packRef ++ ".pack")++objectPath :: LocalPath -> String -> String -> LocalPath+objectPath repoPath d f = repoPath </> "objects" </> fromString d </> fromString f++objectPathOfRef :: LocalPath -> Ref -> LocalPath+objectPathOfRef repoPath ref = objectPath repoPath d f+ 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"))
+ Data/Git/Ref.hs view
@@ -0,0 +1,125 @@+-- |+-- Module : Data.Git.Ref+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unix+--+{-# LANGUAGE DeriveDataTypeable #-}+module Data.Git.Ref+ ( Ref+ -- * Exceptions+ , RefInvalid(..)+ , RefNotFound(..)+ -- * convert from bytestring and string+ , isHex+ , isHexString+ , fromHex+ , fromHexString+ , fromBinary+ , fromDigest+ , toBinary+ , toHex+ , toHexString+ -- * Misc function related to ref+ , refPrefix+ , cmpPrefix+ , toFilePathParts+ -- * Hash ByteString types to a ref+ , hash+ , hashLBS+ ) where++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.Char (isHexDigit)+import Data.Data++import Control.Exception (Exception, throw)++-- | represent a git reference (SHA1)+newtype Ref = Ref (Digest SHA1)+ deriving (Eq,Ord,Typeable)++instance Show Ref where+ 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)++-- | Reference wasn't found+data RefNotFound = RefNotFound Ref+ deriving (Show,Eq,Typeable)++instance Exception RefInvalid+instance Exception RefNotFound++isHex :: ByteString -> Bool+isHex = and . map isHexDigit . BC.unpack++isHexString :: String -> Bool+isHexString = and . map isHexDigit++-- | take a hexadecimal bytestring that represent a reference+-- and turn into a ref+fromHex :: ByteString -> Ref+fromHex s =+ 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+fromHexString :: String -> Ref+fromHexString = fromHex . BC.pack++-- | transform a ref into an hexadecimal bytestring+toHex :: Ref -> ByteString+toHex (Ref bs) = convertToBase Base16 bs++-- | transform a ref into an hexadecimal string+toHexString :: Ref -> String+toHexString (Ref d) = show d++-- | transform a bytestring that represent a binary bytestring+-- and returns a ref.+fromBinary :: ByteString -> Ref+fromBinary b = maybe (throw $ RefInvalid b) Ref $ digestFromByteString b++-- | transform a bytestring that represent a binary bytestring+-- and returns a ref.+fromDigest :: Digest SHA1 -> Ref+fromDigest = Ref++-- | turn a reference into a binary bytestring+toBinary :: Ref -> ByteString+toBinary (Ref b) = B.convert b++-- | returns the prefix (leading byte) of this reference+refPrefix :: Ref -> Int+refPrefix (Ref b) = fromIntegral $ B.unsafeIndex (B.convert b) 0++-- | compare prefix+cmpPrefix :: String -> Ref -> Ordering+cmpPrefix pre ref = pre `compare` (take (length pre) $ toHexString ref)++-- | returns the splitted format "prefix/suffix" for addressing the loose object database+toFilePathParts :: Ref -> (String, String)+toFilePathParts ref = splitAt 2 $ show ref++-- | hash a bytestring into a reference+hash :: ByteString -> Ref+hash = Ref . Crypto.Hash.hash++-- | hash a lazy bytestring into a reference+hashLBS :: L.ByteString -> Ref+hashLBS = Ref . Crypto.Hash.hashlazy
+ Data/Git/Repository.hs view
@@ -0,0 +1,316 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE DeriveDataTypeable #-}+-- |+-- Module : Data.Git.Repository+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unix+--+module Data.Git.Repository+ ( Git+ -- * Config+ , configGetAll+ , configGet+ , Config(..)+ , Section(..)+ -- * Trees+ , HTree+ , HTreeEnt(..)+ , RefName(..)+ , getCommitMaybe+ , getCommit+ , getTreeMaybe+ , getTree+ , rewrite+ , buildHTree+ , resolvePath+ , resolveTreeish+ , resolveRevision+ , initRepo+ , isRepo+ -- * named refs manipulation+ , branchWrite+ , branchList+ , tagWrite+ , tagList+ , headSet+ , headGet+ ) where++import Control.Exception (Exception, throw)++import Data.Maybe (fromMaybe)+import Data.List (find)+import Data.Data+import Data.IORef++import Data.Git.Named+import Data.Git.Types+import Data.Git.Imports+import Data.Git.Storage.Object+import Data.Git.Storage+import Data.Git.Revision+import Data.Git.Storage.Loose+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 qualified Data.Map as M+import qualified Data.Set as Set++-- | hierarchy tree, either a reference to a blob (file) or a tree (directory).+data HTreeEnt = TreeDir Ref HTree | TreeFile Ref+type HTree = [(ModePerm,EntName,HTreeEnt)]++-- | Exception when trying to convert an object pointed by 'Ref' to+-- a type that is different+data InvalidType = InvalidType Ref ObjectType+ deriving (Show,Eq,Typeable)++instance Exception InvalidType++-- 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++-- | get a specified commit+getCommitMaybe :: Git -> Ref -> IO (Maybe Commit)+getCommitMaybe git ref = maybe Nothing objectToCommit <$> getObject git ref True++-- | get a specified commit but raises an exception if doesn't exists or type is not appropriate+getCommit :: Git -> Ref -> IO Commit+getCommit git ref = maybe err id . objectToCommit <$> getObject_ git ref True+ where err = throw $ InvalidType ref TypeCommit++-- | get a specified tree+getTreeMaybe :: Git -> Ref -> IO (Maybe Tree)+getTreeMaybe git ref = maybe Nothing objectToTree <$> getObject git ref True++-- | get a specified tree but raise+getTree :: Git -> Ref -> IO Tree+getTree git ref = maybe err id . objectToTree <$> getObject_ git ref True+ where err = throw $ InvalidType ref TypeTree++-- | try to resolve a string to a specific commit ref+-- for example: HEAD, HEAD^, master~3, shortRef+resolveRevision :: Git -> Revision -> IO (Maybe Ref)+resolveRevision git (Revision prefix 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 ]+ _ -> map (flip ($) (RefName prefix)) [RefTag,RefBranch,RefRemote]++ tryResolvers :: [IO (Maybe Ref)] -> IO (Maybe Ref)+ 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 :: IO (Maybe Ref)+ 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 :: Git -> Ref -> IO (Maybe Tree)+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+++-- | Rewrite a set of commits from a revision and returns the new ref.+--+-- If during revision traversal (diving) there's a commit with zero or multiple+-- parents then the traversal will stop regardless of the amount of parent requested.+--+-- calling "rewrite f 2 (revisionOf d)" on the following tree:+--+-- a <-- b <-- c <-- d+--+-- result in the following tree after mapping with f:+--+-- a <-- f(b) <-- f(c) <-- f(d)+--+rewrite :: Git -- ^ Repository+ -> (Commit -> IO Commit) -- ^ Mapping function+ -> Revision -- ^ revision to start from+ -> Int -- ^ the number of parents to map+ -> IO Ref -- ^ return the new head REF+rewrite git mapCommit revision nbParent = do+ ref <- fromMaybe (error "revision cannot be found") <$> resolveRevision git revision+ resolveParents nbParent ref >>= process . reverse++ where resolveParents :: Int -> Ref -> IO [ (Ref, Commit) ]+ 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 :: Git -> Tree -> IO HTree+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"++-- | resolve the ref (tree or blob) related to a path at a specific commit ref+resolvePath :: Git -- ^ repository+ -> Ref -- ^ commit reference+ -> EntPath -- ^ paths+ -> IO (Maybe Ref)+resolvePath 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++-- | Write a branch to point to a specific reference+branchWrite :: Git -- ^ repository+ -> RefName -- ^ the name of the branch to write+ -> Ref -- ^ the reference to set+ -> IO ()+branchWrite git branchName ref =+ writeRefFile (gitRepoPath git) (RefBranch branchName) (RefDirect ref)++-- | Return the list of branches+branchList :: Git -> IO (Set RefName)+branchList git = do+ ps <- Set.fromList . M.keys . packedBranchs <$> getCacheVal (packedNamed git)+ ls <- Set.fromList <$> looseHeadsList (gitRepoPath git)+ return $ Set.union ps ls++-- | Write a tag to point to a specific reference+tagWrite :: Git -- ^ repository+ -> RefName -- ^ the name of the tag to write+ -> Ref -- ^ the reference to set+ -> IO ()+tagWrite git tagname ref =+ writeRefFile (gitRepoPath git) (RefTag tagname) (RefDirect ref)++-- | Return the list of branches+tagList :: Git -> IO (Set RefName)+tagList git = do+ ps <- Set.fromList . M.keys . packedTags <$> getCacheVal (packedNamed git)+ ls <- Set.fromList <$> looseTagsList (gitRepoPath git)+ return $ Set.union ps ls++-- | Set head to point to either a reference or a branch name.+headSet :: Git -- ^ repository+ -> Either Ref RefName -- ^ either a raw reference or a branch name+ -> IO ()+headSet git (Left ref) =+ writeRefFile (gitRepoPath git) RefHead (RefDirect ref)+headSet git (Right refname) =+ writeRefFile (gitRepoPath git) RefHead (RefLink $ RefBranch refname)++-- | Get what the head is pointing to, or the reference otherwise+headGet :: Git+ -> IO (Either Ref RefName)+headGet 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)++-- | Read the Config+configGetAll :: Git -> IO [Config]+configGetAll git = readIORef (configs git)++-- | Get a configuration element from the config file, starting from the+-- local repository config file, then the global config file.+--+-- for example the equivalent to git config user.name is:+--+-- > configGet git "user" "name"+--+configGet :: Git -- ^ Git context+ -> String -- ^ section name+ -> String -- ^ key name+ -> IO (Maybe String) -- ^ The resulting value if it exists+configGet git section key = do+ cfgs <- configGetAll git+ return $ Cfg.get cfgs section key
+ Data/Git/Revision.hs view
@@ -0,0 +1,129 @@+-- |+-- Module : Data.Git.Revision+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unix+--+{-# LANGUAGE DeriveDataTypeable #-}+module Data.Git.Revision+ ( Revision(..)+ , RevModifier(..)+ , RevisionNotFound(..)+ , fromString+ ) where++import Control.Applicative+import Control.Arrow (first)+import Data.String+import Data.List+import Data.Data+import Data.Char++-- | 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)++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 ++ "}"++-- | A git revision. this can be many things:+-- * a shorten ref+-- * a ref+-- * a named branch or tag+-- followed by optional modifiers 'RevModifier' that can represent:+-- * parenting+-- * type+-- * date+data Revision = Revision String [RevModifier]+ deriving (Eq,Data,Typeable)++-- | Exception when a revision cannot be resolved to a reference+data RevisionNotFound = RevisionNotFound Revision+ deriving (Show,Eq,Data,Typeable)++instance Show Revision where+ show (Revision s ms) = s ++ concatMap show ms++instance IsString Revision where+ 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)++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")++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]) }+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)+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+instance Alternative (Stream elem) where+ 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
+ Data/Git/Storage.hs view
@@ -0,0 +1,349 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module : Data.Git.Storage+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unix+--++module Data.Git.Storage+ ( Git+ , packedNamed+ , gitRepoPath+ , configs+ -- * opening repositories+ , openRepo+ , closeRepo+ , withRepo+ , withCurrentRepo+ , findRepoMaybe+ , findRepo+ , isRepo+ -- * creating repositories+ , initRepo+ -- * repository accessors+ , getDescription+ , setDescription+ -- * iterators+ , iterateIndexes+ , findReference+ , findReferencesWithPrefix+ -- * getting objects+ , getObjectRaw+ , getObjectRawAt+ , getObject+ , getObject_+ , getObjectAt+ , getObjectType+ -- * setting objects+ , setObject+ ) where++import Control.Exception+import qualified Control.Exception as E+import Control.Monad++import Data.List ((\\), isPrefixOf)+import Data.Either (partitionEithers)+import Data.IORef+import Data.Word++import Data.Git.Named+import Data.Git.Imports+import Data.Git.OS+import Data.Git.Path (packedRefsPath)+import Data.Git.Delta+import Data.Git.Storage.FileReader+import Data.Git.Storage.PackIndex+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 qualified Data.Map as M++data PackIndexReader = PackIndexReader PackIndexHeader FileReader++-- | this is a cache representation of the packed-ref file+type CachedPackedRef = CacheFile (PackedRefs (M.Map RefName Ref))++-- | represent a git repo, with possibly already opened filereaders+-- for indexes and packs+data Git = Git+ { gitRepoPath :: LocalPath+ , indexReaders :: IORef [(Ref, PackIndexReader)]+ , packReaders :: IORef [(Ref, FileReader)]+ , packedNamed :: CachedPackedRef+ , configs :: IORef [Config]+ }++-- | open a new git repository context+openRepo :: LocalPath -> IO Git+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 -> IO ()+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.+--+-- If the environment variable GIT_DIR is set then it's used,+-- 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 </> "..")++-- | Find the git repository from the current directory.+--+-- If the environment variable GIT_DIR is set then it's used,+-- 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 </> "..")++-- | execute a function f with a git context.+withRepo :: LocalPath -> (Git -> IO c) -> IO c+withRepo path f = bracket (openRepo path) closeRepo f++-- | execute a function on the current repository.+--+-- check findRepo to see how the git repository is found.+withCurrentRepo :: (Git -> IO a) -> IO a+withCurrentRepo 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)++-- | 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+ mapM_ (createDirectory False . (path </>))+ [ "branches", "hooks", "info"+ , "logs", "objects", "refs"+ , "refs"</> "heads", "refs"</> "tags"]++-- | read the repository's description+getDescription :: Git -> 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"++-- | set the repository's description+setDescription :: Git -> String -> IO ()+setDescription git desc = do+ writeTextFile descriptionPath desc+ where descriptionPath = (gitRepoPath git) </> "description"++iterateIndexes :: Git+ -> (b -> (Ref, 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++-- | Get the object location of a specific reference+findReference :: Git -> Ref -> IO ObjectLocation+findReference git ref = maybe NotFound id <$> (findLoose `mplusIO` findInIndexes)+ where findLoose :: IO (Maybe ObjectLocation)+ findLoose = do+ isLoose <- looseExists (gitRepoPath git) ref+ if isLoose then return (Just $ Loose ref) else return Nothing++ findInIndexes :: IO (Maybe ObjectLocation)+ 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 :: Git -> String -> IO [Ref]+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)++readRawFromPack :: Git -> Ref -> Word64 -> IO (FileReader, PackedObjectRaw)+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++readFromPack :: Git -> Ref -> Word64 -> Bool -> IO (Maybe ObjectInfo)+readFromPack git pref o resolveDelta = do+ (reader, x) <- readRawFromPack git pref o+ if resolveDelta then resolve reader o x else return $ Just $ generifyHeader x+ where generifyHeader :: PackedObjectRaw -> ObjectInfo+ generifyHeader (po, objData) = ObjectInfo { oiHeader = hdr, oiData = objData, oiChains = [] }+ where hdr = (poiType po, poiActualSize po, poiExtra po)++ resolve :: FileReader -> Word64 -> PackedObjectRaw -> IO (Maybe ObjectInfo)+ resolve 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 -> Maybe ObjectInfo+ 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 :: Git -> ObjectLocation -> Bool -> IO (Maybe ObjectInfo)+getObjectRawAt _ NotFound _ = return Nothing+getObjectRawAt git (Loose ref) _ = Just . (\(h,d)-> ObjectInfo h d[]) <$> looseReadRaw (gitRepoPath git) ref+getObjectRawAt git (Packed pref o) resolveDelta = readFromPack git pref o resolveDelta++-- | get an object from repository+getObjectRaw :: Git -> Ref -> Bool -> IO (Maybe ObjectInfo)+getObjectRaw git ref resolveDelta = do+ loc <- findReference git ref+ getObjectRawAt git loc resolveDelta++-- | get an object type from repository+getObjectType :: Git -> Ref -> IO (Maybe ObjectType)+getObjectType 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++-- | get an object from repository using a location to reference it.+getObjectAt :: Git -> ObjectLocation -> Bool -> IO (Maybe Object)+getObjectAt git loc resolveDelta = maybe Nothing toObj <$> getObjectRawAt git loc resolveDelta+ where toObj (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData)++-- | get an object from repository using a ref.+getObject :: Git -- ^ repository+ -> Ref -- ^ the object's reference to+ -> Bool -- ^ whether to resolve deltas if found+ -> IO (Maybe Object) -- ^ returned object if found+getObject git ref resolveDelta = maybe Nothing toObj <$> getObjectRaw git ref resolveDelta+ where toObj (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData)++-- | Just like 'getObject' but will raise a RefNotFound exception if the+-- reference cannot be found.+getObject_ :: Git -- ^ repository+ -> Ref -- ^ the object's reference to+ -> Bool -- ^ whether to resolve deltas if found+ -> IO Object -- ^ returned object if found+getObject_ git ref resolveDelta = maybe (throwIO $ RefNotFound ref) return+ =<< getObject git ref resolveDelta++-- | set an object in the store and returns the new ref+-- this is always going to create a loose object.+setObject :: Git+ -> Object+ -> IO Ref+setObject git obj = looseWrite (gitRepoPath git) obj
+ Data/Git/Storage/CacheFile.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module : Data.Git.Storage.CacheFile+-- License : BSD-style+-- 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++data CacheFile a = CacheFile+ { 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)++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)++tryGetMTime :: LocalPath -> IO (Maybe MTime)+tryGetMTime filepath = (Just <$> getMTime filepath) `E.catch` \(_ :: E.SomeException) -> return Nothing
+ Data/Git/Storage/FileReader.hs view
@@ -0,0 +1,206 @@+-- |+-- Module : Data.Git.Storage.FileReader+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unix+--+{-# LANGUAGE DeriveDataTypeable #-}+module Data.Git.Storage.FileReader+ ( FileReader+ , fileReaderNew+ , fileReaderClose+ , withFileReader+ , withFileReaderDecompress+ , fileReaderGetPos+ , fileReaderGet+ , fileReaderGetLBS+ , fileReaderGetBS+ , fileReaderGetVLF+ , fileReaderSeek+ , fileReaderParse++ , fileReaderInflateToSize+ ) where+++import Control.Exception (bracket, throwIO)++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.Git.Imports+import Data.Git.OS+import qualified Data.Git.Parser as P++import Data.Data+import Data.Word++import Codec.Zlib+import Codec.Zlib.Lowlevel+import Foreign.ForeignPtr+import qualified Control.Exception as E++import System.IO (hSeek, SeekMode(..))++data FileReader = FileReader+ { fbHandle :: Handle+ , fbUseInflate :: Bool+ , fbInflate :: Inflate+ , fbRemaining :: IORef (Maybe ByteString)+ , fbPos :: IORef Word64+ }++data InflateException = InflateException Word64 Word64 String+ 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++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++withFileReaderDecompress :: LocalPath -> (FileReader -> IO a) -> IO a+withFileReaderDecompress path 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+ 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+ nothingOnNull 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)++fileReaderFill :: FileReader -> IO ()+fileReaderFill fb = fileReaderGetNext fb >>= writeIORef (fbRemaining fb)++fileReaderGet :: Int -> FileReader -> IO [ByteString]+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)++fileReaderGetLBS :: Int -> FileReader -> IO L.ByteString+fileReaderGetLBS size fb = L.fromChunks <$> fileReaderGet size fb++fileReaderGetBS :: Int -> FileReader -> IO ByteString+fileReaderGetBS size fb = B.concat <$> fileReaderGet size fb++-- | 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)++-- | 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)++-- | 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)++-- 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++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
+ Data/Git/Storage/FileWriter.hs view
@@ -0,0 +1,64 @@+-- |+-- Module : Data.Git.Storage.FileWriter+-- License : BSD-style+-- 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++defaultCompression :: Int+defaultCompression = 6++-- this is a copy of modifyIORef' found in base 4.6 (ghc 7.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'++data FileWriter = FileWriter+ { writerHandle :: Handle+ , writerDeflate :: Deflate+ , writerDigest :: IORef (Context SHA1)+ }++fileWriterNew :: Handle -> IO FileWriter+fileWriterNew handle = do+ deflate <- initDeflate defaultCompression defaultWindowBits+ digest <- newIORef hashInit+ return $ FileWriter+ { writerHandle = handle+ , writerDeflate = deflate+ , writerDigest = digest+ }++withFileWriter :: LocalPath -> (FileWriter -> IO c) -> IO c+withFileWriter path 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 :: FileWriter -> B.ByteString -> IO ()+fileWriterOutput (FileWriter { writerHandle = handle, writerDigest = digest, writerDeflate = deflate }) bs = do+ modifyIORefStrict digest (\ctx -> hashUpdate ctx bs)+ (>>= postDeflate handle) =<< feedDeflate deflate bs++fileWriterClose :: FileWriter -> IO ()+fileWriterClose (FileWriter { writerHandle = handle, writerDeflate = deflate }) =+ postDeflate handle =<< finishDeflate deflate++fileWriterGetDigest :: FileWriter -> IO Ref+fileWriterGetDigest (FileWriter { writerDigest = digest }) = (fromDigest . hashFinalize) `fmap` readIORef digest
+ Data/Git/Storage/Loose.hs view
@@ -0,0 +1,199 @@+-- |+-- Module : Data.Git.Storage.Loose+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unix+--+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-}+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++import Codec.Compression.Zlib+import Data.Git.Ref+import Data.Git.Path+import Data.Git.Internal+import Data.Git.OS+import Data.Git.Imports+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)++readZippedFile :: LocalPath -> IO Zipped+readZippedFile fp = Zipped <$> readBinaryFileLazy fp++dezip :: Zipped -> L.ByteString+dezip = decompress . getZippedData++isObjectPrefix :: [Char] -> Bool+isObjectPrefix [a,b] = isHexDigit a && isHexDigit b+isObjectPrefix _ = False++-- loose object parsing+parseHeader :: P.Parser ObjectHeader+parseHeader = do+ 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+parseCommitHeader = P.string "commit " >> parseLength >> P.byte 0 >> return HeaderCommit+parseBlobHeader = P.string "blob " >> parseLength >> P.byte 0 >> return HeaderBlob++parseLength :: P.Parser Int+parseLength = P.decimal++parseObject :: L.ByteString -> Object+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+++-- | unmarshall an object (with header) from a bytestring.+looseUnmarshall :: L.ByteString -> Object+looseUnmarshall = parseObject++-- | unmarshall an object (with header) from a zipped stream.+looseUnmarshallZipped :: Zipped -> Object+looseUnmarshallZipped = parseObject . dezip++-- | unmarshall an object as (header, data) tuple from a bytestring+looseUnmarshallRaw :: L.ByteString -> (ObjectHeader, 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)++-- | unmarshall an object as (header, data) tuple from a zipped stream+looseUnmarshallZippedRaw :: Zipped -> (ObjectHeader, ObjectData)+looseUnmarshallZippedRaw = looseUnmarshallRaw . dezip++-- | read a specific ref from a loose object and returns an header and data.+looseReadRaw :: LocalPath -> Ref -> IO (ObjectHeader, ObjectData)+looseReadRaw repoPath ref = looseUnmarshallZippedRaw <$> readZippedFile (objectPathOfRef repoPath ref)++-- | read only the header of a loose object.+looseReadHeader :: LocalPath -> Ref -> IO ObjectHeader+looseReadHeader repoPath ref = toHeader <$> readZippedFile (objectPathOfRef repoPath ref)+ where+ toHeader = either (error . ("parseHeader: " ++)) id . P.eitherParseChunks parseHeader . L.toChunks . dezip++-- | read a specific ref from a loose object and returns an object+looseRead :: LocalPath -> Ref -> IO Object+looseRead repoPath ref = looseUnmarshallZipped <$> readZippedFile (objectPathOfRef repoPath ref)++-- | check if a specific ref exists as loose object+looseExists :: LocalPath -> Ref -> IO Bool+looseExists repoPath ref = isFile (objectPathOfRef repoPath ref)++-- | enumarate all prefixes available in the object store.+looseEnumeratePrefixes :: LocalPath -> IO [[Char]]+looseEnumeratePrefixes repoPath = filter isObjectPrefix <$> getDirectoryContents (repoPath </> fromString "objects")++-- | enumerate all references available with a specific prefix.+looseEnumerateWithPrefixFilter :: LocalPath -> String -> (Ref -> Bool) -> IO [Ref]+looseEnumerateWithPrefixFilter repoPath prefix filterF =+ filter filterF . map (fromHexString . (prefix ++)) . filter isRef <$> getDir (repoPath </> fromString "objects" </> fromString prefix)+ where+ getDir p = E.catch (getDirectoryContents p) (\(_::SomeException) -> return [])+ isRef l = length l == 38++looseEnumerateWithPrefix :: LocalPath -> String -> IO [Ref]+looseEnumerateWithPrefix repoPath prefix =+ looseEnumerateWithPrefixFilter repoPath prefix (const True)++-- | marshall as lazy bytestring an object except deltas.+looseMarshall :: Object -> 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)++-- | create a new blob on a temporary location and on success move it to+-- the object store with its digest name.+looseWriteBlobFromFile :: LocalPath -> LocalPath -> IO Ref+looseWriteBlobFromFile 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++-- | write an object to disk as a loose reference.+-- use looseWriteBlobFromFile for efficiently writing blobs when being commited from a file.+looseWrite :: LocalPath -> Object -> IO Ref+looseWrite 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
+ Data/Git/Storage/Object.hs view
@@ -0,0 +1,355 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE CPP #-}+-- |+-- Module : Data.Git.Storage.Object+-- License : BSD-style+-- 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++import Data.Byteable (toBytes)+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.List (intersperse)+import Data.Word+import Text.Printf++#if MIN_VERSION_bytestring(0,10,0)+import Data.ByteString.Lazy.Builder hiding (word8)+#else+import qualified Data.ByteString.Lazy.Char8 as LC++-- tiny builder interface like for bytestring < 0.10 that+-- use normal lazy bytestring concat.+string7 :: String -> L.ByteString+string7 = LC.pack++byteString :: ByteString -> L.ByteString+byteString = LC.fromChunks . (:[])++toLazyByteString = id+#endif++-- | location of an object in the database+data ObjectLocation = NotFound | Loose Ref | Packed Ref Word64+ deriving (Show,Eq)++-- | Delta objects points to some others objects in the database+-- either as offset in the pack or as a direct reference.+data ObjectPtr = PtrRef Ref | PtrOfs Word64 deriving (Show,Eq)++type ObjectHeader = (ObjectType, Word64, Maybe ObjectPtr)++type ObjectData = L.ByteString++-- | Raw objects infos have an header (type, size, ptr),+-- the data and a pointers chains to parents for resolved objects.+data ObjectInfo = ObjectInfo+ { oiHeader :: ObjectHeader+ , oiData :: ObjectData+ , oiChains :: [ObjectPtr]+ } deriving (Show,Eq)++-- | describe a git object, that could of 6 differents types:+-- tree, blob, commit, tag and deltas (offset or ref).+-- the deltas one are only available in packs.+data Object = ObjCommit Commit+ | ObjTag Tag+ | ObjBlob Blob+ | ObjTree Tree+ | ObjDeltaOfs DeltaOfs+ | ObjDeltaRef DeltaRef+ deriving (Show,Eq)++class Objectable a where+ getType :: a -> ObjectType+ getRaw :: a -> L.ByteString+ isDelta :: a -> Bool+ toObject :: a -> Object++objectToType :: Object -> ObjectType+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 TypeCommit = "commit"+objectTypeMarshall TypeTag = "tag"+objectTypeMarshall _ = error "deltas cannot be marshalled"++objectTypeUnmarshall :: ByteString -> ObjectType+objectTypeUnmarshall "tree" = TypeTree+objectTypeUnmarshall "blob" = TypeBlob+objectTypeUnmarshall "commit" = TypeCommit+objectTypeUnmarshall "tag" = TypeTag+objectTypeUnmarshall _ = error "unknown object type"++objectTypeIsDelta :: ObjectType -> Bool+objectTypeIsDelta TypeDeltaOff = True+objectTypeIsDelta TypeDeltaRef = True+objectTypeIsDelta _ = False++objectIsDelta :: Object -> Bool+objectIsDelta (ObjDeltaOfs _) = True+objectIsDelta (ObjDeltaRef _) = True+objectIsDelta _ = False++objectToTree :: Object -> Maybe Tree+objectToTree (ObjTree tree) = Just tree+objectToTree _ = Nothing++objectToCommit :: Object -> Maybe Commit+objectToCommit (ObjCommit commit) = Just commit+objectToCommit _ = Nothing++objectToTag :: Object -> Maybe Tag+objectToTag (ObjTag tag) = Just tag+objectToTag _ = Nothing++objectToBlob :: Object -> Maybe Blob+objectToBlob (ObjBlob blob) = Just blob+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)++modeperm :: P.Parser ModePerm+modeperm = ModePerm . fromIntegral <$> octal++-- | parse a tree content+treeParse :: P.Parser Tree+treeParse = Tree <$> parseEnts+ where parseEnts = P.hasMore >>= \b -> if b then liftM2 (:) parseEnt parseEnts else return []+ parseEnt = liftM3 (,,) modeperm parseEntName (P.byte 0 >> P.referenceBin)+ parseEntName = entName <$> (P.skipASCII ' ' >> P.takeWhile (/= 0))++-- | parse a blob content+blobParse :: P.Parser Blob+blobParse = (Blob . L.fromChunks . (:[]) <$> P.takeAll)++-- | parse a commit content+commitParse :: P.Parser Commit+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])++-- | parse a tag content+tagParse :: P.Parser Tag+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++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)++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++objectParseTree, objectParseCommit, objectParseTag, objectParseBlob :: P.Parser Object+objectParseTree = ObjTree <$> treeParse+objectParseCommit = ObjCommit <$> commitParse+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' ])++objectWrite :: Object -> L.ByteString+objectWrite (ObjCommit commit) = commitWrite commit+objectWrite (ObjTag tag) = tagWrite tag+objectWrite (ObjBlob blob) = blobWrite blob+objectWrite (ObjTree tree) = treeWrite tree+objectWrite _ = error "delta cannot be marshalled"++treeWrite :: Tree -> L.ByteString+treeWrite (Tree ents) = toLazyByteString $ mconcat $ concatMap writeTreeEnt ents+ where writeTreeEnt (ModePerm perm,name,ref) =+ [ string7 (printf "%o" perm)+ , string7 " "+ , byteString $ toBytes name+ , string7 "\0"+ , byteString $ toBinary ref+ ]++commitWrite :: Commit -> 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+ ]++tagWrite :: Tag -> 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+ ]++eol :: Builder+eol = string7 "\n"++blobWrite :: Blob -> L.ByteString+blobWrite (Blob bData) = bData++instance Objectable Blob where+ getType _ = TypeBlob+ getRaw = blobWrite+ toObject = ObjBlob+ isDelta = const False++instance Objectable Commit where+ getType _ = TypeCommit+ getRaw = commitWrite+ toObject = ObjCommit+ isDelta = const False++instance Objectable Tag where+ getType _ = TypeTag+ getRaw = tagWrite+ toObject = ObjTag+ isDelta = const False++instance Objectable Tree where+ 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++instance Objectable DeltaRef where+ getType _ = TypeDeltaRef+ getRaw = error "delta ref cannot be marshalled"+ toObject = ObjDeltaRef+ isDelta = const True++objectHash :: ObjectType -> Word64 -> L.ByteString -> Ref+objectHash ty w lbs = hashLBS $ L.fromChunks (objectWriteHeader ty w : L.toChunks lbs)++-- 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
+ Data/Git/Storage/Pack.hs view
@@ -0,0 +1,154 @@+-- |+-- Module : Data.Git.Storage.Pack+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unix+--+{-# LANGUAGE OverloadedStrings #-}+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++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.Imports+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.Word++type PackedObjectRaw = (PackedObjectInfo, L.ByteString)++data PackedObjectInfo = PackedObjectInfo+ { poiType :: ObjectType+ , poiOffset :: Word64+ , poiSize :: Word64+ , poiActualSize :: Word64+ , poiExtra :: Maybe ObjectPtr+ } deriving (Show,Eq)++-- | Enumerate the pack refs available in this repository.+packEnumerate :: LocalPath -> IO [Ref]+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++-- | open a pack+packOpen :: LocalPath -> Ref -> IO FileReader+packOpen repoPath packRef = openFile (packPath repoPath packRef) ReadMode >>= fileReaderNew False++-- | close a pack+packClose :: FileReader -> IO ()+packClose = fileReaderClose++-- | return the number of entries in this pack+packReadHeader :: LocalPath -> Ref -> 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++-- | read an object at a specific position using a map function on the objectData+packReadMapAtOffset :: FileReader -> Word64 -> (L.ByteString -> L.ByteString) -> IO (Maybe Object)+packReadMapAtOffset fr offset mapData = fileReaderSeek fr offset >> getNextObject fr mapData++-- | read an object at a specific position+packReadAtOffset :: FileReader -> Word64 -> IO (Maybe Object)+packReadAtOffset fr offset = packReadMapAtOffset fr offset id++-- | read a raw representation at a specific position+packReadRawAtOffset :: FileReader -> Word64 -> IO (PackedObjectRaw)+packReadRawAtOffset fr offset = fileReaderSeek fr offset >> getNextObjectRaw fr++-- | enumerate all objects in this pack and callback to f for reach raw objects+packEnumerateObjects :: LocalPath -> Ref -> Int -> (PackedObjectRaw -> IO a) -> IO ()+packEnumerateObjects 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 :: FileReader -> (L.ByteString -> L.ByteString) -> IO (Maybe Object)+getNextObject fr mapData =+ packedObjectToObject . second mapData <$> getNextObjectRaw fr++packedObjectToObject :: (PackedObjectInfo, L.ByteString) -> Maybe Object+packedObjectToObject (PackedObjectInfo { poiType = ty, poiExtra = extra }, objData) =+ packObjectFromRaw (ty, extra, objData)++packObjectFromRaw :: (ObjectType, Maybe ObjectPtr, L.ByteString) -> Maybe Object+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 (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"++getNextObjectRaw :: FileReader -> IO PackedObjectRaw+getNextObjectRaw fr = do+ sobj <- fileReaderGetPos fr+ (ty, size) <- fileReaderParse fr parseObjectHeader+ extra <- case ty of+ TypeDeltaRef -> Just . PtrRef . fromBinary <$> fileReaderGetBS 20 fr+ TypeDeltaOff -> Just . PtrOfs . deltaOffFromList <$> fileReaderGetVLF fr+ _ -> return Nothing+ objData <- fileReaderInflateToSize fr size+ eobj <- fileReaderGetPos fr++ return (PackedObjectInfo ty sobj (eobj - sobj) size extra, objData)+ where+ parseObjectHeader = do+ (m, ty, sz) <- splitFirst <$> P.anyByte+ size <- if m then (sz +) <$> getNextSize 4 else return sz+ return (ty, size)+ where+ getNextSize n = do+ (c, sz) <- splitOther n <$> P.anyByte+ if c then (sz +) <$> getNextSize (n+7) else return sz++ splitFirst :: Word8 -> (Bool, ObjectType, Word64)+ splitFirst w = (w `testBit` 7, toEnum $ fromIntegral ((w `shiftR` 4) .&. 0x7), fromIntegral (w .&. 0xf))+ splitOther n w = (w `testBit` 7, fromIntegral (w .&. 0x7f) `shiftL` n)++ deltaOffFromList (x:xs) = foldl' acc (fromIntegral (x `clearBit` 7)) xs+ where acc a w = ((a+1) `shiftL` 7) + fromIntegral (w `clearBit` 7)+ deltaOffFromList [] = error "cannot happen"
+ Data/Git/Storage/PackIndex.hs view
@@ -0,0 +1,183 @@+-- |+-- Module : Data.Git.Storage.PackIndex+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unix+--+{-# LANGUAGE OverloadedStrings, BangPatterns #-}+module Data.Git.Storage.PackIndex+ ( PackIndexHeader(..)+ , PackIndex(..)++ -- * handles and enumeration+ , packIndexOpen+ , packIndexClose+ , withPackIndex+ , packIndexEnumerate++ -- * read from packIndex+ , 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.OS+import Data.Git.Storage.FileReader+import Data.Git.Path+import Data.Git.Ref+import qualified Data.Git.Parser as P++-- | represent an packIndex header with the version and the fanout table+data PackIndexHeader = PackIndexHeader !Word32 !(Vector Word32)+ deriving (Show,Eq)++data PackIndex = PackIndex+ { packIndexSha1s :: Vector Ref+ , packIndexCRCs :: Vector Word32+ , packIndexPackoffs :: Vector Word32+ , packIndexPackChecksum :: Ref+ , packIndexChecksum :: Ref+ }++-- | enumerate every indexes file in the pack directory+packIndexEnumerate :: LocalPath -> IO [Ref]+packIndexEnumerate repoPath = map onlyHash . filter isPackFile <$> listDirectoryFilename (repoPath </> "objects" </> "pack")+ where+ isPackFile :: String -> Bool+ isPackFile x = ".idx" `isSuffixOf` x && "pack-" `isPrefixOf` x+ onlyHash = fromHexString . takebut 4 . drop 5+ takebut n l = take (length l - n) l++-- | open an index+packIndexOpen :: LocalPath -> Ref -> IO FileReader+packIndexOpen repoPath indexRef = openFile (indexPath repoPath indexRef) ReadMode >>= fileReaderNew False++-- | close an index+packIndexClose :: FileReader -> IO ()+packIndexClose = fileReaderClose++-- | variant of withFile on the index file and with a FileReader+withPackIndex :: LocalPath -> Ref -> (FileReader -> IO a) -> IO a+withPackIndex repoPath indexRef = withFileReader (indexPath repoPath indexRef)++-- | returns the number of references, referenced in this index.+packIndexHeaderGetSize :: PackIndexHeader -> Word32+packIndexHeaderGetSize (PackIndexHeader _ indexes) = indexes ! 255++-- | byte size of an packIndex header.+packIndexHeaderByteSize :: Int+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))++-- | fold on refs with a specific prefix+packIndexHeaderFoldRef :: PackIndexHeader -> FileReader -> Int -> (a -> Word32 -> Ref -> (a, Bool)) -> a -> IO a+packIndexHeaderFoldRef idxHdr@(PackIndexHeader _ indexes) fr refprefix f initAcc+ | nb == 0 = return initAcc+ | otherwise = do+ let spos = (indexes ! refprefix) - nb+ fileReaderSeek fr (fromIntegral (sha1Offset + spos * 20))+ loop nb initAcc+ where+ loop 0 acc = return acc+ loop n acc = do+ b <- fromBinary <$> fileReaderGetBS 20 fr+ let (!nacc, terminate) = f acc (nb-n) b+ if terminate+ then return nacc+ else loop (n-1) nacc+ nb = packIndexHeaderGetNbWithPrefix idxHdr refprefix+ (sha1Offset,_,_) = packIndexOffsets idxHdr++-- | return the reference offset in the packfile if found+packIndexGetReferenceLocation :: PackIndexHeader -> FileReader -> Ref -> IO (Maybe Word64)+packIndexGetReferenceLocation idxHdr@(PackIndexHeader _ indexes) fr ref = do+ mrpos <- packIndexHeaderFoldRef idxHdr fr refprefix f Nothing+ case mrpos of+ Nothing -> return Nothing+ Just rpos -> do+ let spos = (indexes ! refprefix) - nb+ fileReaderSeek fr (fromIntegral (packOffset + 4 * (spos+rpos)))+ Just . fromIntegral . be32 <$> fileReaderGetBS 4 fr+ where+ f acc rpos rref = if ref == rref then (Just rpos,True) else (acc,False)+ refprefix = refPrefix ref+ nb = packIndexHeaderGetNbWithPrefix idxHdr refprefix+ (_,_,packOffset) = packIndexOffsets idxHdr++-- | get all references that start by prefix.+packIndexGetReferencesWithPrefix :: PackIndexHeader -> FileReader -> String -> IO [Ref]+packIndexGetReferencesWithPrefix idxHdr fr prefix =+ packIndexHeaderFoldRef idxHdr fr refprefix f []+ where+ f acc _ ref = case cmpPrefix prefix ref of+ GT -> (acc ,False)+ EQ -> (ref:acc,False)+ LT -> (acc ,True)+ refprefix = read ("0x" ++ take 2 prefix)++-- | returns absolute offset in the index file of the sha1s, the crcs and the packfiles offset.+packIndexOffsets :: PackIndexHeader -> (Word32, Word32, Word32)+packIndexOffsets idx = (packIndexSha1sOffset, packIndexCRCsOffset, packIndexPackOffOffset)+ where+ packIndexPackOffOffset = packIndexCRCsOffset + crcsTableSz+ packIndexCRCsOffset = packIndexSha1sOffset + sha1TableSz+ packIndexSha1sOffset = fromIntegral packIndexHeaderByteSize+ crcsTableSz = 4 * sz+ sha1TableSz = 20 * sz+ sz = packIndexHeaderGetSize idx++-- | 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++-- | read index header from an index filereader+packIndexReadHeader :: FileReader -> IO PackIndexHeader+packIndexReadHeader fr = fileReaderSeek fr 0 >> fileReaderParse fr parsePackIndexHeader++-- | get index header from an index reference+packIndexGetHeader :: LocalPath -> Ref -> IO PackIndexHeader+packIndexGetHeader repoPath indexRef = withPackIndex repoPath indexRef $ packIndexReadHeader++-- | read all index+packIndexRead :: LocalPath -> Ref -> IO (PackIndexHeader, (Vector Ref, Vector Word32, Vector Word32, [ByteString], Ref, Ref))+packIndexRead repoPath indexRef = do+ withPackIndex repoPath indexRef $ \fr -> do+ idx <- fileReaderParse fr parsePackIndexHeader+ liftM2 (,) (return idx) (fileReaderParse fr (parsePackIndex $ packIndexHeaderGetSize idx))+ where parsePackIndex sz = do+ sha1s <- V.replicateM (fromIntegral sz) P.referenceBin+ crcs <- V.replicateM (fromIntegral sz) P.word32+ packoffs <- V.replicateM (fromIntegral sz) P.word32+ let nbLarge = length $ filter (== True) $ map (\packoff -> packoff `testBit` 31) $ V.toList packoffs+ largeoffs <- replicateM nbLarge (P.take 4)+ packfileChecksum <- P.referenceBin+ idxfileChecksum <- P.referenceBin+ -- large packfile offsets+ -- trailer+ return (sha1s, crcs, packoffs, largeoffs, packfileChecksum, idxfileChecksum)
+ Data/Git/Types.hs view
@@ -0,0 +1,227 @@+-- |+-- Module : Data.Git.Object+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unix+--+{-# LANGUAGE DeriveDataTypeable #-}+module Data.Git.Types+ (+ -- * Type of types+ ObjectType(..)+ -- * Main git types+ , Tree(..)+ , Commit(..)+ , CommitExtra(..)+ , Blob(..)+ , Tag(..)+ , Person(..)+ , EntName+ , entName+ , EntPath+ , entPathAppend+ -- * modeperm type+ , ModePerm(..)+ , FilePermissions(..)+ , ObjectFileType(..)+ , getPermission+ , getFiletype+ -- * time type+ , GitTime(..)+ , gitTime+ , gitTimeToLocal+ -- * Pack delta types+ , DeltaOfs(..)+ , DeltaRef(..)+ -- * Basic types part of other bigger types+ , TreeEnt+ ) where++import Data.Word+import Data.Bits+import Data.Byteable+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 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++-- | type of a git object.+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)++instance Timeable GitTime where+ 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)++instance Show GitTime where+ show (GitTime t tz) =+ timePrint "EPOCH" t ++ " " ++ show tz++gitTime :: Integer -> Int -> GitTime+gitTime seconds tzMins =+ GitTime (fromIntegral seconds) (TimezoneOffset tzMins)++gitTimeToLocal :: GitTime -> LocalTime Elapsed+gitTimeToLocal (GitTime t tz) =+ 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)++newtype ModePerm = ModePerm Word32+ 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)++getFiletype :: ModePerm -> ObjectFileType+getFiletype (ModePerm modeperm) =+ case modeperm `shiftR` 12 of+ _ -> error "filetype unknown"++-- | Git object file type+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)++-- | a bitfield representing a typical unix permission:+-- * bit 0 represents the read permission+-- * bit 1 represents the write permission+-- * bit 2 represents the execute permission+type Perm = Word8++-- | Entity name+newtype EntName = EntName ByteString+ deriving (Eq,Ord)+instance Show EntName where+ show (EntName e) = UTF8.toString e+instance IsString EntName where+ fromString s = entName $ UTF8.fromString s+instance Byteable EntName where+ toBytes (EntName n) = n++entName :: ByteString -> EntName+entName bs+ | 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]++type EntPath = [EntName]++-- | represent one entry in the tree+-- (permission,file or directory name,blob or tree ref)+-- name should maybe a filepath, but not sure about the encoding.+type TreeEnt = (ModePerm,EntName,Ref)++-- | 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)++-- | Represent a root tree with zero to many tree entries.+data Tree = Tree { treeGetEnts :: [TreeEnt] } deriving (Show,Eq)++instance Monoid Tree where+ mempty = Tree []+ mappend (Tree e1) (Tree e2) = Tree (e1 ++ e2)+ mconcat trees = Tree $ concatMap treeGetEnts trees++-- | Represent a binary blob.+data Blob = Blob { blobGetContent :: L.ByteString } deriving (Show,Eq)++-- | Represent a commit object.+data Commit = Commit+ { commitTreeish :: Ref+ , commitParents :: [Ref]+ , commitAuthor :: Person+ , commitCommitter :: Person+ , commitEncoding :: Maybe ByteString+ , commitExtras :: [CommitExtra]+ , commitMessage :: ByteString+ } deriving (Show,Eq)++data CommitExtra = CommitExtra+ { commitExtraKey :: ByteString+ , commitExtraValue :: ByteString+ } deriving (Show,Eq)++-- | Represent a signed tag.+data Tag = Tag+ { tagRef :: Ref+ , tagObjectType :: ObjectType+ , tagBlob :: ByteString+ , tagName :: Person+ , tagS :: ByteString+ } deriving (Show,Eq)++-- | Delta pointing to an offset.+data DeltaOfs = DeltaOfs Word64 Delta+ deriving (Show,Eq)++-- | Delta pointing to a ref.+data DeltaRef = DeltaRef Ref Delta+ deriving (Show,Eq)
+ Data/Git/WorkTree.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+-- |+-- Module : Data.Git.WorkTree+-- License : BSD-style+-- Maintainer : Vincent Hanquez <vincent@snarc.org>+-- Stability : experimental+-- Portability : unix+--+-- a load-on-demand, write-on-demand working tree.+--+module Data.Git.WorkTree+ ( WorkTree+ , EntType(..)+ -- * Create new work trees+ , workTreeNew+ , workTreeFrom+ -- * Modifications methods+ , workTreeDelete+ , workTreeSet+ , workTreeFlush+ ) where++import Data.Git.Ref+import Data.Git.Types+import Data.Git.Storage.Object+import Data.Git.Storage+import Data.Git.Repository++--import qualified Data.ByteString as B++import qualified Data.Map as M++import Control.Monad+import Control.Concurrent.MVar++type Dir = M.Map EntName (ModePerm, TreeSt)+type TreeVar = MVar Dir+data TreeSt = TreeRef Ref | TreeLoaded TreeVar+type WorkTree = MVar TreeSt++data EntType = EntDirectory | EntFile | EntExecutable+ deriving (Show,Eq)++-- | Create a new worktree+workTreeNew :: IO WorkTree+workTreeNew = newMVar M.empty >>= newMVar . TreeLoaded++-- | Create a worktree from a tree reference.+workTreeFrom :: Ref -> IO WorkTree+workTreeFrom ref = newMVar (TreeRef ref)++-- | delete a path from a working tree+--+-- if the path doesn't exist, no error is raised+workTreeDelete :: Git -> WorkTree -> EntPath -> IO ()+workTreeDelete 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 ()++-- | 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 :: Git -> WorkTree -> EntPath -> (EntType, Ref) -> IO ()+workTreeSet git wt path (entType, entRef) = diveFromRoot git wt path dive+ where dive :: TreeVar -> 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 ()+workTreeFlushAt git wt path = do+ undefined+-}++-- | Flush the worktree by creating all the necessary trees in the git store+-- and return the root ref of the work tree.+workTreeFlush :: Git -> WorkTree -> IO Ref+workTreeFlush 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)++----- helpers -----++loadTreeVar :: Git -> Ref -> IO TreeVar+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++entTypeToPerm :: EntType -> ModePerm+entTypeToPerm EntDirectory = ModePerm 0o040000+entTypeToPerm EntExecutable = ModePerm 0o100755 +entTypeToPerm EntFile = ModePerm 0o100644++loadOrGetTree :: Git -> EntName -> TreeVar -> (Dir -> IO (Dir, Either TreeVar a)) -> IO (Either TreeVar 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 :: Git -> WorkTree -> EntPath+ -> (TreeVar -> 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+
+ LICENSE view
@@ -0,0 +1,28 @@+Copyright (c) 2010-2016 Vincent Hanquez <vincent@snarc.org>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,19 @@+git+===++[](https://travis-ci.org/vincenthz/hs-git)+[](http://en.wikipedia.org/wiki/BSD_licenses)+[](http://haskell.org)++git is a reimplementation of git storage and protocol in pure haskell.++what it does do:++* read loose objects, and packed objects.+* write new loose objects+* git like operations available: commit, cat-file, verify-pack, rev-list, ls-tree.++what is doesn't do:++* reimplement the whole of git.+* checkout's index reading/writing, fetching, merging, diffing.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ git.cabal view
@@ -0,0 +1,108 @@+Name: git+Version: 0.1+Synopsis: Git operations in haskell+Description:+ .+ An haskell implementation of git storage operations, allowing users+ to manipulate git repositories (read and write).+ .+ This implementation is fully interoperable with the main C implementation.+ .+ This is stricly only manipulating the git store (what's inside the .git directory),+ and doesn't do anything with the index or your working directory files.+ .+License: BSD3+License-file: LICENSE+Copyright: Vincent Hanquez <vincent@snarc.org>+Author: Vincent Hanquez <vincent@snarc.org>+Maintainer: Vincent Hanquez <vincent@snarc.org>+Category: Development+Stability: experimental+Build-Type: Simple+Homepage: https://github.com/vincenthz/hit+tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1+Cabal-Version: >=1.8+data-files: README.md+extra-source-files: Tests/*.hs++Flag executable+ Description: Build the executable+ Default: False++Flag debug+ Description: Add some debugging options+ Default: False++Library+ Build-Depends: base >= 4 && < 5+ , mtl+ , bytestring >= 0.9+ , byteable+ , containers+ , memory >= 0.13+ , cryptonite+ , vector+ , random+ , zlib+ , zlib-bindings >= 0.1 && < 0.2+ , hourglass >= 0.2+ , unix-compat+ , utf8-string+ , patience+ -- to remove+ , system-filepath+ , system-fileio+ Exposed-modules: Data.Git+ Data.Git.Monad+ Data.Git.Types+ Data.Git.Storage+ Data.Git.Storage.PackIndex+ Data.Git.Storage.Pack+ Data.Git.Storage.Object+ Data.Git.Storage.Loose+ Data.Git.Named+ Data.Git.Delta+ Data.Git.Ref+ Data.Git.Revision+ Data.Git.Repository+ Data.Git.Diff+ Other-modules: Data.Git.Internal+ Data.Git.Imports+ Data.Git.OS+ Data.Git.Config+ Data.Git.Storage.FileReader+ Data.Git.Storage.FileWriter+ Data.Git.Storage.CacheFile+ Data.Git.Path+ Data.Git.Parser+ Data.Git.WorkTree+ ghc-options: -Wall -fno-warn-unused-imports+ -- -fno-warn-missing-signatures+++Test-Suite test-unit+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ Main-Is: Tests.hs+ Build-depends: base >= 3 && < 7+ , bytestring+ , tasty+ , tasty-quickcheck+ , hourglass+ , git++Test-Suite test-repository+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ Main-Is: Repo.hs+ Build-depends: base >= 3 && < 7+ , bytestring+ , tasty+ , tasty-quickcheck+ , hourglass+ , bytedump >= 1.0+ , git++source-repository head+ type: git+ location: https://github.com/vincenthz/hs-git
+ tests/Monad.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE OverloadedStrings #-}++module Monad+ ( testGitMonadLocal+ ) where++import Control.Applicative+import Control.Exception+import Control.Monad++import Data.Git.Monad+import Data.Git.Types (GitTime(..))+import System.Exit+import qualified System.Hourglass as T++testBranch :: RefName+testBranch = "test/not/push"++catchAll :: IO (Either String a) -> IO ()+catchAll f = do+ r <- catchAll' f+ case r of+ Left err -> failWith $ show err+ Right (Left err) -> failWith err+ Right (Right _) -> putStrLn " test/git/monad [OK]"+ where+ catchAll' :: IO a -> IO (Either SomeException a)+ catchAll' f = try f++ failWith :: String -> IO ()+ failWith msg = do+ putStrLn " test/git/monad [FAILED]"+ putStrLn $ " - " ++ msg+ exitFailure++testGitMonadLocal :: IO ()+testGitMonadLocal = catchAll (withCurrentRepo testGitMonad)++timeCurrentGit :: GitM GitTime+timeCurrentGit = liftGit $ GitTime + <$> T.timeCurrent+ <*> T.timezoneCurrent++step :: String -> GitM ()+step = liftGit . putStrLn++testGitMonad :: GitM ()+testGitMonad = do+ t <- timeCurrentGit+ let person = Person+ { personName = "Hit Test Machinery"+ , personEmail = "hit@snarc.org"+ , personTime = t+ }+ withBranch person testBranch True (return ()) $ \isFirstCommit -> case isFirstCommit of+ Nothing -> setMessage "Initial commit"+ Just _ -> setMessage "add new commit"+ step " + new branch created"+ withCommit testBranch $ do+ author <- getAuthor+ when (t /= personTime author)+ $ fail "master's commit is not the last commit performed"+ step " + branch has been verified"
+ tests/Repo.hs view
@@ -0,0 +1,63 @@+import Test.Tasty+import Test.Tasty.QuickCheck++import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as B++import Control.Applicative+import Control.Monad++import Data.Git.Storage.Object+import Data.Git.Storage.Loose+import Data.Git.Storage+import Data.Git.Ref+import Data.Git.Types+import Data.Git.Repository++import Data.Maybe++import Text.Bytedump+import System.Exit++import Monad++onLocalRepo f = do+ fpath <- findRepoMaybe+ case fpath of+ Nothing -> putStrLn "cannot run this test without repository. clone the original repository for test"+ Just _ -> withCurrentRepo f++doLocalMarshallEq git = do+ prefixes <- looseEnumeratePrefixes (gitRepoPath git)+ forM prefixes $ \prefix -> do+ refs <- looseEnumerateWithPrefix (gitRepoPath git) prefix+ forM refs $ \ref -> do+ raw <- looseReadRaw (gitRepoPath git) ref+ obj <- looseRead (gitRepoPath git) ref+ let content = looseMarshall obj+ let raw2 = looseUnmarshallRaw content+ let hashed = hashLBS content+ if ref /= hashed+ then return $ Just (ref, hashed, raw, raw2)+ else return Nothing++printDiff (actualRef, gotRef, (actualHeader, actualRaw), (gotHeader, gotRaw)) = do+ putStrLn "=========== difference found"+ putStrLn ("ref expected: " ++ show actualRef)+ putStrLn ("ref got : " ++ show gotRef)+ putStrLn ("header expected: " ++ show actualHeader)+ putStrLn ("header got : " ++ show gotHeader)+ putStrLn "raw diff:"+ putStrLn $ dumpDiffLBS actualRaw gotRaw++printLocalMarshallError l+ | null l = putStrLn "local marshall: [OK]"+ | otherwise = putStrLn ("local marshall: [" ++ show (length l) ++ " errors]")+ >> mapM_ printDiff l+ >> exitFailure++main = do+ onLocalRepo $ \git -> do+ doLocalMarshallEq git >>= printLocalMarshallError . catMaybes . concat+ return ()+ testGitMonadLocal
+ tests/Tests.hs view
@@ -0,0 +1,132 @@+import Test.Tasty.QuickCheck+import Test.Tasty++import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString as B++import Control.Applicative+import Control.Monad++import Data.Git.Storage.Object+import Data.Git.Storage.Loose+import Data.Git.Ref+import Data.Git.Revision+import Data.Git.Types+import Data.Hourglass++import Data.Maybe++-- for arbitrary instance to generate only data that are writable+-- to disk. i.e. no deltas.+data ObjNoDelta = ObjNoDelta Object+ deriving (Eq)++instance Show ObjNoDelta where+ show (ObjNoDelta o) = show o++arbitraryBS size = B.pack . map fromIntegral <$> replicateM size (choose (0,255) :: Gen Int)+arbitraryBSno0 size = B.pack . map fromIntegral <$> replicateM size (choose (1,255) :: Gen Int)+arbitraryBSasciiNoSpace size = B.pack . map fromIntegral <$> replicateM size (choose (0x21,0x7f) :: Gen Int)+arbitraryBSascii size = B.pack . map fromIntegral <$> replicateM size (choose (0x20,0x7f) :: Gen Int)+arbitraryBSnoangle size = B.pack . map fromIntegral <$> replicateM size (choose (0x40,0x7f) :: Gen Int)++arbitraryEntname size = entName . B.pack . map fromIntegral <$> replicateM size range+ where range :: Gen Int+ range = oneof [ choose (0x21, 0x2e) -- remove 0x2f (slash)+ , choose (0x30, 0x7f)+ ]++instance Arbitrary Ref where+ arbitrary = fromBinary <$> arbitraryBS 20++arbitraryMsg = arbitraryBSno0 1+arbitraryLazy = L.fromChunks . (:[]) <$> arbitraryBS 40++arbitraryRefList :: Gen [Ref]+arbitraryRefList = replicateM 2 arbitrary++arbitraryEnt :: Gen TreeEnt+arbitraryEnt = liftM3 (,,) arbitrary (arbitraryEntname 23) arbitrary+arbitraryEnts = choose (1,2) >>= \i -> replicateM i arbitraryEnt++instance Arbitrary TimezoneOffset where+ arbitrary = TimezoneOffset <$> choose (-11*60, 12*60)+instance Arbitrary Elapsed where+ arbitrary = Elapsed . Seconds <$> choose (0,2^32-1)+instance Arbitrary GitTime where+ arbitrary = GitTime <$> arbitrary <*> arbitrary+instance Arbitrary ModePerm where+ arbitrary = ModePerm <$> elements [ 0o644, 0o664, 0o755, 0 ]+instance Arbitrary RevModifier where+ arbitrary = oneof+ [ RevModParent . getPositive <$> arbitrary+ , RevModParentFirstN . getPositive <$> arbitrary+ , RevModAtType <$> arbitraryType+ , RevModAtDate <$> arbitraryDate+ --, RevModAtN . getPositive <$> arbitrary+ ]++arbitraryDate = elements ["yesterday","29-Jan-1982","5 days ago"]+arbitraryType = elements ["commit","tree"]++instance Arbitrary Revision where+ arbitrary = do+ s <- choose (1,40) >>= flip replicateM (elements ['a'..'z'])+ rms <- choose (1,4) >>= flip replicateM arbitrary+ return $ Revision s rms++arbitraryName = liftM3 Person (arbitraryBSnoangle 16)+ (arbitraryBSnoangle 16)+ arbitrary++arbitraryObjTypeNoDelta = oneof [return TypeTree,return TypeBlob,return TypeCommit,return TypeTag]++arbitrarySmallList = frequency [ (2, return []), (1, resize 3 arbitrary) ]++instance Arbitrary Commit where+ arbitrary = Commit <$> arbitrary <*> arbitraryRefList <*> arbitraryName <*> arbitraryName <*> return Nothing <*> arbitrarySmallList <*> arbitraryMsg++instance Arbitrary CommitExtra where+ arbitrary = CommitExtra <$> arbitraryBSasciiNoSpace 80 <*> arbitraryMsg++instance Arbitrary Tree where+ arbitrary = Tree <$> arbitraryEnts++instance Arbitrary Blob where+ arbitrary = Blob <$> arbitraryLazy++instance Arbitrary Tag where+ arbitrary = Tag <$> arbitrary <*> arbitraryObjTypeNoDelta <*> arbitraryBSascii 20 <*> arbitraryName <*> arbitraryMsg++instance Arbitrary ObjNoDelta where+ arbitrary = ObjNoDelta <$> oneof+ [ toObject <$> (arbitrary :: Gen Commit)+ , toObject <$> (arbitrary :: Gen Tree)+ , toObject <$> (arbitrary :: Gen Blob)+ , toObject <$> (arbitrary :: Gen Tag)+ ]++prop_object_marshalling_id (ObjNoDelta obj) = obj `assertEq` (looseUnmarshall $ looseMarshall obj)+ where assertEq a b+ | show a == show b = True+ | otherwise = error ("not equal:\n" ++ show a ++ "\ngot: " ++ show b)++refTests =+ [ testProperty "hexadecimal" (marshEqual (fromHex . toHex))+ , testProperty "binary" (marshEqual (fromBinary . toBinary))+ , testProperty "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+ ]