hit (empty) → 0.1.0

raw patch · 19 files changed

+2142/−0 lines, 19 filesdep +HUnitdep +QuickCheckdep +attoparsecsetup-changed

Dependencies added: HUnit, QuickCheck, attoparsec, base, bytedump, bytestring, containers, cryptohash, directory, filepath, hashable, hashtables, mtl, parsec, patience, random, test-framework, test-framework-quickcheck2, unix, vector, zlib, zlib-bindings

Files

Data/Git/Delta.hs +84/−0
Data/Git/FileReader.hs +193/−0
Data/Git/FileWriter.hs +52/−0
Data/Git/Index.hs +182/−0
Data/Git/Internal.hs +20/−0
Data/Git/Loose.hs +150/−0
Data/Git/Named.hs +62/−0
Data/Git/Object.hs +249/−0
Data/Git/Pack.hs +152/−0
Data/Git/Path.hs +40/−0
Data/Git/Ref.hs +130/−0
Data/Git/Repository.hs +369/−0
Data/Git/Revision.hs +51/−0
Hit.hs +161/−0
LICENSE +27/−0
README.md +50/−0
Setup.hs +2/−0
Tests.hs +71/−0
hit.cabal +97/−0

+ Data/Git/Delta.hs view

@@ -0,0 +1,84 @@+-- |+-- Module      : Data.Git.Delta+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unix+--+module Data.Git.Delta+	( Delta(..)+	, DeltaCmd(..)+	, deltaParse+	, deltaRead+	, deltaApply+	) where++import Data.Attoparsec+import qualified Data.Attoparsec as A+import qualified Data.Attoparsec.Lazy as AL+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.Bits+import Data.Word++import Control.Applicative ((<$>))++-- | a delta is a source size, a destination size and a list of delta cmd+data Delta = Delta Word64 Word64 [DeltaCmd]+	deriving (Show,Eq)++-- | possible commands in a delta+data DeltaCmd =+	  DeltaCopy ByteString   -- command to insert this bytestring+	| DeltaSrc Word64 Word64 -- command to copy from source (offset, size)+	deriving (Show,Eq)++-- | parse a delta.+-- format is 2 variable sizes, followed by delta cmds. for each cmd:+-- * if first byte MSB is set, we copy from source.+-- * otherwise, we copy from delta.+-- * extensions are not handled.+deltaParse = do+	srcSize <- getDeltaHdrSize+	resSize <- getDeltaHdrSize+	dcmds   <- many (anyWord8 >>= parseWithCmd)+	return $ Delta srcSize resSize dcmds+	where+		getDeltaHdrSize = do+			z <- A.takeWhile (\w -> w `testBit` 7)+			l <- anyWord8+			return $ unbytes 0 $ (map (\w -> w `clearBit` 7) (B.unpack z) ++ [l])+		-- use a foldl ..+		unbytes _  []     = 0+		unbytes sh (x:xs) = (fromIntegral x) `shiftL` sh + unbytes (sh+7) xs+		-- parse one command, either an extension, a copy from src, or a copy from delta.+		parseWithCmd cmd+			| cmd == 0        = error "delta extension not supported"+			| cmd `testBit` 7 = do+				o1 <- word8cond (cmd `testBit` 0) 0+				o2 <- word8cond (cmd `testBit` 1) 8+				o3 <- word8cond (cmd `testBit` 2) 16 +				o4 <- word8cond (cmd `testBit` 3) 24+				s1 <- word8cond (cmd `testBit` 4) 0+				s2 <- word8cond (cmd `testBit` 5) 8+				s3 <- word8cond (cmd `testBit` 6) 16 +				let offset = o1 .|. o2 .|. o3 .|. o4+				let size   = s1 .|. s2 .|. s3+				return $ DeltaSrc offset (if size == 0 then 0x10000 else size)+			| otherwise       = DeltaCopy <$> A.take (fromIntegral cmd)+		word8cond cond sh = 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++-- | apply a delta on a lazy bytestring, returning a new bytestring.+deltaApply :: L.ByteString -> Delta -> L.ByteString+deltaApply src (Delta srcSize _ deltaCmds)+	| L.length src /= fromIntegral srcSize = error "source size do not match"+	| otherwise                            = -- FIXME use a bytestring builder here.+		L.fromChunks $ concatMap resolve deltaCmds where+			resolve (DeltaSrc o s) = L.toChunks $ takeAt (fromIntegral s) (fromIntegral o) src+			resolve (DeltaCopy b)  = [b]+			takeAt sz at = L.take sz . L.drop at

