hit 0.6.3 → 0.7.0
raw patch · 25 files changed
+22/−3590 lines, 25 filesdep +gitdep −attoparsecdep −byteabledep −bytedumpdep ~basedep ~bytestringdep ~hourglass
Dependencies added: git
Dependencies removed: attoparsec, byteable, bytedump, cryptohash, directory, filepath, hit, mtl, parsec, patience, random, system-fileio, system-filepath, tasty, tasty-quickcheck, unix-compat, utf8-string, vector, zlib, zlib-bindings
Dependency ranges changed: base, bytestring, hourglass
Files
- Data/Git.hs +0/−86
- Data/Git/Config.hs +0/−82
- Data/Git/Delta.hs +0/−84
- Data/Git/Diff.hs +0/−285
- Data/Git/Internal.hs +0/−43
- Data/Git/Named.hs +0/−194
- Data/Git/Path.hs +0/−45
- Data/Git/Ref.hs +0/−150
- Data/Git/Repository.hs +0/−312
- Data/Git/Revision.hs +0/−84
- Data/Git/Storage.hs +0/−351
- Data/Git/Storage/CacheFile.hs +0/−45
- Data/Git/Storage/FileReader.hs +0/−207
- Data/Git/Storage/FileWriter.hs +0/−59
- Data/Git/Storage/Loose.hs +0/−179
- Data/Git/Storage/Object.hs +0/−347
- Data/Git/Storage/Pack.hs +0/−156
- Data/Git/Storage/PackIndex.hs +0/−186
- Data/Git/Types.hs +0/−227
- Data/Git/WorkTree.hs +0/−151
- Hit/Hit.hs +12/−8
- README.md +2/−49
- Tests/Repo.hs +0/−59
- Tests/Tests.hs +0/−110
- hit.cabal +8/−91
− Data/Git.hs
@@ -1,86 +0,0 @@--- |--- 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
@@ -1,82 +0,0 @@--- |--- 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 Control.Applicative-import Control.Monad (mplus)-import Data.Git.Path-import Data.List (find)-import Filesystem.Path.CurrentOS-import Filesystem (getHomeDirectory)-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 filepath = parseConfig <$> readFile (encodeString filepath)-readConfig gitRepo = readConfigPath (configPath gitRepo)--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
@@ -1,84 +0,0 @@--- |--- 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.Attoparsec-import qualified Data.Attoparsec as A-import qualified Data.Attoparsec.Lazy as AL-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import Data.Bits-import Data.Word--import Control.Applicative ((<$>), many)---- | 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 = do- srcSize <- getDeltaHdrSize- resSize <- getDeltaHdrSize- dcmds <- many (anyWord8 >>= parseWithCmd)- return $ Delta srcSize resSize dcmds- where- getDeltaHdrSize = do- z <- A.takeWhile (\w -> w `testBit` 7)- l <- anyWord8- return $ unbytes 0 $ (map (\w -> w `clearBit` 7) (B.unpack z) ++ [l])- -- 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 <$> A.take (fromIntegral cmd)- word8cond cond sh =- if cond then (flip shiftL sh . fromIntegral) <$> anyWord8 else return 0---- | read one delta from a lazy bytestring.-deltaRead = AL.maybeResult . AL.parse deltaParse---- | 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
@@ -1,285 +0,0 @@--- |--- 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- , HitDiff(..)- , HitFileContent(..)- , FilteredDiff(..)- , HitFileRef(..)- , HitFileMode(..)- , 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)- a /= b = not (a == b)---- | 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 HitFileContent = NewBinaryFile- | OldBinaryFile- | NewTextFile [TextLine]- | OldTextFile [TextLine]- | ModifiedBinaryFile- | ModifiedFile [FilteredDiff]- | UnModifiedFile--data HitFileMode = NewMode ModePerm- | OldMode ModePerm- | ModifiedMode ModePerm ModePerm- | UnModifiedMode ModePerm--data HitFileRef = 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 HitDiff = HitDiff- { hFileName :: EntPath- , hFileContent :: HitFileContent- , hFileMode :: HitFileMode- , hFileRef :: HitFileRef- }---- | 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 [HitDiff]-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- -> [HitDiff] -- ^ Accumulator- -> [HitDiff] -- ^ 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 (HitDiff (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 (HitDiff (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- _ -> (HitDiff (bsFilename new) (content ref) mode ref):acc- where content :: HitFileRef -> HitFileContent- content (UnModifiedRef _) = UnModifiedFile- content _ = createDiff (bsContent old) (bsContent new)-- createDiff :: BlobContent -> BlobContent -> HitFileContent- 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 HitwebAccu = 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, HitwebAccu, [FilteredDiff]) -> (Int, HitwebAccu, [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/Internal.hs
@@ -1,43 +0,0 @@--- |--- Module : Data.Git.Internal--- License : BSD-style--- Maintainer : Vincent Hanquez <vincent@snarc.org>--- Stability : experimental--- Portability : unix----module Data.Git.Internal- ( be32- , be16- , Zipped(..)- , readZippedFile- , dezip- ) where--import Control.Applicative-import Data.Bits-import Data.Word-import qualified Data.ByteString as B-import qualified Data.ByteString.Lazy as L-import Codec.Compression.Zlib-import Filesystem.Path-import Filesystem.Path.Rules-import Prelude hiding (FilePath)--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)--newtype Zipped = Zipped { getZippedData :: L.ByteString }- deriving (Show,Eq)--readZippedFile :: FilePath -> IO Zipped-readZippedFile fp = Zipped <$> L.readFile (encodeString posix fp)--dezip :: Zipped -> L.ByteString-dezip = decompress . getZippedData
− Data/Git/Named.hs
@@ -1,194 +0,0 @@--- |--- 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 Control.Applicative ((<$>))--import qualified Filesystem as F-import qualified Filesystem.Path.Rules as FP (posix, decode, encode, encodeString, decodeString)-import Filesystem.Path.CurrentOS hiding (root)--import Data.String-import Data.Git.Path-import Data.Git.Ref-import Data.List (isPrefixOf)-import qualified Data.ByteString as B-import qualified Data.ByteString.Char8 as BC-import Prelude hiding (FilePath)---- | 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 = [ '~', '^', ':', '\\', '*', '?', '[' ]--isValidRefFilepath :: FilePath -> Bool-isValidRefFilepath f- | valid f = isValidRefName $ encodeString f- | otherwise = False---- FIXME BC.unpack/pack should be probably be utf8.toString,--- however i don't know if encoding is consistant.--- it should probably be overridable.-pathDecode :: B.ByteString -> FilePath-pathDecode = FP.decode FP.posix--pathEncode :: FilePath -> B.ByteString-pathEncode = FP.encode FP.posix--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 :: FilePath -> RefSpecTy -> FilePath-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 :: FilePath- -> ([(RefName, Ref)] -> a)- -> IO (PackedRefs a)-readPackedRefs gitRepo constr = do- exists <- F.isFile (packedRefsPath gitRepo)- if exists then readLines else return $ finalize emptyPackedRefs- where emptyPackedRefs = PackedRefs [] [] []- readLines = finalize . foldl accu emptyPackedRefs . BC.lines <$> F.readFile (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 = FP.encodeString FP.posix $ pathDecode $ 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 :: FilePath -> IO [RefName]-listRefs root = listRefsAcc [] root- where listRefsAcc acc dir = do- files <- F.listDirectory dir- getRefsRecursively dir acc files- getRefsRecursively _ acc [] = return acc- getRefsRecursively dir acc (x:xs) = do- isDir <- F.isDirectory x- extra <- if isDir- then listRefsAcc [] dir- else let r = stripRoot x- in if isValidRefFilepath r- then return [fromString $ encodeString r]- else return []- getRefsRecursively dir (extra ++ acc) xs- stripRoot p = maybe (error "stripRoot invalid") id $ stripPrefix root p--looseHeadsList :: FilePath -> IO [RefName]-looseHeadsList gitRepo = listRefs (headsPath gitRepo)--looseTagsList :: FilePath -> IO [RefName]-looseTagsList gitRepo = listRefs (tagsPath gitRepo)--looseRemotesList :: FilePath -> IO [RefName]-looseRemotesList gitRepo = listRefs (remotesPath gitRepo)--existsRefFile :: FilePath -> RefSpecTy -> IO Bool-existsRefFile gitRepo specty = F.isFile $ toPath gitRepo specty--writeRefFile :: FilePath -> RefSpecTy -> RefContentTy -> IO ()-writeRefFile gitRepo specty refcont = F.writeFile filepath $ fromRefContent refcont- where filepath = toPath gitRepo specty- fromRefContent (RefLink link) = B.concat ["ref: ", pathEncode $ FP.decodeString FP.posix $ fromRefTy link, B.singleton 0xa]- fromRefContent (RefDirect ref) = B.concat [toHex ref, B.singleton 0xa]- fromRefContent (RefContentUnknown c) = c--readRefFile :: FilePath -> RefSpecTy -> IO RefContentTy-readRefFile gitRepo specty = toRefContent <$> F.readFile filepath- where filepath = toPath gitRepo specty- toRefContent content- | "ref: " `B.isPrefixOf` content = RefLink $ toRefTy $ FP.encodeString FP.posix $ pathDecode $ head $ BC.lines $ B.drop 5 content- | B.length content < 42 = RefDirect $ fromHex $ B.take 40 content- | otherwise = RefContentUnknown content
− Data/Git/Path.hs
@@ -1,45 +0,0 @@--- |--- 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 Filesystem.Path.CurrentOS-import System.Random-import Control.Applicative ((<$>))-import Data.Git.Ref-import Data.String--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 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 gitRepo name ent = remotePath gitRepo name </> fromString ent--packDirPath repoPath = repoPath </> "objects" </> "pack"--indexPath repoPath indexRef =- packDirPath repoPath </> fromString ("pack-" ++ toHexString indexRef ++ ".idx")--packPath repoPath packRef =- packDirPath repoPath </> fromString ("pack-" ++ toHexString packRef ++ ".pack")--objectPath repoPath d f = repoPath </> "objects" </> fromString d </> fromString f-objectPathOfRef repoPath ref = objectPath repoPath d f- where (d,f) = toFilePathParts ref--objectTemporaryPath repoPath = do- r <- fst . random <$> getStdGen :: IO Int- return (repoPath </> "objects" </> fromString ("tmp-" ++ show r ++ ".tmp"))
− Data/Git/Ref.hs
@@ -1,150 +0,0 @@--- |--- 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- , toBinary- , toHex- , toHexString- -- * Misc function related to ref- , refPrefix- , cmpPrefix- , toFilePathParts- -- * Hash ByteString types to a ref- , hash- , hashLBS- ) where--import Control.Monad (forM_)-import qualified Crypto.Hash.SHA1 as SHA1-import Data.ByteString (ByteString)-import qualified Data.ByteString as B-import qualified Data.ByteString.Internal as B (unsafeCreate)-import qualified Data.ByteString.Unsafe as B (unsafeIndex)-import qualified Data.ByteString.Char8 as BC-import Data.Bits-import Data.Char (isHexDigit)-import Data.Data--import Foreign.Storable-import Control.Exception (Exception, throw)---- | represent a git reference (SHA1)-newtype Ref = Ref ByteString- deriving (Eq,Ord,Data,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,Data,Typeable)--instance Exception RefInvalid-instance Exception RefNotFound--isHex = and . map isHexDigit . BC.unpack-isHexString = and . map isHexDigit---- | take a hexadecimal bytestring that represent a reference--- and turn into a ref-fromHex :: ByteString -> Ref-fromHex s- | B.length s == 40 = Ref $ B.unsafeCreate 20 populateRef- | otherwise = throw $ RefInvalid s- where populateRef ptr = forM_ [0..19] $ \i -> do- let v = (unhex (B.unsafeIndex s (i*2+0)) `shiftL` 4) .|. unhex (B.unsafeIndex s (i*2+1))- pokeElemOff ptr (i+0) v-- unhex 0x30 = 0 -- '0'- unhex 0x31 = 1- unhex 0x32 = 2- unhex 0x33 = 3- unhex 0x34 = 4- unhex 0x35 = 5- unhex 0x36 = 6- unhex 0x37 = 7- unhex 0x38 = 8- unhex 0x39 = 9 -- '9'- unhex 0x41 = 10 -- 'A'- unhex 0x42 = 11- unhex 0x43 = 12- unhex 0x44 = 13- unhex 0x45 = 14- unhex 0x46 = 15 -- 'F'- unhex 0x61 = 10 -- 'a'- unhex 0x62 = 11- unhex 0x63 = 12- unhex 0x64 = 13- unhex 0x65 = 14- unhex 0x66 = 15 -- 'f'- unhex _ = throw $ RefInvalid s---- | 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) = B.unsafeCreate 40 populateHex- where populateHex ptr = forM_ [0..19] $ \i -> do- let (a,b) = B.unsafeIndex bs i `divMod` 16- pokeElemOff ptr (i*2+0) (hex a)- pokeElemOff ptr (i*2+1) (hex b)- hex i- | i >= 0 && i <= 9 = 0x30 + i- | i >= 10 && i <= 15 = 0x61 + i - 10- | otherwise = 0---- | transform a ref into an hexadecimal string-toHexString :: Ref -> String-toHexString = BC.unpack . toHex---- | transform a bytestring that represent a binary bytestring--- and returns a ref.-fromBinary :: ByteString -> Ref-fromBinary b- | B.length b == 20 = Ref b- | otherwise = throw $ RefInvalid b -- should hexify the ref here---- | turn a reference into a binary bytestring-toBinary :: Ref -> ByteString-toBinary (Ref b) = b---- | returns the prefix (leading byte) of this reference-refPrefix :: Ref -> Int-refPrefix (Ref b) = fromIntegral $ B.unsafeIndex 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 = Ref . SHA1.hash---- | hash a lazy bytestring into a reference-hashLBS = Ref . SHA1.hashlazy
− Data/Git/Repository.hs
@@ -1,312 +0,0 @@-{-# 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.Applicative ((<$>))-import Control.Monad-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.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,Data,Typeable)--instance Exception InvalidType---- should be a standard function that do that...-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 >>= 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 Ref- tryResolvers [] = return $ fromHexString prefix- tryResolvers (resolver:xs) = resolver >>= isResolved- where isResolved (Just r) = return r- isResolved Nothing = tryResolvers xs-- resolvePrePrefix :: IO (Maybe Ref)- resolvePrePrefix = 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
@@ -1,84 +0,0 @@--- |--- 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 Text.Parsec-import Data.String-import Data.Data---- | 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) id $ parse parser "" s- where parser = do- p <- many (noneOf "^~@")- mods <- many (choice [parseParent, parseFirstParent, parseAt])- return $ Revision p mods- parseParent = try $ do- _ <- char '^'- n <- optionMaybe (many1 digit)- case n of- Nothing -> return $ RevModParent 1- Just d -> return $ RevModParent (read d)- parseFirstParent = try $- char '~' >> many1 digit >>= return . RevModParentFirstN . read- parseAt = try $ do- _ <- char '@' >> char '{'- at <- choice [ parseAtType, parseAtDate, parseAtN ]- _ <- char '}'- return at- parseAtType = try $ do- ty <- choice $ map string ["tree","commit","blob","tag"]- return $ RevModAtType ty- parseAtN = try $ do- many1 digit >>= return . RevModAtN . read- parseAtDate = try $ do- many (noneOf "}") >>= return . RevModAtDate
− Data/Git/Storage.hs
@@ -1,351 +0,0 @@-{-# 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 Filesystem-import Filesystem.Path hiding (concat)-import Filesystem.Path.Rules-import System.Environment--import Control.Applicative-import Control.Exception-import qualified Control.Exception as E-import Control.Monad--import Data.String-import Data.List ((\\), isPrefixOf)-import Data.Either (partitionEithers)-import Data.IORef-import Data.Word--import Data.Git.Named-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.Map as M--import Prelude hiding (FilePath)--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 :: FilePath- , indexReaders :: IORef [(Ref, PackIndexReader)]- , packReaders :: IORef [(Ref, FileReader)]- , packedNamed :: CachedPackedRef- , configs :: IORef [Config]- }---- | open a new git repository context-openRepo :: FilePath -> 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 FilePath)-findRepoMaybe = do- menvDir <- E.catch (Just . decodeString posix_ghc704 <$> getEnv "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 -> FilePath -> IO (Maybe FilePath)- 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 FilePath-findRepo = do- menvDir <- E.catch (Just . decodeString posix_ghc704 <$> getEnv "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 -> FilePath -> IO FilePath- 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 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 :: FilePath -> 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 :: FilePath -> IO ()-initRepo path = do- exists <- isDirectory path- when exists $ error "destination directory already exists"- createDirectory True 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 <- Prelude.readFile $ encodeString posix 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- Prelude.writeFile (encodeString posix descriptionPath) desc- where descriptionPath = (gitRepoPath git) </> "description"--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 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 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
@@ -1,45 +0,0 @@-{-# 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.Applicative ((<$>))-import Control.Concurrent.MVar-import qualified Control.Exception as E-import Filesystem.Path-import Filesystem.Path.CurrentOS (encodeString)-import Prelude hiding (FilePath)-import System.PosixCompat.Files (getFileStatus, modificationTime)-import System.PosixCompat.Types (EpochTime)--data CacheFile a = CacheFile- { cacheFilepath :: FilePath- , cacheRefresh :: IO a- , cacheIniVal :: a- , cacheLock :: MVar (MTime, a)- }--timeZero = 0--newCacheVal :: FilePath -> 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 <- getMTime $ 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)--newtype MTime = MTime EpochTime deriving (Eq,Ord)--getMTime filepath = (Just . MTime . modificationTime <$> getFileStatus (encodeString filepath))- `E.catch` \(_ :: E.SomeException) -> return Nothing
− Data/Git/Storage/FileReader.hs
@@ -1,207 +0,0 @@--- |--- 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.Applicative ((<$>))-import Control.Exception (bracket, throwIO)-import Control.Monad--import Data.Attoparsec (parseWith, Parser, IResult(..))-import qualified Data.Attoparsec as A-import Data.Bits-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.Data-import Data.Word--import Codec.Zlib-import Codec.Zlib.Lowlevel-import Foreign.ForeignPtr-import qualified Control.Exception as E--import System.IO (hClose, hSeek, SeekMode(..))-import Filesystem-import Filesystem.Path-import Prelude hiding (FilePath)--data FileReader = FileReader- { fbHandle :: Handle- , fbUseInflate :: Bool- , fbInflate :: Inflate- , fbRemaining :: IORef 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 B.empty- pos <- newIORef 0- inflate <- initInflate defaultWindowBits- return $ FileReader handle decompress inflate ref pos--fileReaderClose :: FileReader -> IO ()-fileReaderClose = hClose . fbHandle--withFileReader :: FilePath -> (FileReader -> IO a) -> IO a-withFileReader path f =- bracket (openFile path ReadMode) (hClose) $ \handle ->- bracket (fileReaderNew False handle) (\_ -> return ()) f--withFileReaderDecompress :: FilePath -> (FileReader -> IO a) -> IO a-withFileReaderDecompress path f =- bracket (openFile path ReadMode) (hClose) $ \handle ->- bracket (fileReaderNew True handle) (\_ -> return ()) f--fileReaderGetNext :: FileReader -> IO 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 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--fileReaderGetPos :: FileReader -> IO Word64-fileReaderGetPos fr = do- storeLeft <- 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 <- readIORef ref- if B.length b >= left- then do- let (b1, b2) = B.splitAt left b- writeIORef ref 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 B.empty >> writeIORef pos absPos >> hSeek handle AbsoluteSeek (fromIntegral absPos)---- | parse from a filebuffer-fileReaderParse :: FileReader -> Parser a -> IO a-fileReaderParse fr@(FileReader { fbRemaining = ref }) parseF = do- initBS <- readIORef ref- result <- parseWith (fileReaderGetNext fr) parseF initBS- case result of- Done remaining a -> writeIORef ref remaining >> return a- Partial _ -> error "parsing failed: partial with a handle, reached EOF ?"- Fail _ ctxs err -> error ("parsing failed: " ++ show ctxs ++ " : " ++ show 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 $ do- bs <- A.takeWhile (\w -> w `testBit` 7)- l <- A.anyWord8- return $ (map (\w -> w `clearBit` 7) $ B.unpack bs) ++ [l]--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 rbs (fileReaderGetNext fb)- `E.catch` augmentAndRaise left- writeIORef ref 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 = do- zstr <- zstreamNew- inflateInit2 zstr defaultWindowBits- newForeignPtr c_free_z_stream_inflate zstr--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
@@ -1,59 +0,0 @@--- |--- 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.IORef-import qualified Data.ByteString as B-import Codec.Zlib-import Control.Exception (bracket)--import qualified Crypto.Hash.SHA1 as SHA1--import System.IO (hClose)-import Filesystem--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 SHA1.Ctx- }--fileWriterNew handle = do- deflate <- initDeflate defaultCompression defaultWindowBits- digest <- newIORef SHA1.init- return $ FileWriter- { writerHandle = handle- , writerDeflate = deflate- , writerDigest = digest- }--withFileWriter path f =- bracket (openFile path WriteMode) (hClose) $ \handle ->- bracket (fileWriterNew handle) (fileWriterClose) f--postDeflate handle = maybe (return ()) (B.hPut handle)--fileWriterOutput (FileWriter { writerHandle = handle, writerDigest = digest, writerDeflate = deflate }) bs = do- modifyIORefStrict digest (\ctx -> SHA1.update ctx bs)- (>>= postDeflate handle) =<< feedDeflate deflate bs--fileWriterClose (FileWriter { writerHandle = handle, writerDeflate = deflate }) =- postDeflate handle =<< finishDeflate deflate--fileWriterGetDigest (FileWriter { writerDigest = digest }) = (fromBinary . SHA1.finalize) `fmap` readIORef digest
− Data/Git/Storage/Loose.hs
@@ -1,179 +0,0 @@--- |--- 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.Storage.FileWriter-import Data.Git.Storage.Object--import Filesystem-import Filesystem.Path-import Filesystem.Path.Rules--import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString as B--import Data.Attoparsec.Lazy-import qualified Data.Attoparsec.Char8 as PC-import Control.Applicative ((<$>), (<|>))-import Control.Monad-import Control.Exception (onException, SomeException)-import qualified Control.Exception as E--import Data.String-import Data.Char (isHexDigit)--import Prelude hiding (FilePath)--isObjectPrefix [a,b] = isHexDigit a && isHexDigit b-isObjectPrefix _ = False--decimal :: Parser Int-decimal = PC.decimal---- loose object parsing-parseHeader = do- h <- takeWhile1 ((/=) 0x20)- _ <- word8 0x20- sz <- decimal- return (objectTypeUnmarshall $ BC.unpack h, fromIntegral sz, Nothing)--parseTreeHeader = string "tree " >> decimal >> word8 0-parseTagHeader = string "tag " >> decimal >> word8 0-parseCommitHeader = string "commit " >> decimal >> word8 0-parseBlobHeader = string "blob " >> decimal >> word8 0--parseTree = parseTreeHeader >> objectParseTree-parseTag = parseTagHeader >> objectParseTag-parseCommit = parseCommitHeader >> objectParseCommit-parseBlob = parseBlobHeader >> objectParseBlob--parseObject :: L.ByteString -> Object-parseObject = parseSuccess (parseTree <|> parseBlob <|> parseCommit <|> parseTag)- where parseSuccess p = either error id . eitherResult . parse p---- | 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 maybeResult $ parse parseHeader 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 repoPath ref = looseUnmarshallZippedRaw <$> readZippedFile (objectPathOfRef repoPath ref)---- | read only the header of a loose object.-looseReadHeader repoPath ref = toHeader <$> readZippedFile (objectPathOfRef repoPath ref)- where toHeader = either error id . eitherResult . parse parseHeader . dezip---- | read a specific ref from a loose object and returns an object-looseRead repoPath ref = looseUnmarshallZipped <$> readZippedFile (objectPathOfRef repoPath ref)---- | check if a specific ref exists as loose object-looseExists repoPath ref = isFile (objectPathOfRef repoPath ref)---- | enumarate all prefixes available in the object store.-looseEnumeratePrefixes repoPath = filter isObjectPrefix <$> getDirectoryContents (repoPath </> fromString "objects")---- | enumerate all references available with a specific prefix.-looseEnumerateWithPrefixFilter :: FilePath -> 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 :: FilePath -> String -> IO [Ref]-looseEnumerateWithPrefix repoPath prefix =- looseEnumerateWithPrefixFilter repoPath prefix (const True)---- | marshall as lazy bytestring an object except deltas.-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 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 repoPath obj = createDirectory True (directory 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 p = map (encodeString posix . filename) <$> listDirectory p
− Data/Git/Storage/Object.hs
@@ -1,347 +0,0 @@-{-# 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.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.Attoparsec.Lazy-import qualified Data.Attoparsec.Lazy as P-import qualified Data.Attoparsec.Char8 as PC-import Control.Applicative ((<$>), (<*), (*>), many)-import Control.Monad--import Data.List (intersperse)-import Data.Monoid-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 :: String -> 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 :: Parser Int-octal = B.foldl' step 0 `fmap` takeWhile1 isOct- where isOct w = w >= 0x30 && w <= 0x37- step a w = a * 8 + fromIntegral (w - 0x30)--modeperm :: Parser ModePerm-modeperm = ModePerm . fromIntegral <$> octal--tillEOL :: Parser ByteString-tillEOL = PC.takeWhile ((/= '\n'))--skipEOL = skipChar '\n'--skipChar :: Char -> Parser ()-skipChar c = PC.char c >> return ()--referenceHex = fromHex <$> P.take 40-referenceBin = fromBinary <$> P.take 20---- | parse a tree content-treeParse = Tree <$> parseEnts- where parseEnts = atEnd >>= \end -> if end then return [] else liftM2 (:) parseEnt parseEnts- parseEnt = liftM3 (,,) modeperm parseEntName (word8 0 >> referenceBin)- parseEntName = entName <$> (PC.char ' ' >> takeTill ((==) 0))---- | parse a blob content-blobParse = (Blob <$> takeLazyByteString)---- | parse a commit content-commitParse = do- tree <- string "tree " >> referenceHex- skipChar '\n'- parents <- many parseParentRef- author <- string "author " >> parsePerson- committer <- string "committer " >> parsePerson- encoding <- option Nothing $ Just <$> (string "encoding " >> tillEOL)- extras <- many parseExtra- skipChar '\n'- message <- takeByteString- return $ Commit tree parents author committer encoding extras message- where- parseParentRef = do- tree <- string "parent " >> referenceHex- skipChar '\n'- return tree- parseExtra = do- f <- B.pack . (:[]) <$> notWord8 0xa- r <- tillEOL- skipEOL- v <- concatLines <$> many (string " " *> tillEOL <* skipEOL)- return $ CommitExtra (f `B.append` r) v- concatLines = B.concat . intersperse (B.pack [0xa])---- | parse a tag content-tagParse = do- object <- string "object " >> referenceHex- skipChar '\n'- type_ <- objectTypeUnmarshall . BC.unpack <$> (string "type " >> takeTill ((==) 0x0a))- skipChar '\n'- tag <- string "tag " >> takeTill ((==) 0x0a)- skipChar '\n'- tagger <- string "tagger " >> parsePerson- skipChar '\n'- signature <- takeByteString- return $ Tag object type_ tag tagger signature--parsePerson = do- name <- B.init <$> PC.takeWhile ((/=) '<')- skipChar '<'- email <- PC.takeWhile ((/=) '>')- _ <- string "> "- time <- PC.decimal :: Parser Integer- _ <- string " "- timezoneFmt <- PC.signed PC.decimal- let timezoneSign = if timezoneFmt < 0 then negate else id- let (h,m) = abs timezoneFmt `divMod` 100- timezone = timezoneSign (h * 60 + m)- skipChar '\n'- return $ Person name email (gitTime time timezone)--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 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 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 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 = string7 "\n"--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 label (Person name email locTime) =- B.concat [label, " ", name, " <", email, "> ", BC.pack timeStr]- where timeStr = show locTime
− Data/Git/Storage/Pack.hs
@@ -1,156 +0,0 @@--- |--- 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.Applicative ((<$>))-import Control.Arrow (second)-import Control.Monad--import Filesystem.Path.Rules-import Filesystem.Path-import Filesystem--import Data.Bits-import Data.List-import qualified Data.ByteString.Lazy as L--import Data.Attoparsec (anyWord8)-import qualified Data.Attoparsec as A-import qualified Data.Attoparsec.Lazy as AL--import Data.Git.Internal-import Data.Git.Path-import Data.Git.Storage.Object-import Data.Git.Delta-import Data.Git.Ref-import Data.Git.Types-import Data.Git.Storage.FileReader--import Data.Word-import Prelude hiding (FilePath)--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 repoPath = map onlyHash . filter isPackFile . map (encodeString posix . filename) <$> listDirectory (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 :: FilePath -> 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 repoPath packRef =- withFileReader (packPath repoPath packRef) $ \filereader ->- fileReaderParse filereader parseHeader- where parseHeader = do- packMagic <- be32 <$> A.take 4- when (packMagic /= 0x5041434b) $ error "not a git packfile"- ver <- be32 <$> A.take 4- when (ver /= 2) $ error ("pack file version not supported: " ++ show ver)- be32 <$> A.take 4---- | read an object at a specific position using a map function on the objectData-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 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 { poiType = ty, poiExtra = extra }, objData) =- packObjectFromRaw (ty, extra, objData)--packObjectFromRaw (TypeCommit, Nothing, objData) = AL.maybeResult $ AL.parse objectParseCommit objData-packObjectFromRaw (TypeTree, Nothing, objData) = AL.maybeResult $ AL.parse objectParseTree objData-packObjectFromRaw (TypeBlob, Nothing, objData) = AL.maybeResult $ AL.parse objectParseBlob objData-packObjectFromRaw (TypeTag, Nothing, objData) = AL.maybeResult $ AL.parse objectParseTag objData-packObjectFromRaw (TypeDeltaOff, Just (PtrOfs o), objData) = toObject . DeltaOfs o <$> deltaRead objData-packObjectFromRaw (TypeDeltaRef, Just (PtrRef r), objData) = toObject . DeltaRef r <$> deltaRead 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 <$> anyWord8- size <- if m then (sz +) <$> getNextSize 4 else return sz- return (ty, size)- where- getNextSize n = do- (c, sz) <- splitOther n <$> anyWord8- 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
@@ -1,186 +0,0 @@--- |--- 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 Control.Applicative ((<$>))-import Control.Monad--import Filesystem-import Filesystem.Path-import Filesystem.Path.Rules--import Data.List-import Data.Bits-import Data.Word-import Data.String--import Data.Vector (Vector, (!))-import qualified Data.Vector as V--import qualified Data.Attoparsec as A--import Data.Git.Internal-import Data.Git.Storage.FileReader-import Data.Git.Path-import Data.Git.Ref--import Prelude hiding (FilePath)---- | 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 repoPath = map onlyHash . filter isPackFile . map (encodeString posix . filename) <$> listDirectory (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 :: FilePath -> 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 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 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 = do- magic <- be32 <$> A.take 4- when (magic /= 0xff744f63) $ error "wrong magic number for packIndex"- ver <- be32 <$> A.take 4- when (ver /= 2) $ error "unsupported packIndex version"- fanouts <- V.replicateM 256 (be32 <$> A.take 4)- 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 :: FilePath -> Ref -> IO PackIndexHeader-packIndexGetHeader repoPath indexRef = withPackIndex repoPath indexRef $ packIndexReadHeader---- | read all index-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) (fromBinary <$> A.take 20)- crcs <- V.replicateM (fromIntegral sz) (be32 <$> A.take 4)- packoffs <- V.replicateM (fromIntegral sz) (be32 <$> A.take 4)- let nbLarge = length $ filter (== True) $ map (\packoff -> packoff `testBit` 31) $ V.toList packoffs- largeoffs <- replicateM nbLarge (A.take 4)- packfileChecksum <- fromBinary <$> A.take 20- idxfileChecksum <- fromBinary <$> A.take 20- -- large packfile offsets- -- trailer- return (sha1s, crcs, packoffs, largeoffs, packfileChecksum, idxfileChecksum)
− Data/Git/Types.hs
@@ -1,227 +0,0 @@--- |--- 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.Monoid-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.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
@@ -1,151 +0,0 @@-{-# 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-
Hit/Hit.hs view
@@ -1,4 +1,7 @@ {-# LANGUAGE BangPatterns #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeApplications #-} -- | -- Module : Hit -- License : BSD-style@@ -31,11 +34,11 @@ import qualified Data.HashTable.IO as H import qualified Data.Hashable as Hashable -import Data.Algorithm.Patience as AP (Item(..))+import Data.Git.Diff.Patience as AP (Item(..)) type HashTable k v = H.CuckooHashTable k v -instance Hashable.Hashable Ref where+instance Hashable.Hashable (Ref SHA1) where hashWithSalt salt = Hashable.hashWithSalt salt . toBinary verifyPack pref git = do@@ -76,7 +79,7 @@ modifyIORef leftParsed (\i -> i-1) setObj_ refs offsets tree x - dumpTree :: HashTable Word64 Ref -> HashTable Ref (PackedObjectInfo, Maybe (ObjectPtr, Int)) -> M.Map Ref () -> IO ()+ dumpTree :: HashTable Word64 (Ref SHA1) -> HashTable (Ref SHA1) (PackedObjectInfo SHA1, Maybe (ObjectPtr SHA1, Int)) -> M.Map (Ref SHA1) () -> IO () dumpTree offsets tree refs = do forM_ (M.toAscList refs) $ \(ref, ()) -> do ent <- fromJust <$> H.lookup tree ref@@ -165,13 +168,14 @@ return () where author = commitAuthor commit +showDiff :: Revision -> Revision -> Git SHA1 -> IO () showDiff rev1 rev2 git = do ref1 <- maybe (error "revision cannot be found") id <$> resolveRevision git rev1 ref2 <- maybe (error "revision cannot be found") id <$> resolveRevision git rev2 diffList <- getDiffWith (defaultDiff 5) ([]) ref1 ref2 git mapM_ showADiff diffList where- showADiff :: HitDiff -> IO ()+ showADiff :: GitDiff SHA1 -> IO () showADiff hd = do printFileName $ hFileName hd printFileMode $ hFileMode hd@@ -181,20 +185,20 @@ printFileName :: EntPath -> IO () printFileName filename = putStrLn $ "Hit.Diff on file: " ++ (show filename) - printFileMode :: HitFileMode -> IO ()+ printFileMode :: GitFileMode -> IO () printFileMode (NewMode (ModePerm m)) = printf "new file mode: %06o\n" m printFileMode (OldMode (ModePerm m)) = printf "old file mode: %06o\n" m printFileMode (UnModifiedMode (ModePerm m)) = printf "current file mode: %06o\n" m printFileMode (ModifiedMode (ModePerm o) (ModePerm n)) = printf "file mode: %06o -> %06o\n" o n - printFileRef :: HitFileRef -> IO ()+ printFileRef :: GitFileRef SHA1 -> IO () printFileRef (NewRef r) = putStrLn $ "+++ new/" ++ (show r) printFileRef (OldRef r) = putStrLn $ "--- old/" ++ (show r) printFileRef (UnModifiedRef r) = putStrLn $ "=== cur/" ++ (show r) printFileRef (ModifiedRef o n) = do putStrLn $ "+++ new/" ++ (show n) putStrLn $ "--- old/" ++ (show o) - printFileDiff :: HitFileContent -> IO ()+ printFileDiff :: GitFileContent -> IO () printFileDiff NewBinaryFile = putStrLn "Binary file created" printFileDiff OldBinaryFile = putStrLn "Binary file deleted" printFileDiff ModifiedBinaryFile = putStrLn "Binary file modified"@@ -226,7 +230,7 @@ main = do args <- getArgs case args of- ["verify-pack",ref] -> withCurrentRepo $ verifyPack (fromHexString ref)+ ["verify-pack",ref] -> withCurrentRepo $ verifyPack (fromHexString @SHA1 ref) ["cat-file",ty,ref] -> withCurrentRepo $ catFile ty (fromHexString ref) ["ls-tree",rev] -> withCurrentRepo $ lsTree (fromString rev) "" ["ls-tree",rev,path] -> withCurrentRepo $ lsTree (fromString rev) path
README.md view
@@ -1,53 +1,6 @@ Hit === -Hit is a reimplementation of some git operations 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.--The main functions for users are available from the Data.Git module.--The essential functions are:--* withRepo: create a new git context and execute a function with the context. functional equivalent of withFile but for git repository.-* withCurrentRepo: similar to withRepo but found the repository from the user current directory.-* resolveRevision: turns a git revision (e.g. HEAD, 0a24^^^~3) into a SHA1 reference.-* resolvePath: from a commit ref and a path, it will gives the tree or blob reference of the object at the specific path (see example).-* getObject: from a SHA1 reference, gives a high level object (Commit, Blob, Tree, Tag, Delta) from the git repository. if called with resolveDelta set, it will resolves deltas to be simple objects with the deltas applied.-* getObjectRaw: similar to getObject but gives a raw representation (lazy bytestring) of the object.-* getCommit: similar to getObject but gives back a commit.-* getTree: similar to getObject but gives back a tree.--API Example--------------resolving path of the README file and returning the reference to the blob :-- {-# LANGUAGE OverloadedStrings #-}- import Data.Git.Repository-- showPathRef commitRef = withRepo ".git" $ \git -> do- ref <- maybe (error "inexistent object at this path") id `fmap` resolvePath git commitRef ["README"]- putStrLn ("README has the reference: " ++ show ref)---catting an object from a ref:-- import Data.Git.Repository-- catFile ref = withRepo ".git" $ \git -> do- obj <- maybe (error "not a valid object") id `fmap` getObjectRaw git ref True- L.putStrLn (oiData obj)-+Git like feature program using the git library -more examples on how to use api can be found in Hit.hs.+For the library, look at the 'git' packages, which is mostly compatible with 'hit'
− Tests/Repo.hs
@@ -1,59 +0,0 @@-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--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 = onLocalRepo $ \git -> do- doLocalMarshallEq git >>= printLocalMarshallError . catMaybes . concat- return ()
− Tests/Tests.hs
@@ -1,110 +0,0 @@-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.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 ]--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))- ]- where- marshEqual t ref = ref == t ref--objTests =- [ testProperty "unmarshall.marshall==id" prop_object_marshalling_id- ]--main = defaultMain $ testGroup "hit"- [ testGroup "ref marshalling" refTests- , testGroup "object marshalling" objTests- ]
hit.cabal view
@@ -1,15 +1,11 @@ Name: hit-Version: 0.6.3-Synopsis: Git operations in haskell+Version: 0.7.0+Synopsis: Git like program 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.+ Small haskell executable usable example using the git library .- 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.+ Library component is available at 'git' . License: BSD3 License-file: LICENSE@@ -19,107 +15,28 @@ Category: Development Stability: experimental Build-Type: Simple-Homepage: http://github.com/vincenthz/hit+Homepage: https://github.com/vincenthz/hit 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- , attoparsec >= 0.10.1- , parsec >= 3- , containers- , system-filepath- , system-fileio- , cryptohash- , vector- , random- , zlib- , zlib-bindings >= 0.1 && < 0.2- , hourglass >= 0.2- , unix-compat- , utf8-string- , patience- Exposed-modules: Data.Git- 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.Config- Data.Git.Storage.FileReader- Data.Git.Storage.FileWriter- Data.Git.Storage.CacheFile- Data.Git.Path- Data.Git.WorkTree- ghc-options: -Wall -fno-warn-missing-signatures- Executable Hit Main-Is: Hit.hs hs-source-dirs: Hit ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures if flag(debug) ghc-options: -rtsopts -auto-all -caf-all- if flag(executable)- Build-depends: base >= 4 && < 5- , mtl+ Build-depends: base >= 4 && < 7 , containers , hashable >= 1.2 , hashtables , bytestring- , attoparsec >= 0.10.1- , parsec >= 3- , filepath- , directory- , hit , hourglass- , patience- Buildable: True- else- Buildable: False--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- , hit--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- , hit+ , git >= 0.3.0 source-repository head type: git- location: git://github.com/vincenthz/hit+ location: https://github.com/vincenthz/hit