packages feed

hit 0.2.2 → 0.3.0

raw patch · 30 files changed

+2147/−1849 lines, 30 filesdep +hitdep +timedep ~basedep ~zlib-bindings

Dependencies added: hit, time

Dependency ranges changed: base, zlib-bindings

Files

+ Data/Git.hs view
@@ -0,0 +1,50 @@+-- |+-- Module      : Data.Git+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unix+--+module Data.Git+    (+    -- * Basic types+      Ref+    , Commit(..)+    , Tree(..)+    , Blob(..)+    , Tag(..)++    -- * Revision+    , Revision+    , resolveRevision++    -- * Object resolution+    , resolveTreeish+    , resolvePath++    -- * repo context+    , withCurrentRepo+    , withRepo+    , findRepo++    -- * Repository queries and creation+    , initRepo+    , isRepo++    -- * Context operations+    , rewrite++    -- * Get objects+    , getObject+    , getCommit+    , getTree++    -- * Set objects+    , setObject+    ) where++import Data.Git.Ref+import Data.Git.Types+import Data.Git.Storage+import Data.Git.Repository+import Data.Git.Revision
Data/Git/Delta.hs view
@@ -6,12 +6,12 @@ -- Portability : unix -- module Data.Git.Delta-	( Delta(..)-	, DeltaCmd(..)-	, deltaParse-	, deltaRead-	, deltaApply-	) where+        ( Delta(..)+        , DeltaCmd(..)+        , deltaParse+        , deltaRead+        , deltaApply+        ) where  import Data.Attoparsec import qualified Data.Attoparsec as A@@ -26,13 +26,13 @@  -- | a delta is a source size, a destination size and a list of delta cmd data Delta = Delta Word64 Word64 [DeltaCmd]-	deriving (Show,Eq)+        deriving (Show,Eq)  -- | possible commands in a delta data DeltaCmd =-	  DeltaCopy ByteString   -- command to insert this bytestring-	| DeltaSrc Word64 Word64 -- command to copy from source (offset, size)-	deriving (Show,Eq)+          DeltaCopy ByteString   -- command to insert this bytestring+        | DeltaSrc Word64 Word64 -- command to copy from source (offset, size)+        deriving (Show,Eq)  -- | parse a delta. -- format is 2 variable sizes, followed by delta cmds. for each cmd:@@ -40,35 +40,35 @@ -- * 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 = do-			if cond then (flip shiftL sh . fromIntegral) <$> anyWord8 else return 0+        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 = do+                        if cond then (flip shiftL sh . fromIntegral) <$> anyWord8 else return 0  -- | read one delta from a lazy bytestring. deltaRead = AL.maybeResult . AL.parse deltaParse@@ -76,9 +76,9 @@ -- | apply a delta on a lazy bytestring, returning a new bytestring. deltaApply :: L.ByteString -> Delta -> L.ByteString deltaApply src (Delta srcSize _ deltaCmds)-	| L.length src /= fromIntegral srcSize = error "source size do not match"-	| otherwise                            = -- FIXME use a bytestring builder here.-		L.fromChunks $ concatMap resolve deltaCmds where-			resolve (DeltaSrc o s) = L.toChunks $ takeAt (fromIntegral s) (fromIntegral o) src-			resolve (DeltaCopy b)  = [b]-			takeAt sz at = L.take sz . L.drop at+        | L.length src /= fromIntegral srcSize = error "source size do not match"+        | otherwise                            = -- FIXME use a bytestring builder here.+                L.fromChunks $ concatMap resolve deltaCmds where+                        resolve (DeltaSrc o s) = L.toChunks $ takeAt (fromIntegral s) (fromIntegral o) src+                        resolve (DeltaCopy b)  = [b]+                        takeAt sz at = L.take sz . L.drop at
− Data/Git/FileReader.hs 
@@ -1,193 +0,0 @@--- |--- Module      : Data.Git.FileReader--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : unix----module Data.Git.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.Word--import Codec.Zlib-import Codec.Zlib.Lowlevel-import Foreign.ForeignPtr--import System.IO--data FileReader = FileReader-	{ fbHandle     :: Handle-	, fbUseInflate :: Bool-	, fbInflate    :: Inflate-	, fbRemaining  :: IORef ByteString-	, fbPos        :: IORef Word64-	}--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 =<< withInflateInput (fbInflate fb) b id--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)-		writeIORef ref remaining-		let nleft = left - fromIntegral (B.length dbs)-		if nleft > 0-			then liftM (dbs:) (loop inflate nleft)-			else return [dbs]---- 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/FileWriter.hs 
@@ -1,52 +0,0 @@--- |--- Module      : Data.Git.FileWriter--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : unix----module Data.Git.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--defaultCompression = 6--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 _      Nothing    = return ()-postDeflate handle (Just dbs) = B.hPut handle dbs--fileWriterOutput (FileWriter { writerHandle = handle, writerDigest = digest, writerDeflate = deflate }) bs = do-	putStrLn ("outputing" ++ show bs)-	modifyIORef digest (\ctx -> SHA1.update ctx bs)-	postDeflate handle =<< withDeflateInput deflate bs id--fileWriterClose (FileWriter { writerHandle = handle, writerDeflate = deflate }) = do-	postDeflate handle =<< finishDeflate deflate id--fileWriterGetDigest (FileWriter { writerDigest = digest }) = (fromBinary . SHA1.finalize) `fmap` readIORef digest
− Data/Git/Index.hs 
@@ -1,182 +0,0 @@--- |--- Module      : Data.Git.Index--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : unix----{-# LANGUAGE OverloadedStrings, BangPatterns #-}-module Data.Git.Index-	( IndexHeader(..)-	, Index(..)--	-- * handles and enumeration-	, indexOpen-	, indexClose-	, withIndex-	, indexEnumerate--	-- * read from index-	, indexHeaderGetNbWithPrefix-	, indexGetReferenceLocation-	, indexGetReferencesWithPrefix-	, indexReadHeader-	, indexRead-	, indexGetHeader-	) where--import Control.Applicative ((<$>))-import Control.Monad--import System.FilePath-import System.Directory-import System.IO--import Data.List-import Data.Bits-import Data.Word--import Data.Vector (Vector, (!))-import qualified Data.Vector as V--import qualified Data.Attoparsec as A--import Data.Git.Internal-import Data.Git.FileReader-import Data.Git.Path-import Data.Git.Ref---- | represent an index header with the version and the fanout table-data IndexHeader = IndexHeader !Word32 !(Vector Word32)-	deriving (Show,Eq)--data Index = Index-	{ indexSha1s        :: Vector Ref-	, indexCRCs         :: Vector Word32-	, indexPackoffs     :: Vector Word32-	, indexPackChecksum :: Ref-	, indexChecksum     :: Ref-	}---- | enumerate every indexes file in the pack directory-indexEnumerate repoPath = map onlyHash . filter isPackFile <$> getDirectoryContents (repoPath </> "objects" </> "pack")-	where-		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-indexOpen :: FilePath -> Ref -> IO FileReader-indexOpen repoPath indexRef = openFile (indexPath repoPath indexRef) ReadMode >>= fileReaderNew False---- | close an index-indexClose :: FileReader -> IO ()-indexClose = fileReaderClose---- | variant of withFile on the index file and with a FileReader-withIndex repoPath indexRef = withFileReader (indexPath repoPath indexRef)---- | returns the number of references, referenced in this index.-indexHeaderGetSize :: IndexHeader -> Word32-indexHeaderGetSize (IndexHeader _ indexes) = indexes ! 255---- | byte size of an index header.-indexHeaderByteSize :: Int-indexHeaderByteSize = 2*4 {- header -} + 256*4 {- fanout table -}---- | get the number of reference in this index with a specific prefix-indexHeaderGetNbWithPrefix :: IndexHeader -> Int -> Word32-indexHeaderGetNbWithPrefix (IndexHeader _ indexes) n-	| n < 0 || n > 255 = 0-	| n == 0           = indexes ! 0-	| otherwise        = (indexes ! n) - (indexes ! (n-1))---- | fold on refs with a specific prefix-indexHeaderFoldRef :: IndexHeader -> FileReader -> Int -> (a -> Word32 -> Ref -> (a, Bool)) -> a -> IO a-indexHeaderFoldRef idxHdr@(IndexHeader _ 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         = indexHeaderGetNbWithPrefix idxHdr refprefix-		(sha1Offset,_,_) = indexOffsets idxHdr---- | return the reference offset in the packfile if found-indexGetReferenceLocation :: IndexHeader -> FileReader -> Ref -> IO (Maybe Word64)-indexGetReferenceLocation idxHdr@(IndexHeader _ indexes) fr ref = do-	mrpos <- indexHeaderFoldRef 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         = indexHeaderGetNbWithPrefix idxHdr refprefix-		(_,_,packOffset) = indexOffsets idxHdr---- | get all references that start by prefix.-indexGetReferencesWithPrefix :: IndexHeader -> FileReader -> String -> IO [Ref]-indexGetReferencesWithPrefix idxHdr fr prefix =-	indexHeaderFoldRef 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.-indexOffsets idx = (indexSha1sOffset, indexCRCsOffset, indexPackOffOffset)-	where-		indexPackOffOffset = indexCRCsOffset + crcsTableSz-		indexCRCsOffset    = indexSha1sOffset + sha1TableSz-		indexSha1sOffset   = fromIntegral indexHeaderByteSize-		crcsTableSz        = 4 * sz-		sha1TableSz        = 20 * sz-		sz                 = indexHeaderGetSize idx---- | parse index header-parseIndexHeader = do-	magic   <- be32 <$> A.take 4-	when (magic /= 0xff744f63) $ error "wrong magic number for index"-	ver     <- be32 <$> A.take 4-	when (ver /= 2) $ error "unsupported index version"-	fanouts <- V.replicateM 256 (be32 <$> A.take 4)-	return $ IndexHeader ver fanouts---- | read index header from an index filereader-indexReadHeader :: FileReader -> IO IndexHeader-indexReadHeader fr = fileReaderSeek fr 0 >> fileReaderParse fr parseIndexHeader---- | get index header from an index reference-indexGetHeader :: FilePath -> Ref -> IO IndexHeader-indexGetHeader repoPath indexRef = withIndex repoPath indexRef $ indexReadHeader---- | read all index-indexRead repoPath indexRef = do-	withIndex repoPath indexRef $ \fr -> do-		idx <- fileReaderParse fr parseIndexHeader-		liftM2 (,) (return idx) (fileReaderParse fr (parseIndex $ indexHeaderGetSize idx))-	where parseIndex 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/Internal.hs view
@@ -6,8 +6,9 @@ -- Portability : unix -- module Data.Git.Internal-	( be32-	) where+        ( be32+        , be16+        ) where  import Data.Bits import Data.Word@@ -18,3 +19,7 @@        + fromIntegral (B.index b 1) `shiftL` 16        + fromIntegral (B.index b 2) `shiftL` 8        + fromIntegral (B.index b 3)++be16 :: B.ByteString -> Word16+be16 b = fromIntegral (B.index b 0) `shiftL` 8+       + fromIntegral (B.index b 1)
− Data/Git/Loose.hs 
@@ -1,152 +0,0 @@--- |--- Module      : Data.Git.Loose--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : unix----{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}-module Data.Git.Loose-	(-	-- * marshall from and to lazy bytestring-	  looseUnmarshall-	, looseUnmarshallRaw-	, 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.FileWriter-import Data.Git.Object--import System.FilePath-import System.Directory-import System.IO (openFile, hFileSize, IOMode(..))--import qualified Data.ByteString.Char8 as BC-import qualified Data.ByteString.Lazy as L--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.Char (isHexDigit)--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 lazy bytestring.-looseUnmarshall :: L.ByteString -> Object-looseUnmarshall = parseObject . decompress---- | unmarshall an object as (header, data) tuple from a lazy bytestring.-looseUnmarshallRaw :: L.ByteString -> (ObjectHeader, ObjectData)-looseUnmarshallRaw l =-	let dl = decompress l in-	let i = L.findIndex ((==) 0) dl in-	case i of-		Nothing  -> error "object not right format. missing 0"-		Just idx ->-			let (h, r) = L.splitAt (idx+1) dl in-			case maybeResult $ parse parseHeader h of-				Nothing  -> error "cannot open object"-				Just hdr -> (hdr, r)---- | read a specific ref from a loose object and returns an header and data.-looseReadRaw repoPath ref = looseUnmarshallRaw <$> L.readFile (objectPathOfRef repoPath ref)---- | read only the header of a loose object.-looseReadHeader repoPath ref = toHeader <$> L.readFile (objectPathOfRef repoPath ref)-	where toHeader = either error id . eitherResult . parse parseHeader . decompress---- | read a specific ref from a loose object and returns an object-looseRead repoPath ref = looseUnmarshall <$> L.readFile (objectPathOfRef repoPath ref)---- | check if a specific ref exists as loose object-looseExists repoPath ref = doesFileExist (objectPathOfRef repoPath ref)---- | enumarate all prefixes available in the object store.-looseEnumeratePrefixes repoPath = filter isObjectPrefix <$> getDirectoryContents (repoPath </> "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 </> "objects" </> prefix)-	where-		getDir p = E.catch (getDirectoryContents p) (\(_::SomeException) -> return [])-		isRef l = length l == 38--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         = compress $ 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 <- openFile file ReadMode >>= hFileSize-	let hdr = objectWriteHeader TypeBlob (fromIntegral fsz)-	tmpPath <- objectTemporaryPath repoPath-	flip onException (removeFile tmpPath) $ do-		npath <- withFileWriter tmpPath $ \fw -> do-			fileWriterOutput fw hdr-			chunks <- L.toChunks <$> L.readFile file-			mapM_ (fileWriterOutput fw) chunks-			digest <- fileWriterGetDigest fw-			return $ objectPathOfRef repoPath digest-		exists <- doesFileExist npath-		when exists $ error "destination already exists"-		renameFile tmpPath npath---- | write an object to disk as a loose reference.--- use looseWriteBlobFromFile for efficiently writing blobs when being commited from a file.-looseWrite repoPath obj = L.writeFile (objectPathOfRef repoPath ref) content-	where-		content = looseMarshall obj-		ref     = hashLBS content
Data/Git/Named.hs view
@@ -7,19 +7,19 @@ -- Portability : unix -- module Data.Git.Named-	( headList-	, headExists-	, headRead-	, headWrite-	, remotesList-	, remoteList-	, tagList-	, tagExists-	, tagRead-	, tagWrite-	, specialRead-	, specialExists-	) where+        ( headsList+        , headExists+        , headRead+        , headWrite+        , remotesList+        , remoteList+        , tagsList+        , tagExists+        , tagRead+        , tagWrite+        , specialRead+        , specialExists+        ) where  import Control.Applicative ((<$>)) @@ -32,10 +32,10 @@ import qualified Data.ByteString.Char8 as BC  getDirectoryContentNoDots path = filter noDot <$> getDirectoryContents path-	where noDot = (not . isPrefixOf ".")+        where noDot = (not . isPrefixOf ".") -headList gitRepo = getDirectoryContentNoDots (headsPath gitRepo)-tagList gitRepo = getDirectoryContentNoDots (tagsPath gitRepo)+headsList gitRepo = getDirectoryContentNoDots (headsPath gitRepo)+tagsList gitRepo = getDirectoryContentNoDots (tagsPath gitRepo) remotesList gitRepo = getDirectoryContentNoDots (remotesPath gitRepo) remoteList gitRepo remote = getDirectoryContentNoDots (remotePath gitRepo remote) @@ -43,12 +43,12 @@ readRef path = fromHex . B.take 40 <$> B.readFile path  readRefAndFollow gitRepo path = do-	content <- B.readFile path-	if "ref: " `B.isPrefixOf` content-		then do -- BC.unpack should be utf8.toString, and the whole thing is really fragile. need to do the proper thing.-			let file = BC.unpack $ BC.init $ B.drop 5 content-			readRefAndFollow gitRepo (gitRepo ++ "/" ++ file)-		else return (fromHex $ B.take 40 content)+        content <- B.readFile path+        if "ref: " `B.isPrefixOf` content+                then do -- BC.unpack should be utf8.toString, and the whole thing is really fragile. need to do the proper thing.+                        let file = BC.unpack $ BC.init $ B.drop 5 content+                        readRefAndFollow gitRepo (gitRepo ++ "/" ++ file)+                else return (fromHex $ B.take 40 content)  headExists gitRepo name    = doesFileExist (headPath gitRepo name) headRead gitRepo name      = readRef (headPath gitRepo name)
− Data/Git/Object.hs 
@@ -1,346 +0,0 @@-{-# LANGUAGE ExistentialQuantification #-}--- |--- Module      : Data.Git.Object--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : unix----{-# LANGUAGE OverloadedStrings #-}-module Data.Git.Object-	( ObjectLocation(..)-	, ObjectType(..)-	, ObjectHeader-	, ObjectData-	, ObjectPtr(..)-	, Object(..)-	, Tree(..)-	, Commit(..)-	, Blob(..)-	, Tag(..)-	, DeltaOfs(..)-	, DeltaRef(..)-	, ObjectInfo(..)-	, objectWrap-	, 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.Delta--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.Word-import Text.Printf--{--import Blaze.ByteString.Builder-import Blaze.ByteString.Builder.ByteString--}---- | location of an object in the database-data ObjectLocation = NotFound | Loose Ref | Packed Ref Word64-	deriving (Show,Eq)---- | 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 = (Int,ByteString,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)-type Name = (ByteString,ByteString,Int,Int)---- | type of a git object.-data ObjectType =-	  TypeTree-	| TypeBlob-	| TypeCommit-	| TypeTag-	| TypeDeltaOff-	| TypeDeltaRef-	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)--class Objectable a where-	getType :: a -> ObjectType-	getRaw  :: a -> L.ByteString-	isDelta :: a -> Bool--	toCommit :: a -> Maybe Commit-	toCommit = const Nothing-	toTree   :: a -> Maybe Tree-	toTree = const Nothing-	toTag    :: a -> Maybe Tag-	toTag = const Nothing-	toBlob   :: a -> Maybe Blob-	toBlob = const Nothing---- | 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 through packs.-data Object = forall a . Objectable a => Object a--objectWrap :: Objectable a => a -> Object-objectWrap a = Object a--data Tree = Tree { treeGetEnts :: [TreeEnt] } deriving (Show,Eq)-data Blob = Blob { blobGetContent :: L.ByteString } deriving (Show,Eq)-data Commit = Commit-	{ commitTreeish   :: Ref-	, commitParents   :: [Ref]-	, commitAuthor    :: Name-	, commitCommitter :: Name-	, commitMessage   :: ByteString-	} deriving (Show,Eq)-data Tag = Tag-	{ tagRef        :: Ref-	, tagObjectType :: ObjectType-	, tagBlob       :: ByteString-	, tagName       :: Name-	, tagS          :: ByteString-	} deriving (Show,Eq)-data DeltaOfs = DeltaOfs Word64 Delta-	deriving (Show,Eq)-data DeltaRef = DeltaRef Ref Delta-	deriving (Show,Eq)--objectToType :: Object -> ObjectType-objectToType (Object a) = getType a--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 (Object a) = isDelta a--objectToTree :: Object -> Maybe Tree-objectToTree (Object a) = toTree a--objectToCommit :: Object -> Maybe Commit-objectToCommit (Object a) = toCommit a--objectToTag :: Object -> Maybe Tag-objectToTag (Object a) = toTag a--objectToBlob :: Object -> Maybe Blob-objectToBlob (Object a) = toBlob a---- | 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)--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)--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 (,,) octal (PC.char ' ' >> takeTill ((==) 0)) (word8 0 >> referenceBin)--- | 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 " >> parseName-	committer <- string "committer " >> parseName-	skipChar '\n'-	message <- takeByteString-	return $ Commit tree parents author committer message-	where-		parseParentRef = do-			tree <- string "parent " >> referenceHex-			skipChar '\n'-			return tree-		--- | 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 " >> parseName-	skipChar '\n'-	signature <- takeByteString-	return $ Tag object type_ tag tagger signature--parseName = do-	name <- B.init <$> PC.takeWhile ((/=) '<')-	skipChar '<'-	email <- PC.takeWhile ((/=) '>')-	_ <- string "> "-	time <- PC.decimal-	_ <- string " "-	timezone <- PC.signed PC.decimal-	skipChar '\n'-	return (name, email, time, timezone)--objectParseTree = objectWrap <$> treeParse-objectParseCommit = objectWrap <$> commitParse-objectParseTag = objectWrap <$> tagParse-objectParseBlob = objectWrap <$> 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 (Object a) = getRaw a--treeWrite (Tree ents) = L.fromChunks $ concat $ map writeTreeEnt ents where-	writeTreeEnt (perm,name,ref) =-		[ BC.pack $ printf "%o" perm-		, BC.singleton ' '-		, name-		, B.singleton 0-		, toBinary ref-		]--commitWrite (Commit tree parents author committer msg) =-	L.fromChunks [BC.unlines ls, B.singleton 0xa, msg]-	where-		ls = [ "tree " `BC.append` (toHex tree) ] ++-		     map (BC.append "parent " . toHex) parents ++-		     [ writeName "author" author-		     , writeName "committer" committer ]--tagWrite (Tag ref ty tag tagger signature) =-	L.fromChunks [BC.unlines ls, B.singleton 0xa, signature]-	where-		ls = [ "object " `BC.append` (toHex ref)-		     , "type " `BC.append` (BC.pack $ objectTypeMarshall ty)-		     , "tag " `BC.append` tag-		     , writeName "tagger" tagger ]--blobWrite (Blob bData) = bData--instance Objectable Blob where-	getType _ = TypeBlob-	getRaw    = blobWrite-	isDelta   = const False-	toBlob t  = Just t--instance Objectable Commit where-	getType _  = TypeCommit-	getRaw     = commitWrite-	isDelta    = const False-	toCommit t = Just t--instance Objectable Tag where-	getType _ = TypeTag-	getRaw    = tagWrite-	isDelta   = const False-	toTag t   = Just t--instance Objectable Tree where-	getType _ = TypeTree-	getRaw    = treeWrite-	isDelta   = const False-	toTree t  = Just t--instance Objectable DeltaOfs where-	getType _ = TypeDeltaOff-	getRaw    = error "delta offset cannot be marshalled"-	isDelta   = const True--instance Objectable DeltaRef where-	getType _ = TypeDeltaRef-	getRaw    = error "delta ref cannot be marshalled"-	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 (name, email, time, tz) =-	B.concat [label, " ", name, " <", email, "> ", BC.pack (show time), " ", BC.pack (showtz tz)]-	where showtz i = (if i > 0 then "+" else "") ++ show i
− Data/Git/Pack.hs 
@@ -1,152 +0,0 @@--- |--- Module      : Data.Git.Pack--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : unix----module Data.Git.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 System.IO-import System.FilePath-import System.Directory--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.Object-import Data.Git.Delta-import Data.Git.Ref-import Data.Git.FileReader--import Data.Word--type PackedObjectRaw = (PackedObjectInfo, L.ByteString)--data PackedObjectInfo = PackedObjectInfo-	{ poiType       :: ObjectType-	, poiOffset     :: Word64-	, poiSize       :: Word64-	, poiActualSize :: Word64-	, poiExtra      :: Maybe ObjectPtr-	} deriving (Show,Eq)---- | Enumerate the pack refs available in this repository.-packEnumerate repoPath = map onlyHash . filter isPackFile <$> getDirectoryContents (repoPath </> "objects" </> "pack")-	where-		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) = objectWrap . DeltaOfs o <$> deltaRead objData-packObjectFromRaw (TypeDeltaRef, Just (PtrRef r), objData) = objectWrap . 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/Path.hs view
@@ -26,15 +26,15 @@ packDirPath repoPath = repoPath </> "objects" </> "pack"  indexPath repoPath indexRef =-	packDirPath repoPath </> ("pack-" ++ toHexString indexRef ++ ".idx")+        packDirPath repoPath </> ("pack-" ++ toHexString indexRef ++ ".idx")  packPath repoPath packRef =-	packDirPath repoPath </> ("pack-" ++ toHexString packRef ++ ".pack")+        packDirPath repoPath </> ("pack-" ++ toHexString packRef ++ ".pack")  objectPath repoPath d f = repoPath </> "objects" </> d </> f objectPathOfRef repoPath ref = objectPath repoPath d f-	where (d,f) = toFilePathParts ref+        where (d,f) = toFilePathParts ref  objectTemporaryPath repoPath = do-	r <- fst . random <$> getStdGen :: IO Int-	return (repoPath </> "objects" </> ("tmp-" ++ show r ++ ".tmp"))+        r <- fst . random <$> getStdGen :: IO Int+        return (repoPath </> "objects" </> ("tmp-" ++ show r ++ ".tmp"))
Data/Git/Ref.hs view
@@ -6,21 +6,21 @@ -- Portability : unix -- module Data.Git.Ref-	( Ref-	, isHex-	, isHexString-	, fromHex-	, fromHexString-	, fromBinary-	, toBinary-	, toHex-	, toHexString-	, refPrefix-	, cmpPrefix-	, toFilePathParts-	, hash-	, hashLBS-	) where+        ( Ref+        , isHex+        , isHexString+        , fromHex+        , fromHexString+        , fromBinary+        , toBinary+        , toHex+        , toHexString+        , refPrefix+        , cmpPrefix+        , toFilePathParts+        , hash+        , hashLBS+        ) where  import Control.Monad (forM_) import qualified Crypto.Hash.SHA1 as SHA1@@ -36,10 +36,10 @@  -- | represent a git reference (SHA1) newtype Ref = Ref ByteString-	deriving (Eq,Ord)+        deriving (Eq,Ord)  instance Show Ref where-	show = BC.unpack . toHex+        show = BC.unpack . toHex  isHex = and . map isHexDigit . BC.unpack isHexString = and . map isHexDigit@@ -48,36 +48,36 @@ -- and turn into a ref fromHex :: ByteString -> Ref fromHex s-	| B.length s == 40 = Ref $ B.unsafeCreate 20 populateRef-	| otherwise        = error ("not a valid hex ref: " ++ show 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+        | B.length s == 40 = Ref $ B.unsafeCreate 20 populateRef+        | otherwise        = error ("not a valid hex ref: " ++ show 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 _    = error "error fromHex: not a valid hex character"+                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 _    = error "error fromHex: not a valid hex character"  -- | take a hexadecimal string that represent a reference -- and turn into a ref@@ -87,15 +87,15 @@ -- | 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+        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@@ -105,8 +105,8 @@ -- and returns a ref. fromBinary :: ByteString -> Ref fromBinary b-	| B.length b == 20 = Ref b-	| otherwise        = error "not a valid binary ref"+        | B.length b == 20 = Ref b+        | otherwise        = error "not a valid binary ref"  -- | turn a reference into a binary bytestring toBinary :: Ref -> ByteString
Data/Git/Repository.hs view
@@ -8,374 +8,191 @@ -- Portability : unix -- module Data.Git.Repository-	( Git-	, HTree-	, HTreeEnt(..)-	, gitRepoPath-	, openRepo-	, closeRepo-	, withRepo-	, findRepo-	, findReference-	, findReferencesWithPrefix-	, findObjectRaw-	, findObjectRawAt-	, findObject-	, findCommit-	, findTree-	, findObjectAt-	, buildHTree-	, resolvePath-	, resolveTreeish-	, resolveRevision-	, initRepo-	, isRepo-	) where--import System.Directory-import System.FilePath-import System.Environment+        ( Git+        , HTree+        , HTreeEnt(..)+        , getCommit+        , getTree+        , rewrite+        , buildHTree+        , resolvePath+        , resolveTreeish+        , resolveRevision+        , initRepo+        , isRepo+        ) where  import Control.Applicative ((<$>))-import Control.Exception-import qualified Control.Exception as E import Control.Monad -import Data.Word-import Data.IORef-import Data.List ((\\), find, isPrefixOf)+import Data.Maybe (fromMaybe)+import Data.List (find)  import Data.ByteString (ByteString) -import Data.Git.Delta-import Data.Git.FileReader-import Data.Git.Index-import Data.Git.Pack import Data.Git.Named-import Data.Git.Object+import Data.Git.Types+import Data.Git.Storage.Object+import Data.Git.Storage import Data.Git.Revision-import Data.Git.Loose+import Data.Git.Storage.Loose import Data.Git.Ref -data IndexReader = IndexReader IndexHeader FileReader---- | represent an git repo, with possibly already opened filereaders--- for indexes and packs-data Git = Git-	{ gitRepoPath  :: FilePath-	, indexReaders :: IORef [(Ref, IndexReader)]-	, packReaders  :: IORef [(Ref, FileReader)]-	}- -- | hierarchy tree, either a reference to a blob (file) or a tree (directory). data HTreeEnt = TreeDir Ref HTree | TreeFile Ref type HTree = [(Int,ByteString,HTreeEnt)] --- | open a new git repository context-openRepo :: FilePath -> IO Git-openRepo path = liftM2 (Git path) (newIORef []) (newIORef [])---- | 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 (IndexReader _ fr) = fileReaderClose fr---- | find the git repository from the current directory.-findRepo :: IO FilePath-findRepo = do-	menvDir <- E.catch (Just <$> getEnv "GIT_DIR") (\(_:: SomeException) -> return Nothing)-	case menvDir of-		Nothing     -> checkDir 0-		Just envDir -> do-			e <- isRepo envDir-			when (not e) $ error "environment GIT_DIR is not a git repository" -			return envDir-	where-		checkDir 128 = error "not a git repository"-		checkDir n   = do-			let filepath = concat (replicate n ("../") ++ [".git"])-			e <- isRepo filepath-			if e then return filepath else checkDir (n+1)---- | execute a function f with a git context.-withRepo path f = bracket (openRepo path) closeRepo f----iterateIndexes :: Git -> (a -> (IdxRef, IndexReader) -> IO (a,Bool)) -> a -> IO a-iterateIndexes git f initAcc = do-	allIndexes    <- indexEnumerate (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 <- indexOpen (gitRepoPath git) idxref-			idx <- indexReadHeader fr-			let idxreader = IndexReader 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--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, (IndexReader idxhdr indexreader)) = do-			mloc <- indexGetReferenceLocation 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"-	| not (isHexString pre) = error "reference prefix contains non hexchar"-	| 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 (_, (IndexReader idxhdr indexreader)) = do-			refs <- indexGetReferencesWithPrefix idxhdr indexreader pre-			return (refs:acc,False)--readRawFromPack :: Git -> Ref -> Word64 -> IO (FileReader, PackedObjectRaw)-readRawFromPack git pref offset = do-	readers <- readIORef (packReaders git)-	reader <- case lookup pref readers of-		Just r  -> return r-		Nothing -> do-			p <- packOpen (gitRepoPath git) pref-			modifyIORef (packReaders git) ((pref, p):)-			return p-	po <- packReadRawAtOffset reader offset-	return (reader, po)--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 <- findObjectRaw 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-findObjectRawAt :: Git -> ObjectLocation -> Bool -> IO (Maybe ObjectInfo)-findObjectRawAt _   NotFound    _ = return Nothing-findObjectRawAt git (Loose ref) _ = Just . (\(h,d)-> ObjectInfo h d[]) <$> looseReadRaw (gitRepoPath git) ref-findObjectRawAt git (Packed pref o) resolveDelta = readFromPack git pref o resolveDelta---- | get an object from repository-findObjectRaw :: Git -> Ref -> Bool -> IO (Maybe ObjectInfo)-findObjectRaw git ref resolveDelta = do-	loc <- findReference git ref-	findObjectRawAt git loc resolveDelta---- | get an object type from repository-findObjectType :: Git -> Ref -> IO (Maybe ObjectType)-findObjectType git ref = findReference git ref >>= findObjectTypeAt-	where-		findObjectTypeAt NotFound        = return Nothing-		findObjectTypeAt (Loose _)       = Just . (\(t,_,_) -> t) <$> looseReadHeader (gitRepoPath git) ref-		findObjectTypeAt (Packed pref o) =-			fmap ((\(ty,_,_) -> ty) . oiHeader) <$> readFromPack git pref o True---- | get an object from repository using a location to reference it.-findObjectAt :: Git -> ObjectLocation -> Bool -> IO (Maybe Object)-findObjectAt git loc resolveDelta = maybe Nothing toObject <$> findObjectRawAt git loc resolveDelta-	where-		toObject (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData)---- | get an object from repository using a ref.-findObject :: Git -> Ref -> Bool -> IO (Maybe Object)-findObject git ref resolveDelta = maybe Nothing toObject <$> findObjectRaw git ref resolveDelta-	where-		toObject (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData)- -- should be a standard function that do that... mapJustM f (Just o) = f o mapJustM _ Nothing  = return Nothing -findCommit :: Git -> Ref -> IO (Maybe Commit)-findCommit git ref = findObject git ref True >>= mapJustM unwrap-	where-		unwrap (objectToCommit -> Just c@(Commit _ _ _ _ _)) = return $ Just c-		unwrap _                                             = return Nothing+-- | get a specified commit+getCommit :: Git -> Ref -> IO (Maybe Commit)+getCommit git ref = getObject git ref True >>= mapJustM unwrap+        where+                unwrap (objectToCommit -> Just c@(Commit _ _ _ _ _)) = return $ Just c+                unwrap _                                             = return Nothing -findTree :: Git -> Ref -> IO (Maybe Tree)-findTree git ref = findObject git ref True >>= mapJustM unwrap-	where-		unwrap (objectToTree -> Just c@(Tree _ )) = return $ Just c-		unwrap _                                  = return Nothing+-- | get a specified tree+getTree :: Git -> Ref -> IO (Maybe Tree)+getTree git ref = getObject git ref True >>= mapJustM unwrap+        where+                unwrap (objectToTree -> Just c@(Tree _ )) = return $ Just c+                unwrap _                                  = return Nothing  -- | 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) = resolvePrefix >>= modf modifiers-	where-		resolvePrefix :: IO Ref-		resolvePrefix = resolveNamedPrefix fs >>= maybe resolvePrePrefix (return . Just) >>= maybe (return $ fromHexString prefix) return+        where+                resolvePrefix :: IO Ref+                resolvePrefix = resolveNamedPrefix fs >>= maybe resolvePrePrefix (return . Just) >>= maybe (return $ fromHexString prefix) return -		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"+                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" -		fs = [ (specialExists, specialRead), (tagExists, tagRead), (headExists, headRead) ]+                fs = [ (specialExists, specialRead), (tagExists, tagRead), (headExists, headRead) ] -		resolveNamedPrefix []     = return Nothing-		resolveNamedPrefix (x:xs) = do-			exists <- (fst x) (gitRepoPath git) prefix-			if exists-				then Just <$> (snd x) (gitRepoPath git) prefix-				else resolveNamedPrefix xs-	-		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+                resolveNamedPrefix []     = return Nothing+                resolveNamedPrefix (x:xs) = do+                        exists <- (fst x) (gitRepoPath git) prefix+                        if exists+                                then Just <$> (snd x) (gitRepoPath git) prefix+                                else resolveNamedPrefix xs+        +                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"+                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 = do-			obj <- findCommit git ref-			case obj of-				Just (Commit _ parents _ _ _) -> return parents-				Nothing -> error "reference in commit chain doesn't exists"+                getParentRefs ref = do+                        obj <- getCommit git ref+                        case obj of+                                Just (Commit _ parents _ _ _) -> return parents+                                Nothing -> error "reference in commit chain doesn't exists"  -- | 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 = findObject git ref True >>= mapJustM recToTree where-	recToTree (objectToCommit -> Just (Commit tree _ _ _ _)) = resolveTreeish git tree-	recToTree (objectToTag    -> Just (Tag tref _ _ _ _))    = resolveTreeish git tref-	recToTree (objectToTree   -> Just t@(Tree _))            = return $ Just t-	recToTree _                                              = return Nothing+resolveTreeish git ref = getObject git ref True >>= mapJustM recToTree where+        recToTree (objectToCommit -> Just (Commit 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 . fromMaybe (error "commit cannot be found") <$> getCommit git ref+          resolveParents n ref = do commit <- fromMaybe (error "commit cannot be found") <$> 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) . objectWrap >>= flip rewriteOne next++          rewriteOne prevRef [] = return prevRef+          rewriteOne prevRef ((_,commit):next) = do+                      newCommit <- mapCommit $ commit { commitParents = [prevRef] }+                      ref       <- looseWrite (gitRepoPath git) (objectWrap 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 <- findObjectType git ref-		case obj of-			Just TypeBlob -> return (perm, ent, TreeFile ref)-			Just TypeTree -> do-				ctree <- findTree git ref-				case ctree of-					Nothing -> error "unknown reference in tree object: no such child"-					Just t  -> do-						dir   <- buildHTree git t-						return (perm, ent, TreeDir ref dir)-			Just _        -> error "wrong type embedded in tree object"-			Nothing       -> error "unknown reference in tree object"+        where resolveTree (perm, ent, ref) = do+                obj <- getObjectType git ref+                case obj of+                        Just TypeBlob -> return (perm, ent, TreeFile ref)+                        Just TypeTree -> do+                                ctree <- getTree git ref+                                case ctree of+                                        Nothing -> error "unknown reference in tree object: no such child"+                                        Just t  -> do+                                                dir   <- buildHTree git t+                                                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 -> Ref -> [ByteString] -> IO (Maybe Ref)+resolvePath :: Git            -- ^ repository+            -> Ref            -- ^ commit reference+            -> [ByteString]   -- ^ paths+            -> IO (Maybe Ref) resolvePath git commitRef paths = do-	commit <- findCommit git commitRef-	case commit of-		Just (Commit tree _ _ _ _) -> resolve tree paths-		Nothing                    -> error ("not a valid ref: " ++ show commitRef)-	where-		resolve :: Ref -> [ByteString] -> IO (Maybe Ref)-		resolve treeRef []     = return $ Just treeRef-		resolve treeRef (x:xs) = do-			tree <- findTree git treeRef-			case tree of-				Just (Tree ents) -> do-					let cEnt = treeEntRef <$> findEnt x ents-					if xs == []-						then return cEnt-						else maybe (return Nothing) (\z -> resolve z xs) cEnt-				Nothing          -> error ("not a valid ref: " ++ show treeRef)--		findEnt x = find (\(_, b, _) -> b == x)-		treeEntRef (_,_,r) = r-	--- | basic checks to see if a specific path looks like a git repo.-isRepo :: FilePath -> IO Bool-isRepo path = do-	dir     <- doesDirectoryExist path-	subDirs <- mapM (doesDirectoryExist . (path </>))-		["branches","hooks","info"-		,"logs","objects","refs"-		,"refs"</>"heads","refs"</>"tags"]-	return $ and ([dir] ++ subDirs)+        commit <- getCommit git commitRef+        case commit of+                Just (Commit tree _ _ _ _) -> resolve tree paths+                Nothing                    -> error ("not a valid commit ref: " ++ show commitRef)+        where+                resolve :: Ref -> [ByteString] -> IO (Maybe Ref)+                resolve treeRef []     = return $ Just treeRef+                resolve treeRef (x:xs) = do+                        tree <- getTree git treeRef+                        case tree of+                                Just (Tree ents) -> do+                                        let cEnt = treeEntRef <$> findEnt x ents+                                        if xs == []+                                                then return cEnt+                                                else maybe (return Nothing) (\z -> resolve z xs) cEnt+                                Nothing          -> error ("not a valid tree ref: " ++ show treeRef) --- | initialize a new repository at a specific location.-initRepo :: FilePath -> IO ()-initRepo path = do-	exists <- doesDirectoryExist path-	when exists $ error "destination directory already exists"-	createDirectory path-	mapM_ (createDirectory . (path </>))-		["branches","hooks","info"-		,"logs","objects","refs"-		,"refs"</>"heads","refs"</>"tags"]+                findEnt x = find (\(_, b, _) -> b == x)+                treeEntRef (_,_,r) = r
Data/Git/Revision.hs view
@@ -1,51 +1,55 @@ -- |--- Module      : Data.Git.Delta+-- Module      : Data.Git.Revision -- License     : BSD-style -- Maintainer  : Vincent Hanquez <vincent@snarc.org> -- Stability   : experimental -- Portability : unix -- module Data.Git.Revision-	( Revision(..)-	, RevModifier(..)-	, revFromString-	) where+        ( Revision(..)+        , RevModifier(..)+        , fromString+        ) where  import Text.Parsec+import Data.String  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)+          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 Revision = Revision String [RevModifier]-	deriving (Eq)+        deriving (Eq) +instance IsString Revision where+    fromString = revFromString+ 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+        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 view
@@ -0,0 +1,277 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module      : Data.Git.Storage+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unix+--++module Data.Git.Storage+    ( Git+    , gitRepoPath+    , openRepo+    , closeRepo+    , withRepo+    , withCurrentRepo+    , findRepo+    , isRepo+    , initRepo+    , iterateIndexes+    , findReference+    , findReferencesWithPrefix+    -- * getting objects+    , getObjectRaw+    , getObjectRawAt+    , getObject+    , getObjectAt+    , getObjectType+    -- * setting objects+    , setObject+    ) where++import System.Directory+import System.FilePath+import System.Environment++import Control.Applicative ((<$>))+import Control.Exception+import qualified Control.Exception as E+import Control.Monad++import Data.List ((\\), isPrefixOf)+import Data.IORef+import Data.Word++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.Ref++data PackIndexReader = PackIndexReader PackIndexHeader FileReader++-- | represent an git repo, with possibly already opened filereaders+-- for indexes and packs+data Git = Git+        { gitRepoPath  :: FilePath+        , indexReaders :: IORef [(Ref, PackIndexReader)]+        , packReaders  :: IORef [(Ref, FileReader)]+        }++-- | open a new git repository context+openRepo :: FilePath -> IO Git+openRepo path = liftM2 (Git path) (newIORef []) (newIORef [])++-- | 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+findRepo :: IO FilePath+findRepo = do+        menvDir <- E.catch (Just <$> getEnv "GIT_DIR") (\(_:: SomeException) -> return Nothing)+        case menvDir of+                Nothing     -> checkDir 0+                Just envDir -> do+                        e <- isRepo envDir+                        when (not e) $ error "environment GIT_DIR is not a git repository" +                        return envDir+        where+                checkDir 128 = error "not a git repository"+                checkDir n   = do+                        let filepath = concat (replicate n ("../") ++ [".git"])+                        e <- isRepo filepath+                        if e then return filepath else checkDir (n+1)++-- | 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     <- doesDirectoryExist path+        subDirs <- mapM (doesDirectoryExist . (path </>))+                ["branches","hooks","info"+                ,"logs","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 <- doesDirectoryExist path+        when exists $ error "destination directory already exists"+        createDirectory path+        mapM_ (createDirectory . (path </>))+                ["branches","hooks","info"+                ,"logs","objects","refs"+                ,"refs"</>"heads","refs"</>"tags"]++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"+        | not (isHexString pre) = error "reference prefix contains non hexchar"+        | 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 toObject <$> getObjectRawAt git loc resolveDelta+        where+                toObject (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 toObject <$> getObjectRaw git ref resolveDelta+        where+                toObject (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData)++-- | 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/FileReader.hs view
@@ -0,0 +1,193 @@+-- |+-- Module      : Data.Git.Storage.FileReader+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unix+--+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.Word++import Codec.Zlib+import Codec.Zlib.Lowlevel+import Foreign.ForeignPtr++import System.IO++data FileReader = FileReader+        { fbHandle     :: Handle+        , fbUseInflate :: Bool+        , fbInflate    :: Inflate+        , fbRemaining  :: IORef ByteString+        , fbPos        :: IORef Word64+        }++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)+                writeIORef ref remaining+                let nleft = left - fromIntegral (B.length dbs)+                if nleft > 0+                        then liftM (dbs:) (loop inflate nleft)+                        else return [dbs]++-- 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 view
@@ -0,0 +1,50 @@+-- |+-- 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++defaultCompression = 6++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+        modifyIORef 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 view
@@ -0,0 +1,158 @@+-- |+-- Module      : Data.Git.Storage.Loose+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unix+--+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}+module Data.Git.Storage.Loose+        (+        -- * marshall from and to lazy bytestring+          looseUnmarshall+        , looseUnmarshallRaw+        , 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.Storage.FileWriter+import Data.Git.Storage.Object++import System.FilePath+import System.Directory+import System.IO (openFile, hFileSize, IOMode(..))++import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as L++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.Char (isHexDigit)++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 lazy bytestring.+looseUnmarshall :: L.ByteString -> Object+looseUnmarshall = parseObject . decompress++-- | unmarshall an object as (header, data) tuple from a lazy bytestring.+looseUnmarshallRaw :: L.ByteString -> (ObjectHeader, ObjectData)+looseUnmarshallRaw l =+        let dl = decompress l in+        let i = L.findIndex ((==) 0) dl in+        case i of+                Nothing  -> error "object not right format. missing 0"+                Just idx ->+                        let (h, r) = L.splitAt (idx+1) dl in+                        case maybeResult $ parse parseHeader h of+                                Nothing  -> error "cannot open object"+                                Just hdr -> (hdr, r)++-- | read a specific ref from a loose object and returns an header and data.+looseReadRaw repoPath ref = looseUnmarshallRaw <$> L.readFile (objectPathOfRef repoPath ref)++-- | read only the header of a loose object.+looseReadHeader repoPath ref = toHeader <$> L.readFile (objectPathOfRef repoPath ref)+        where toHeader = either error id . eitherResult . parse parseHeader . decompress++-- | read a specific ref from a loose object and returns an object+looseRead repoPath ref = looseUnmarshall <$> L.readFile (objectPathOfRef repoPath ref)++-- | check if a specific ref exists as loose object+looseExists repoPath ref = doesFileExist (objectPathOfRef repoPath ref)++-- | enumarate all prefixes available in the object store.+looseEnumeratePrefixes repoPath = filter isObjectPrefix <$> getDirectoryContents (repoPath </> "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 </> "objects" </> 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 <- openFile file ReadMode >>= hFileSize+        let hdr = objectWriteHeader TypeBlob (fromIntegral fsz)+        tmpPath <- objectTemporaryPath repoPath+        flip onException (removeFile tmpPath) $ do+                (ref, npath) <- withFileWriter tmpPath $ \fw -> do+                        fileWriterOutput fw hdr+                        chunks <- L.toChunks <$> L.readFile file+                        mapM_ (fileWriterOutput fw) chunks+                        digest <- fileWriterGetDigest fw+                        return (digest, objectPathOfRef repoPath digest)+                exists <- doesFileExist npath+                when exists $ error "destination already exists"+                renameFile tmpPath npath+                return ref++-- | write an object to disk as a loose reference.+-- use looseWriteBlobFromFile for efficiently writing blobs when being commited from a file.+looseWrite repoPath obj = createDirectoryIfMissing True (takeDirectory path)+                       >> doesFileExist path+                       >>= \exists -> unless exists (L.writeFile path $ compress content)+                       >> return ref+        where+                path    = objectPathOfRef repoPath ref+                content = looseMarshall obj+                ref     = hashLBS content
+ Data/Git/Storage/Object.hs view
@@ -0,0 +1,287 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}+-- |+-- 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(..)+        , objectWrap+        , 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.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.Word+import Text.Printf++import Data.Time.LocalTime+import Data.Time.Clock.POSIX++{-+import Blaze.ByteString.Builder+import Blaze.ByteString.Builder.ByteString+-}++-- | 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)++class Objectable a where+        getType :: a -> ObjectType+        getRaw  :: a -> L.ByteString+        isDelta :: a -> Bool++        toCommit :: a -> Maybe Commit+        toCommit = const Nothing+        toTree   :: a -> Maybe Tree+        toTree = const Nothing+        toTag    :: a -> Maybe Tag+        toTag = const Nothing+        toBlob   :: a -> Maybe Blob+        toBlob = const Nothing++-- | 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 through packs.+data Object = forall a . Objectable a => Object a++objectWrap :: Objectable a => a -> Object+objectWrap a = Object a++objectToType :: Object -> ObjectType+objectToType (Object a) = getType a++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 (Object a) = isDelta a++objectToTree :: Object -> Maybe Tree+objectToTree (Object a) = toTree a++objectToCommit :: Object -> Maybe Commit+objectToCommit (Object a) = toCommit a++objectToTag :: Object -> Maybe Tag+objectToTag (Object a) = toTag a++objectToBlob :: Object -> Maybe Blob+objectToBlob (Object a) = toBlob a++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)++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 (,,) octal (PC.char ' ' >> takeTill ((==) 0)) (word8 0 >> referenceBin)+-- | 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 " >> parseName+        committer <- string "committer " >> parseName+        skipChar '\n'+        message <- takeByteString+        return $ Commit tree parents author committer message+        where+                parseParentRef = do+                        tree <- string "parent " >> referenceHex+                        skipChar '\n'+                        return tree+                +-- | 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 " >> parseName+        skipChar '\n'+        signature <- takeByteString+        return $ Tag object type_ tag tagger signature++parseName = do+        name <- B.init <$> PC.takeWhile ((/=) '<')+        skipChar '<'+        email <- PC.takeWhile ((/=) '>')+        _ <- string "> "+        time <- PC.decimal :: Parser Integer+        _ <- string " "+        timezone <- PC.signed PC.decimal+        let (hours,minutes) = timezone `divMod` 100+        skipChar '\n'+        let tz = minutesToTimeZone (hours*60 + (if hours > 0 then minutes else (-minutes)))+        return (name, email, posixSecondsToUTCTime $ fromIntegral time, tz)++objectParseTree = objectWrap <$> treeParse+objectParseCommit = objectWrap <$> commitParse+objectParseTag = objectWrap <$> tagParse+objectParseBlob = objectWrap <$> 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 (Object a) = getRaw a++treeWrite (Tree ents) = L.fromChunks $ concat $ map writeTreeEnt ents where+        writeTreeEnt (perm,name,ref) =+                [ BC.pack $ printf "%o" perm+                , BC.singleton ' '+                , name+                , B.singleton 0+                , toBinary ref+                ]++commitWrite (Commit tree parents author committer msg) =+        L.fromChunks [BC.unlines ls, B.singleton 0xa, msg]+        where+                ls = [ "tree " `BC.append` (toHex tree) ] +++                     map (BC.append "parent " . toHex) parents +++                     [ writeName "author" author+                     , writeName "committer" committer ]++tagWrite (Tag ref ty tag tagger signature) =+        L.fromChunks [BC.unlines ls, B.singleton 0xa, signature]+        where+                ls = [ "object " `BC.append` (toHex ref)+                     , "type " `BC.append` (BC.pack $ objectTypeMarshall ty)+                     , "tag " `BC.append` tag+                     , writeName "tagger" tagger ]++blobWrite (Blob bData) = bData++instance Objectable Blob where+        getType _ = TypeBlob+        getRaw    = blobWrite+        isDelta   = const False+        toBlob t  = Just t++instance Objectable Commit where+        getType _  = TypeCommit+        getRaw     = commitWrite+        isDelta    = const False+        toCommit t = Just t++instance Objectable Tag where+        getType _ = TypeTag+        getRaw    = tagWrite+        isDelta   = const False+        toTag t   = Just t++instance Objectable Tree where+        getType _ = TypeTree+        getRaw    = treeWrite+        isDelta   = const False+        toTree t  = Just t++instance Objectable DeltaOfs where+        getType _ = TypeDeltaOff+        getRaw    = error "delta offset cannot be marshalled"+        isDelta   = const True++instance Objectable DeltaRef where+        getType _ = TypeDeltaRef+        getRaw    = error "delta ref cannot be marshalled"+        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 (name, email, time, tz) =+        B.concat [label, " ", name, " <", email, "> ", BC.pack (printf "%d %s" timeSeconds (timeZoneOffsetString tz)) ]+        where timeSeconds :: Integer+              timeSeconds = truncate (realToFrac $ utcTimeToPOSIXSeconds time :: Double)
+ Data/Git/Storage/Pack.hs view
@@ -0,0 +1,153 @@+-- |+-- Module      : Data.Git.Storage.Pack+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unix+--+module Data.Git.Storage.Pack+        ( PackedObjectInfo(..)+        , PackedObjectRaw+        -- * Enumerators of packs+        , packEnumerate+        -- * Helpers to process packs+        , packOpen+        , packClose+        -- * Command for the content of a pack+        , packReadHeader+        , packReadMapAtOffset+        , packReadAtOffset+        , packReadRawAtOffset+        , packEnumerateObjects+        -- * turn a packed object into a +        , packedObjectToObject+        , packObjectFromRaw+        ) where++import Control.Applicative ((<$>))+import Control.Arrow (second)+import Control.Monad++import System.IO+import System.FilePath+import System.Directory++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++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 <$> getDirectoryContents (repoPath </> "objects" </> "pack")+        where+                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) = objectWrap . DeltaOfs o <$> deltaRead objData+packObjectFromRaw (TypeDeltaRef, Just (PtrRef r), objData) = objectWrap . 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 view
@@ -0,0 +1,182 @@+-- |+-- 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 System.FilePath+import System.Directory+import System.IO++import Data.List+import Data.Bits+import Data.Word++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++-- | 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 <$> getDirectoryContents (repoPath </> "objects" </> "pack")+        where+                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 view
@@ -0,0 +1,108 @@+-- |+-- Module      : Data.Git.Object+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unix+--+module Data.Git.Types+    (+    -- * Type of types+      ObjectType(..)+    -- * Main git types+    , Tree(..)+    , Commit(..)+    , Blob(..)+    , Tag(..)+    -- * Pack delta types+    , DeltaOfs(..)+    , DeltaRef(..)+    -- * Basic types part of other bigger types+    , TreeEnt+    , Name+    ) where++import Data.Word+import Data.Monoid+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as L++import Data.Git.Ref+import Data.Git.Delta+import Data.Time.Clock+import Data.Time.LocalTime++-- | type of a git object.+data ObjectType =+          TypeTree+        | TypeBlob+        | TypeCommit+        | TypeTag+        | TypeDeltaOff+        | TypeDeltaRef+        deriving (Show,Eq)++-- | 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)++-- | 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 = (Int,ByteString,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)+type Name = (ByteString,ByteString,UTCTime,TimeZone)++-- | 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    :: Name+        , commitCommitter :: Name+        , commitMessage   :: ByteString+        } deriving (Show,Eq)++-- | Represent a signed tag.+data Tag = Tag+        { tagRef        :: Ref+        , tagObjectType :: ObjectType+        , tagBlob       :: ByteString+        , tagName       :: Name+        , 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)
− Hit.hs 
@@ -1,160 +0,0 @@-{-# LANGUAGE BangPatterns #-}--- |--- Module      : Hit--- License     : BSD-style--- Maintainer  : Vincent Hanquez <vincent@snarc.org>--- Stability   : experimental--- Portability : unix----module Main where--import System.Environment-import Control.Applicative ((<$>))-import Control.Monad-import Data.IORef-import Data.Maybe-import Data.Git.Pack-import Data.Git.Object-import Data.Git.Ref-import Data.Git.Repository-import Data.Git.Revision-import Data.Word-import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString.Char8 as BC-import Text.Printf-import qualified Data.Map as M-import qualified Data.HashTable.IO as H-import qualified Data.Hashable as Hashable--type HashTable k v = H.CuckooHashTable k v--instance Hashable.Hashable Ref where-	hash = Hashable.hash . toBinary--verifyPack pref git = do-	offsets     <- H.new-	tree        <- H.new-	refs        <- newIORef M.empty-	entries     <- fromIntegral <$> packReadHeader (gitRepoPath git) pref-	leftParsed  <- newIORef entries-	-- enumerate all objects either directly in tree for fully formed objects-	-- or a list of delta to resolves -	packEnumerateObjects (gitRepoPath git) pref entries (setObj leftParsed refs offsets tree)-	readIORefAndReplace refs M.empty >>= dumpTree offsets tree-	where-		readIORefAndReplace ioref emptyVal = do-			v <- readIORef ioref-			writeIORef ioref emptyVal-			return v--		setObj_ refs offsets tree (!info, objData)-			| objectTypeIsDelta (poiType info) = do-				(!ty, !ref, !ptr, !lenChain) <- do-					let loc = Packed pref (poiOffset info)-					objInfo <- maybe (error "cannot find delta chain") id <$> findObjectRawAt git loc True-					let (ty, sz, _) = oiHeader objInfo-					let !ref = objectHash ty sz (oiData objInfo)-					let ptr = head $ oiChains objInfo -- it's safe since deltas always have a non empty valid chain-					return (ty, ref, ptr, (length $ oiChains objInfo))-				H.insert tree ref (info { poiType = ty }, Just (ptr, lenChain))-			| otherwise = do-				let !ref = objectHash (poiType info) (poiActualSize info) objData-				modifyIORef refs (M.insert ref ())-				H.insert offsets (poiOffset info) ref-				H.insert tree ref (info,Nothing)--		setObj leftParsed refs offsets tree x = do-			parsed <- readIORef leftParsed-			when ((parsed `mod` 256) == 0) $ putStrLn (show parsed ++ " left to parse")-			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 offsets tree refs = do-			forM_ (M.toAscList refs) $ \(ref, ()) -> do-				ent <- fromJust <$> H.lookup tree ref-				printEnt offsets ref ent--		-- print one line about the entry-		-- format is <sha1> <type> <real size> <size> <offset> [<number of chain element> <parent element>]-		printEnt _ ref (info,Nothing) = do-			printf "%s %-6s %d %d %d\n" (show ref)-			       (objectTypeMarshall $ poiType info)-			       (poiActualSize info)-			       (poiSize info)-			       (poiOffset info)--		printEnt offsets ref (info,Just (parentOffset, lenChain)) = do-			parentRef <- case parentOffset of-				PtrRef r -> return r-				PtrOfs off -> do-					let poff = poiOffset info - off-					maybe (error "cannot find delta's parent in pack ?") id <$> H.lookup offsets poff-			printf "%s %-6s %d %d %d %d %s\n" (show ref)-			       (objectTypeMarshall $ poiType info)-			       (poiActualSize info)-			       (poiSize info)-			       (poiOffset info)-			       (lenChain)-			       (show parentRef)---catFile ty ref git = do-	let expectedType = case ty of-		"commit" -> Just TypeCommit-		"blob"   -> Just TypeBlob-		"tag"    -> Just TypeTag-		"tree"   -> Just TypeTree-		"-t"     -> Nothing-		_        -> error "unknown type request"-	mobj <- findObjectRaw git ref True-	case mobj of-		Nothing  -> error "not a valid object"-		Just obj ->-			let (objty, _, _) = oiHeader obj in-			case expectedType of-				Nothing  -> putStrLn $ objectTypeMarshall objty-				Just ety -> do-					when (ety /= objty) $ error "not expected type"-					L.putStrLn (oiData obj)--lsTree revision _ git = do-	ref <- maybe (error "revision cannot be found") id <$> resolveRevision git revision-	tree <- resolveTreeish git ref-	case tree of-		Just t -> do-			htree <- buildHTree git t-			mapM_ (showTreeEnt) htree -		_      -> error "cannot build a tree from this reference"-	where-		showTreeEnt (p,n,TreeDir r _) = printf "%06o tree %s    %s\n" p (show r) (BC.unpack n)-		showTreeEnt (p,n,TreeFile r)  = printf "%06o blob %s    %s\n" p (show r) (BC.unpack n)--revList revision git = do-	ref <- maybe (error "revision cannot be found") id <$> resolveRevision git revision-	loopTillEmpty ref-	where loopTillEmpty ref = do-		obj <- findCommit git ref-		case obj of-			Just (Commit _ parents _ _ _) -> do-				putStrLn $ show ref-				-- this behave like rev-list --first-parent.-				-- otherwise the parents need to be organized and printed-				-- in a reverse chronological fashion.-				case parents of-					[]    -> return ()-					(p:_) -> loopTillEmpty p-			Nothing -> error "reference in commit chain doesn't exists"--main = do-	p    <- findRepo-	args <- getArgs-	case args of-		["verify-pack",ref]  -> withRepo p $ verifyPack (fromHexString ref)-		["cat-file",ty,ref]  -> withRepo p $ catFile ty (fromHexString ref)-		["ls-tree",rev]      -> withRepo p $ lsTree (revFromString rev) ""-		["ls-tree",rev,path] -> withRepo p $ lsTree (revFromString rev) path-		["rev-list",rev]     -> withRepo p $ revList (revFromString rev)-		cmd : [] -> error ("unknown command: " ++ cmd)-		[]       -> error "no args"-		_        -> error "unknown command line arguments"
+ Hit/Hit.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE BangPatterns #-}+-- |+-- Module      : Hit+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unix+--+module Main where++import System.Environment+import Control.Applicative ((<$>))+import Control.Monad+import Data.IORef+import Data.Maybe+import Data.Git.Storage.Pack+import Data.Git.Storage.Object+import Data.Git.Storage+import Data.Git.Types+import Data.Git.Ref+import Data.Git.Repository+import Data.Git.Revision+import Data.Word+import qualified Data.ByteString.Lazy.Char8 as LC+import qualified Data.ByteString.Char8 as BC+import Text.Printf+import qualified Data.Map as M+import qualified Data.HashTable.IO as H+import qualified Data.Hashable as Hashable++type HashTable k v = H.CuckooHashTable k v++instance Hashable.Hashable Ref where+	hash = Hashable.hash . toBinary++verifyPack pref git = do+	offsets     <- H.new+	tree        <- H.new+	refs        <- newIORef M.empty+	entries     <- fromIntegral <$> packReadHeader (gitRepoPath git) pref+	leftParsed  <- newIORef entries+	-- enumerate all objects either directly in tree for fully formed objects+	-- or a list of delta to resolves +	packEnumerateObjects (gitRepoPath git) pref entries (setObj leftParsed refs offsets tree)+	readIORefAndReplace refs M.empty >>= dumpTree offsets tree+	where+		readIORefAndReplace ioref emptyVal = do+			v <- readIORef ioref+			writeIORef ioref emptyVal+			return v++		setObj_ refs offsets tree (!info, objData)+			| objectTypeIsDelta (poiType info) = do+				(!ty, !ref, !ptr, !lenChain) <- do+					let loc = Packed pref (poiOffset info)+					objInfo <- maybe (error "cannot find delta chain") id <$> getObjectRawAt git loc True+					let (ty, sz, _) = oiHeader objInfo+					let !ref = objectHash ty sz (oiData objInfo)+					let ptr = head $ oiChains objInfo -- it's safe since deltas always have a non empty valid chain+					return (ty, ref, ptr, (length $ oiChains objInfo))+				H.insert tree ref (info { poiType = ty }, Just (ptr, lenChain))+			| otherwise = do+				let !ref = objectHash (poiType info) (poiActualSize info) objData+				modifyIORef refs (M.insert ref ())+				H.insert offsets (poiOffset info) ref+				H.insert tree ref (info,Nothing)++		setObj leftParsed refs offsets tree x = do+			parsed <- readIORef leftParsed+			when ((parsed `mod` 256) == 0) $ putStrLn (show parsed ++ " left to parse")+			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 offsets tree refs = do+			forM_ (M.toAscList refs) $ \(ref, ()) -> do+				ent <- fromJust <$> H.lookup tree ref+				printEnt offsets ref ent++		-- print one line about the entry+		-- format is <sha1> <type> <real size> <size> <offset> [<number of chain element> <parent element>]+		printEnt _ ref (info,Nothing) = do+			printf "%s %-6s %d %d %d\n" (show ref)+			       (objectTypeMarshall $ poiType info)+			       (poiActualSize info)+			       (poiSize info)+			       (poiOffset info)++		printEnt offsets ref (info,Just (parentOffset, lenChain)) = do+			parentRef <- case parentOffset of+				PtrRef r -> return r+				PtrOfs off -> do+					let poff = poiOffset info - off+					maybe (error "cannot find delta's parent in pack ?") id <$> H.lookup offsets poff+			printf "%s %-6s %d %d %d %d %s\n" (show ref)+			       (objectTypeMarshall $ poiType info)+			       (poiActualSize info)+			       (poiSize info)+			       (poiOffset info)+			       (lenChain)+			       (show parentRef)+++catFile ty ref git = do+	let expectedType = case ty of+		"commit" -> Just TypeCommit+		"blob"   -> Just TypeBlob+		"tag"    -> Just TypeTag+		"tree"   -> Just TypeTree+		"-t"     -> Nothing+		_        -> error "unknown type request"+	mobj <- getObjectRaw git ref True+	case mobj of+		Nothing  -> error "not a valid object"+		Just obj ->+			let (objty, _, _) = oiHeader obj in+			case expectedType of+				Nothing  -> putStrLn $ objectTypeMarshall objty+				Just ety -> do+					when (ety /= objty) $ error "not expected type"+					LC.putStrLn (oiData obj)++lsTree revision _ git = do+	ref <- maybe (error "revision cannot be found") id <$> resolveRevision git revision+	tree <- resolveTreeish git ref+	case tree of+		Just t -> do+			htree <- buildHTree git t+			mapM_ (showTreeEnt) htree +		_      -> error "cannot build a tree from this reference"+	where+		showTreeEnt (p,n,TreeDir r _) = printf "%06o tree %s    %s\n" p (show r) (BC.unpack n)+		showTreeEnt (p,n,TreeFile r)  = printf "%06o blob %s    %s\n" p (show r) (BC.unpack n)++revList revision git = do+	ref <- maybe (error "revision cannot be found") id <$> resolveRevision git revision+	loopTillEmpty ref+	where loopTillEmpty ref = do+		obj <- getCommit git ref+		case obj of+			Just (Commit _ parents _ _ _) -> do+				putStrLn $ show ref+				-- this behave like rev-list --first-parent.+				-- otherwise the parents need to be organized and printed+				-- in a reverse chronological fashion.+				case parents of+					[]    -> return ()+					(p:_) -> loopTillEmpty p+			Nothing -> error "reference in commit chain doesn't exists"++main = do+	args <- getArgs+	case args of+		["verify-pack",ref]  -> withCurrentRepo $ verifyPack (fromHexString 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+		["rev-list",rev]     -> withCurrentRepo $ revList (fromString rev)+		cmd : [] -> error ("unknown command: " ++ cmd)+		[]       -> error "no args"+		_        -> error "unknown command line arguments"
LICENSE view
@@ -1,10 +1,11 @@-Copyright (c) 2010-2011 Vincent Hanquez <vincent@snarc.org>+Copyright (c) 2010-2012 Vincent Hanquez <vincent@snarc.org>  All rights reserved.  Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:+ 1. Redistributions of source code must retain the above copyright    notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright
README.md view
@@ -15,15 +15,18 @@ * reimplement the whole of git. * checkout's index reading/writing, fetching, merging, diffing. -The main functions for users are available from the Data.Git.Repository module.+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).-* findObject: 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.-* findObjectRaw: similar to findObject but gives a raw representation (lazy bytestring) of the object.+* 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 -----------@@ -34,7 +37,7 @@     import Data.Git.Repository      showPathRef commitRef = withRepo ".git" $ \git -> do-	ref <- maybe (error "inexistent object at this path") id `fmap` resolvePath git commitRef ["README"]+        ref <- maybe (error "inexistent object at this path") id `fmap` resolvePath git commitRef ["README"]         putStrLn ("README has the reference: " ++ show ref)  @@ -43,7 +46,7 @@     import Data.Git.Repository      catFile ref = withRepo ".git" $ \git -> do-	obj <- maybe (error "not a valid object") id `fmap` findObjectRaw git ref True+        obj <- maybe (error "not a valid object") id `fmap` getObjectRaw git ref True         L.putStrLn (oiData obj)
− Tests.hs 
@@ -1,88 +0,0 @@-import Test.QuickCheck-import Test.Framework(defaultMain, testGroup)-import Test.Framework.Providers.QuickCheck2(testProperty)--import qualified Data.ByteString.Lazy as L-import qualified Data.ByteString as B--import Control.Applicative-import Control.Monad--import Data.Git.Object-import Data.Git.Loose-import Data.Git.Ref---- for arbitrary instance to generate only data that are writable--- to disk. i.e. no deltas.---data ObjNoDelta = ObjNoDelta Object----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)--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)--instance Arbitrary Ref where-	arbitrary = fromBinary <$> arbitraryBS 20--arbitraryMsg = arbitraryBSno0 128-arbitraryLazy = L.fromChunks . (:[]) <$> arbitraryBS 4096--arbitraryRefList :: Gen [Ref]-arbitraryRefList = replicateM 2 arbitrary--arbitraryEnt = liftM3 (,,) arbitrary (arbitraryBSno0 48) arbitrary-arbitraryEnts = choose (1,100) >>= \i -> replicateM i arbitraryEnt--arbitraryName = liftM4 (,,,) (arbitraryBSnoangle 16)-                             (arbitraryBSnoangle 16)-                             (arbitrary `suchThat` (\i -> i > 0))-                              arbitrary--arbitraryObjTypeNoDelta = oneof [return TypeTree,return TypeBlob,return TypeCommit,return TypeTag]--instance Arbitrary Commit where-	arbitrary = Commit <$> arbitrary <*> arbitraryRefList <*> arbitraryName <*> arbitraryName <*> 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 Object where-	arbitrary = undefined--instance Arbitrary ObjNoDelta where-	arbitrary = ObjNoDelta <$> oneof-		[ liftM5 Commit arbitrary arbitraryRefList arbitraryName arbitraryName arbitraryMsg-		, liftM Tree arbitraryEnts-		, liftM Blob arbitraryLazy-		, liftM5 Tag-		]--}----prop_object_marshalling_id (ObjNoDelta obj) = obj == (looseUnmarshall $ looseMarshall obj)--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 "ref marshalling" refTests-	, testGroup "object marshalling" objTests-	]
+ Tests/Repo.hs view
@@ -0,0 +1,59 @@+import Test.QuickCheck+import Test.Framework(defaultMain, testGroup, buildTest)+import Test.Framework.Providers.QuickCheck2(testProperty)++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.Time.LocalTime+import Data.Time.Clock+import Data.Time.Calendar+import Data.Maybe++import Text.Bytedump+import System.Exit++onLocalRepo f = 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 view
@@ -0,0 +1,99 @@+import Test.QuickCheck+import Test.Framework(defaultMain, testGroup)+import Test.Framework.Providers.QuickCheck2(testProperty)++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.Time.LocalTime+import Data.Time.Clock+import Data.Time.Calendar++-- for arbitrary instance to generate only data that are writable+-- to disk. i.e. no deltas.+--data ObjNoDelta = ObjNoDelta Object++--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)++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)++instance Arbitrary Ref where+	arbitrary = fromBinary <$> arbitraryBS 20++arbitraryMsg = arbitraryBSno0 128+arbitraryLazy = L.fromChunks . (:[]) <$> arbitraryBS 4096++arbitraryRefList :: Gen [Ref]+arbitraryRefList = replicateM 2 arbitrary++arbitraryEnt = liftM3 (,,) arbitrary (arbitraryBSno0 48) arbitrary+arbitraryEnts = choose (1,100) >>= \i -> replicateM i arbitraryEnt++instance Arbitrary TimeZone where+    arbitrary = hoursToTimeZone <$> arbitrary ++instance Arbitrary UTCTime where+    arbitrary = UTCTime <$> (flip addDays b <$> choose (0, 365 * 40))+                        <*> (secondsToDiffTime <$> arbitrary)+        where b = fromGregorian 1970 1 1+arbitraryName = liftM4 (,,,) (arbitraryBSnoangle 16)+                             (arbitraryBSnoangle 16)+                             arbitrary+                             arbitrary++arbitraryObjTypeNoDelta = oneof [return TypeTree,return TypeBlob,return TypeCommit,return TypeTag]++instance Arbitrary Commit where+	arbitrary = Commit <$> arbitrary <*> arbitraryRefList <*> arbitraryName <*> arbitraryName <*> 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 Object where+	arbitrary = undefined++instance Arbitrary ObjNoDelta where+	arbitrary = ObjNoDelta <$> oneof+		[ liftM5 Commit arbitrary arbitraryRefList arbitraryName arbitraryName arbitraryMsg+		, liftM Tree arbitraryEnts+		, liftM Blob arbitraryLazy+		, liftM5 Tag+		]+-}++--prop_object_marshalling_id (ObjNoDelta obj) = obj == (looseUnmarshall $ looseMarshall obj)++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 "ref marshalling" refTests+	, testGroup "object marshalling" objTests+	]
hit.cabal view
@@ -1,5 +1,5 @@ Name:                hit-Version:             0.2.2+Version:             0.3.0 Synopsis:            Git operations Description:         Provides low level git operations License:             BSD3@@ -11,12 +11,9 @@ Stability:           experimental Build-Type:          Simple Homepage:            http://github.com/vincenthz/hit-Cabal-Version:       >=1.6+Cabal-Version:       >=1.8 data-files:          README.md--Flag test-  Description:       Build unit test-  Default:           False+extra-source-files:  Tests/*.hs  Flag executable   Description:       Build the executable@@ -38,26 +35,31 @@                    , vector                    , random                    , zlib-                   , zlib-bindings >= 0.0.1+                   , zlib-bindings >= 0.1 && < 0.2                    , bytedump-  Exposed-modules:   Data.Git.Index-                     Data.Git.Pack-                     Data.Git.Object-                     Data.Git.Loose+                   , time+  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   Other-modules:     Data.Git.Internal-                     Data.Git.FileReader-                     Data.Git.FileWriter+                     Data.Git.Storage.FileReader+                     Data.Git.Storage.FileWriter                      Data.Git.Path   ghc-options:       -Wall -fno-warn-missing-signatures  Executable           Hit   Main-Is:           Hit.hs-  ghc-options:       -Wall -fno-warn-missing-signatures+  hs-source-dirs:    Hit+  ghc-options:       -Wall -fno-warn-orphans -fno-warn-missing-signatures   if flag(debug)     ghc-options:     -rtsops -auto-all -caf-all   if flag(executable)@@ -68,27 +70,41 @@                    , hashtables                    , bytestring                    , attoparsec >= 0.10.1+                   , parsec     >= 3                    , filepath                    , directory-                   , zlib                    , bytedump+                   , hit     Buildable: True   else     Buildable: False -Executable           Tests+Test-Suite test-unit+  type:              exitcode-stdio-1.0+  hs-source-dirs:    Tests   Main-Is:           Tests.hs-  if flag(test)-    Buildable:       True-    Build-depends:   base >= 3 && < 7+  Build-depends:     base >= 3 && < 7                    , HUnit                    , QuickCheck >= 2                    , bytestring                    , test-framework >= 0.3                    , test-framework-quickcheck2 >= 0.2-  else-    Buildable:       False+                   , time+                   , hit +Test-Suite test-repository+  type:              exitcode-stdio-1.0+  hs-source-dirs:    Tests+  Main-Is:           Repo.hs+  Build-depends:     base >= 3 && < 7+                   , HUnit+                   , QuickCheck >= 2+                   , bytestring+                   , test-framework >= 0.3+                   , test-framework-quickcheck2 >= 0.2+                   , time+                   , bytedump+                   , hit  source-repository head   type: git