+ Data/Git/FileReader.hs view

@@ -0,0 +1,193 @@+-- |+-- 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, Result(..))+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 view

@@ -0,0 +1,52 @@+-- |+-- 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 view

@@ -0,0 +1,182 @@+-- |+-- 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

@@ -0,0 +1,20 @@+-- |+-- Module      : Data.Git.Internal+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unix+--+module Data.Git.Internal+	( be32+	) where++import Data.Bits+import Data.Word+import qualified Data.ByteString as B++be32 :: B.ByteString -> Word32+be32 b = fromIntegral (B.index b 0) `shiftL` 24+       + fromIntegral (B.index b 1) `shiftL` 16+       + fromIntegral (B.index b 2) `shiftL` 8+       + fromIntegral (B.index b 3)

+ Data/Git/Loose.hs view

@@ -0,0 +1,150 @@+-- |+-- 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.Posix.Files++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 = 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 (DeltaOfs _ _) = error "cannot write delta offset as single object"+looseMarshall (DeltaRef _ _) = error "cannot write delta ref as single object"+looseMarshall obj            = 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 <- fromIntegral . fileSize <$> getFileStatus file+	let hdr = objectWriteHeader TypeBlob 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

@@ -0,0 +1,62 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module      : Data.Git.Named+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unix+--+module Data.Git.Named+	( headList+	, headExists+	, headRead+	, headWrite+	, remotesList+	, remoteList+	, tagList+	, tagExists+	, tagRead+	, tagWrite+	, specialRead+	, specialExists+	) where++import Control.Applicative ((<$>))++import System.Directory++import Data.Git.Path+import Data.Git.Ref+import Data.List (isPrefixOf)+import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC++getDirectoryContentNoDots path = filter noDot <$> getDirectoryContents path+	where noDot = (not . isPrefixOf ".")++headList gitRepo = getDirectoryContentNoDots (headsPath gitRepo)+tagList gitRepo = getDirectoryContentNoDots (tagsPath gitRepo)+remotesList gitRepo = getDirectoryContentNoDots (remotesPath gitRepo)+remoteList gitRepo remote = getDirectoryContentNoDots (remotePath gitRepo remote)++writeRef path ref = B.writeFile path (B.concat [toHex ref, B.singleton 0xa])+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)++headExists gitRepo name    = doesFileExist (headPath gitRepo name)+headRead gitRepo name      = readRef (headPath gitRepo name)+headWrite gitRepo name ref = writeRef (headPath gitRepo name) ref++tagExists gitRepo name    = doesFileExist (tagPath gitRepo name)+tagRead gitRepo name      = readRef (tagPath gitRepo name)+tagWrite gitRepo name ref = writeRef (tagPath gitRepo name) ref++specialRead gitRepo name   = readRefAndFollow gitRepo (specialPath gitRepo name)+specialExists gitRepo name = doesFileExist (specialPath gitRepo name)

+ Data/Git/Object.hs view

