hit 0.3.0 → 0.4.0

raw patch · 17 files changed

+602/−280 lines, 17 filesdep +blaze-builderdep +system-fileiodep +system-filepathdep ~bytedumpPVP ok

version bump matches the API change (PVP)

Dependencies added: blaze-builder, system-fileio, system-filepath

Dependency ranges changed: bytedump

API changes (from Hackage documentation)

Files

• Data/Git.hs +3/−0
• Data/Git/Internal.hs +21/−3
• Data/Git/Named.hs +104/−23
• Data/Git/Path.hs +13/−10
• Data/Git/Repository.hs +68/−44
• Data/Git/Storage.hs +43/−26
• Data/Git/Storage/CacheFile.hs +44/−0
• Data/Git/Storage/FileReader.hs +15/−1
• Data/Git/Storage/FileWriter.hs +2/−1
• Data/Git/Storage/Loose.hs +49/−28
• Data/Git/Storage/Object.hs +121/−80
• Data/Git/Storage/Pack.hs +8/−6
• Data/Git/Storage/PackIndex.hs +7/−4
• Data/Git/Types.hs +32/−6
• Hit/Hit.hs +2/−2
• Tests/Tests.hs +52/−38
• hit.cabal +18/−8

@@ -10,9 +10,12 @@     -- * Basic types       Ref     , Commit(..)+    , Person(..)+    , CommitExtra(..)     , Tree(..)     , Blob(..)     , Tag(..)+    , GitTime(..)      -- * Revision     , Revision

@@ -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

@@ -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)+-}

@@ -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"))

@@ -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)

@@ -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.

@@ -0,0 +1,44 @@+{-# LANGUAGE ScopedTypeVariables #-}+-- |+-- Module      : Data.Git.Storage.CacheFile+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : unix+--+module Data.Git.Storage.CacheFile (CacheFile, newCacheVal, getCacheVal) where++import Control.Applicative ((<$>))+import Control.Concurrent.MVar+import qualified Control.Exception as E+import 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

@@ -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. 

@@ -15,7 +15,8 @@  import qualified Crypto.Hash.SHA1 as SHA1 -import System.IO+import System.IO (hClose)+import Filesystem  defaultCompression = 6 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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 <email> time timezone -- FIXME: should be a string, but I don't know if the data is stored -- consistantly in one encoding (UTF8)-type Name = (ByteString,ByteString,UTCTime,TimeZone)+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) 

@@ -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

@@ -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+    ]

@@ -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 <vincent@snarc.org>@@ -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