diff --git a/Data/Git.hs b/Data/Git.hs --- a/Data/Git.hs +++ b/Data/Git.hs @@ -10,9 +10,12 @@ -- * Basic types Ref , Commit(..) + , Person(..) + , CommitExtra(..) , Tree(..) , Blob(..) , Tag(..) + , GitTime(..) -- * Revision , Revision diff --git a/Data/Git/Internal.hs b/Data/Git/Internal.hs --- a/Data/Git/Internal.hs +++ b/Data/Git/Internal.hs @@ -6,13 +6,22 @@ -- Portability : unix -- module Data.Git.Internal - ( be32 - , be16 - ) where + ( be32 + , be16 + , Zipped(..) + , readZippedFile + , dezip + ) where +import Control.Applicative import Data.Bits import Data.Word import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L +import Codec.Compression.Zlib +import Filesystem.Path +import Filesystem.Path.Rules +import Prelude hiding (FilePath) be32 :: B.ByteString -> Word32 be32 b = fromIntegral (B.index b 0) `shiftL` 24 @@ -23,3 +32,12 @@ be16 :: B.ByteString -> Word16 be16 b = fromIntegral (B.index b 0) `shiftL` 8 + fromIntegral (B.index b 1) + +newtype Zipped = Zipped { getZippedData :: L.ByteString } + deriving (Show,Eq) + +readZippedFile :: FilePath -> IO Zipped +readZippedFile fp = Zipped <$> L.readFile (encodeString posix fp) + +dezip :: Zipped -> L.ByteString +dezip = decompress . getZippedData diff --git a/Data/Git/Named.hs b/Data/Git/Named.hs --- a/Data/Git/Named.hs +++ b/Data/Git/Named.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Git.Named -- License : BSD-style @@ -7,33 +8,100 @@ -- Portability : unix -- module Data.Git.Named - ( headsList - , headExists - , headRead - , headWrite - , remotesList - , remoteList - , tagsList - , tagExists - , tagRead - , tagWrite - , specialRead - , specialExists - ) where + ( RefSpecTy(..) + , RefContentTy(..) + , readPackedRefs + , existsRefFile + , writeRefFile + , readRefFile + ) where import Control.Applicative ((<$>)) -import System.Directory +import qualified Filesystem as F +import qualified Filesystem.Path.Rules as FP (posix, decode, encode, encodeString, decodeString) +import Filesystem.Path.CurrentOS +import Data.String import Data.Git.Path import Data.Git.Ref import Data.List (isPrefixOf) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC +import Prelude hiding (FilePath) -getDirectoryContentNoDots path = filter noDot <$> getDirectoryContents path - where noDot = (not . isPrefixOf ".") +-- | Represent a named specifier. +data RefSpecTy = RefHead + | RefOrigHead + | RefFetchHead + | RefBranch String + | RefTag String + | RefRemote String + | RefPatches String + | RefStash + | RefOther String + deriving (Show,Eq,Ord) +-- | content of a ref file. +data RefContentTy = RefDirect Ref + | RefLink RefSpecTy + | RefContentUnknown B.ByteString + deriving (Show,Eq) + +-- FIXME BC.unpack/pack should be probably be utf8.toString, +-- however i don't know if encoding is consistant. +-- it should probably be overridable. +pathDecode :: B.ByteString -> FilePath +pathDecode = FP.decode FP.posix + +pathEncode :: FilePath -> B.ByteString +pathEncode = FP.encode FP.posix + +toRefTy :: String -> RefSpecTy +toRefTy s + | "refs/tags/" `isPrefixOf` s = RefTag $ drop 10 s + | "refs/heads/" `isPrefixOf` s = RefBranch $ drop 11 s + | "refs/remotes/" `isPrefixOf` s = RefRemote $ drop 13 s + | "refs/patches/" `isPrefixOf` s = RefPatches $ drop 13 s + | "refs/stash" == s = RefStash + | "HEAD" == s = RefHead + | "ORIG_HEAD" == s = RefOrigHead + | "FETCH_HEAD" == s = RefFetchHead + | otherwise = RefOther $ s + +fromRefTy :: RefSpecTy -> String +fromRefTy (RefBranch h) = "refs/heads/" ++ h +fromRefTy (RefTag h) = "refs/tags/" ++ h +fromRefTy (RefRemote h) = "refs/remotes/" ++ h +fromRefTy (RefPatches h) = "refs/patches/" ++ h +fromRefTy RefStash = "refs/stash" +fromRefTy RefHead = "HEAD" +fromRefTy RefOrigHead = "ORIG_HEAD" +fromRefTy RefFetchHead = "FETCH_HEAD" +fromRefTy (RefOther h) = h + +toPath :: FilePath -> RefSpecTy -> FilePath +toPath gitRepo (RefBranch h) = gitRepo "refs" "heads" fromString h +toPath gitRepo (RefTag h) = gitRepo "refs" "tags" fromString h +toPath gitRepo (RefRemote h) = gitRepo "refs" "remotes" fromString h +toPath gitRepo (RefPatches h) = gitRepo "refs" "patches" fromString h +toPath gitRepo RefStash = gitRepo "refs" "stash" +toPath gitRepo RefHead = gitRepo "HEAD" +toPath gitRepo RefOrigHead = gitRepo "ORIG_HEAD" +toPath gitRepo RefFetchHead = gitRepo "FETCH_HEAD" +toPath gitRepo (RefOther h) = gitRepo fromString h + +readPackedRefs gitRepo = do + exists <- F.isFile (packedRefsPath gitRepo) + if exists then readLines else return [] + where readLines = foldl accu [] . BC.lines <$> F.readFile (packedRefsPath gitRepo) + accu a l + | "#" `BC.isPrefixOf` l = a + | otherwise = let (ref, r) = B.splitAt 40 l + name = FP.encodeString FP.posix $ pathDecode $ B.tail r + in (toRefTy name, fromHex ref) : a + +{- headsList gitRepo = getDirectoryContentNoDots (headsPath gitRepo) tagsList gitRepo = getDirectoryContentNoDots (tagsPath gitRepo) remotesList gitRepo = getDirectoryContentNoDots (remotesPath gitRepo) @@ -41,15 +109,27 @@ 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) +existsRefFile :: FilePath -> RefSpecTy -> IO Bool +existsRefFile gitRepo specty = F.isFile $ toPath gitRepo specty +writeRefFile :: FilePath -> RefSpecTy -> RefContentTy -> IO () +writeRefFile gitRepo specty refcont = F.writeFile filepath $ fromRefContent refcont + where filepath = toPath gitRepo specty + fromRefContent (RefLink link) = B.concat ["ref: ", pathEncode $ FP.decodeString FP.posix $ fromRefTy link, B.singleton 0xa] + fromRefContent (RefDirect ref) = B.concat [toHex ref, B.singleton 0xa] + fromRefContent (RefContentUnknown c) = c + +readRefFile :: FilePath -> RefSpecTy -> IO RefContentTy +readRefFile gitRepo specty = toRefContent <$> F.readFile filepath + where filepath = toPath gitRepo specty + toRefContent content + | "ref: " `B.isPrefixOf` content = RefLink $ toRefTy $ FP.encodeString FP.posix $ pathDecode $ head $ BC.lines $ B.drop 5 content + | B.length content < 42 = RefDirect $ fromHex $ B.take 40 content + | otherwise = RefContentUnknown content + +{- headExists gitRepo name = doesFileExist (headPath gitRepo name) headRead gitRepo name = readRef (headPath gitRepo name) headWrite gitRepo name ref = writeRef (headPath gitRepo name) ref @@ -60,3 +140,4 @@ specialRead gitRepo name = readRefAndFollow gitRepo (specialPath gitRepo name) specialExists gitRepo name = doesFileExist (specialPath gitRepo name) +-} diff --git a/Data/Git/Path.hs b/Data/Git/Path.hs --- a/Data/Git/Path.hs +++ b/Data/Git/Path.hs @@ -5,36 +5,39 @@ -- Stability : experimental -- Portability : unix -- +{-# LANGUAGE OverloadedStrings #-} module Data.Git.Path where -import System.FilePath +import Filesystem.Path.CurrentOS import System.Random import Control.Applicative ((<$>)) import Data.Git.Ref +import Data.String headsPath gitRepo = gitRepo "refs" "heads" tagsPath gitRepo = gitRepo "refs" "tags" remotesPath gitRepo = gitRepo "refs" "remotes" +packedRefsPath gitRepo = gitRepo "packed-refs" -headPath gitRepo name = headsPath gitRepo name -tagPath gitRepo name = tagsPath gitRepo name -remotePath gitRepo name = remotesPath gitRepo name -specialPath gitRepo name = gitRepo name +headPath gitRepo name = headsPath gitRepo fromString name +tagPath gitRepo name = tagsPath gitRepo fromString name +remotePath gitRepo name = remotesPath gitRepo fromString name +specialPath gitRepo name = gitRepo fromString name -remoteEntPath gitRepo name ent = remotePath gitRepo name ent +remoteEntPath gitRepo name ent = remotePath gitRepo name fromString ent packDirPath repoPath = repoPath "objects" "pack" indexPath repoPath indexRef = - packDirPath repoPath ("pack-" ++ toHexString indexRef ++ ".idx") + packDirPath repoPath fromString ("pack-" ++ toHexString indexRef ++ ".idx") packPath repoPath packRef = - packDirPath repoPath ("pack-" ++ toHexString packRef ++ ".pack") + packDirPath repoPath fromString ("pack-" ++ toHexString packRef ++ ".pack") -objectPath repoPath d f = repoPath "objects" d f +objectPath repoPath d f = repoPath "objects" fromString d fromString f objectPathOfRef repoPath ref = objectPath repoPath d f where (d,f) = toFilePathParts ref objectTemporaryPath repoPath = do r <- fst . random <$> getStdGen :: IO Int - return (repoPath "objects" ("tmp-" ++ show r ++ ".tmp")) + return (repoPath "objects" fromString ("tmp-" ++ show r ++ ".tmp")) diff --git a/Data/Git/Repository.hs b/Data/Git/Repository.hs --- a/Data/Git/Repository.hs +++ b/Data/Git/Repository.hs @@ -36,8 +36,11 @@ import Data.Git.Storage import Data.Git.Revision import Data.Git.Storage.Loose +import Data.Git.Storage.CacheFile import Data.Git.Ref +import qualified Data.Map as M + -- | 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)] @@ -50,66 +53,87 @@ 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 + unwrap (objectToCommit -> Just c@(Commit {})) = 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 (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 +resolveRevision git (Revision prefix modifiers) = + getCacheVal (packedNamed git) >>= \c -> resolvePrefix c >>= modf modifiers + where + resolvePrefix lookupCache = tryResolvers + [resolveNamedPrefix lookupCache namedResolvers + ,resolvePrePrefix + ] - 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" + resolveNamedPrefix _ [] = return Nothing + resolveNamedPrefix lookupCache (x:xs) = followToRef (resolveNamedPrefix lookupCache xs) x + where followToRef onFailure refty = do + exists <- existsRefFile (gitRepoPath git) refty + if exists + then do refcont <- readRefFile (gitRepoPath git) refty + case refcont of + RefDirect ref -> return $ Just ref + RefLink refspecty -> followToRef onFailure refspecty + _ -> error "cannot handle reference content" + else case M.lookup refty lookupCache of + Nothing -> onFailure + y -> return y - fs = [ (specialExists, specialRead), (tagExists, tagRead), (headExists, headRead) ] + namedResolvers = case prefix of + "HEAD" -> [ RefHead ] + "ORIG_HEAD" -> [ RefOrigHead ] + "FETCH_HEAD" -> [ RefFetchHead ] + _ -> [ RefTag prefix, RefBranch prefix, RefRemote prefix ] - 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" + tryResolvers :: [IO (Maybe Ref)] -> IO Ref + tryResolvers [] = return $ fromHexString prefix + tryResolvers (resolver:xs) = resolver >>= isResolved + where isResolved (Just r) = return r + isResolved Nothing = tryResolvers xs - getParentRefs ref = do - obj <- getCommit git ref - case obj of - Just (Commit _ parents _ _ _) -> return parents - Nothing -> error "reference in commit chain doesn't exists" + resolvePrePrefix :: IO (Maybe Ref) + resolvePrePrefix = do + refs <- findReferencesWithPrefix git prefix + case refs of + [] -> return Nothing + [r] -> return (Just r) + _ -> error "multiple references with this prefix" + modf [] ref = return (Just ref) + modf (RevModParent i:xs) ref = do + parentRefs <- getParentRefs ref + case i of + 0 -> error "revision modifier ^0 is not implemented" + _ -> case drop (i - 1) parentRefs of + [] -> error "no such parent" + (p:_) -> modf xs p + + modf (RevModParentFirstN 1:xs) ref = modf (RevModParent 1:xs) ref + modf (RevModParentFirstN n:xs) ref = do + parentRefs <- getParentRefs ref + modf (RevModParentFirstN (n-1):xs) (head parentRefs) + modf (_:_) _ = error "unimplemented revision modifier" + + getParentRefs ref = do + obj <- getCommit git ref + case obj of + Just (Commit { commitParents = 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 = getObject git ref True >>= mapJustM recToTree where - recToTree (objectToCommit -> Just (Commit tree _ _ _ _)) = resolveTreeish git tree + recToTree (objectToCommit -> Just (Commit { commitTreeish = tree })) = resolveTreeish git tree recToTree (objectToTag -> Just (Tag tref _ _ _ _)) = resolveTreeish git tref recToTree (objectToTree -> Just t@(Tree _)) = return $ Just t recToTree _ = return Nothing @@ -146,12 +170,12 @@ process [] = error "nothing to rewrite" process ((_,commit):next) = - mapCommit commit >>= looseWrite (gitRepoPath git) . objectWrap >>= flip rewriteOne next + mapCommit commit >>= looseWrite (gitRepoPath git) . toObject >>= flip rewriteOne next rewriteOne prevRef [] = return prevRef rewriteOne prevRef ((_,commit):next) = do newCommit <- mapCommit $ commit { commitParents = [prevRef] } - ref <- looseWrite (gitRepoPath git) (objectWrap newCommit) + ref <- looseWrite (gitRepoPath git) (toObject newCommit) rewriteOne ref next -- | build a hierarchy tree from a tree object @@ -179,7 +203,7 @@ resolvePath git commitRef paths = do commit <- getCommit git commitRef case commit of - Just (Commit tree _ _ _ _) -> resolve tree paths + Just (Commit { commitTreeish = tree }) -> resolve tree paths Nothing -> error ("not a valid commit ref: " ++ show commitRef) where resolve :: Ref -> [ByteString] -> IO (Maybe Ref) diff --git a/Data/Git/Storage.hs b/Data/Git/Storage.hs --- a/Data/Git/Storage.hs +++ b/Data/Git/Storage.hs @@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} -- | -- Module : Data.Git.Storage -- License : BSD-style @@ -9,6 +10,7 @@ module Data.Git.Storage ( Git + , packedNamed , gitRepoPath , openRepo , closeRepo @@ -30,8 +32,9 @@ , setObject ) where -import System.Directory -import System.FilePath +import Filesystem +import Filesystem.Path hiding (concat) +import Filesystem.Path.Rules import System.Environment import Control.Applicative ((<$>)) @@ -39,31 +42,44 @@ import qualified Control.Exception as E import Control.Monad +import Data.String import Data.List ((\\), isPrefixOf) import Data.IORef import Data.Word +import Data.Git.Named +import Data.Git.Path (packedRefsPath) import Data.Git.Delta import Data.Git.Storage.FileReader import Data.Git.Storage.PackIndex import Data.Git.Storage.Object import Data.Git.Storage.Pack import Data.Git.Storage.Loose +import Data.Git.Storage.CacheFile import Data.Git.Ref +import qualified Data.Map as M + +import Prelude hiding (FilePath) + data PackIndexReader = PackIndexReader PackIndexHeader FileReader +-- | this is a cache representation of the packed-ref file +type PackedRef = CacheFile (M.Map RefSpecTy Ref) + -- | 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)] + , packedNamed :: PackedRef } -- | open a new git repository context openRepo :: FilePath -> IO Git -openRepo path = liftM2 (Git path) (newIORef []) (newIORef []) +openRepo path = liftM3 (Git path) (newIORef []) (newIORef []) packedRef + where packedRef = newCacheVal (packedRefsPath path) (M.fromList <$> readPackedRefs path) M.empty -- | close a git repository context, closing all remaining fileReaders. closeRepo :: Git -> IO () @@ -78,19 +94,20 @@ -- 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) + menvDir <- E.catch (Just . decodeString posix_ghc704 <$> getEnv "GIT_DIR") (\(_:: SomeException) -> return Nothing) case menvDir of - Nothing -> checkDir 0 + Nothing -> getWorkingDirectory >>= checkDir 0 Just envDir -> do e <- isRepo envDir when (not e) $ error "environment GIT_DIR is not a git repository" return envDir where - checkDir 128 = error "not a git repository" - checkDir n = do - let filepath = concat (replicate n ("../") ++ [".git"]) + checkDir :: Int -> FilePath -> IO FilePath + checkDir 128 _ = error "not a git repository" + checkDir n wd = do + let filepath = wd ".git" e <- isRepo filepath - if e then return filepath else checkDir (n+1) + if e then return filepath else checkDir (n+1) (if absolute wd then parent wd else wd "..") -- | execute a function f with a git context. withRepo path f = bracket (openRepo path) closeRepo f @@ -104,23 +121,23 @@ -- | 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"] + dir <- isDirectory path + subDirs <- mapM (isDirectory . (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 + exists <- isDirectory path when exists $ error "destination directory already exists" - createDirectory path - mapM_ (createDirectory . (path )) - ["branches","hooks","info" - ,"logs","objects","refs" - ,"refs""heads","refs""tags"] + createDirectory True path + mapM_ (createDirectory False . (path )) + [ "branches", "hooks", "info" + , "logs", "objects", "refs" + , "refs" "heads", "refs" "tags"] iterateIndexes git f initAcc = do allIndexes <- packIndexEnumerate (gitRepoPath git) @@ -175,8 +192,8 @@ -- | 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" + | invalidLength = error ("not a valid prefix: " ++ show pre) + | not (isHexString pre) = error ("reference prefix contains non hexchar: " ++ show pre) | otherwise = do looseRefs <- looseEnumerateWithPrefixFilter (gitRepoPath git) (take 2 pre) matchRef packedRefs <- concat <$> iterateIndexes git idxPrefixMatch [] @@ -256,18 +273,18 @@ -- | 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 +getObjectAt git loc resolveDelta = maybe Nothing toObj <$> getObjectRawAt git loc resolveDelta where - toObject (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData) + toObj (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData) -- | get an object from repository using a ref. getObject :: Git -- ^ repository -> Ref -- ^ the object's reference to -> Bool -- ^ whether to resolve deltas if found -> IO (Maybe Object) -- ^ returned object if found -getObject git ref resolveDelta = maybe Nothing toObject <$> getObjectRaw git ref resolveDelta +getObject git ref resolveDelta = maybe Nothing toObj <$> getObjectRaw git ref resolveDelta where - toObject (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData) + toObj (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. diff --git a/Data/Git/Storage/CacheFile.hs b/Data/Git/Storage/CacheFile.hs new file mode 100644 --- /dev/null +++ b/Data/Git/Storage/CacheFile.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Data.Git.Storage.CacheFile +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : unix +-- +module Data.Git.Storage.CacheFile (CacheFile, newCacheVal, getCacheVal) where + +import Control.Applicative ((<$>)) +import Control.Concurrent.MVar +import qualified Control.Exception as E +import Data.Time.Clock +import Filesystem +import Filesystem.Path +import Prelude hiding (FilePath) + +data CacheFile a = CacheFile + { cacheFilepath :: FilePath + , cacheRefresh :: IO a + , cacheIniVal :: a + , cacheLock :: MVar (MTime, a) + } + +utcZero = UTCTime (toEnum 0) 0 + +newCacheVal :: FilePath -> IO a -> a -> IO (CacheFile a) +newCacheVal path refresh initialVal = + CacheFile path refresh initialVal <$> newMVar (MTime utcZero, initialVal) + +getCacheVal :: CacheFile a -> IO a +getCacheVal cachefile = modifyMVar (cacheLock cachefile) getOrRefresh + where getOrRefresh s@(mtime, cachedVal) = do + cMTime <- getMTime $ cacheFilepath cachefile + case cMTime of + Nothing -> return ((MTime utcZero, cacheIniVal cachefile), cacheIniVal cachefile) + Just newMtime | newMtime > mtime -> cacheRefresh cachefile >>= \v -> return ((newMtime, v), v) + | otherwise -> return (s, cachedVal) + +newtype MTime = MTime UTCTime deriving (Eq,Ord) + +getMTime filepath = (Just . MTime <$> getModified filepath) + `E.catch` \(_ :: E.SomeException) -> return Nothing diff --git a/Data/Git/Storage/FileReader.hs b/Data/Git/Storage/FileReader.hs --- a/Data/Git/Storage/FileReader.hs +++ b/Data/Git/Storage/FileReader.hs @@ -5,6 +5,7 @@ -- Stability : experimental -- Portability : unix -- +{-# LANGUAGE DeriveDataTypeable #-} module Data.Git.Storage.FileReader ( FileReader , fileReaderNew @@ -37,13 +38,18 @@ import Data.ByteString.Lazy.Internal (defaultChunkSize) import Data.IORef +import Data.Data import Data.Word import Codec.Zlib import Codec.Zlib.Lowlevel import Foreign.ForeignPtr +import qualified Control.Exception as E -import System.IO +import System.IO (hClose, hSeek, SeekMode(..)) +import Filesystem +import Filesystem.Path +import Prelude hiding (FilePath) data FileReader = FileReader { fbHandle :: Handle @@ -53,6 +59,11 @@ , fbPos :: IORef Word64 } +data InflateException = InflateException Word64 Word64 String + deriving (Show,Eq,Typeable) + +instance E.Exception InflateException + fileReaderNew :: Bool -> Handle -> IO FileReader fileReaderNew decompress handle = do ref <- newIORef B.empty @@ -149,11 +160,14 @@ let maxToInflate = min left (16 * 1024) let lastBlock = if left == maxToInflate then True else False (dbs,remaining) <- inflateToSize inflate (fromIntegral maxToInflate) lastBlock rbs (fileReaderGetNext fb) + `E.catch` augmentAndRaise left writeIORef ref remaining let nleft = left - fromIntegral (B.length dbs) if nleft > 0 then liftM (dbs:) (loop inflate nleft) else return [dbs] + augmentAndRaise :: Word64 -> E.SomeException -> IO a + augmentAndRaise left exn = throwIO $ InflateException outputSize left (show exn) -- lowlevel helpers to inflate only to a specific size. diff --git a/Data/Git/Storage/FileWriter.hs b/Data/Git/Storage/FileWriter.hs --- a/Data/Git/Storage/FileWriter.hs +++ b/Data/Git/Storage/FileWriter.hs @@ -15,7 +15,8 @@ import qualified Crypto.Hash.SHA1 as SHA1 -import System.IO +import System.IO (hClose) +import Filesystem defaultCompression = 6 diff --git a/Data/Git/Storage/Loose.hs b/Data/Git/Storage/Loose.hs --- a/Data/Git/Storage/Loose.hs +++ b/Data/Git/Storage/Loose.hs @@ -5,12 +5,15 @@ -- Stability : experimental -- Portability : unix -- -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-} module Data.Git.Storage.Loose ( + Zipped(..) -- * marshall from and to lazy bytestring - looseUnmarshall + , looseUnmarshall , looseUnmarshallRaw + , looseUnmarshallZipped + , looseUnmarshallZippedRaw , looseMarshall -- * read and check object existence , looseRead @@ -29,15 +32,17 @@ import Codec.Compression.Zlib import Data.Git.Ref import Data.Git.Path +import Data.Git.Internal import Data.Git.Storage.FileWriter import Data.Git.Storage.Object -import System.FilePath -import System.Directory -import System.IO (openFile, hFileSize, IOMode(..)) +import Filesystem +import Filesystem.Path +import Filesystem.Path.Rules import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString as B import Data.Attoparsec.Lazy import qualified Data.Attoparsec.Char8 as PC @@ -46,8 +51,11 @@ import Control.Exception (onException, SomeException) import qualified Control.Exception as E +import Data.String import Data.Char (isHexDigit) +import Prelude hiding (FilePath) + isObjectPrefix [a,b] = isHexDigit a && isHexDigit b isObjectPrefix _ = False @@ -75,43 +83,49 @@ parseObject = parseSuccess (parseTree <|> parseBlob <|> parseCommit <|> parseTag) where parseSuccess p = either error id . eitherResult . parse p --- | unmarshall an object (with header) from a lazy bytestring. +-- | unmarshall an object (with header) from a bytestring. looseUnmarshall :: L.ByteString -> Object -looseUnmarshall = parseObject . decompress +looseUnmarshall = parseObject --- | unmarshall an object as (header, data) tuple from a lazy bytestring. +-- | unmarshall an object (with header) from a zipped stream. +looseUnmarshallZipped :: Zipped -> Object +looseUnmarshallZipped = parseObject . dezip + +-- | unmarshall an object as (header, data) tuple from a bytestring looseUnmarshallRaw :: L.ByteString -> (ObjectHeader, ObjectData) -looseUnmarshallRaw l = - let dl = decompress l in - let i = L.findIndex ((==) 0) dl in - case i of +looseUnmarshallRaw stream = + case L.findIndex ((==) 0) stream of Nothing -> error "object not right format. missing 0" Just idx -> - let (h, r) = L.splitAt (idx+1) dl in + let (h, r) = L.splitAt (idx+1) stream in case maybeResult $ parse parseHeader h of Nothing -> error "cannot open object" Just hdr -> (hdr, r) +-- | unmarshall an object as (header, data) tuple from a zipped stream +looseUnmarshallZippedRaw :: Zipped -> (ObjectHeader, ObjectData) +looseUnmarshallZippedRaw = looseUnmarshallRaw . dezip + -- | read a specific ref from a loose object and returns an header and data. -looseReadRaw repoPath ref = looseUnmarshallRaw <$> L.readFile (objectPathOfRef repoPath ref) +looseReadRaw repoPath ref = looseUnmarshallZippedRaw <$> readZippedFile (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 +looseReadHeader repoPath ref = toHeader <$> readZippedFile (objectPathOfRef repoPath ref) + where toHeader = either error id . eitherResult . parse parseHeader . dezip -- | read a specific ref from a loose object and returns an object -looseRead repoPath ref = looseUnmarshall <$> L.readFile (objectPathOfRef repoPath ref) +looseRead repoPath ref = looseUnmarshallZipped <$> readZippedFile (objectPathOfRef repoPath ref) -- | check if a specific ref exists as loose object -looseExists repoPath ref = doesFileExist (objectPathOfRef repoPath ref) +looseExists repoPath ref = isFile (objectPathOfRef repoPath ref) -- | enumarate all prefixes available in the object store. -looseEnumeratePrefixes repoPath = filter isObjectPrefix <$> getDirectoryContents (repoPath "objects") +looseEnumeratePrefixes repoPath = filter isObjectPrefix <$> getDirectoryContents (repoPath fromString "objects") -- | enumerate all references available with a specific prefix. looseEnumerateWithPrefixFilter :: FilePath -> String -> (Ref -> Bool) -> IO [Ref] looseEnumerateWithPrefixFilter repoPath prefix filterF = - filter filterF . map (fromHexString . (prefix ++)) . filter isRef <$> getDir (repoPath "objects" prefix) + filter filterF . map (fromHexString . (prefix ++)) . filter isRef <$> getDir (repoPath fromString "objects" fromString prefix) where getDir p = E.catch (getDirectoryContents p) (\(_::SomeException) -> return []) isRef l = length l == 38 @@ -131,28 +145,35 @@ -- | 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 + fsz <- getSize file let hdr = objectWriteHeader TypeBlob (fromIntegral fsz) tmpPath <- objectTemporaryPath repoPath flip onException (removeFile tmpPath) $ do (ref, npath) <- withFileWriter tmpPath $ \fw -> do fileWriterOutput fw hdr - chunks <- L.toChunks <$> L.readFile file - mapM_ (fileWriterOutput fw) chunks + withFile file ReadMode $ \h -> loop h fw digest <- fileWriterGetDigest fw return (digest, objectPathOfRef repoPath digest) - exists <- doesFileExist npath + exists <- isFile npath when exists $ error "destination already exists" - renameFile tmpPath npath + rename tmpPath npath return ref + where loop h fw = do + r <- B.hGet h (32*1024) + if B.null r + then return () + else fileWriterOutput fw r >> loop h fw -- | write an object to disk as a loose reference. -- use looseWriteBlobFromFile for efficiently writing blobs when being commited from a file. -looseWrite repoPath obj = createDirectoryIfMissing True (takeDirectory path) - >> doesFileExist path - >>= \exists -> unless exists (L.writeFile path $ compress content) +looseWrite repoPath obj = createDirectory False (directory path) + >> isFile path + >>= \exists -> unless exists (writeFileLazy path $ compress content) >> return ref where path = objectPathOfRef repoPath ref content = looseMarshall obj ref = hashLBS content + writeFileLazy p bs = withFile p WriteMode (\h -> L.hPut h bs) + +getDirectoryContents p = map (encodeString posix . filename) <$> listDirectory p diff --git a/Data/Git/Storage/Object.hs b/Data/Git/Storage/Object.hs --- a/Data/Git/Storage/Object.hs +++ b/Data/Git/Storage/Object.hs @@ -15,7 +15,7 @@ , ObjectPtr(..) , Object(..) , ObjectInfo(..) - , objectWrap + , Objectable(..) , objectToType , objectTypeMarshall , objectTypeUnmarshall @@ -51,19 +51,16 @@ import Data.Attoparsec.Lazy import qualified Data.Attoparsec.Lazy as P import qualified Data.Attoparsec.Char8 as PC -import Control.Applicative ((<$>), many) +import Control.Applicative ((<$>), (<*), (*>), many) import Control.Monad +import Data.List (intersperse) +import Data.Monoid import Data.Word import Text.Printf -import Data.Time.LocalTime -import Data.Time.Clock.POSIX - -{- import Blaze.ByteString.Builder -import Blaze.ByteString.Builder.ByteString --} +import Blaze.ByteString.Builder.Char8 -- | location of an object in the database data ObjectLocation = NotFound | Loose Ref | Packed Ref Word64 @@ -85,30 +82,30 @@ , 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 +-- the deltas one are only available in packs. +data Object = ObjCommit Commit + | ObjTag Tag + | ObjBlob Blob + | ObjTree Tree + | ObjDeltaOfs DeltaOfs + | ObjDeltaRef DeltaRef + deriving (Show,Eq) -objectWrap :: Objectable a => a -> Object -objectWrap a = Object a +class Objectable a where + getType :: a -> ObjectType + getRaw :: a -> L.ByteString + isDelta :: a -> Bool + toObject :: a -> Object objectToType :: Object -> ObjectType -objectToType (Object a) = getType a +objectToType (ObjTree _) = TypeTree +objectToType (ObjBlob _) = TypeBlob +objectToType (ObjCommit _) = TypeCommit +objectToType (ObjTag _) = TypeTag +objectToType (ObjDeltaOfs _) = TypeDeltaOff +objectToType (ObjDeltaRef _) = TypeDeltaRef objectTypeMarshall :: ObjectType -> String objectTypeMarshall TypeTree = "tree" @@ -130,25 +127,36 @@ objectTypeIsDelta _ = False objectIsDelta :: Object -> Bool -objectIsDelta (Object a) = isDelta a +objectIsDelta (ObjDeltaOfs _) = True +objectIsDelta (ObjDeltaRef _) = True +objectIsDelta _ = False objectToTree :: Object -> Maybe Tree -objectToTree (Object a) = toTree a +objectToTree (ObjTree tree) = Just tree +objectToTree _ = Nothing objectToCommit :: Object -> Maybe Commit -objectToCommit (Object a) = toCommit a +objectToCommit (ObjCommit commit) = Just commit +objectToCommit _ = Nothing objectToTag :: Object -> Maybe Tag -objectToTag (Object a) = toTag a +objectToTag (ObjTag tag) = Just tag +objectToTag _ = Nothing objectToBlob :: Object -> Maybe Blob -objectToBlob (Object a) = toBlob a +objectToBlob (ObjBlob blob) = Just blob +objectToBlob _ = Nothing octal :: Parser Int octal = B.foldl' step 0 `fmap` takeWhile1 isOct where isOct w = w >= 0x30 && w <= 0x37 step a w = a * 8 + fromIntegral (w - 0x30) +tillEOL :: Parser ByteString +tillEOL = PC.takeWhile ((/= '\n')) + +skipEOL = skipChar '\n' + skipChar :: Char -> Parser () skipChar c = PC.char c >> return () @@ -156,9 +164,10 @@ 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) +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) @@ -167,17 +176,26 @@ tree <- string "tree " >> referenceHex skipChar '\n' parents <- many parseParentRef - author <- string "author " >> parseName - committer <- string "committer " >> parseName + author <- string "author " >> parsePerson + committer <- string "committer " >> parsePerson + encoding <- option Nothing $ Just <$> (string "encoding " >> tillEOL) + extras <- many parseExtra skipChar '\n' message <- takeByteString - return $ Commit tree parents author committer message + return $ Commit tree parents author committer encoding extras message where parseParentRef = do tree <- string "parent " >> referenceHex skipChar '\n' return tree - + parseExtra = do + f <- B.pack . (:[]) <$> notWord8 0xa + r <- tillEOL + skipEOL + v <- concatLines <$> many (string " " *> tillEOL <* skipEOL) + return $ CommitExtra (f `B.append` r) v + concatLines = B.concat . intersperse (B.pack [0xa]) + -- | parse a tag content tagParse = do object <- string "object " >> referenceHex @@ -186,12 +204,12 @@ skipChar '\n' tag <- string "tag " >> takeTill ((==) 0x0a) skipChar '\n' - tagger <- string "tagger " >> parseName + tagger <- string "tagger " >> parsePerson skipChar '\n' signature <- takeByteString return $ Tag object type_ tag tagger signature -parseName = do +parsePerson = do name <- B.init <$> PC.takeWhile ((/=) '<') skipChar '<' email <- PC.takeWhile ((/=) '>') @@ -199,89 +217,112 @@ 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) + return $ Person name email (GitTime time timezone) -objectParseTree = objectWrap <$> treeParse -objectParseCommit = objectWrap <$> commitParse -objectParseTag = objectWrap <$> tagParse -objectParseBlob = objectWrap <$> blobParse +objectParseTree = ObjTree <$> treeParse +objectParseCommit = ObjCommit <$> commitParse +objectParseTag = ObjTag <$> tagParse +objectParseBlob = ObjBlob <$> blobParse -- header of loose objects, but also useful for any object to determine object's hash objectWriteHeader :: ObjectType -> Word64 -> ByteString objectWriteHeader ty sz = BC.pack (objectTypeMarshall ty ++ " " ++ show sz ++ [ '\0' ]) objectWrite :: Object -> L.ByteString -objectWrite (Object a) = getRaw a +objectWrite (ObjCommit commit) = commitWrite commit +objectWrite (ObjTag tag) = tagWrite tag +objectWrite (ObjBlob blob) = blobWrite blob +objectWrite (ObjTree tree) = treeWrite tree +objectWrite _ = error "delta cannot be marshalled" -treeWrite (Tree ents) = L.fromChunks $ concat $ map writeTreeEnt ents where - writeTreeEnt (perm,name,ref) = - [ BC.pack $ printf "%o" perm - , BC.singleton ' ' - , name - , B.singleton 0 - , toBinary ref +treeWrite (Tree ents) = toLazyByteString $ mconcat $ concatMap writeTreeEnt ents + where writeTreeEnt (perm,name,ref) = + [ fromString (printf "%o" perm) + , fromString " " + , fromByteString name + , fromString "\0" + , fromByteString $ 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 ] +commitWrite (Commit tree parents author committer encoding extra msg) = + toLazyByteString $ mconcat els + where + toNamedRef s r = mconcat [fromString s, fromByteString (toHex r),eol] + toParent = toNamedRef "parent " + toCommitExtra :: CommitExtra -> [Builder] + toCommitExtra (CommitExtra k v) = [fromByteString k, eol] ++ + (concatMap (\l -> [fromByteString " ", fromByteString l, eol]) $ linesLast v) + linesLast b + | B.length b > 0 && B.last b == 0xa = BC.lines b ++ [ "" ] + | otherwise = BC.lines b + els = [toNamedRef "tree " tree ] + ++ map toParent parents + ++ [fromByteString $ writeName "author" author, eol + ,fromByteString $ writeName "committer" committer, eol + ,maybe (fromByteString B.empty) (fromByteString) encoding -- FIXME need eol + ] + ++ concatMap toCommitExtra extra + ++ [eol + ,fromByteString msg + ] + 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 ] + toLazyByteString $ mconcat els + where els = [ fromString "object ", fromByteString (toHex ref), eol + , fromString "type ", fromString (objectTypeMarshall ty), eol + , fromString "tag ", fromByteString tag, eol + , fromByteString $ writeName "tagger" tagger, eol + , eol + , fromByteString signature + ] +eol = fromString "\n" + blobWrite (Blob bData) = bData instance Objectable Blob where getType _ = TypeBlob getRaw = blobWrite + toObject = ObjBlob isDelta = const False - toBlob t = Just t instance Objectable Commit where - getType _ = TypeCommit - getRaw = commitWrite - isDelta = const False - toCommit t = Just t + getType _ = TypeCommit + getRaw = commitWrite + toObject = ObjCommit + isDelta = const False instance Objectable Tag where getType _ = TypeTag getRaw = tagWrite + toObject = ObjTag isDelta = const False - toTag t = Just t instance Objectable Tree where getType _ = TypeTree getRaw = treeWrite + toObject = ObjTree isDelta = const False - toTree t = Just t instance Objectable DeltaOfs where getType _ = TypeDeltaOff getRaw = error "delta offset cannot be marshalled" + toObject = ObjDeltaOfs isDelta = const True instance Objectable DeltaRef where getType _ = TypeDeltaRef getRaw = error "delta ref cannot be marshalled" + toObject = ObjDeltaRef isDelta = const True objectHash :: ObjectType -> Word64 -> L.ByteString -> Ref objectHash ty w lbs = hashLBS $ L.fromChunks (objectWriteHeader ty w : L.toChunks lbs) -- used for objectWrite for commit and tag -writeName label (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) +writeName label (Person name email (GitTime time tz)) = + B.concat [label, " ", name, " <", email, "> ", BC.pack (printf "%d %s%02d%02d" time tzs tzh tzm) ] + where tzs = if tz >= 0 then "+" else "-" :: String + (tzh,tzm) = abs (tz) `divMod` 100 diff --git a/Data/Git/Storage/Pack.hs b/Data/Git/Storage/Pack.hs --- a/Data/Git/Storage/Pack.hs +++ b/Data/Git/Storage/Pack.hs @@ -5,6 +5,7 @@ -- Stability : experimental -- Portability : unix -- +{-# LANGUAGE OverloadedStrings #-} module Data.Git.Storage.Pack ( PackedObjectInfo(..) , PackedObjectRaw @@ -28,9 +29,9 @@ import Control.Arrow (second) import Control.Monad -import System.IO -import System.FilePath -import System.Directory +import Filesystem.Path.Rules +import Filesystem.Path +import Filesystem import Data.Bits import Data.List @@ -49,6 +50,7 @@ import Data.Git.Storage.FileReader import Data.Word +import Prelude hiding (FilePath) type PackedObjectRaw = (PackedObjectInfo, L.ByteString) @@ -61,7 +63,7 @@ } deriving (Show,Eq) -- | Enumerate the pack refs available in this repository. -packEnumerate repoPath = map onlyHash . filter isPackFile <$> getDirectoryContents (repoPath "objects" "pack") +packEnumerate repoPath = map onlyHash . filter isPackFile . map (encodeString posix . filename) <$> listDirectory (repoPath "objects" "pack") where isPackFile x = ".pack" `isSuffixOf` x onlyHash = fromHexString . takebut 5 . drop 5 @@ -118,8 +120,8 @@ 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 (TypeDeltaOff, Just (PtrOfs o), objData) = toObject . DeltaOfs o <$> deltaRead objData +packObjectFromRaw (TypeDeltaRef, Just (PtrRef r), objData) = toObject . DeltaRef r <$> deltaRead objData packObjectFromRaw _ = error "can't happen unless someone change getNextObjectRaw" getNextObjectRaw :: FileReader -> IO PackedObjectRaw diff --git a/Data/Git/Storage/PackIndex.hs b/Data/Git/Storage/PackIndex.hs --- a/Data/Git/Storage/PackIndex.hs +++ b/Data/Git/Storage/PackIndex.hs @@ -28,13 +28,14 @@ import Control.Applicative ((<$>)) import Control.Monad -import System.FilePath -import System.Directory -import System.IO +import Filesystem +import Filesystem.Path +import Filesystem.Path.Rules import Data.List import Data.Bits import Data.Word +import Data.String import Data.Vector (Vector, (!)) import qualified Data.Vector as V @@ -46,6 +47,8 @@ import Data.Git.Path import Data.Git.Ref +import Prelude hiding (FilePath) + -- | represent an packIndex header with the version and the fanout table data PackIndexHeader = PackIndexHeader !Word32 !(Vector Word32) deriving (Show,Eq) @@ -59,7 +62,7 @@ } -- | enumerate every indexes file in the pack directory -packIndexEnumerate repoPath = map onlyHash . filter isPackFile <$> getDirectoryContents (repoPath "objects" "pack") +packIndexEnumerate repoPath = map onlyHash . filter isPackFile . map (encodeString posix . filename) <$> listDirectory (repoPath "objects" "pack") where isPackFile x = ".idx" `isSuffixOf` x && "pack-" `isPrefixOf` x onlyHash = fromHexString . takebut 4 . drop 5 diff --git a/Data/Git/Types.hs b/Data/Git/Types.hs --- a/Data/Git/Types.hs +++ b/Data/Git/Types.hs @@ -12,14 +12,19 @@ -- * Main git types , Tree(..) , Commit(..) + , CommitExtra(..) , Blob(..) , Tag(..) + , Person(..) + -- * time type + , GitTime(..) + , toUTCTime + , toPOSIXTime -- * Pack delta types , DeltaOfs(..) , DeltaRef(..) -- * Basic types part of other bigger types , TreeEnt - , Name ) where import Data.Word @@ -30,7 +35,7 @@ import Data.Git.Ref import Data.Git.Delta import Data.Time.Clock -import Data.Time.LocalTime +import Data.Time.Clock.POSIX -- | type of a git object. data ObjectType = @@ -42,6 +47,16 @@ | TypeDeltaRef deriving (Show,Eq) +-- | Git time is number of seconds since unix epoch +data GitTime = GitTime Integer Int + deriving (Show,Eq) + +toUTCTime :: GitTime -> UTCTime +toUTCTime (GitTime seconds _) = posixSecondsToUTCTime $ fromIntegral seconds + +toPOSIXTime :: GitTime -> POSIXTime +toPOSIXTime = utcTimeToPOSIXSeconds . toUTCTime + -- | the enum instance is useful when marshalling to pack file. instance Enum ObjectType where fromEnum TypeCommit = 0x1 @@ -68,7 +83,11 @@ -- has the format: name 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) +data Person = Person + { personName :: ByteString + , personEmail :: ByteString + , personTime :: GitTime + } deriving (Show,Eq) -- | Represent a root tree with zero to many tree entries. data Tree = Tree { treeGetEnts :: [TreeEnt] } deriving (Show,Eq) @@ -85,17 +104,24 @@ data Commit = Commit { commitTreeish :: Ref , commitParents :: [Ref] - , commitAuthor :: Name - , commitCommitter :: Name + , commitAuthor :: Person + , commitCommitter :: Person + , commitEncoding :: Maybe ByteString + , commitExtras :: [CommitExtra] , commitMessage :: ByteString } deriving (Show,Eq) +data CommitExtra = CommitExtra + { commitExtraKey :: ByteString + , commitExtraValue :: ByteString + } deriving (Show,Eq) + -- | Represent a signed tag. data Tag = Tag { tagRef :: Ref , tagObjectType :: ObjectType , tagBlob :: ByteString - , tagName :: Name + , tagName :: Person , tagS :: ByteString } deriving (Show,Eq) diff --git a/Hit/Hit.hs b/Hit/Hit.hs --- a/Hit/Hit.hs +++ b/Hit/Hit.hs @@ -138,7 +138,7 @@ where loopTillEmpty ref = do obj <- getCommit git ref case obj of - Just (Commit _ parents _ _ _) -> do + Just (Commit { commitParents = parents }) -> do putStrLn $ show ref -- this behave like rev-list --first-parent. -- otherwise the parents need to be organized and printed @@ -146,7 +146,7 @@ case parents of [] -> return () (p:_) -> loopTillEmpty p - Nothing -> error "reference in commit chain doesn't exists" + Nothing -> error ("commit reference " ++ show ref ++ " in commit chain doesn't exists") main = do args <- getArgs diff --git a/Tests/Tests.hs b/Tests/Tests.hs --- a/Tests/Tests.hs +++ b/Tests/Tests.hs @@ -16,12 +16,15 @@ import Data.Time.Clock import Data.Time.Calendar +import Data.Maybe + -- for arbitrary instance to generate only data that are writable -- to disk. i.e. no deltas. ---data ObjNoDelta = ObjNoDelta Object +data ObjNoDelta = ObjNoDelta Object + deriving (Eq) ---instance Show ObjNoDelta where --- show (ObjNoDelta o) = show o +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) @@ -30,70 +33,81 @@ arbitraryBSnoangle size = B.pack . map fromIntegral <$> replicateM size (choose (0x40,0x7f) :: Gen Int) instance Arbitrary Ref where - arbitrary = fromBinary <$> arbitraryBS 20 + arbitrary = fromBinary <$> arbitraryBS 20 -arbitraryMsg = arbitraryBSno0 128 -arbitraryLazy = L.fromChunks . (:[]) <$> arbitraryBS 4096 +arbitraryMsg = arbitraryBSno0 1 +arbitraryLazy = L.fromChunks . (:[]) <$> arbitraryBS 40 arbitraryRefList :: Gen [Ref] arbitraryRefList = replicateM 2 arbitrary arbitraryEnt = liftM3 (,,) arbitrary (arbitraryBSno0 48) arbitrary -arbitraryEnts = choose (1,100) >>= \i -> replicateM i arbitraryEnt +arbitraryEnts = choose (1,2) >>= \i -> replicateM i arbitraryEnt instance Arbitrary TimeZone where - arbitrary = hoursToTimeZone <$> arbitrary + arbitrary = hoursToTimeZone . rel <$> arbitrary + where rel a = (a `mod` 24) - 12 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 +instance Arbitrary GitTime where + arbitrary = GitTime <$> (arbitrary `suchThat` \i -> i > 0) <*> arbitraryTz + where arbitraryTz = do + h <- choose (0, 23) + m <- (* 30) <$> choose (0,1) + return (h * 100 + m - 1200) + +arbitraryName = liftM3 Person (arbitraryBSnoangle 16) + (arbitraryBSnoangle 16) + arbitrary + arbitraryObjTypeNoDelta = oneof [return TypeTree,return TypeBlob,return TypeCommit,return TypeTag] +arbitrarySmallList = frequency [ (2, return []), (1, resize 3 arbitrary) ] + instance Arbitrary Commit where - arbitrary = Commit <$> arbitrary <*> arbitraryRefList <*> arbitraryName <*> arbitraryName <*> arbitraryMsg + arbitrary = Commit <$> arbitrary <*> arbitraryRefList <*> arbitraryName <*> arbitraryName <*> return Nothing <*> arbitrarySmallList <*> arbitraryMsg +instance Arbitrary CommitExtra where + arbitrary = CommitExtra <$> arbitraryBSascii 80 <*> arbitraryMsg + instance Arbitrary Tree where - arbitrary = Tree <$> arbitraryEnts + arbitrary = Tree <$> arbitraryEnts instance Arbitrary Blob where - arbitrary = Blob <$> arbitraryLazy + arbitrary = Blob <$> arbitraryLazy instance Arbitrary Tag where - arbitrary = Tag <$> arbitrary <*> arbitraryObjTypeNoDelta <*> arbitraryBSascii 20 <*> arbitraryName <*> arbitraryMsg - -{- -instance Arbitrary Object where - arbitrary = undefined + arbitrary = Tag <$> arbitrary <*> arbitraryObjTypeNoDelta <*> arbitraryBSascii 20 <*> arbitraryName <*> arbitraryMsg instance Arbitrary ObjNoDelta where - arbitrary = ObjNoDelta <$> oneof - [ liftM5 Commit arbitrary arbitraryRefList arbitraryName arbitraryName arbitraryMsg - , liftM Tree arbitraryEnts - , liftM Blob arbitraryLazy - , liftM5 Tag - ] --} + arbitrary = ObjNoDelta <$> oneof + [ toObject <$> (arbitrary :: Gen Commit) + , toObject <$> (arbitrary :: Gen Tree) + , toObject <$> (arbitrary :: Gen Blob) + , toObject <$> (arbitrary :: Gen Tag) + ] ---prop_object_marshalling_id (ObjNoDelta obj) = obj == (looseUnmarshall $ looseMarshall obj) +prop_object_marshalling_id (ObjNoDelta obj) = obj `assertEq` (looseUnmarshall $ looseMarshall obj) + where assertEq a b + | show a == show b = True + | otherwise = error ("not equal:\n" ++ show a ++ "\ngot: " ++ show b) refTests = - [ testProperty "hexadecimal" (marshEqual (fromHex . toHex)) - , testProperty "binary" (marshEqual (fromBinary . toBinary)) - ] - where - marshEqual t ref = ref == t ref + [ 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 - ] + [ testProperty "unmarshall.marshall==id" prop_object_marshalling_id + ] main = defaultMain - [ testGroup "ref marshalling" refTests - , testGroup "object marshalling" objTests - ] + [ testGroup "ref marshalling" refTests + , testGroup "object marshalling" objTests + ] diff --git a/hit.cabal b/hit.cabal --- a/hit.cabal +++ b/hit.cabal @@ -1,7 +1,16 @@ Name: hit -Version: 0.3.0 -Synopsis: Git operations -Description: Provides low level git operations +Version: 0.4.0 +Synopsis: Git operations in haskell +Description: + . + An haskell implementation of git storage operations, allowing users + to manipulate git repositories (read and write). + . + This implementation is fully interoperable with the main C implementation. + . + This is stricly only manipulating the git store (what's inside the .git directory), + and doesn't do anything with the index or your working directory files. + . License: BSD3 License-file: LICENSE Copyright: Vincent Hanquez @@ -27,16 +36,17 @@ Build-Depends: base >= 4 && < 5 , mtl , bytestring + , blaze-builder , attoparsec >= 0.10.1 , parsec >= 3 - , filepath - , directory + , containers + , system-filepath + , system-fileio , cryptohash , vector , random , zlib , zlib-bindings >= 0.1 && < 0.2 - , bytedump , time Exposed-modules: Data.Git Data.Git.Types @@ -53,6 +63,7 @@ Other-modules: Data.Git.Internal Data.Git.Storage.FileReader Data.Git.Storage.FileWriter + Data.Git.Storage.CacheFile Data.Git.Path ghc-options: -Wall -fno-warn-missing-signatures @@ -73,7 +84,6 @@ , parsec >= 3 , filepath , directory - , bytedump , hit Buildable: True else @@ -103,7 +113,7 @@ , test-framework >= 0.3 , test-framework-quickcheck2 >= 0.2 , time - , bytedump + , bytedump >= 1.0 , hit source-repository head