@@ -0,0 +1,249 @@+-- |+-- 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(..)+	, ObjectInfo(..)+	, objectToType+	, objectTypeMarshall+	, objectTypeUnmarshall+	, objectTypeIsDelta+	-- * parsing function+	, 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 ((<$>))+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)++-- | 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 =+	  Tree [TreeEnt]+	| Blob L.ByteString+	| Commit Ref [Ref] Name Name ByteString+	| Tag Ref ObjectType ByteString Name ByteString+	| DeltaOfs Word64 Delta+	| DeltaRef Ref Delta+	deriving (Show,Eq)++objectToType :: Object -> ObjectType+objectToType (Commit _ _ _ _ _) = TypeCommit+objectToType (Blob _)           = TypeBlob+objectToType (Tree _)           = TypeTree+objectToType (Tag _ _ _ _ _)    = TypeTag+objectToType (DeltaOfs _ _)     = TypeDeltaOff+objectToType (DeltaRef _ _)     = TypeDeltaRef++objectTypeMarshall :: ObjectType -> String+objectTypeMarshall TypeTree   = "tree"+objectTypeMarshall TypeBlob   = "blob"+objectTypeMarshall TypeCommit = "commit"+objectTypeMarshall TypeTag    = "tag"+objectTypeMarshall _          = error "deltas cannot be marshalled"++objectTypeUnmarshall :: String -> ObjectType+objectTypeUnmarshall "tree"   = TypeTree+objectTypeUnmarshall "blob"   = TypeBlob+objectTypeUnmarshall "commit" = TypeCommit+objectTypeUnmarshall "tag"    = TypeTag+objectTypeUnmarshall _        = error "unknown object type"++objectTypeIsDelta :: ObjectType -> Bool+objectTypeIsDelta TypeDeltaOff = True+objectTypeIsDelta TypeDeltaRef = True+objectTypeIsDelta _            = False++-- | 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+objectParseTree = (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+objectParseBlob = (Blob <$> takeLazyByteString)++-- | parse a commit content+objectParseCommit = 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+objectParseTag = 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)++-- 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 (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+		]++objectWrite (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 ]++objectWrite (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 ]++objectWrite (Blob bData) = bData++objectWrite _       = error "delta object are not supported here"++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 view

@@ -0,0 +1,152 @@+-- |+-- 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) = DeltaOfs o <$> deltaRead objData+packObjectFromRaw (TypeDeltaRef, Just (PtrRef r), objData) = 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

@@ -0,0 +1,40 @@+-- |+-- Module      : Data.Git.Path+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unix+--+module Data.Git.Path where++import System.FilePath+import System.Random+import Control.Applicative ((<$>))+import Data.Git.Ref++headsPath gitRepo = gitRepo </> "refs" </> "heads"+tagsPath gitRepo  = gitRepo </> "refs" </> "tags"+remotesPath gitRepo = gitRepo </> "refs" </> "remotes"++headPath gitRepo name = headsPath gitRepo </> name+tagPath gitRepo name = tagsPath gitRepo </> name+remotePath gitRepo name = remotesPath gitRepo </> name+specialPath gitRepo name = gitRepo </> name++remoteEntPath gitRepo name ent = remotePath gitRepo name </> ent++packDirPath repoPath = repoPath </> "objects" </> "pack"++indexPath repoPath indexRef =+	packDirPath repoPath </> ("pack-" ++ toHexString indexRef ++ ".idx")++packPath repoPath packRef =+	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++objectTemporaryPath repoPath = do+	r <- fst . random <$> getStdGen :: IO Int+	return (repoPath </> "objects" </> ("tmp-" ++ show r ++ ".tmp"))

+ Data/Git/Ref.hs view

@@ -0,0 +1,130 @@+-- |+-- Module      : Data.Git.Ref+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unix+--+module Data.Git.Ref+	( 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+import Data.ByteString (ByteString)+import qualified Data.ByteString as B+import qualified Data.ByteString.Internal as B (unsafeCreate)+import qualified Data.ByteString.Unsafe as B (unsafeIndex)+import qualified Data.ByteString.Char8 as BC+import Data.Bits+import Data.Char (isHexDigit)++import Foreign.Storable++-- | represent a git reference (SHA1)+newtype Ref = Ref ByteString+	deriving (Eq,Ord)++instance Show Ref where+	show = BC.unpack . toHex++isHex = and . map isHexDigit . BC.unpack+isHexString = and . map isHexDigit++-- | take a hexadecimal bytestring that represent a reference+-- and turn into a ref+fromHex :: ByteString -> Ref+fromHex s+	| B.length s == 40 = Ref $ B.unsafeCreate 20 populateRef+	| otherwise        = 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"++-- | take a hexadecimal string that represent a reference+-- and turn into a ref+fromHexString :: String -> Ref+fromHexString = fromHex . BC.pack++-- | transform a ref into an hexadecimal bytestring+toHex :: Ref -> ByteString+toHex (Ref bs) = B.unsafeCreate 40 populateHex+	where+		populateHex ptr = forM_ [0..19] $ \i -> do+			let (a,b) = B.unsafeIndex bs i `divMod` 16+			pokeElemOff ptr (i*2+0) (hex a)+			pokeElemOff ptr (i*2+1) (hex b)+		hex i+			| i >= 0 && i <= 9   = 0x30 + i+			| i >= 10 && i <= 15 = 0x61 + i - 10+			| otherwise          = 0++-- | transform a ref into an hexadecimal string+toHexString :: Ref -> String+toHexString = BC.unpack . toHex++-- | transform a bytestring that represent a binary bytestring+-- and returns a ref.+fromBinary :: ByteString -> Ref+fromBinary b+	| B.length b == 20 = Ref b+	| otherwise        = error "not a valid binary ref"++-- | turn a reference into a binary bytestring+toBinary :: Ref -> ByteString+toBinary (Ref b) = b++-- | returns the prefix (leading byte) of this reference+refPrefix :: Ref -> Int+refPrefix (Ref b) = fromIntegral $ B.unsafeIndex b 0++-- | compare prefix+cmpPrefix :: String -> Ref -> Ordering+cmpPrefix pre ref = pre `compare` (take (length pre) $ toHexString ref)++-- | returns the splitted format "prefix/suffix" for addressing the loose object database+toFilePathParts :: Ref -> (String, String)+toFilePathParts ref = splitAt 2 $ show ref++-- | hash a bytestring into a reference+hash = Ref . SHA1.hash++hashLBS = Ref . SHA1.hashlazy

+ Data/Git/Repository.hs view

@@ -0,0 +1,369 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module      : Data.Git.Repository+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unix+--+module Data.Git.Repository+	( Git+	, HTree+	, HTreeEnt(..)+	, gitRepoPath+	, openRepo+	, closeRepo+	, withRepo+	, findRepo+	, findReference+	, findReferencesWithPrefix+	, findObjectRaw+	, findObjectRawAt+	, findObject+	, findObjectAt+	, buildHTree+	, resolvePath+	, resolveTreeish+	, resolveRevision+	, initRepo+	, isRepo+	) 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.Word+import Data.IORef+import Data.List ((\\), find, isPrefixOf)++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.Revision+import Data.Git.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)++-- | 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++		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) ]++		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"++		getParentRefs ref = do+			obj <- findObject git ref True+			case obj of+				Just (Commit _ parents _ _ _) -> return parents+				Just _  -> error "wrong object type, expecting commit"+				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 Object)+resolveTreeish git ref = do+	obj <- findObject git ref True+	case obj of+		Just (Commit tree _ _ _ _) -> resolveTreeish git tree+		Just (Tree _)              -> return obj+		Just (Tag tref _ _ _ _)    -> resolveTreeish git tref +		Just _                     -> return Nothing+		Nothing                    -> return Nothing++-- | build a hierarchy tree from a tree object+buildHTree :: Git -> Object -> 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 <- findObject git ref True+				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"+buildHTree _   _           = error "cannot build a tree structure from anything else than a tree"++-- | resolve the ref (tree or blob) related to a path at a specific commit ref+resolvePath :: Git -> Ref -> [ByteString] -> IO (Maybe Ref)+resolvePath git commitRef paths = do+	commit <- findObject git commitRef True+	case commit of+		Just (Commit tree _ _ _ _) -> resolve tree paths+		Just _                     -> error ("expecting commit object at " ++ show commitRef)+		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 <- findObject git treeRef True+			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+				Just _           -> error ("expecting tree object at " ++ show treeRef)+				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"</>"remotes","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"</>"remotes","refs"</>"tags"]

+ Data/Git/Revision.hs view

@@ -0,0 +1,51 @@+-- |+-- Module      : Data.Git.Delta+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unix+--+module Data.Git.Revision+	( Revision(..)+	, RevModifier(..)+	, revFromString+	) where++import Text.Parsec++data RevModifier =+	  RevModParent Int       -- ^ parent accessor ^<n> and ^+	| RevModParentFirstN Int -- ^ parent accessor ~<n>+	| RevModAtType String    -- ^ @{type} accessor+	| RevModAtDate String    -- ^ @{date} accessor+	| RevModAtN Int          -- ^ @{n} accessor+	deriving (Eq)++data Revision = Revision String [RevModifier]+	deriving (Eq)++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

+ 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.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 <- findObject git ref True+		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+			Just _  -> error "wrong object type, expecting commit"+			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"

+ LICENSE view

@@ -0,0 +1,27 @@+Copyright (c) 2010-2011 Vincent Hanquez <vincent@snarc.org>++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,50 @@+        Hit+        ===++Hit is a reimplementation of some git operations in pure haskell.+++what it does do:++* read loose objects, and packed objects.+* write new loose objects+* git like operations available: commit, cat-file, verify-pack, rev-list, ls-tree.++what is doesn't do:++* reimplement the whole of git.+* checkout's index reading/writing, fetching, merging, diffing.++The main functions for users are available from the Data.Git.Repository 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.+* 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.++API Example+-----------++resolving path of the README file and returning the reference to the blob :++    {-# LANGUAGE OverloadedStrings #-}+    import Data.Git.Repository++    showPathRef commitRef = withRepo ".git" $ \git -> do+	ref <- maybe (error "inexistent object at this path") id `fmap` resolvePath git commitRef ["README"]+        putStrLn ("README has the reference: " ++ show ref)+++catting an object from a ref:++    import Data.Git.Repository++    catFile ref = withRepo ".git" $ \git -> do+	obj <- maybe (error "not a valid object") id `fmap` findObjectRaw git ref True+        L.putStrLn (oiData obj)+++more examples on how to use api can be found in Hit.hs.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ Tests.hs view

@@ -0,0 +1,71 @@+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 ObjNoDelta where+	arbitrary = ObjNoDelta <$> oneof+		[ liftM5 Commit arbitrary arbitraryRefList arbitraryName arbitraryName arbitraryMsg+		, liftM Tree arbitraryEnts+		, liftM Blob arbitraryLazy+		, liftM5 Tag arbitrary arbitraryObjTypeNoDelta (arbitraryBSascii 20) arbitraryName arbitraryMsg+		]++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

@@ -0,0 +1,97 @@+Name:                hit+Version:             0.1.0+Synopsis:            Git operations+Description:         Provides low level git operations+License:             BSD3+License-file:        LICENSE+Copyright:           Vincent Hanquez <vincent@snarc.org>+Author:              Vincent Hanquez <vincent@snarc.org>+Maintainer:          Vincent Hanquez <vincent@snarc.org>+Category:            Development+Stability:           experimental+Build-Type:          Simple+Homepage:            http://github.com/vincenthz/hit+Cabal-Version:       >=1.6+data-files:          README.md++Flag test+  Description:       Build unit test+  Default:           False++Flag executable+  Description:       Build the executable+  Default:           False++Flag debug+  Description:       Add some debugging options+  Default:           False++Library+  Build-Depends:     base >= 4 && < 5+                   , mtl+                   , bytestring+                   , attoparsec+                   , parsec     >= 3+                   , filepath+                   , directory+                   , cryptohash+                   , vector+                   , random+                   , zlib+                   , zlib-bindings >= 0.0.1+                   , patience+                   , bytedump+                   , unix+  Exposed-modules:   Data.Git.Index+                     Data.Git.Pack+                     Data.Git.Object+                     Data.Git.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.Path+  ghc-options:       -Wall -fno-warn-missing-signatures++Executable           Hit+  Main-Is:           Hit.hs+  ghc-options:       -Wall -fno-warn-missing-signatures+  if flag(debug)+    ghc-options:     -rtsops -auto-all -caf-all+  if flag(executable)+    Build-depends:   base >= 4 && < 5+                   , mtl+                   , containers+                   , hashable+                   , hashtables+                   , bytestring+                   , attoparsec+                   , filepath+                   , directory+                   , zlib+                   , bytedump+    Buildable: True+  else+    Buildable: False++Executable           Tests+  Main-Is:           Tests.hs+  if flag(test)+    Buildable:       True+    Build-depends:   base >= 3 && < 7+                   , HUnit+                   , QuickCheck >= 2+                   , bytestring+                   , test-framework >= 0.3+                   , test-framework-quickcheck2 >= 0.2+  else+    Buildable:       False+++source-repository head+  type: git+  location: git://github.com/vincenthz/hit