diff --git a/Data/Git.hs b/Data/Git.hs deleted file mode 100644 --- a/Data/Git.hs +++ /dev/null @@ -1,86 +0,0 @@ --- | --- Module : Data.Git --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unix --- -module Data.Git - ( - -- * Basic types - Ref - , RefName(..) - , Commit(..) - , Person(..) - , CommitExtra(..) - , Tree(..) - , Blob(..) - , Tag(..) - , GitTime - , ModePerm(..) - , EntName - , EntPath - , entName - , entPathAppend - - -- * Helper & type related to ModePerm - , ObjectFileType(..) - , FilePermissions(..) - , getPermission - , getFiletype - - -- * Revision - , Revision - , resolveRevision - - -- * Object resolution - , resolveTreeish - , resolvePath - - -- * repo context - , Git - , withCurrentRepo - , withRepo - , findRepo - - -- * Repository queries and creation - , initRepo - , isRepo - - -- * Context operations - , rewrite - - -- * Get objects - , getObject - , getCommit - , getTree - - -- * Set objects - , setObject - , toObject - - -- * Work trees - , WorkTree - , EntType(..) - , workTreeNew - , workTreeFrom - , workTreeDelete - , workTreeSet - , workTreeFlush - - -- * Named refs - , branchWrite - , branchList - , tagWrite - , tagList - , headSet - , headGet - ) where - -import Data.Git.Ref -import Data.Git.Types -import Data.Git.Storage -import Data.Git.Repository -import Data.Git.Revision -import Data.Git.Storage.Object (toObject) -import Data.Git.WorkTree diff --git a/Data/Git/Config.hs b/Data/Git/Config.hs deleted file mode 100644 --- a/Data/Git/Config.hs +++ /dev/null @@ -1,82 +0,0 @@ --- | --- Module : Data.Git.Config --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unix --- --- config related types and methods. --- -{-# LANGUAGE OverloadedStrings #-} -module Data.Git.Config - ( Config(..) - , Section(..) - -- * reading methods - , readConfig - , readGlobalConfig - -- * methods - , listSections - , get - ) where - -import Control.Applicative -import Control.Monad (mplus) -import Data.Git.Path -import Data.List (find) -import Filesystem.Path.CurrentOS -import Filesystem (getHomeDirectory) -import qualified Data.Set as S - -newtype Config = Config [Section] - deriving (Show,Eq) - -data Section = Section - { sectionName :: String - , sectionKVs :: [(String, String)] - } deriving (Show,Eq) - -parseConfig :: String -> Config -parseConfig = Config . reverse . toSections . foldl accSections ([], Nothing) . lines - where toSections (l,Nothing) = l - toSections (l,Just s) = s : l - - -- a new section in the config file - accSections (sections, mcurrent) ('[':sectNameE) - | last sectNameE == ']' = - let sectName = take (length sectNameE - 1) sectNameE - in case mcurrent of - Nothing -> (sections, Just $ Section sectName []) - Just current -> (sectionFinalize current : sections, Just $ Section sectName []) - | otherwise = - (sections, mcurrent) - -- a normal line without having any section defined yet - accSections acc@(_, Nothing) _ = acc - -- potentially a k-v line in an existing section - accSections (sections, Just current) kvLine = - case break (== '=') kvLine of - (k,'=':v) -> (sections, Just $ sectionAppend current (strip k, strip v)) - (_,_) -> (sections, Just current) -- not a k = v line - -- append a key-value - sectionAppend (Section n l) kv = Section n (kv:l) - sectionFinalize (Section n l) = Section n $ reverse l - - strip s = dropSpaces $ reverse $ dropSpaces $ reverse s - where dropSpaces = dropWhile (\c -> c == ' ' || c == '\t') - -readConfigPath filepath = parseConfig <$> readFile (encodeString filepath) -readConfig gitRepo = readConfigPath (configPath gitRepo) - -readGlobalConfig = getHomeDirectory >>= readConfigPath . (\homeDir -> homeDir ".gitconfig") - -listSections :: [Config] -> [String] -listSections = S.toList . foldr accSections S.empty - where accSections (Config sections) set = foldr S.insert set (map sectionName sections) - --- | Get a configuration element in a stack of config file, starting from the top. -get :: [Config] -- ^ stack of config - -> String -- ^ section name - -> String -- ^ key name - -> Maybe String -get [] _ _ = Nothing -get (Config c:cs) section key = findOne `mplus` get cs section key - where findOne = find (\s -> sectionName s == section) c >>= lookup key . sectionKVs diff --git a/Data/Git/Delta.hs b/Data/Git/Delta.hs deleted file mode 100644 --- a/Data/Git/Delta.hs +++ /dev/null @@ -1,84 +0,0 @@ --- | --- Module : Data.Git.Delta --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unix --- -module Data.Git.Delta - ( Delta(..) - , DeltaCmd(..) - , deltaParse - , deltaRead - , deltaApply - ) where - -import Data.Attoparsec -import qualified Data.Attoparsec as A -import qualified Data.Attoparsec.Lazy as AL -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.Bits -import Data.Word - -import Control.Applicative ((<$>), many) - --- | a delta is a source size, a destination size and a list of delta cmd -data Delta = Delta Word64 Word64 [DeltaCmd] - deriving (Show,Eq) - --- | possible commands in a delta -data DeltaCmd = - DeltaCopy ByteString -- command to insert this bytestring - | DeltaSrc Word64 Word64 -- command to copy from source (offset, size) - deriving (Show,Eq) - --- | parse a delta. --- format is 2 variable sizes, followed by delta cmds. for each cmd: --- * if first byte MSB is set, we copy from source. --- * otherwise, we copy from delta. --- * extensions are not handled. -deltaParse = do - srcSize <- getDeltaHdrSize - resSize <- getDeltaHdrSize - dcmds <- many (anyWord8 >>= parseWithCmd) - return $ Delta srcSize resSize dcmds - where - getDeltaHdrSize = do - z <- A.takeWhile (\w -> w `testBit` 7) - l <- anyWord8 - return $ unbytes 0 $ (map (\w -> w `clearBit` 7) (B.unpack z) ++ [l]) - -- use a foldl .. - unbytes _ [] = 0 - unbytes sh (x:xs) = (fromIntegral x) `shiftL` sh + unbytes (sh+7) xs - -- parse one command, either an extension, a copy from src, or a copy from delta. - parseWithCmd cmd - | cmd == 0 = error "delta extension not supported" - | cmd `testBit` 7 = do - o1 <- word8cond (cmd `testBit` 0) 0 - o2 <- word8cond (cmd `testBit` 1) 8 - o3 <- word8cond (cmd `testBit` 2) 16 - o4 <- word8cond (cmd `testBit` 3) 24 - s1 <- word8cond (cmd `testBit` 4) 0 - s2 <- word8cond (cmd `testBit` 5) 8 - s3 <- word8cond (cmd `testBit` 6) 16 - let offset = o1 .|. o2 .|. o3 .|. o4 - let size = s1 .|. s2 .|. s3 - return $ DeltaSrc offset (if size == 0 then 0x10000 else size) - | otherwise = DeltaCopy <$> A.take (fromIntegral cmd) - word8cond cond sh = - if cond then (flip shiftL sh . fromIntegral) <$> anyWord8 else return 0 - --- | read one delta from a lazy bytestring. -deltaRead = AL.maybeResult . AL.parse deltaParse - --- | apply a delta on a lazy bytestring, returning a new bytestring. -deltaApply :: L.ByteString -> Delta -> L.ByteString -deltaApply src (Delta srcSize _ deltaCmds) - | L.length src /= fromIntegral srcSize = error "source size do not match" - | otherwise = -- FIXME use a bytestring builder here. - L.fromChunks $ concatMap resolve deltaCmds - where resolve (DeltaSrc o s) = L.toChunks $ takeAt (fromIntegral s) (fromIntegral o) src - resolve (DeltaCopy b) = [b] - takeAt sz at = L.take sz . L.drop at diff --git a/Data/Git/Diff.hs b/Data/Git/Diff.hs deleted file mode 100644 --- a/Data/Git/Diff.hs +++ /dev/null @@ -1,285 +0,0 @@ --- | --- Module : Data.Git.Diff --- License : BSD-style --- Maintainer : Nicolas DI PRIMA --- Stability : experimental --- Portability : unix --- --- Basic Git diff methods. --- - -module Data.Git.Diff - ( - -- * Basic features - BlobContent(..) - , BlobState(..) - , BlobStateDiff(..) - , getDiffWith - -- * Default helpers - , HitDiff(..) - , HitFileContent(..) - , FilteredDiff(..) - , HitFileRef(..) - , HitFileMode(..) - , TextLine(..) - , defaultDiff - , getDiff - ) where - -import Data.List (find, filter) -import Data.Char (ord) -import Data.Git -import Data.Git.Repository -import Data.Git.Storage -import Data.Git.Storage.Object -import Data.ByteString.Lazy.Char8 as L - -import Data.Algorithm.Patience as AP (Item(..), diff) - --- | represents a blob's content (i.e., the content of a file at a given --- reference). -data BlobContent = FileContent [L.ByteString] -- ^ Text file's lines - | BinaryContent L.ByteString -- ^ Binary content - deriving (Show) - --- | This is a blob description at a given state (revision) -data BlobState = BlobState - { bsFilename :: EntPath - , bsMode :: ModePerm - , bsRef :: Ref - , bsContent :: BlobContent - } - deriving (Show) - --- | Two 'BlobState' are equal if they have the same filename, i.e., --- --- > ((BlobState x _ _ _) == (BlobState y _ _ _)) = (x == y) -instance Eq BlobState where - (BlobState f1 _ _ _) == (BlobState f2 _ _ _) = (f2 == f1) - a /= b = not (a == b) - --- | Represents a file state between two revisions --- A file (a blob) can be present in the first Tree's revision but not in the --- second one, then it has been deleted. If only in the second Tree's revision, --- then it has been created. If it is in the both, maybe it has been changed. -data BlobStateDiff = OnlyOld BlobState - | OnlyNew BlobState - | OldAndNew BlobState BlobState - -buildListForDiff :: Git -> Ref -> IO [BlobState] -buildListForDiff git ref = do - commit <- getCommit git ref - tree <- resolveTreeish git $ commitTreeish commit - case tree of - Just t -> do htree <- buildHTree git t - buildTreeList htree [] - _ -> error "cannot build a tree from this reference" - where - buildTreeList :: HTree -> EntPath -> IO [BlobState] - buildTreeList [] _ = return [] - buildTreeList ((d,n,TreeFile r):xs) pathPrefix = do - content <- catBlobFile r - let isABinary = isBinaryFile content - listTail <- buildTreeList xs pathPrefix - case isABinary of - False -> return $ (BlobState (entPathAppend pathPrefix n) d r (FileContent $ L.lines content)) : listTail - True -> return $ (BlobState (entPathAppend pathPrefix n) d r (BinaryContent content)) : listTail - buildTreeList ((_,n,TreeDir _ subTree):xs) pathPrefix = do - l1 <- buildTreeList xs pathPrefix - l2 <- buildTreeList subTree (entPathAppend pathPrefix n) - return $ l1 ++ l2 - - catBlobFile :: Ref -> IO L.ByteString - catBlobFile blobRef = do - mobj <- getObjectRaw git blobRef True - case mobj of - Nothing -> error "not a valid object" - Just obj -> return $ oiData obj - getBinaryStat :: L.ByteString -> Double - getBinaryStat bs = L.foldl' (\acc w -> acc + if isBin $ ord w then 1 else 0) 0 bs / (fromIntegral $ L.length bs) - where - isBin :: Int -> Bool - isBin i - | i >= 0 && i <= 8 = True - | i == 12 = True - | i >= 14 && i <= 31 = True - | otherwise = False - - isBinaryFile :: L.ByteString -> Bool - isBinaryFile file = let bs = L.take 512 file - in getBinaryStat bs > 0.0 - --- | generate a diff list between two revisions with a given diff helper. --- --- Useful to extract any kind of information from two different revisions. --- For example you can get the number of deleted files: --- --- > getdiffwith f 0 head^ head git --- > where f (OnlyOld _) acc = acc+1 --- > f _ acc = acc --- --- Or save the list of new files: --- --- > getdiffwith f [] head^ head git --- > where f (OnlyNew bs) acc = (bsFilename bs):acc --- > f _ acc = acc -getDiffWith :: (BlobStateDiff -> a -> a) -- ^ diff helper (State -> accumulator -> accumulator) - -> a -- ^ accumulator - -> Ref -- ^ commit reference (the original state) - -> Ref -- ^ commit reference (the new state) - -> Git -- ^ repository - -> IO a -getDiffWith f acc ref1 ref2 git = do - commit1 <- buildListForDiff git ref1 - commit2 <- buildListForDiff git ref2 - return $ Prelude.foldr f acc $ doDiffWith commit1 commit2 - where - doDiffWith :: [BlobState] -> [BlobState] -> [BlobStateDiff] - doDiffWith [] [] = [] - doDiffWith [bs1] [] = [OnlyOld bs1] - doDiffWith [] (bs2:xs2) = (OnlyNew bs2):(doDiffWith [] xs2) - doDiffWith (bs1:xs1) xs2 = - let bs2Maybe = Data.List.find (\x -> x == bs1) xs2 - in case bs2Maybe of - Just bs2 -> let subxs2 = Data.List.filter (\x -> x /= bs2) xs2 - in (OldAndNew bs1 bs2):(doDiffWith xs1 subxs2) - Nothing -> (OnlyOld bs1):(doDiffWith xs1 xs2) - -data TextLine = TextLine - { lineNumber :: Integer - , lineContent :: L.ByteString - } -instance Eq TextLine where - a == b = (lineContent a) == (lineContent b) - a /= b = not (a == b) -instance Ord TextLine where - compare a b = compare (lineContent a) (lineContent b) - a < b = (lineContent a) < (lineContent b) - a <= b = (lineContent a) <= (lineContent b) - a > b = b < a - a >= b = b <= a - -data FilteredDiff = NormalLine (Item TextLine) | Separator - -data HitFileContent = NewBinaryFile - | OldBinaryFile - | NewTextFile [TextLine] - | OldTextFile [TextLine] - | ModifiedBinaryFile - | ModifiedFile [FilteredDiff] - | UnModifiedFile - -data HitFileMode = NewMode ModePerm - | OldMode ModePerm - | ModifiedMode ModePerm ModePerm - | UnModifiedMode ModePerm - -data HitFileRef = NewRef Ref - | OldRef Ref - | ModifiedRef Ref Ref - | UnModifiedRef Ref - --- | This is a proposed diff records for a given file. --- It contains useful information: --- * the filename (with its path in the root project) --- * a file diff (with the Data.Algorithm.Patience method) --- * the file's mode (i.e. the file priviledge) --- * the file's ref -data HitDiff = HitDiff - { hFileName :: EntPath - , hFileContent :: HitFileContent - , hFileMode :: HitFileMode - , hFileRef :: HitFileRef - } - --- | A default Diff getter which returns all diff information (Mode, Content --- and Binary) with a context of 5 lines. --- --- > getDiff = getDiffWith (defaultDiff 5) [] -getDiff :: Ref - -> Ref - -> Git - -> IO [HitDiff] -getDiff = getDiffWith (defaultDiff 5) [] - --- | A default diff helper. It is an example about how you can write your own --- diff helper or you can use it if you want to get all of differences. -defaultDiff :: Int -- ^ Number of line for context - -> BlobStateDiff - -> [HitDiff] -- ^ Accumulator - -> [HitDiff] -- ^ Accumulator with a new content -defaultDiff _ (OnlyOld old ) acc = - let oldMode = OldMode (bsMode old) - oldRef = OldRef (bsRef old) - oldContent = case bsContent old of - BinaryContent _ -> OldBinaryFile - FileContent l -> OldTextFile (Prelude.zipWith TextLine [1..] l) - in (HitDiff (bsFilename old) oldContent oldMode oldRef):acc -defaultDiff _ (OnlyNew new) acc = - let newMode = NewMode (bsMode new) - newRef = NewRef (bsRef new) - newContent = case bsContent new of - BinaryContent _ -> NewBinaryFile - FileContent l -> NewTextFile (Prelude.zipWith TextLine [1..] l) - in (HitDiff (bsFilename new) newContent newMode newRef):acc -defaultDiff context (OldAndNew old new) acc = - let mode = if (bsMode old) /= (bsMode new) then ModifiedMode (bsMode old) (bsMode new) - else UnModifiedMode (bsMode new) - ref = if (bsRef old) == (bsRef new) then UnModifiedRef (bsRef new) - else ModifiedRef (bsRef old) (bsRef new) - in case (mode, ref) of - ((UnModifiedMode _), (UnModifiedRef _)) -> acc - _ -> (HitDiff (bsFilename new) (content ref) mode ref):acc - where content :: HitFileRef -> HitFileContent - content (UnModifiedRef _) = UnModifiedFile - content _ = createDiff (bsContent old) (bsContent new) - - createDiff :: BlobContent -> BlobContent -> HitFileContent - createDiff (FileContent a) (FileContent b) = - let linesA = Prelude.zipWith TextLine [1..] a - linesB = Prelude.zipWith TextLine [1..] b - in ModifiedFile $ diffGetContext context (diff linesA linesB) - createDiff _ _ = ModifiedBinaryFile - --- Used by diffGetContext -data HitwebAccu = AccuBottom | AccuTop - --- Context filter -diffGetContext :: Int -> [Item TextLine] -> [FilteredDiff] -diffGetContext 0 list = fmap NormalLine list -diffGetContext context list = - let (_, _, filteredDiff) = Prelude.foldr filterContext (0, AccuBottom, []) list - theList = removeTrailingBoth filteredDiff - in case Prelude.head theList of - (NormalLine (Both l1 _)) -> if (lineNumber l1) > 1 then Separator:theList - else theList - _ -> theList - where -- only keep 'context'. The file is annalyzed from the bottom to the top. - -- The accumulator here is a tuple3 with (the line counter, the - -- direction and the list of elements) - filterContext :: (Item TextLine) -> (Int, HitwebAccu, [FilteredDiff]) -> (Int, HitwebAccu, [FilteredDiff]) - filterContext (Both l1 l2) (c, AccuBottom, acc) = - if c < context then (c+1, AccuBottom, (NormalLine (Both l1 l2)):acc) - else (c , AccuBottom, (NormalLine (Both l1 l2)) - :((Prelude.take (context-1) acc) - ++ [Separator] - ++ (Prelude.drop (context+1) acc))) - filterContext (Both l1 l2) (c, AccuTop, acc) = - if c < context then (c+1, AccuTop , (NormalLine (Both l1 l2)):acc) - else (0 , AccuBottom, (NormalLine (Both l1 l2)):acc) - filterContext element (_, _, acc) = - (0, AccuTop, (NormalLine element):acc) - - startWithSeparator :: [FilteredDiff] -> Bool - startWithSeparator [] = False - startWithSeparator (Separator:_) = True - startWithSeparator ((NormalLine l):xs) = - case l of - (Both _ _) -> startWithSeparator xs - _ -> False - - removeTrailingBoth :: [FilteredDiff] -> [FilteredDiff] - removeTrailingBoth diffList = - let test = startWithSeparator diffList - in if test then Prelude.tail $ Prelude.dropWhile (\a -> not $ startWithSeparator [a]) diffList - else diffList diff --git a/Data/Git/Internal.hs b/Data/Git/Internal.hs deleted file mode 100644 --- a/Data/Git/Internal.hs +++ /dev/null @@ -1,43 +0,0 @@ --- | --- Module : Data.Git.Internal --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unix --- -module Data.Git.Internal - ( be32 - , be16 - , Zipped(..) - , readZippedFile - , dezip - ) where - -import Control.Applicative -import Data.Bits -import Data.Word -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Codec.Compression.Zlib -import Filesystem.Path -import Filesystem.Path.Rules -import Prelude hiding (FilePath) - -be32 :: B.ByteString -> Word32 -be32 b = fromIntegral (B.index b 0) `shiftL` 24 - + fromIntegral (B.index b 1) `shiftL` 16 - + fromIntegral (B.index b 2) `shiftL` 8 - + fromIntegral (B.index b 3) - -be16 :: B.ByteString -> Word16 -be16 b = fromIntegral (B.index b 0) `shiftL` 8 - + fromIntegral (B.index b 1) - -newtype Zipped = Zipped { getZippedData :: L.ByteString } - deriving (Show,Eq) - -readZippedFile :: FilePath -> IO Zipped -readZippedFile fp = Zipped <$> L.readFile (encodeString posix fp) - -dezip :: Zipped -> L.ByteString -dezip = decompress . getZippedData diff --git a/Data/Git/Named.hs b/Data/Git/Named.hs deleted file mode 100644 --- a/Data/Git/Named.hs +++ /dev/null @@ -1,194 +0,0 @@ --- | --- Module : Data.Git.Named --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unix --- --- Manipulation of named references --- * reading packed-refs file --- * reading single heads/tags/remote file -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -module Data.Git.Named - ( RefSpecTy(..) - , RefContentTy(..) - , RefName(..) - , readPackedRefs - , PackedRefs(..) - -- * manipulating loosed name references - , existsRefFile - , writeRefFile - , readRefFile - -- * listings looses name references - , looseHeadsList - , looseTagsList - , looseRemotesList - ) where - -import Control.Applicative ((<$>)) - -import qualified Filesystem as F -import qualified Filesystem.Path.Rules as FP (posix, decode, encode, encodeString, decodeString) -import Filesystem.Path.CurrentOS hiding (root) - -import Data.String -import Data.Git.Path -import Data.Git.Ref -import Data.List (isPrefixOf) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import Prelude hiding (FilePath) - --- | Represent a named specifier. -data RefSpecTy = RefHead - | RefOrigHead - | RefFetchHead - | RefBranch RefName - | RefTag RefName - | RefRemote RefName - | RefPatches String - | RefStash - | RefOther String - deriving (Show,Eq,Ord) - --- | content of a ref file. -data RefContentTy = RefDirect Ref - | RefLink RefSpecTy - | RefContentUnknown B.ByteString - deriving (Show,Eq) - -newtype RefName = RefName { refNameRaw :: String } - deriving (Show,Eq,Ord) - -instance IsString RefName where - fromString s - | isValidRefName s = RefName s - | otherwise = error ("invalid RefName " ++ show s) - -isValidRefName :: String -> Bool -isValidRefName s = not (or $ map isBadChar s) - where isBadChar :: Char -> Bool - isBadChar c = c <= ' ' || c >= toEnum 0x7f || c `elem` badAscii - badAscii = [ '~', '^', ':', '\\', '*', '?', '[' ] - -isValidRefFilepath :: FilePath -> Bool -isValidRefFilepath f - | valid f = isValidRefName $ encodeString f - | otherwise = False - --- FIXME BC.unpack/pack should be probably be utf8.toString, --- however i don't know if encoding is consistant. --- it should probably be overridable. -pathDecode :: B.ByteString -> FilePath -pathDecode = FP.decode FP.posix - -pathEncode :: FilePath -> B.ByteString -pathEncode = FP.encode FP.posix - -toRefTy :: String -> RefSpecTy -toRefTy s - | "refs/tags/" `isPrefixOf` s = RefTag $ RefName $ drop 10 s - | "refs/heads/" `isPrefixOf` s = RefBranch $ RefName $ drop 11 s - | "refs/remotes/" `isPrefixOf` s = RefRemote $ RefName $ drop 13 s - | "refs/patches/" `isPrefixOf` s = RefPatches $ drop 13 s - | "refs/stash" == s = RefStash - | "HEAD" == s = RefHead - | "ORIG_HEAD" == s = RefOrigHead - | "FETCH_HEAD" == s = RefFetchHead - | otherwise = RefOther $ s - -fromRefTy :: RefSpecTy -> String -fromRefTy (RefBranch h) = "refs/heads/" ++ refNameRaw h -fromRefTy (RefTag h) = "refs/tags/" ++ refNameRaw h -fromRefTy (RefRemote h) = "refs/remotes/" ++ refNameRaw h -fromRefTy (RefPatches h) = "refs/patches/" ++ h -fromRefTy RefStash = "refs/stash" -fromRefTy RefHead = "HEAD" -fromRefTy RefOrigHead = "ORIG_HEAD" -fromRefTy RefFetchHead = "FETCH_HEAD" -fromRefTy (RefOther h) = h - -toPath :: FilePath -> RefSpecTy -> FilePath -toPath gitRepo (RefBranch h) = gitRepo "refs" "heads" fromString (refNameRaw h) -toPath gitRepo (RefTag h) = gitRepo "refs" "tags" fromString (refNameRaw h) -toPath gitRepo (RefRemote h) = gitRepo "refs" "remotes" fromString (refNameRaw h) -toPath gitRepo (RefPatches h) = gitRepo "refs" "patches" fromString h -toPath gitRepo RefStash = gitRepo "refs" "stash" -toPath gitRepo RefHead = gitRepo "HEAD" -toPath gitRepo RefOrigHead = gitRepo "ORIG_HEAD" -toPath gitRepo RefFetchHead = gitRepo "FETCH_HEAD" -toPath gitRepo (RefOther h) = gitRepo fromString h - -data PackedRefs a = PackedRefs - { packedRemotes :: a - , packedBranchs :: a - , packedTags :: a - } - -readPackedRefs :: FilePath - -> ([(RefName, Ref)] -> a) - -> IO (PackedRefs a) -readPackedRefs gitRepo constr = do - exists <- F.isFile (packedRefsPath gitRepo) - if exists then readLines else return $ finalize emptyPackedRefs - where emptyPackedRefs = PackedRefs [] [] [] - readLines = finalize . foldl accu emptyPackedRefs . BC.lines <$> F.readFile (packedRefsPath gitRepo) - finalize (PackedRefs a b c) = PackedRefs (constr a) (constr b) (constr c) - accu a l - | "#" `BC.isPrefixOf` l = a - | otherwise = - let (ref, r) = B.splitAt 40 l - name = FP.encodeString FP.posix $ pathDecode $ B.tail r - in case toRefTy name of - -- accumulate tag, branch and remotes - RefTag refname -> a { packedTags = (refname, fromHex ref) : packedTags a } - RefBranch refname -> a { packedBranchs = (refname, fromHex ref) : packedBranchs a } - RefRemote refname -> a { packedRemotes = (refname, fromHex ref) : packedRemotes a } - -- anything else that shouldn't be there get dropped on the floor - _ -> a - --- | list all the loose refs available recursively from a directory starting point -listRefs :: FilePath -> IO [RefName] -listRefs root = listRefsAcc [] root - where listRefsAcc acc dir = do - files <- F.listDirectory dir - getRefsRecursively dir acc files - getRefsRecursively _ acc [] = return acc - getRefsRecursively dir acc (x:xs) = do - isDir <- F.isDirectory x - extra <- if isDir - then listRefsAcc [] dir - else let r = stripRoot x - in if isValidRefFilepath r - then return [fromString $ encodeString r] - else return [] - getRefsRecursively dir (extra ++ acc) xs - stripRoot p = maybe (error "stripRoot invalid") id $ stripPrefix root p - -looseHeadsList :: FilePath -> IO [RefName] -looseHeadsList gitRepo = listRefs (headsPath gitRepo) - -looseTagsList :: FilePath -> IO [RefName] -looseTagsList gitRepo = listRefs (tagsPath gitRepo) - -looseRemotesList :: FilePath -> IO [RefName] -looseRemotesList gitRepo = listRefs (remotesPath gitRepo) - -existsRefFile :: FilePath -> RefSpecTy -> IO Bool -existsRefFile gitRepo specty = F.isFile $ toPath gitRepo specty - -writeRefFile :: FilePath -> RefSpecTy -> RefContentTy -> IO () -writeRefFile gitRepo specty refcont = F.writeFile filepath $ fromRefContent refcont - where filepath = toPath gitRepo specty - fromRefContent (RefLink link) = B.concat ["ref: ", pathEncode $ FP.decodeString FP.posix $ fromRefTy link, B.singleton 0xa] - fromRefContent (RefDirect ref) = B.concat [toHex ref, B.singleton 0xa] - fromRefContent (RefContentUnknown c) = c - -readRefFile :: FilePath -> RefSpecTy -> IO RefContentTy -readRefFile gitRepo specty = toRefContent <$> F.readFile filepath - where filepath = toPath gitRepo specty - toRefContent content - | "ref: " `B.isPrefixOf` content = RefLink $ toRefTy $ FP.encodeString FP.posix $ pathDecode $ head $ BC.lines $ B.drop 5 content - | B.length content < 42 = RefDirect $ fromHex $ B.take 40 content - | otherwise = RefContentUnknown content diff --git a/Data/Git/Path.hs b/Data/Git/Path.hs deleted file mode 100644 --- a/Data/Git/Path.hs +++ /dev/null @@ -1,45 +0,0 @@ --- | --- Module : Data.Git.Path --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unix --- -{-# LANGUAGE OverloadedStrings #-} -module Data.Git.Path where - -import Filesystem.Path.CurrentOS -import System.Random -import Control.Applicative ((<$>)) -import Data.Git.Ref -import Data.String - -configPath gitRepo = gitRepo "config" - -headsPath gitRepo = gitRepo "refs" "heads" "" -tagsPath gitRepo = gitRepo "refs" "tags" "" -remotesPath gitRepo = gitRepo "refs" "remotes" "" -packedRefsPath gitRepo = gitRepo "packed-refs" - -headPath gitRepo name = headsPath gitRepo fromString name -tagPath gitRepo name = tagsPath gitRepo fromString name -remotePath gitRepo name = remotesPath gitRepo fromString name -specialPath gitRepo name = gitRepo fromString name - -remoteEntPath gitRepo name ent = remotePath gitRepo name fromString ent - -packDirPath repoPath = repoPath "objects" "pack" - -indexPath repoPath indexRef = - packDirPath repoPath fromString ("pack-" ++ toHexString indexRef ++ ".idx") - -packPath repoPath packRef = - packDirPath repoPath fromString ("pack-" ++ toHexString packRef ++ ".pack") - -objectPath repoPath d f = repoPath "objects" fromString d fromString f -objectPathOfRef repoPath ref = objectPath repoPath d f - where (d,f) = toFilePathParts ref - -objectTemporaryPath repoPath = do - r <- fst . random <$> getStdGen :: IO Int - return (repoPath "objects" fromString ("tmp-" ++ show r ++ ".tmp")) diff --git a/Data/Git/Ref.hs b/Data/Git/Ref.hs deleted file mode 100644 --- a/Data/Git/Ref.hs +++ /dev/null @@ -1,150 +0,0 @@ --- | --- Module : Data.Git.Ref --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unix --- -{-# LANGUAGE DeriveDataTypeable #-} -module Data.Git.Ref - ( Ref - -- * Exceptions - , RefInvalid(..) - , RefNotFound(..) - -- * convert from bytestring and string - , isHex - , isHexString - , fromHex - , fromHexString - , fromBinary - , toBinary - , toHex - , toHexString - -- * Misc function related to ref - , refPrefix - , cmpPrefix - , toFilePathParts - -- * Hash ByteString types to a ref - , hash - , hashLBS - ) where - -import Control.Monad (forM_) -import qualified Crypto.Hash.SHA1 as SHA1 -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Internal as B (unsafeCreate) -import qualified Data.ByteString.Unsafe as B (unsafeIndex) -import qualified Data.ByteString.Char8 as BC -import Data.Bits -import Data.Char (isHexDigit) -import Data.Data - -import Foreign.Storable -import Control.Exception (Exception, throw) - --- | represent a git reference (SHA1) -newtype Ref = Ref ByteString - deriving (Eq,Ord,Data,Typeable) - -instance Show Ref where - show = BC.unpack . toHex - --- | Invalid Reference exception raised when --- using something that is not a ref as a ref. -data RefInvalid = RefInvalid ByteString - deriving (Show,Eq,Data,Typeable) - --- | Reference wasn't found -data RefNotFound = RefNotFound Ref - deriving (Show,Eq,Data,Typeable) - -instance Exception RefInvalid -instance Exception RefNotFound - -isHex = and . map isHexDigit . BC.unpack -isHexString = and . map isHexDigit - --- | take a hexadecimal bytestring that represent a reference --- and turn into a ref -fromHex :: ByteString -> Ref -fromHex s - | B.length s == 40 = Ref $ B.unsafeCreate 20 populateRef - | otherwise = throw $ RefInvalid s - where populateRef ptr = forM_ [0..19] $ \i -> do - let v = (unhex (B.unsafeIndex s (i*2+0)) `shiftL` 4) .|. unhex (B.unsafeIndex s (i*2+1)) - pokeElemOff ptr (i+0) v - - unhex 0x30 = 0 -- '0' - unhex 0x31 = 1 - unhex 0x32 = 2 - unhex 0x33 = 3 - unhex 0x34 = 4 - unhex 0x35 = 5 - unhex 0x36 = 6 - unhex 0x37 = 7 - unhex 0x38 = 8 - unhex 0x39 = 9 -- '9' - unhex 0x41 = 10 -- 'A' - unhex 0x42 = 11 - unhex 0x43 = 12 - unhex 0x44 = 13 - unhex 0x45 = 14 - unhex 0x46 = 15 -- 'F' - unhex 0x61 = 10 -- 'a' - unhex 0x62 = 11 - unhex 0x63 = 12 - unhex 0x64 = 13 - unhex 0x65 = 14 - unhex 0x66 = 15 -- 'f' - unhex _ = throw $ RefInvalid s - --- | take a hexadecimal string that represent a reference --- and turn into a ref -fromHexString :: String -> Ref -fromHexString = fromHex . BC.pack - --- | transform a ref into an hexadecimal bytestring -toHex :: Ref -> ByteString -toHex (Ref bs) = B.unsafeCreate 40 populateHex - where populateHex ptr = forM_ [0..19] $ \i -> do - let (a,b) = B.unsafeIndex bs i `divMod` 16 - pokeElemOff ptr (i*2+0) (hex a) - pokeElemOff ptr (i*2+1) (hex b) - hex i - | i >= 0 && i <= 9 = 0x30 + i - | i >= 10 && i <= 15 = 0x61 + i - 10 - | otherwise = 0 - --- | transform a ref into an hexadecimal string -toHexString :: Ref -> String -toHexString = BC.unpack . toHex - --- | transform a bytestring that represent a binary bytestring --- and returns a ref. -fromBinary :: ByteString -> Ref -fromBinary b - | B.length b == 20 = Ref b - | otherwise = throw $ RefInvalid b -- should hexify the ref here - --- | turn a reference into a binary bytestring -toBinary :: Ref -> ByteString -toBinary (Ref b) = b - --- | returns the prefix (leading byte) of this reference -refPrefix :: Ref -> Int -refPrefix (Ref b) = fromIntegral $ B.unsafeIndex b 0 - --- | compare prefix -cmpPrefix :: String -> Ref -> Ordering -cmpPrefix pre ref = pre `compare` (take (length pre) $ toHexString ref) - --- | returns the splitted format "prefix/suffix" for addressing the loose object database -toFilePathParts :: Ref -> (String, String) -toFilePathParts ref = splitAt 2 $ show ref - --- | hash a bytestring into a reference -hash = Ref . SHA1.hash - --- | hash a lazy bytestring into a reference -hashLBS = Ref . SHA1.hashlazy diff --git a/Data/Git/Repository.hs b/Data/Git/Repository.hs deleted file mode 100644 --- a/Data/Git/Repository.hs +++ /dev/null @@ -1,312 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE DeriveDataTypeable #-} --- | --- Module : Data.Git.Repository --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unix --- -module Data.Git.Repository - ( Git - -- * Config - , configGetAll - , configGet - , Config(..) - , Section(..) - -- * Trees - , HTree - , HTreeEnt(..) - , RefName(..) - , getCommitMaybe - , getCommit - , getTreeMaybe - , getTree - , rewrite - , buildHTree - , resolvePath - , resolveTreeish - , resolveRevision - , initRepo - , isRepo - -- * named refs manipulation - , branchWrite - , branchList - , tagWrite - , tagList - , headSet - , headGet - ) where - -import Control.Applicative ((<$>)) -import Control.Monad -import Control.Exception (Exception, throw) - -import Data.Maybe (fromMaybe) -import Data.List (find) -import Data.Data -import Data.IORef - -import Data.Git.Named -import Data.Git.Types -import Data.Git.Storage.Object -import Data.Git.Storage -import Data.Git.Revision -import Data.Git.Storage.Loose -import Data.Git.Storage.CacheFile -import Data.Git.Ref -import Data.Git.Config (Config(..), Section(..)) -import qualified Data.Git.Config as Cfg - -import Data.Set (Set) - -import qualified Data.Map as M -import qualified Data.Set as Set - --- | hierarchy tree, either a reference to a blob (file) or a tree (directory). -data HTreeEnt = TreeDir Ref HTree | TreeFile Ref -type HTree = [(ModePerm,EntName,HTreeEnt)] - --- | Exception when trying to convert an object pointed by 'Ref' to --- a type that is different -data InvalidType = InvalidType Ref ObjectType - deriving (Show,Eq,Data,Typeable) - -instance Exception InvalidType - --- should be a standard function that do that... -mapJustM f (Just o) = f o -mapJustM _ Nothing = return Nothing - --- | get a specified commit -getCommitMaybe :: Git -> Ref -> IO (Maybe Commit) -getCommitMaybe git ref = maybe Nothing objectToCommit <$> getObject git ref True - --- | get a specified commit but raises an exception if doesn't exists or type is not appropriate -getCommit :: Git -> Ref -> IO Commit -getCommit git ref = maybe err id . objectToCommit <$> getObject_ git ref True - where err = throw $ InvalidType ref TypeCommit - --- | get a specified tree -getTreeMaybe :: Git -> Ref -> IO (Maybe Tree) -getTreeMaybe git ref = maybe Nothing objectToTree <$> getObject git ref True - --- | get a specified tree but raise -getTree :: Git -> Ref -> IO Tree -getTree git ref = maybe err id . objectToTree <$> getObject_ git ref True - where err = throw $ InvalidType ref TypeTree - --- | try to resolve a string to a specific commit ref --- for example: HEAD, HEAD^, master~3, shortRef -resolveRevision :: Git -> Revision -> IO (Maybe Ref) -resolveRevision git (Revision prefix modifiers) = - getCacheVal (packedNamed git) >>= \c -> resolvePrefix c >>= modf modifiers - where - resolvePrefix lookupCache = tryResolvers - [resolveNamedPrefix lookupCache namedResolvers - ,resolvePrePrefix - ] - - resolveNamedPrefix _ [] = return Nothing - resolveNamedPrefix lookupCache (x:xs) = followToRef (resolveNamedPrefix lookupCache xs) x - where followToRef onFailure refty = do - exists <- existsRefFile (gitRepoPath git) refty - if exists - then do refcont <- readRefFile (gitRepoPath git) refty - case refcont of - RefDirect ref -> return $ Just ref - RefLink refspecty -> followToRef onFailure refspecty - _ -> error "cannot handle reference content" - else case refty of - RefTag name -> mapLookup name $ packedTags lookupCache - RefBranch name -> mapLookup name $ packedBranchs lookupCache - RefRemote name -> mapLookup name $ packedRemotes lookupCache - _ -> return Nothing - where mapLookup name m = maybe onFailure (return . Just) $ M.lookup name m - - namedResolvers = case prefix of - "HEAD" -> [ RefHead ] - "ORIG_HEAD" -> [ RefOrigHead ] - "FETCH_HEAD" -> [ RefFetchHead ] - _ -> map (flip ($) (RefName prefix)) [RefTag,RefBranch,RefRemote] - - tryResolvers :: [IO (Maybe Ref)] -> IO Ref - tryResolvers [] = return $ fromHexString prefix - tryResolvers (resolver:xs) = resolver >>= isResolved - where isResolved (Just r) = return r - isResolved Nothing = tryResolvers xs - - resolvePrePrefix :: IO (Maybe Ref) - resolvePrePrefix = do - refs <- findReferencesWithPrefix git prefix - case refs of - [] -> return Nothing - [r] -> return (Just r) - _ -> error "multiple references with this prefix" - - modf [] ref = return (Just ref) - modf (RevModParent i:xs) ref = do - parentRefs <- getParentRefs ref - case i of - 0 -> error "revision modifier ^0 is not implemented" - _ -> case drop (i - 1) parentRefs of - [] -> error "no such parent" - (p:_) -> modf xs p - - modf (RevModParentFirstN 1:xs) ref = modf (RevModParent 1:xs) ref - modf (RevModParentFirstN n:xs) ref = do - parentRefs <- getParentRefs ref - modf (RevModParentFirstN (n-1):xs) (head parentRefs) - modf (_:_) _ = error "unimplemented revision modifier" - - getParentRefs ref = commitParents <$> getCommit git ref - --- | returns a tree from a ref that might be either a commit, a tree or a tag. -resolveTreeish :: Git -> Ref -> IO (Maybe Tree) -resolveTreeish git ref = getObject git ref True >>= mapJustM recToTree - where recToTree (objectToCommit -> Just (Commit { commitTreeish = tree })) = resolveTreeish git tree - recToTree (objectToTag -> Just (Tag tref _ _ _ _)) = resolveTreeish git tref - recToTree (objectToTree -> Just t@(Tree _)) = return $ Just t - recToTree _ = return Nothing - - --- | Rewrite a set of commits from a revision and returns the new ref. --- --- If during revision traversal (diving) there's a commit with zero or multiple --- parents then the traversal will stop regardless of the amount of parent requested. --- --- calling "rewrite f 2 (revisionOf d)" on the following tree: --- --- a <-- b <-- c <-- d --- --- result in the following tree after mapping with f: --- --- a <-- f(b) <-- f(c) <-- f(d) --- -rewrite :: Git -- ^ Repository - -> (Commit -> IO Commit) -- ^ Mapping function - -> Revision -- ^ revision to start from - -> Int -- ^ the number of parents to map - -> IO Ref -- ^ return the new head REF -rewrite git mapCommit revision nbParent = do - ref <- fromMaybe (error "revision cannot be found") <$> resolveRevision git revision - resolveParents nbParent ref >>= process . reverse - - where resolveParents :: Int -> Ref -> IO [ (Ref, Commit) ] - resolveParents 0 ref = (:[]) . (,) ref <$> getCommit git ref - resolveParents n ref = do commit <- getCommit git ref - case commitParents commit of - [parentRef] -> liftM ((ref,commit) :) (resolveParents (n-1) parentRef) - _ -> return [(ref,commit)] - - process [] = error "nothing to rewrite" - process ((_,commit):next) = - mapCommit commit >>= looseWrite (gitRepoPath git) . toObject >>= flip rewriteOne next - - rewriteOne prevRef [] = return prevRef - rewriteOne prevRef ((_,commit):next) = do - newCommit <- mapCommit $ commit { commitParents = [prevRef] } - ref <- looseWrite (gitRepoPath git) (toObject newCommit) - rewriteOne ref next - --- | build a hierarchy tree from a tree object -buildHTree :: Git -> Tree -> IO HTree -buildHTree git (Tree ents) = mapM resolveTree ents - where resolveTree (perm, ent, ref) = do - obj <- getObjectType git ref - case obj of - Just TypeBlob -> return (perm, ent, TreeFile ref) - Just TypeTree -> do ctree <- getTree git ref - dir <- buildHTree git ctree - return (perm, ent, TreeDir ref dir) - Just _ -> error "wrong type embedded in tree object" - Nothing -> error "unknown reference in tree object" - --- | resolve the ref (tree or blob) related to a path at a specific commit ref -resolvePath :: Git -- ^ repository - -> Ref -- ^ commit reference - -> EntPath -- ^ paths - -> IO (Maybe Ref) -resolvePath git commitRef paths = - getCommit git commitRef >>= \commit -> resolve (commitTreeish commit) paths - where resolve :: Ref -> EntPath -> IO (Maybe Ref) - resolve treeRef [] = return $ Just treeRef - resolve treeRef (x:xs) = do - (Tree ents) <- getTree git treeRef - let cEnt = treeEntRef <$> findEnt x ents - if xs == [] - then return cEnt - else maybe (return Nothing) (\z -> resolve z xs) cEnt - - findEnt x = find (\(_, b, _) -> b == x) - treeEntRef (_,_,r) = r - --- | Write a branch to point to a specific reference -branchWrite :: Git -- ^ repository - -> RefName -- ^ the name of the branch to write - -> Ref -- ^ the reference to set - -> IO () -branchWrite git branchName ref = - writeRefFile (gitRepoPath git) (RefBranch branchName) (RefDirect ref) - --- | Return the list of branches -branchList :: Git -> IO (Set RefName) -branchList git = do - ps <- Set.fromList . M.keys . packedBranchs <$> getCacheVal (packedNamed git) - ls <- Set.fromList <$> looseHeadsList (gitRepoPath git) - return $ Set.union ps ls - --- | Write a tag to point to a specific reference -tagWrite :: Git -- ^ repository - -> RefName -- ^ the name of the tag to write - -> Ref -- ^ the reference to set - -> IO () -tagWrite git tagname ref = - writeRefFile (gitRepoPath git) (RefTag tagname) (RefDirect ref) - --- | Return the list of branches -tagList :: Git -> IO (Set RefName) -tagList git = do - ps <- Set.fromList . M.keys . packedTags <$> getCacheVal (packedNamed git) - ls <- Set.fromList <$> looseTagsList (gitRepoPath git) - return $ Set.union ps ls - --- | Set head to point to either a reference or a branch name. -headSet :: Git -- ^ repository - -> Either Ref RefName -- ^ either a raw reference or a branch name - -> IO () -headSet git (Left ref) = - writeRefFile (gitRepoPath git) RefHead (RefDirect ref) -headSet git (Right refname) = - writeRefFile (gitRepoPath git) RefHead (RefLink $ RefBranch refname) - --- | Get what the head is pointing to, or the reference otherwise -headGet :: Git - -> IO (Either Ref RefName) -headGet git = do - content <- readRefFile (gitRepoPath git) RefHead - case content of - RefLink (RefBranch b) -> return $ Right b - RefLink spec -> error ("unknown content link in HEAD: " ++ show spec) - RefDirect r -> return $ Left r - RefContentUnknown bs -> error ("unknown content in HEAD: " ++ show bs) - --- | Read the Config -configGetAll :: Git -> IO [Config] -configGetAll git = readIORef (configs git) - --- | Get a configuration element from the config file, starting from the --- local repository config file, then the global config file. --- --- for example the equivalent to git config user.name is: --- --- > configGet git "user" "name" --- -configGet :: Git -- ^ Git context - -> String -- ^ section name - -> String -- ^ key name - -> IO (Maybe String) -- ^ The resulting value if it exists -configGet git section key = do - cfgs <- configGetAll git - return $ Cfg.get cfgs section key diff --git a/Data/Git/Revision.hs b/Data/Git/Revision.hs deleted file mode 100644 --- a/Data/Git/Revision.hs +++ /dev/null @@ -1,84 +0,0 @@ --- | --- Module : Data.Git.Revision --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unix --- -{-# LANGUAGE DeriveDataTypeable #-} -module Data.Git.Revision - ( Revision(..) - , RevModifier(..) - , RevisionNotFound(..) - , fromString - ) where - -import Text.Parsec -import Data.String -import Data.Data - --- | A modifier to a revision, which is --- a function apply of a revision -data RevModifier = - RevModParent Int -- ^ parent accessor ^ and ^ - | RevModParentFirstN Int -- ^ parent accessor ~ - | RevModAtType String -- ^ @{type} accessor - | RevModAtDate String -- ^ @{date} accessor - | RevModAtN Int -- ^ @{n} accessor - deriving (Eq,Data,Typeable) - -instance Show RevModifier where - show (RevModParent 1) = "^" - show (RevModParent n) = "^" ++ show n - show (RevModParentFirstN n) = "~" ++ show n - show (RevModAtType s) = "@{" ++ s ++ "}" - show (RevModAtDate s) = "@{" ++ s ++ "}" - show (RevModAtN s) = "@{" ++ show s ++ "}" - --- | A git revision. this can be many things: --- * a shorten ref --- * a ref --- * a named branch or tag --- followed by optional modifiers 'RevModifier' that can represent: --- * parenting --- * type --- * date -data Revision = Revision String [RevModifier] - deriving (Eq,Data,Typeable) - --- | Exception when a revision cannot be resolved to a reference -data RevisionNotFound = RevisionNotFound Revision - deriving (Show,Eq,Data,Typeable) - -instance Show Revision where - show (Revision s ms) = s ++ concatMap show ms - -instance IsString Revision where - fromString = revFromString - -revFromString :: String -> Revision -revFromString s = either (error.show) id $ parse parser "" s - where parser = do - p <- many (noneOf "^~@") - mods <- many (choice [parseParent, parseFirstParent, parseAt]) - return $ Revision p mods - parseParent = try $ do - _ <- char '^' - n <- optionMaybe (many1 digit) - case n of - Nothing -> return $ RevModParent 1 - Just d -> return $ RevModParent (read d) - parseFirstParent = try $ - char '~' >> many1 digit >>= return . RevModParentFirstN . read - parseAt = try $ do - _ <- char '@' >> char '{' - at <- choice [ parseAtType, parseAtDate, parseAtN ] - _ <- char '}' - return at - parseAtType = try $ do - ty <- choice $ map string ["tree","commit","blob","tag"] - return $ RevModAtType ty - parseAtN = try $ do - many1 digit >>= return . RevModAtN . read - parseAtDate = try $ do - many (noneOf "}") >>= return . RevModAtDate diff --git a/Data/Git/Storage.hs b/Data/Git/Storage.hs deleted file mode 100644 --- a/Data/Git/Storage.hs +++ /dev/null @@ -1,351 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE OverloadedStrings #-} --- | --- Module : Data.Git.Storage --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unix --- - -module Data.Git.Storage - ( Git - , packedNamed - , gitRepoPath - , configs - -- * opening repositories - , openRepo - , closeRepo - , withRepo - , withCurrentRepo - , findRepoMaybe - , findRepo - , isRepo - -- * creating repositories - , initRepo - -- * repository accessors - , getDescription - , setDescription - -- * iterators - , iterateIndexes - , findReference - , findReferencesWithPrefix - -- * getting objects - , getObjectRaw - , getObjectRawAt - , getObject - , getObject_ - , getObjectAt - , getObjectType - -- * setting objects - , setObject - ) where - -import Filesystem -import Filesystem.Path hiding (concat) -import Filesystem.Path.Rules -import System.Environment - -import Control.Applicative -import Control.Exception -import qualified Control.Exception as E -import Control.Monad - -import Data.String -import Data.List ((\\), isPrefixOf) -import Data.Either (partitionEithers) -import Data.IORef -import Data.Word - -import Data.Git.Named -import Data.Git.Path (packedRefsPath) -import Data.Git.Delta -import Data.Git.Storage.FileReader -import Data.Git.Storage.PackIndex -import Data.Git.Storage.Object -import Data.Git.Storage.Pack -import Data.Git.Storage.Loose -import Data.Git.Storage.CacheFile -import Data.Git.Ref -import Data.Git.Config - -import qualified Data.Map as M - -import Prelude hiding (FilePath) - -data PackIndexReader = PackIndexReader PackIndexHeader FileReader - --- | this is a cache representation of the packed-ref file -type CachedPackedRef = CacheFile (PackedRefs (M.Map RefName Ref)) - --- | represent a git repo, with possibly already opened filereaders --- for indexes and packs -data Git = Git - { gitRepoPath :: FilePath - , indexReaders :: IORef [(Ref, PackIndexReader)] - , packReaders :: IORef [(Ref, FileReader)] - , packedNamed :: CachedPackedRef - , configs :: IORef [Config] - } - --- | open a new git repository context -openRepo :: FilePath -> IO Git -openRepo path = Git path <$> newIORef [] - <*> newIORef [] - <*> packedRef - <*> (readConfigs >>= newIORef) - where packedRef = newCacheVal (packedRefsPath path) - (readPackedRefs path M.fromList) - (PackedRefs M.empty M.empty M.empty) - readConfigs = do - global <- E.try readGlobalConfig :: IO (Either IOException Config) - local <- E.try (readConfig path) - return $ snd $ partitionEithers [local,global] - --- | close a git repository context, closing all remaining fileReaders. -closeRepo :: Git -> IO () -closeRepo (Git { indexReaders = ireaders, packReaders = preaders }) = do - mapM_ (closeIndexReader . snd) =<< readIORef ireaders - mapM_ (fileReaderClose . snd) =<< readIORef preaders - where closeIndexReader (PackIndexReader _ fr) = fileReaderClose fr - --- | Find the git repository from the current directory. --- --- If the environment variable GIT_DIR is set then it's used, --- otherwise iterate from current directory, up to 128 parents for a .git directory -findRepoMaybe :: IO (Maybe FilePath) -findRepoMaybe = do - menvDir <- E.catch (Just . decodeString posix_ghc704 <$> getEnv "GIT_DIR") (\(_:: SomeException) -> return Nothing) - case menvDir of - Nothing -> getWorkingDirectory >>= checkDir 0 - Just envDir -> isRepo envDir >>= \e -> return (if e then Just envDir else Nothing) - where checkDir :: Int -> FilePath -> IO (Maybe FilePath) - checkDir 128 _ = return Nothing - checkDir n wd = do - let filepath = wd ".git" - e <- isRepo filepath - if e then return (Just filepath) else checkDir (n+1) (if absolute wd then parent wd else wd "..") - --- | Find the git repository from the current directory. --- --- If the environment variable GIT_DIR is set then it's used, --- otherwise iterate from current directory, up to 128 parents for a .git directory -findRepo :: IO FilePath -findRepo = do - menvDir <- E.catch (Just . decodeString posix_ghc704 <$> getEnv "GIT_DIR") (\(_:: SomeException) -> return Nothing) - case menvDir of - Nothing -> getWorkingDirectory >>= checkDir 0 - Just envDir -> do - e <- isRepo envDir - when (not e) $ error "environment GIT_DIR is not a git repository" - return envDir - where checkDir :: Int -> FilePath -> IO FilePath - checkDir 128 _ = error "not a git repository" - checkDir n wd = do - let filepath = wd ".git" - e <- isRepo filepath - if e then return filepath else checkDir (n+1) (if absolute wd then parent wd else wd "..") - --- | execute a function f with a git context. -withRepo path f = bracket (openRepo path) closeRepo f - --- | execute a function on the current repository. --- --- check findRepo to see how the git repository is found. -withCurrentRepo :: (Git -> IO a) -> IO a -withCurrentRepo f = findRepo >>= \path -> withRepo path f - --- | basic checks to see if a specific path looks like a git repo. -isRepo :: FilePath -> IO Bool -isRepo path = do - dir <- isDirectory path - subDirs <- mapM (isDirectory . (path )) - [ "hooks", "info" - , "objects", "refs" - , "refs" "heads", "refs" "tags"] - return $ and ([dir] ++ subDirs) - --- | initialize a new repository at a specific location. -initRepo :: FilePath -> IO () -initRepo path = do - exists <- isDirectory path - when exists $ error "destination directory already exists" - createDirectory True path - mapM_ (createDirectory False . (path )) - [ "branches", "hooks", "info" - , "logs", "objects", "refs" - , "refs" "heads", "refs" "tags"] - --- | read the repository's description -getDescription :: Git -> IO (Maybe String) -getDescription git = do - isdescription <- isFile descriptionPath - if (isdescription) - then do - content <- Prelude.readFile $ encodeString posix descriptionPath - return $ Just content - else return Nothing - where descriptionPath = (gitRepoPath git) "description" - --- | set the repository's description -setDescription :: Git -> String -> IO () -setDescription git desc = do - Prelude.writeFile (encodeString posix descriptionPath) desc - where descriptionPath = (gitRepoPath git) "description" - -iterateIndexes git f initAcc = do - allIndexes <- packIndexEnumerate (gitRepoPath git) - readers <- readIORef (indexReaders git) - (a,terminate) <- loop initAcc readers - if terminate - then return a - else readRemainingIndexes a (allIndexes \\ map fst readers) - where loop acc [] = return (acc, False) - loop acc (r:rs) = do - (nacc, terminate) <- f acc r - if terminate - then return (nacc,True) - else loop nacc rs - - readRemainingIndexes acc [] = return acc - readRemainingIndexes acc (idxref:idxs) = do - fr <- packIndexOpen (gitRepoPath git) idxref - idx <- packIndexReadHeader fr - let idxreader = PackIndexReader idx fr - let r = (idxref, idxreader) - modifyIORef (indexReaders git) (\l -> r : l) - (nacc, terminate) <- f acc r - if terminate - then return nacc - else readRemainingIndexes nacc idxs - --- | Get the object location of a specific reference -findReference :: Git -> Ref -> IO ObjectLocation -findReference git ref = maybe NotFound id <$> (findLoose `mplusIO` findInIndexes) - where findLoose :: IO (Maybe ObjectLocation) - findLoose = do - isLoose <- looseExists (gitRepoPath git) ref - if isLoose then return (Just $ Loose ref) else return Nothing - - findInIndexes :: IO (Maybe ObjectLocation) - findInIndexes = iterateIndexes git isinIndex Nothing --f -> (a -> IndexReader -> IO (a,Bool)) -> a -> IO a - - isinIndex acc (idxref, (PackIndexReader idxhdr indexreader)) = do - mloc <- packIndexGetReferenceLocation idxhdr indexreader ref - case mloc of - Nothing -> return (acc, False) - Just loc -> return (Just $ Packed idxref loc, True) - - mplusIO :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a) - mplusIO f g = f >>= \vopt -> case vopt of - Nothing -> g - Just v -> return $ Just v - --- | get all the references that start by a specific prefix -findReferencesWithPrefix :: Git -> String -> IO [Ref] -findReferencesWithPrefix git pre - | invalidLength = error ("not a valid prefix: " ++ show pre) - | not (isHexString pre) = error ("reference prefix contains non hexchar: " ++ show pre) - | otherwise = do - looseRefs <- looseEnumerateWithPrefixFilter (gitRepoPath git) (take 2 pre) matchRef - packedRefs <- concat <$> iterateIndexes git idxPrefixMatch [] - return (looseRefs ++ packedRefs) - where -- not very efficient way to do that... will do for now. - matchRef ref = pre `isPrefixOf` toHexString ref - invalidLength = length pre < 2 || length pre > 39 - - idxPrefixMatch acc (_, (PackIndexReader idxhdr indexreader)) = do - refs <- packIndexGetReferencesWithPrefix idxhdr indexreader pre - return (refs:acc,False) - -readRawFromPack :: Git -> Ref -> Word64 -> IO (FileReader, PackedObjectRaw) -readRawFromPack git pref offset = do - readers <- readIORef (packReaders git) - reader <- maybe getDefault return $ lookup pref readers - po <- packReadRawAtOffset reader offset - return (reader, po) - where getDefault = do p <- packOpen (gitRepoPath git) pref - modifyIORef (packReaders git) ((pref, p):) - return p - -readFromPack :: Git -> Ref -> Word64 -> Bool -> IO (Maybe ObjectInfo) -readFromPack git pref o resolveDelta = do - (reader, x) <- readRawFromPack git pref o - if resolveDelta then resolve reader o x else return $ Just $ generifyHeader x - where generifyHeader :: PackedObjectRaw -> ObjectInfo - generifyHeader (po, objData) = ObjectInfo { oiHeader = hdr, oiData = objData, oiChains = [] } - where hdr = (poiType po, poiActualSize po, poiExtra po) - - resolve :: FileReader -> Word64 -> PackedObjectRaw -> IO (Maybe ObjectInfo) - resolve reader offset (po, objData) = do - case (poiType po, poiExtra po) of - (TypeDeltaOff, Just ptr@(PtrOfs doff)) -> do - let delta = deltaRead objData - let noffset = offset - doff - base <- resolve reader noffset =<< packReadRawAtOffset reader noffset - return $ addToChain ptr $ applyDelta delta base - (TypeDeltaRef, Just ptr@(PtrRef bref)) -> do - let delta = deltaRead objData - base <- getObjectRaw git bref True - return $ addToChain ptr $ applyDelta delta base - _ -> - return $ Just $ generifyHeader (po, objData) - - addToChain ptr (Just oi) = Just (oi { oiChains = ptr : oiChains oi }) - addToChain _ Nothing = Nothing - - applyDelta :: Maybe Delta -> Maybe ObjectInfo -> Maybe ObjectInfo - applyDelta (Just delta@(Delta _ rSize _)) (Just objInfo) = Just $ objInfo - { oiHeader = (\(a,_,c) -> (a,rSize,c)) $ oiHeader objInfo - , oiData = deltaApply (oiData objInfo) delta - } - applyDelta _ _ = Nothing - --- | get an object from repository -getObjectRawAt :: Git -> ObjectLocation -> Bool -> IO (Maybe ObjectInfo) -getObjectRawAt _ NotFound _ = return Nothing -getObjectRawAt git (Loose ref) _ = Just . (\(h,d)-> ObjectInfo h d[]) <$> looseReadRaw (gitRepoPath git) ref -getObjectRawAt git (Packed pref o) resolveDelta = readFromPack git pref o resolveDelta - --- | get an object from repository -getObjectRaw :: Git -> Ref -> Bool -> IO (Maybe ObjectInfo) -getObjectRaw git ref resolveDelta = do - loc <- findReference git ref - getObjectRawAt git loc resolveDelta - --- | get an object type from repository -getObjectType :: Git -> Ref -> IO (Maybe ObjectType) -getObjectType git ref = findReference git ref >>= getObjectTypeAt - where getObjectTypeAt NotFound = return Nothing - getObjectTypeAt (Loose _) = Just . (\(t,_,_) -> t) <$> looseReadHeader (gitRepoPath git) ref - getObjectTypeAt (Packed pref o) = - fmap ((\(ty,_,_) -> ty) . oiHeader) <$> readFromPack git pref o True - --- | get an object from repository using a location to reference it. -getObjectAt :: Git -> ObjectLocation -> Bool -> IO (Maybe Object) -getObjectAt git loc resolveDelta = maybe Nothing toObj <$> getObjectRawAt git loc resolveDelta - where toObj (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData) - --- | get an object from repository using a ref. -getObject :: Git -- ^ repository - -> Ref -- ^ the object's reference to - -> Bool -- ^ whether to resolve deltas if found - -> IO (Maybe Object) -- ^ returned object if found -getObject git ref resolveDelta = maybe Nothing toObj <$> getObjectRaw git ref resolveDelta - where toObj (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData) - --- | Just like 'getObject' but will raise a RefNotFound exception if the --- reference cannot be found. -getObject_ :: Git -- ^ repository - -> Ref -- ^ the object's reference to - -> Bool -- ^ whether to resolve deltas if found - -> IO Object -- ^ returned object if found -getObject_ git ref resolveDelta = maybe (throwIO $ RefNotFound ref) return - =<< getObject git ref resolveDelta - --- | set an object in the store and returns the new ref --- this is always going to create a loose object. -setObject :: Git - -> Object - -> IO Ref -setObject git obj = looseWrite (gitRepoPath git) obj diff --git a/Data/Git/Storage/CacheFile.hs b/Data/Git/Storage/CacheFile.hs deleted file mode 100644 --- a/Data/Git/Storage/CacheFile.hs +++ /dev/null @@ -1,45 +0,0 @@ -{-# 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 Filesystem.Path -import Filesystem.Path.CurrentOS (encodeString) -import Prelude hiding (FilePath) -import System.PosixCompat.Files (getFileStatus, modificationTime) -import System.PosixCompat.Types (EpochTime) - -data CacheFile a = CacheFile - { cacheFilepath :: FilePath - , cacheRefresh :: IO a - , cacheIniVal :: a - , cacheLock :: MVar (MTime, a) - } - -timeZero = 0 - -newCacheVal :: FilePath -> IO a -> a -> IO (CacheFile a) -newCacheVal path refresh initialVal = - CacheFile path refresh initialVal <$> newMVar (MTime timeZero, initialVal) - -getCacheVal :: CacheFile a -> IO a -getCacheVal cachefile = modifyMVar (cacheLock cachefile) getOrRefresh - where getOrRefresh s@(mtime, cachedVal) = do - cMTime <- getMTime $ cacheFilepath cachefile - case cMTime of - Nothing -> return ((MTime timeZero, cacheIniVal cachefile), cacheIniVal cachefile) - Just newMtime | newMtime > mtime -> cacheRefresh cachefile >>= \v -> return ((newMtime, v), v) - | otherwise -> return (s, cachedVal) - -newtype MTime = MTime EpochTime deriving (Eq,Ord) - -getMTime filepath = (Just . MTime . modificationTime <$> getFileStatus (encodeString filepath)) - `E.catch` \(_ :: E.SomeException) -> return Nothing diff --git a/Data/Git/Storage/FileReader.hs b/Data/Git/Storage/FileReader.hs deleted file mode 100644 --- a/Data/Git/Storage/FileReader.hs +++ /dev/null @@ -1,207 +0,0 @@ --- | --- Module : Data.Git.Storage.FileReader --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unix --- -{-# LANGUAGE DeriveDataTypeable #-} -module Data.Git.Storage.FileReader - ( FileReader - , fileReaderNew - , fileReaderClose - , withFileReader - , withFileReaderDecompress - , fileReaderGetPos - , fileReaderGet - , fileReaderGetLBS - , fileReaderGetBS - , fileReaderGetVLF - , fileReaderSeek - , fileReaderParse - - , fileReaderInflateToSize - ) where - - -import Control.Applicative ((<$>)) -import Control.Exception (bracket, throwIO) -import Control.Monad - -import Data.Attoparsec (parseWith, Parser, IResult(..)) -import qualified Data.Attoparsec as A -import Data.Bits -import Data.ByteString (ByteString) -import Data.ByteString.Unsafe -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L -import Data.ByteString.Lazy.Internal (defaultChunkSize) -import Data.IORef - -import Data.Data -import Data.Word - -import Codec.Zlib -import Codec.Zlib.Lowlevel -import Foreign.ForeignPtr -import qualified Control.Exception as E - -import System.IO (hClose, hSeek, SeekMode(..)) -import Filesystem -import Filesystem.Path -import Prelude hiding (FilePath) - -data FileReader = FileReader - { fbHandle :: Handle - , fbUseInflate :: Bool - , fbInflate :: Inflate - , fbRemaining :: IORef ByteString - , fbPos :: IORef Word64 - } - -data InflateException = InflateException Word64 Word64 String - deriving (Show,Eq,Typeable) - -instance E.Exception InflateException - -fileReaderNew :: Bool -> Handle -> IO FileReader -fileReaderNew decompress handle = do - ref <- newIORef B.empty - pos <- newIORef 0 - inflate <- initInflate defaultWindowBits - return $ FileReader handle decompress inflate ref pos - -fileReaderClose :: FileReader -> IO () -fileReaderClose = hClose . fbHandle - -withFileReader :: FilePath -> (FileReader -> IO a) -> IO a -withFileReader path f = - bracket (openFile path ReadMode) (hClose) $ \handle -> - bracket (fileReaderNew False handle) (\_ -> return ()) f - -withFileReaderDecompress :: FilePath -> (FileReader -> IO a) -> IO a -withFileReaderDecompress path f = - bracket (openFile path ReadMode) (hClose) $ \handle -> - bracket (fileReaderNew True handle) (\_ -> return ()) f - -fileReaderGetNext :: FileReader -> IO ByteString -fileReaderGetNext fb = do - bs <- if fbUseInflate fb then inflateTillPop else B.hGet (fbHandle fb) 8192 - modifyIORef (fbPos fb) (\pos -> pos + (fromIntegral $ B.length bs)) - return bs - where inflateTillPop = do - b <- B.hGet (fbHandle fb) 4096 - if B.null b - then finishInflate (fbInflate fb) - else (>>= maybe inflateTillPop return) =<< feedInflate (fbInflate fb) b - -fileReaderGetPos :: FileReader -> IO Word64 -fileReaderGetPos fr = do - storeLeft <- B.length <$> readIORef (fbRemaining fr) - pos <- readIORef (fbPos fr) - return (pos - fromIntegral storeLeft) - -fileReaderFill :: FileReader -> IO () -fileReaderFill fb = fileReaderGetNext fb >>= writeIORef (fbRemaining fb) - -fileReaderGet :: Int -> FileReader -> IO [ByteString] -fileReaderGet size fb@(FileReader { fbRemaining = ref }) = loop size - where loop left = do - b <- readIORef ref - if B.length b >= left - then do - let (b1, b2) = B.splitAt left b - writeIORef ref b2 - return [b1] - else do - let nleft = left - B.length b - fileReaderFill fb - liftM (b :) (loop nleft) - -fileReaderGetLBS :: Int -> FileReader -> IO L.ByteString -fileReaderGetLBS size fb = L.fromChunks <$> fileReaderGet size fb - -fileReaderGetBS :: Int -> FileReader -> IO ByteString -fileReaderGetBS size fb = B.concat <$> fileReaderGet size fb - --- | seek in a handle, and reset the remaining buffer to empty. -fileReaderSeek :: FileReader -> Word64 -> IO () -fileReaderSeek (FileReader { fbHandle = handle, fbRemaining = ref, fbPos = pos }) absPos = do - writeIORef ref B.empty >> writeIORef pos absPos >> hSeek handle AbsoluteSeek (fromIntegral absPos) - --- | parse from a filebuffer -fileReaderParse :: FileReader -> Parser a -> IO a -fileReaderParse fr@(FileReader { fbRemaining = ref }) parseF = do - initBS <- readIORef ref - result <- parseWith (fileReaderGetNext fr) parseF initBS - case result of - Done remaining a -> writeIORef ref remaining >> return a - Partial _ -> error "parsing failed: partial with a handle, reached EOF ?" - Fail _ ctxs err -> error ("parsing failed: " ++ show ctxs ++ " : " ++ show err) - --- | get a Variable Length Field. get byte as long as MSB is set, and one byte after -fileReaderGetVLF :: FileReader -> IO [Word8] -fileReaderGetVLF fr = fileReaderParse fr $ do - bs <- A.takeWhile (\w -> w `testBit` 7) - l <- A.anyWord8 - return $ (map (\w -> w `clearBit` 7) $ B.unpack bs) ++ [l] - -fileReaderInflateToSize :: FileReader -> Word64 -> IO L.ByteString -fileReaderInflateToSize fb@(FileReader { fbRemaining = ref }) outputSize = do - --pos <- fileReaderGetPos fb - --putStrLn ("inflate to size " ++ show outputSize ++ " " ++ show pos) - inflate <- inflateNew - l <- loop inflate outputSize - --posend <- fileReaderGetPos fb - --putStrLn ("inflated input " ++ show posend) - return $ L.fromChunks l - where loop inflate left = do - rbs <- readIORef ref - let maxToInflate = min left (16 * 1024) - let lastBlock = if left == maxToInflate then True else False - (dbs,remaining) <- inflateToSize inflate (fromIntegral maxToInflate) lastBlock rbs (fileReaderGetNext fb) - `E.catch` augmentAndRaise left - writeIORef ref remaining - let nleft = left - fromIntegral (B.length dbs) - if nleft > 0 - then liftM (dbs:) (loop inflate nleft) - else return [dbs] - augmentAndRaise :: Word64 -> E.SomeException -> IO a - augmentAndRaise left exn = throwIO $ InflateException outputSize left (show exn) - --- lowlevel helpers to inflate only to a specific size. - -inflateNew = do - zstr <- zstreamNew - inflateInit2 zstr defaultWindowBits - newForeignPtr c_free_z_stream_inflate zstr - -inflateToSize inflate sz isLastBlock ibs nextBs = withForeignPtr inflate $ \zstr -> do - let boundSz = min defaultChunkSize sz - -- create an output buffer - fbuff <- mallocForeignPtrBytes boundSz - withForeignPtr fbuff $ \buff -> do - c_set_avail_out zstr buff (fromIntegral boundSz) - rbs <- loop zstr ibs - bs <- B.packCStringLen (buff, boundSz) - return (bs, rbs) - where - loop zstr nbs = do - (ai, streamEnd) <- inflateOneInput zstr nbs - ao <- c_get_avail_out zstr - if (isLastBlock && streamEnd) || (not isLastBlock && ao == 0) - then return $ bsTakeLast ai nbs - else do - --when (ai /= 0) $ error ("input not consumed completly: ai" ++ show ai) - (if ai == 0 - then nextBs - else return (bsTakeLast ai nbs)) >>= loop zstr - - inflateOneInput zstr bs = unsafeUseAsCStringLen bs $ \(istr, ilen) -> do - c_set_avail_in zstr istr $ fromIntegral ilen - r <- c_call_inflate_noflush zstr - when (r < 0 && r /= (-5)) $ do - throwIO $ ZlibException $ fromIntegral r - ai <- c_get_avail_in zstr - return (ai, r == 1) - bsTakeLast len bs = B.drop (B.length bs - fromIntegral len) bs diff --git a/Data/Git/Storage/FileWriter.hs b/Data/Git/Storage/FileWriter.hs deleted file mode 100644 --- a/Data/Git/Storage/FileWriter.hs +++ /dev/null @@ -1,59 +0,0 @@ --- | --- Module : Data.Git.Storage.FileWriter --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unix --- -module Data.Git.Storage.FileWriter where - -import Data.Git.Ref -import Data.IORef -import qualified Data.ByteString as B -import Codec.Zlib -import Control.Exception (bracket) - -import qualified Crypto.Hash.SHA1 as SHA1 - -import System.IO (hClose) -import Filesystem - -defaultCompression = 6 - --- this is a copy of modifyIORef' found in base 4.6 (ghc 7.6), --- for older version of base. -modifyIORefStrict :: IORef a -> (a -> a) -> IO () -modifyIORefStrict ref f = do - x <- readIORef ref - let x' = f x - x' `seq` writeIORef ref x' - -data FileWriter = FileWriter - { writerHandle :: Handle - , writerDeflate :: Deflate - , writerDigest :: IORef SHA1.Ctx - } - -fileWriterNew handle = do - deflate <- initDeflate defaultCompression defaultWindowBits - digest <- newIORef SHA1.init - return $ FileWriter - { writerHandle = handle - , writerDeflate = deflate - , writerDigest = digest - } - -withFileWriter path f = - bracket (openFile path WriteMode) (hClose) $ \handle -> - bracket (fileWriterNew handle) (fileWriterClose) f - -postDeflate handle = maybe (return ()) (B.hPut handle) - -fileWriterOutput (FileWriter { writerHandle = handle, writerDigest = digest, writerDeflate = deflate }) bs = do - modifyIORefStrict digest (\ctx -> SHA1.update ctx bs) - (>>= postDeflate handle) =<< feedDeflate deflate bs - -fileWriterClose (FileWriter { writerHandle = handle, writerDeflate = deflate }) = - postDeflate handle =<< finishDeflate deflate - -fileWriterGetDigest (FileWriter { writerDigest = digest }) = (fromBinary . SHA1.finalize) `fmap` readIORef digest diff --git a/Data/Git/Storage/Loose.hs b/Data/Git/Storage/Loose.hs deleted file mode 100644 --- a/Data/Git/Storage/Loose.hs +++ /dev/null @@ -1,179 +0,0 @@ --- | --- Module : Data.Git.Storage.Loose --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unix --- -{-# LANGUAGE OverloadedStrings, ScopedTypeVariables, ViewPatterns #-} -module Data.Git.Storage.Loose - ( - Zipped(..) - -- * marshall from and to lazy bytestring - , looseUnmarshall - , looseUnmarshallRaw - , looseUnmarshallZipped - , looseUnmarshallZippedRaw - , looseMarshall - -- * read and check object existence - , looseRead - , looseReadHeader - , looseReadRaw - , looseExists - -- * write objects - , looseWriteBlobFromFile - , looseWrite - -- * enumeration of loose objects - , looseEnumeratePrefixes - , looseEnumerateWithPrefixFilter - , looseEnumerateWithPrefix - ) where - -import Codec.Compression.Zlib -import Data.Git.Ref -import Data.Git.Path -import Data.Git.Internal -import Data.Git.Storage.FileWriter -import Data.Git.Storage.Object - -import Filesystem -import Filesystem.Path -import Filesystem.Path.Rules - -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString as B - -import Data.Attoparsec.Lazy -import qualified Data.Attoparsec.Char8 as PC -import Control.Applicative ((<$>), (<|>)) -import Control.Monad -import Control.Exception (onException, SomeException) -import qualified Control.Exception as E - -import Data.String -import Data.Char (isHexDigit) - -import Prelude hiding (FilePath) - -isObjectPrefix [a,b] = isHexDigit a && isHexDigit b -isObjectPrefix _ = False - -decimal :: Parser Int -decimal = PC.decimal - --- loose object parsing -parseHeader = do - h <- takeWhile1 ((/=) 0x20) - _ <- word8 0x20 - sz <- decimal - return (objectTypeUnmarshall $ BC.unpack h, fromIntegral sz, Nothing) - -parseTreeHeader = string "tree " >> decimal >> word8 0 -parseTagHeader = string "tag " >> decimal >> word8 0 -parseCommitHeader = string "commit " >> decimal >> word8 0 -parseBlobHeader = string "blob " >> decimal >> word8 0 - -parseTree = parseTreeHeader >> objectParseTree -parseTag = parseTagHeader >> objectParseTag -parseCommit = parseCommitHeader >> objectParseCommit -parseBlob = parseBlobHeader >> objectParseBlob - -parseObject :: L.ByteString -> Object -parseObject = parseSuccess (parseTree <|> parseBlob <|> parseCommit <|> parseTag) - where parseSuccess p = either error id . eitherResult . parse p - --- | unmarshall an object (with header) from a bytestring. -looseUnmarshall :: L.ByteString -> Object -looseUnmarshall = parseObject - --- | unmarshall an object (with header) from a zipped stream. -looseUnmarshallZipped :: Zipped -> Object -looseUnmarshallZipped = parseObject . dezip - --- | unmarshall an object as (header, data) tuple from a bytestring -looseUnmarshallRaw :: L.ByteString -> (ObjectHeader, ObjectData) -looseUnmarshallRaw stream = - case L.findIndex ((==) 0) stream of - Nothing -> error "object not right format. missing 0" - Just idx -> - let (h, r) = L.splitAt (idx+1) stream in - case maybeResult $ parse parseHeader h of - Nothing -> error "cannot open object" - Just hdr -> (hdr, r) - --- | unmarshall an object as (header, data) tuple from a zipped stream -looseUnmarshallZippedRaw :: Zipped -> (ObjectHeader, ObjectData) -looseUnmarshallZippedRaw = looseUnmarshallRaw . dezip - --- | read a specific ref from a loose object and returns an header and data. -looseReadRaw repoPath ref = looseUnmarshallZippedRaw <$> readZippedFile (objectPathOfRef repoPath ref) - --- | read only the header of a loose object. -looseReadHeader repoPath ref = toHeader <$> readZippedFile (objectPathOfRef repoPath ref) - where toHeader = either error id . eitherResult . parse parseHeader . dezip - --- | read a specific ref from a loose object and returns an object -looseRead repoPath ref = looseUnmarshallZipped <$> readZippedFile (objectPathOfRef repoPath ref) - --- | check if a specific ref exists as loose object -looseExists repoPath ref = isFile (objectPathOfRef repoPath ref) - --- | enumarate all prefixes available in the object store. -looseEnumeratePrefixes repoPath = filter isObjectPrefix <$> getDirectoryContents (repoPath fromString "objects") - --- | enumerate all references available with a specific prefix. -looseEnumerateWithPrefixFilter :: FilePath -> String -> (Ref -> Bool) -> IO [Ref] -looseEnumerateWithPrefixFilter repoPath prefix filterF = - filter filterF . map (fromHexString . (prefix ++)) . filter isRef <$> getDir (repoPath fromString "objects" fromString prefix) - where - getDir p = E.catch (getDirectoryContents p) (\(_::SomeException) -> return []) - isRef l = length l == 38 - -looseEnumerateWithPrefix :: FilePath -> String -> IO [Ref] -looseEnumerateWithPrefix repoPath prefix = - looseEnumerateWithPrefixFilter repoPath prefix (const True) - --- | marshall as lazy bytestring an object except deltas. -looseMarshall obj - | objectIsDelta obj = error "cannot write delta object loose" - | otherwise = L.concat [ L.fromChunks [hdrB], objData ] - where - objData = objectWrite obj - hdrB = objectWriteHeader (objectToType obj) (fromIntegral $ L.length objData) - --- | create a new blob on a temporary location and on success move it to --- the object store with its digest name. -looseWriteBlobFromFile repoPath file = do - fsz <- getSize file - let hdr = objectWriteHeader TypeBlob (fromIntegral fsz) - tmpPath <- objectTemporaryPath repoPath - flip onException (removeFile tmpPath) $ do - (ref, npath) <- withFileWriter tmpPath $ \fw -> do - fileWriterOutput fw hdr - withFile file ReadMode $ \h -> loop h fw - digest <- fileWriterGetDigest fw - return (digest, objectPathOfRef repoPath digest) - exists <- isFile npath - when exists $ error "destination already exists" - rename tmpPath npath - return ref - where loop h fw = do - r <- B.hGet h (32*1024) - if B.null r - then return () - else fileWriterOutput fw r >> loop h fw - --- | write an object to disk as a loose reference. --- use looseWriteBlobFromFile for efficiently writing blobs when being commited from a file. -looseWrite repoPath obj = createDirectory True (directory path) - >> isFile path - >>= \exists -> unless exists (writeFileLazy path $ compress content) - >> return ref - where - path = objectPathOfRef repoPath ref - content = looseMarshall obj - ref = hashLBS content - writeFileLazy p bs = withFile p WriteMode (\h -> L.hPut h bs) - -getDirectoryContents p = map (encodeString posix . filename) <$> listDirectory p diff --git a/Data/Git/Storage/Object.hs b/Data/Git/Storage/Object.hs deleted file mode 100644 --- a/Data/Git/Storage/Object.hs +++ /dev/null @@ -1,347 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE CPP #-} --- | --- Module : Data.Git.Storage.Object --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unix --- -module Data.Git.Storage.Object - ( ObjectLocation(..) - , ObjectType(..) - , ObjectHeader - , ObjectData - , ObjectPtr(..) - , Object(..) - , ObjectInfo(..) - , Objectable(..) - , objectToType - , objectTypeMarshall - , objectTypeUnmarshall - , objectTypeIsDelta - , objectIsDelta - , objectToTree - , objectToCommit - , objectToTag - , objectToBlob - -- * parsing function - , treeParse - , commitParse - , tagParse - , blobParse - , objectParseTree - , objectParseCommit - , objectParseTag - , objectParseBlob - -- * writing function - , objectWriteHeader - , objectWrite - , objectHash - ) where - -import Data.Git.Ref -import Data.Git.Types - -import Data.Byteable (toBytes) -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy as L - -import Data.Attoparsec.Lazy -import qualified Data.Attoparsec.Lazy as P -import qualified Data.Attoparsec.Char8 as PC -import Control.Applicative ((<$>), (<*), (*>), many) -import Control.Monad - -import Data.List (intersperse) -import Data.Monoid -import Data.Word -import Text.Printf - -#if MIN_VERSION_bytestring(0,10,0) -import Data.ByteString.Lazy.Builder hiding (word8) -#else -import qualified Data.ByteString.Lazy.Char8 as LC - --- tiny builder interface like for bytestring < 0.10 that --- use normal lazy bytestring concat. -string7 :: String -> L.ByteString -string7 = LC.pack - -byteString :: ByteString -> L.ByteString -byteString = LC.fromChunks . (:[]) - -toLazyByteString = id -#endif - --- | location of an object in the database -data ObjectLocation = NotFound | Loose Ref | Packed Ref Word64 - deriving (Show,Eq) - --- | Delta objects points to some others objects in the database --- either as offset in the pack or as a direct reference. -data ObjectPtr = PtrRef Ref | PtrOfs Word64 deriving (Show,Eq) - -type ObjectHeader = (ObjectType, Word64, Maybe ObjectPtr) - -type ObjectData = L.ByteString - --- | Raw objects infos have an header (type, size, ptr), --- the data and a pointers chains to parents for resolved objects. -data ObjectInfo = ObjectInfo - { oiHeader :: ObjectHeader - , oiData :: ObjectData - , oiChains :: [ObjectPtr] - } deriving (Show,Eq) - --- | describe a git object, that could of 6 differents types: --- tree, blob, commit, tag and deltas (offset or ref). --- the deltas one are only available in packs. -data Object = ObjCommit Commit - | ObjTag Tag - | ObjBlob Blob - | ObjTree Tree - | ObjDeltaOfs DeltaOfs - | ObjDeltaRef DeltaRef - deriving (Show,Eq) - -class Objectable a where - getType :: a -> ObjectType - getRaw :: a -> L.ByteString - isDelta :: a -> Bool - toObject :: a -> Object - -objectToType :: Object -> ObjectType -objectToType (ObjTree _) = TypeTree -objectToType (ObjBlob _) = TypeBlob -objectToType (ObjCommit _) = TypeCommit -objectToType (ObjTag _) = TypeTag -objectToType (ObjDeltaOfs _) = TypeDeltaOff -objectToType (ObjDeltaRef _) = TypeDeltaRef - -objectTypeMarshall :: ObjectType -> String -objectTypeMarshall TypeTree = "tree" -objectTypeMarshall TypeBlob = "blob" -objectTypeMarshall TypeCommit = "commit" -objectTypeMarshall TypeTag = "tag" -objectTypeMarshall _ = error "deltas cannot be marshalled" - -objectTypeUnmarshall :: String -> ObjectType -objectTypeUnmarshall "tree" = TypeTree -objectTypeUnmarshall "blob" = TypeBlob -objectTypeUnmarshall "commit" = TypeCommit -objectTypeUnmarshall "tag" = TypeTag -objectTypeUnmarshall _ = error "unknown object type" - -objectTypeIsDelta :: ObjectType -> Bool -objectTypeIsDelta TypeDeltaOff = True -objectTypeIsDelta TypeDeltaRef = True -objectTypeIsDelta _ = False - -objectIsDelta :: Object -> Bool -objectIsDelta (ObjDeltaOfs _) = True -objectIsDelta (ObjDeltaRef _) = True -objectIsDelta _ = False - -objectToTree :: Object -> Maybe Tree -objectToTree (ObjTree tree) = Just tree -objectToTree _ = Nothing - -objectToCommit :: Object -> Maybe Commit -objectToCommit (ObjCommit commit) = Just commit -objectToCommit _ = Nothing - -objectToTag :: Object -> Maybe Tag -objectToTag (ObjTag tag) = Just tag -objectToTag _ = Nothing - -objectToBlob :: Object -> Maybe Blob -objectToBlob (ObjBlob blob) = Just blob -objectToBlob _ = Nothing - -octal :: Parser Int -octal = B.foldl' step 0 `fmap` takeWhile1 isOct - where isOct w = w >= 0x30 && w <= 0x37 - step a w = a * 8 + fromIntegral (w - 0x30) - -modeperm :: Parser ModePerm -modeperm = ModePerm . fromIntegral <$> octal - -tillEOL :: Parser ByteString -tillEOL = PC.takeWhile ((/= '\n')) - -skipEOL = skipChar '\n' - -skipChar :: Char -> Parser () -skipChar c = PC.char c >> return () - -referenceHex = fromHex <$> P.take 40 -referenceBin = fromBinary <$> P.take 20 - --- | parse a tree content -treeParse = Tree <$> parseEnts - where parseEnts = atEnd >>= \end -> if end then return [] else liftM2 (:) parseEnt parseEnts - parseEnt = liftM3 (,,) modeperm parseEntName (word8 0 >> referenceBin) - parseEntName = entName <$> (PC.char ' ' >> takeTill ((==) 0)) - --- | parse a blob content -blobParse = (Blob <$> takeLazyByteString) - --- | parse a commit content -commitParse = do - tree <- string "tree " >> referenceHex - skipChar '\n' - parents <- many parseParentRef - author <- string "author " >> parsePerson - committer <- string "committer " >> parsePerson - encoding <- option Nothing $ Just <$> (string "encoding " >> tillEOL) - extras <- many parseExtra - skipChar '\n' - message <- takeByteString - return $ Commit tree parents author committer encoding extras message - where - parseParentRef = do - tree <- string "parent " >> referenceHex - skipChar '\n' - return tree - parseExtra = do - f <- B.pack . (:[]) <$> notWord8 0xa - r <- tillEOL - skipEOL - v <- concatLines <$> many (string " " *> tillEOL <* skipEOL) - return $ CommitExtra (f `B.append` r) v - concatLines = B.concat . intersperse (B.pack [0xa]) - --- | parse a tag content -tagParse = do - object <- string "object " >> referenceHex - skipChar '\n' - type_ <- objectTypeUnmarshall . BC.unpack <$> (string "type " >> takeTill ((==) 0x0a)) - skipChar '\n' - tag <- string "tag " >> takeTill ((==) 0x0a) - skipChar '\n' - tagger <- string "tagger " >> parsePerson - skipChar '\n' - signature <- takeByteString - return $ Tag object type_ tag tagger signature - -parsePerson = do - name <- B.init <$> PC.takeWhile ((/=) '<') - skipChar '<' - email <- PC.takeWhile ((/=) '>') - _ <- string "> " - time <- PC.decimal :: Parser Integer - _ <- string " " - timezoneFmt <- PC.signed PC.decimal - let timezoneSign = if timezoneFmt < 0 then negate else id - let (h,m) = abs timezoneFmt `divMod` 100 - timezone = timezoneSign (h * 60 + m) - skipChar '\n' - return $ Person name email (gitTime time timezone) - -objectParseTree = ObjTree <$> treeParse -objectParseCommit = ObjCommit <$> commitParse -objectParseTag = ObjTag <$> tagParse -objectParseBlob = ObjBlob <$> blobParse - --- header of loose objects, but also useful for any object to determine object's hash -objectWriteHeader :: ObjectType -> Word64 -> ByteString -objectWriteHeader ty sz = BC.pack (objectTypeMarshall ty ++ " " ++ show sz ++ [ '\0' ]) - -objectWrite :: Object -> L.ByteString -objectWrite (ObjCommit commit) = commitWrite commit -objectWrite (ObjTag tag) = tagWrite tag -objectWrite (ObjBlob blob) = blobWrite blob -objectWrite (ObjTree tree) = treeWrite tree -objectWrite _ = error "delta cannot be marshalled" - -treeWrite (Tree ents) = toLazyByteString $ mconcat $ concatMap writeTreeEnt ents - where writeTreeEnt (ModePerm perm,name,ref) = - [ string7 (printf "%o" perm) - , string7 " " - , byteString $ toBytes name - , string7 "\0" - , byteString $ toBinary ref - ] - -commitWrite (Commit tree parents author committer encoding extra msg) = - toLazyByteString $ mconcat els - where - toNamedRef s r = mconcat [string7 s, byteString (toHex r),eol] - toParent = toNamedRef "parent " - toCommitExtra (CommitExtra k v) = [byteString k, eol] ++ - (concatMap (\l -> [byteString " ", byteString l, eol]) $ linesLast v) - - linesLast b - | B.length b > 0 && B.last b == 0xa = BC.lines b ++ [ "" ] - | otherwise = BC.lines b - els = [toNamedRef "tree " tree ] - ++ map toParent parents - ++ [byteString $ writeName "author" author, eol - ,byteString $ writeName "committer" committer, eol - ,maybe (byteString B.empty) (byteString) encoding -- FIXME need eol - ] - ++ concatMap toCommitExtra extra - ++ [eol - ,byteString msg - ] - -tagWrite (Tag ref ty tag tagger signature) = - toLazyByteString $ mconcat els - where els = [ string7 "object ", byteString (toHex ref), eol - , string7 "type ", string7 (objectTypeMarshall ty), eol - , string7 "tag ", byteString tag, eol - , byteString $ writeName "tagger" tagger, eol - , eol - , byteString signature - ] - -eol = string7 "\n" - -blobWrite (Blob bData) = bData - -instance Objectable Blob where - getType _ = TypeBlob - getRaw = blobWrite - toObject = ObjBlob - isDelta = const False - -instance Objectable Commit where - getType _ = TypeCommit - getRaw = commitWrite - toObject = ObjCommit - isDelta = const False - -instance Objectable Tag where - getType _ = TypeTag - getRaw = tagWrite - toObject = ObjTag - isDelta = const False - -instance Objectable Tree where - getType _ = TypeTree - getRaw = treeWrite - toObject = ObjTree - isDelta = const False - -instance Objectable DeltaOfs where - getType _ = TypeDeltaOff - getRaw = error "delta offset cannot be marshalled" - toObject = ObjDeltaOfs - isDelta = const True - -instance Objectable DeltaRef where - getType _ = TypeDeltaRef - getRaw = error "delta ref cannot be marshalled" - toObject = ObjDeltaRef - isDelta = const True - -objectHash :: ObjectType -> Word64 -> L.ByteString -> Ref -objectHash ty w lbs = hashLBS $ L.fromChunks (objectWriteHeader ty w : L.toChunks lbs) - --- used for objectWrite for commit and tag -writeName label (Person name email locTime) = - B.concat [label, " ", name, " <", email, "> ", BC.pack timeStr] - where timeStr = show locTime diff --git a/Data/Git/Storage/Pack.hs b/Data/Git/Storage/Pack.hs deleted file mode 100644 --- a/Data/Git/Storage/Pack.hs +++ /dev/null @@ -1,156 +0,0 @@ --- | --- Module : Data.Git.Storage.Pack --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unix --- -{-# LANGUAGE OverloadedStrings #-} -module Data.Git.Storage.Pack - ( PackedObjectInfo(..) - , PackedObjectRaw - -- * Enumerators of packs - , packEnumerate - -- * Helpers to process packs - , packOpen - , packClose - -- * Command for the content of a pack - , packReadHeader - , packReadMapAtOffset - , packReadAtOffset - , packReadRawAtOffset - , packEnumerateObjects - -- * turn a packed object into a - , packedObjectToObject - , packObjectFromRaw - ) where - -import Control.Applicative ((<$>)) -import Control.Arrow (second) -import Control.Monad - -import Filesystem.Path.Rules -import Filesystem.Path -import Filesystem - -import Data.Bits -import Data.List -import qualified Data.ByteString.Lazy as L - -import Data.Attoparsec (anyWord8) -import qualified Data.Attoparsec as A -import qualified Data.Attoparsec.Lazy as AL - -import Data.Git.Internal -import Data.Git.Path -import Data.Git.Storage.Object -import Data.Git.Delta -import Data.Git.Ref -import Data.Git.Types -import Data.Git.Storage.FileReader - -import Data.Word -import Prelude hiding (FilePath) - -type PackedObjectRaw = (PackedObjectInfo, L.ByteString) - -data PackedObjectInfo = PackedObjectInfo - { poiType :: ObjectType - , poiOffset :: Word64 - , poiSize :: Word64 - , poiActualSize :: Word64 - , poiExtra :: Maybe ObjectPtr - } deriving (Show,Eq) - --- | Enumerate the pack refs available in this repository. -packEnumerate repoPath = map onlyHash . filter isPackFile . map (encodeString posix . filename) <$> listDirectory (repoPath "objects" "pack") - where - isPackFile :: String -> Bool - isPackFile x = ".pack" `isSuffixOf` x - onlyHash = fromHexString . takebut 5 . drop 5 - takebut n l = take (length l - n) l - --- | open a pack -packOpen :: FilePath -> Ref -> IO FileReader -packOpen repoPath packRef = openFile (packPath repoPath packRef) ReadMode >>= fileReaderNew False - --- | close a pack -packClose :: FileReader -> IO () -packClose = fileReaderClose - --- | return the number of entries in this pack -packReadHeader repoPath packRef = - withFileReader (packPath repoPath packRef) $ \filereader -> - fileReaderParse filereader parseHeader - where parseHeader = do - packMagic <- be32 <$> A.take 4 - when (packMagic /= 0x5041434b) $ error "not a git packfile" - ver <- be32 <$> A.take 4 - when (ver /= 2) $ error ("pack file version not supported: " ++ show ver) - be32 <$> A.take 4 - --- | read an object at a specific position using a map function on the objectData -packReadMapAtOffset fr offset mapData = fileReaderSeek fr offset >> getNextObject fr mapData - --- | read an object at a specific position -packReadAtOffset :: FileReader -> Word64 -> IO (Maybe Object) -packReadAtOffset fr offset = packReadMapAtOffset fr offset id - --- | read a raw representation at a specific position -packReadRawAtOffset :: FileReader -> Word64 -> IO (PackedObjectRaw) -packReadRawAtOffset fr offset = fileReaderSeek fr offset >> getNextObjectRaw fr - --- | enumerate all objects in this pack and callback to f for reach raw objects -packEnumerateObjects repoPath packRef entries f = - withFileReader (packPath repoPath packRef) $ \filebuffer -> do - fileReaderSeek filebuffer 12 - parseNext filebuffer entries - where - parseNext :: FileReader -> Int -> IO () - parseNext _ 0 = return () - parseNext fr ents = getNextObjectRaw fr >>= f >> parseNext fr (ents-1) - -getNextObject :: FileReader -> (L.ByteString -> L.ByteString) -> IO (Maybe Object) -getNextObject fr mapData = - packedObjectToObject . second mapData <$> getNextObjectRaw fr - -packedObjectToObject (PackedObjectInfo { poiType = ty, poiExtra = extra }, objData) = - packObjectFromRaw (ty, extra, objData) - -packObjectFromRaw (TypeCommit, Nothing, objData) = AL.maybeResult $ AL.parse objectParseCommit objData -packObjectFromRaw (TypeTree, Nothing, objData) = AL.maybeResult $ AL.parse objectParseTree objData -packObjectFromRaw (TypeBlob, Nothing, objData) = AL.maybeResult $ AL.parse objectParseBlob objData -packObjectFromRaw (TypeTag, Nothing, objData) = AL.maybeResult $ AL.parse objectParseTag objData -packObjectFromRaw (TypeDeltaOff, Just (PtrOfs o), objData) = toObject . DeltaOfs o <$> deltaRead objData -packObjectFromRaw (TypeDeltaRef, Just (PtrRef r), objData) = toObject . DeltaRef r <$> deltaRead objData -packObjectFromRaw _ = error "can't happen unless someone change getNextObjectRaw" - -getNextObjectRaw :: FileReader -> IO PackedObjectRaw -getNextObjectRaw fr = do - sobj <- fileReaderGetPos fr - (ty, size) <- fileReaderParse fr parseObjectHeader - extra <- case ty of - TypeDeltaRef -> Just . PtrRef . fromBinary <$> fileReaderGetBS 20 fr - TypeDeltaOff -> Just . PtrOfs . deltaOffFromList <$> fileReaderGetVLF fr - _ -> return Nothing - objData <- fileReaderInflateToSize fr size - eobj <- fileReaderGetPos fr - - return (PackedObjectInfo ty sobj (eobj - sobj) size extra, objData) - where - parseObjectHeader = do - (m, ty, sz) <- splitFirst <$> anyWord8 - size <- if m then (sz +) <$> getNextSize 4 else return sz - return (ty, size) - where - getNextSize n = do - (c, sz) <- splitOther n <$> anyWord8 - if c then (sz +) <$> getNextSize (n+7) else return sz - - splitFirst :: Word8 -> (Bool, ObjectType, Word64) - splitFirst w = (w `testBit` 7, toEnum $ fromIntegral ((w `shiftR` 4) .&. 0x7), fromIntegral (w .&. 0xf)) - splitOther n w = (w `testBit` 7, fromIntegral (w .&. 0x7f) `shiftL` n) - - deltaOffFromList (x:xs) = foldl' acc (fromIntegral (x `clearBit` 7)) xs - where acc a w = ((a+1) `shiftL` 7) + fromIntegral (w `clearBit` 7) - deltaOffFromList [] = error "cannot happen" diff --git a/Data/Git/Storage/PackIndex.hs b/Data/Git/Storage/PackIndex.hs deleted file mode 100644 --- a/Data/Git/Storage/PackIndex.hs +++ /dev/null @@ -1,186 +0,0 @@ --- | --- Module : Data.Git.Storage.PackIndex --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unix --- -{-# LANGUAGE OverloadedStrings, BangPatterns #-} -module Data.Git.Storage.PackIndex - ( PackIndexHeader(..) - , PackIndex(..) - - -- * handles and enumeration - , packIndexOpen - , packIndexClose - , withPackIndex - , packIndexEnumerate - - -- * read from packIndex - , packIndexHeaderGetNbWithPrefix - , packIndexGetReferenceLocation - , packIndexGetReferencesWithPrefix - , packIndexReadHeader - , packIndexRead - , packIndexGetHeader - ) where - -import Control.Applicative ((<$>)) -import Control.Monad - -import Filesystem -import Filesystem.Path -import Filesystem.Path.Rules - -import Data.List -import Data.Bits -import Data.Word -import Data.String - -import Data.Vector (Vector, (!)) -import qualified Data.Vector as V - -import qualified Data.Attoparsec as A - -import Data.Git.Internal -import Data.Git.Storage.FileReader -import Data.Git.Path -import Data.Git.Ref - -import Prelude hiding (FilePath) - --- | represent an packIndex header with the version and the fanout table -data PackIndexHeader = PackIndexHeader !Word32 !(Vector Word32) - deriving (Show,Eq) - -data PackIndex = PackIndex - { packIndexSha1s :: Vector Ref - , packIndexCRCs :: Vector Word32 - , packIndexPackoffs :: Vector Word32 - , packIndexPackChecksum :: Ref - , packIndexChecksum :: Ref - } - --- | enumerate every indexes file in the pack directory -packIndexEnumerate repoPath = map onlyHash . filter isPackFile . map (encodeString posix . filename) <$> listDirectory (repoPath "objects" "pack") - where - isPackFile :: String -> Bool - isPackFile x = ".idx" `isSuffixOf` x && "pack-" `isPrefixOf` x - onlyHash = fromHexString . takebut 4 . drop 5 - takebut n l = take (length l - n) l - --- | open an index -packIndexOpen :: FilePath -> Ref -> IO FileReader -packIndexOpen repoPath indexRef = openFile (indexPath repoPath indexRef) ReadMode >>= fileReaderNew False - --- | close an index -packIndexClose :: FileReader -> IO () -packIndexClose = fileReaderClose - --- | variant of withFile on the index file and with a FileReader -withPackIndex repoPath indexRef = withFileReader (indexPath repoPath indexRef) - --- | returns the number of references, referenced in this index. -packIndexHeaderGetSize :: PackIndexHeader -> Word32 -packIndexHeaderGetSize (PackIndexHeader _ indexes) = indexes ! 255 - --- | byte size of an packIndex header. -packIndexHeaderByteSize :: Int -packIndexHeaderByteSize = 2*4 {- header -} + 256*4 {- fanout table -} - --- | get the number of reference in this index with a specific prefix -packIndexHeaderGetNbWithPrefix :: PackIndexHeader -> Int -> Word32 -packIndexHeaderGetNbWithPrefix (PackIndexHeader _ indexes) n - | n < 0 || n > 255 = 0 - | n == 0 = indexes ! 0 - | otherwise = (indexes ! n) - (indexes ! (n-1)) - --- | fold on refs with a specific prefix -packIndexHeaderFoldRef :: PackIndexHeader -> FileReader -> Int -> (a -> Word32 -> Ref -> (a, Bool)) -> a -> IO a -packIndexHeaderFoldRef idxHdr@(PackIndexHeader _ indexes) fr refprefix f initAcc - | nb == 0 = return initAcc - | otherwise = do - let spos = (indexes ! refprefix) - nb - fileReaderSeek fr (fromIntegral (sha1Offset + spos * 20)) - loop nb initAcc - where - loop 0 acc = return acc - loop n acc = do - b <- fromBinary <$> fileReaderGetBS 20 fr - let (!nacc, terminate) = f acc (nb-n) b - if terminate - then return nacc - else loop (n-1) nacc - nb = packIndexHeaderGetNbWithPrefix idxHdr refprefix - (sha1Offset,_,_) = packIndexOffsets idxHdr - --- | return the reference offset in the packfile if found -packIndexGetReferenceLocation :: PackIndexHeader -> FileReader -> Ref -> IO (Maybe Word64) -packIndexGetReferenceLocation idxHdr@(PackIndexHeader _ indexes) fr ref = do - mrpos <- packIndexHeaderFoldRef idxHdr fr refprefix f Nothing - case mrpos of - Nothing -> return Nothing - Just rpos -> do - let spos = (indexes ! refprefix) - nb - fileReaderSeek fr (fromIntegral (packOffset + 4 * (spos+rpos))) - Just . fromIntegral . be32 <$> fileReaderGetBS 4 fr - where - f acc rpos rref = if ref == rref then (Just rpos,True) else (acc,False) - refprefix = refPrefix ref - nb = packIndexHeaderGetNbWithPrefix idxHdr refprefix - (_,_,packOffset) = packIndexOffsets idxHdr - --- | get all references that start by prefix. -packIndexGetReferencesWithPrefix :: PackIndexHeader -> FileReader -> String -> IO [Ref] -packIndexGetReferencesWithPrefix idxHdr fr prefix = - packIndexHeaderFoldRef idxHdr fr refprefix f [] - where - f acc _ ref = case cmpPrefix prefix ref of - GT -> (acc ,False) - EQ -> (ref:acc,False) - LT -> (acc ,True) - refprefix = read ("0x" ++ take 2 prefix) - --- | returns absolute offset in the index file of the sha1s, the crcs and the packfiles offset. -packIndexOffsets idx = (packIndexSha1sOffset, packIndexCRCsOffset, packIndexPackOffOffset) - where - packIndexPackOffOffset = packIndexCRCsOffset + crcsTableSz - packIndexCRCsOffset = packIndexSha1sOffset + sha1TableSz - packIndexSha1sOffset = fromIntegral packIndexHeaderByteSize - crcsTableSz = 4 * sz - sha1TableSz = 20 * sz - sz = packIndexHeaderGetSize idx - --- | parse index header -parsePackIndexHeader = do - magic <- be32 <$> A.take 4 - when (magic /= 0xff744f63) $ error "wrong magic number for packIndex" - ver <- be32 <$> A.take 4 - when (ver /= 2) $ error "unsupported packIndex version" - fanouts <- V.replicateM 256 (be32 <$> A.take 4) - return $ PackIndexHeader ver fanouts - --- | read index header from an index filereader -packIndexReadHeader :: FileReader -> IO PackIndexHeader -packIndexReadHeader fr = fileReaderSeek fr 0 >> fileReaderParse fr parsePackIndexHeader - --- | get index header from an index reference -packIndexGetHeader :: FilePath -> Ref -> IO PackIndexHeader -packIndexGetHeader repoPath indexRef = withPackIndex repoPath indexRef $ packIndexReadHeader - --- | read all index -packIndexRead repoPath indexRef = do - withPackIndex repoPath indexRef $ \fr -> do - idx <- fileReaderParse fr parsePackIndexHeader - liftM2 (,) (return idx) (fileReaderParse fr (parsePackIndex $ packIndexHeaderGetSize idx)) - where parsePackIndex sz = do - sha1s <- V.replicateM (fromIntegral sz) (fromBinary <$> A.take 20) - crcs <- V.replicateM (fromIntegral sz) (be32 <$> A.take 4) - packoffs <- V.replicateM (fromIntegral sz) (be32 <$> A.take 4) - let nbLarge = length $ filter (== True) $ map (\packoff -> packoff `testBit` 31) $ V.toList packoffs - largeoffs <- replicateM nbLarge (A.take 4) - packfileChecksum <- fromBinary <$> A.take 20 - idxfileChecksum <- fromBinary <$> A.take 20 - -- large packfile offsets - -- trailer - return (sha1s, crcs, packoffs, largeoffs, packfileChecksum, idxfileChecksum) diff --git a/Data/Git/Types.hs b/Data/Git/Types.hs deleted file mode 100644 --- a/Data/Git/Types.hs +++ /dev/null @@ -1,227 +0,0 @@ --- | --- Module : Data.Git.Object --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unix --- -{-# LANGUAGE DeriveDataTypeable #-} -module Data.Git.Types - ( - -- * Type of types - ObjectType(..) - -- * Main git types - , Tree(..) - , Commit(..) - , CommitExtra(..) - , Blob(..) - , Tag(..) - , Person(..) - , EntName - , entName - , EntPath - , entPathAppend - -- * modeperm type - , ModePerm(..) - , FilePermissions(..) - , ObjectFileType(..) - , getPermission - , getFiletype - -- * time type - , GitTime(..) - , gitTime - , gitTimeToLocal - -- * Pack delta types - , DeltaOfs(..) - , DeltaRef(..) - -- * Basic types part of other bigger types - , TreeEnt - ) where - -import Data.Word -import Data.Bits -import Data.Byteable -import Data.Monoid -import Data.String -import Data.ByteString (ByteString) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as L - -import Data.Git.Ref -import Data.Git.Delta -import Data.Hourglass (Elapsed, TimezoneOffset(..) - , timePrint, timeConvert - , Time(..), Timeable(..) - , LocalTime, localTimeSetTimezone, localTimeFromGlobal) -import Data.Data -import qualified Data.ByteString.UTF8 as UTF8 - --- | type of a git object. -data ObjectType = - TypeTree - | TypeBlob - | TypeCommit - | TypeTag - | TypeDeltaOff - | TypeDeltaRef - deriving (Show,Eq,Data,Typeable) - --- | Git time is number of seconds since unix epoch in the UTC zone with --- the current timezone associated -data GitTime = GitTime - { gitTimeUTC :: Elapsed - , gitTimeTimezone :: TimezoneOffset - } deriving (Eq) - -instance Timeable GitTime where - timeGetNanoSeconds _ = 0 - timeGetElapsedP (GitTime t _) = timeConvert t - timeGetElapsed (GitTime t _) = t -instance Time GitTime where - timeFromElapsedP e = GitTime (timeGetElapsed e) (TimezoneOffset 0) - timeFromElapsed e = GitTime e (TimezoneOffset 0) - -instance Show GitTime where - show (GitTime t tz) = - timePrint "EPOCH" t ++ " " ++ show tz - -gitTime :: Integer -> Int -> GitTime -gitTime seconds tzMins = - GitTime (fromIntegral seconds) (TimezoneOffset tzMins) - -gitTimeToLocal :: GitTime -> LocalTime Elapsed -gitTimeToLocal (GitTime t tz) = - localTimeSetTimezone tz (localTimeFromGlobal t) - --- | the enum instance is useful when marshalling to pack file. -instance Enum ObjectType where - fromEnum TypeCommit = 0x1 - fromEnum TypeTree = 0x2 - fromEnum TypeBlob = 0x3 - fromEnum TypeTag = 0x4 - fromEnum TypeDeltaOff = 0x6 - fromEnum TypeDeltaRef = 0x7 - - toEnum 0x1 = TypeCommit - toEnum 0x2 = TypeTree - toEnum 0x3 = TypeBlob - toEnum 0x4 = TypeTag - toEnum 0x6 = TypeDeltaOff - toEnum 0x7 = TypeDeltaRef - toEnum n = error ("not a valid object: " ++ show n) - -newtype ModePerm = ModePerm Word32 - deriving (Show,Eq) - -getPermission :: ModePerm -> FilePermissions -getPermission (ModePerm modeperm) = - let owner = (modeperm .&. 0x700) `shiftR` 6 - group = (modeperm .&. 0x70) `shiftR` 3 - other = modeperm .&. 0x7 - in FilePermissions (fromIntegral owner) (fromIntegral group) (fromIntegral other) - -getFiletype :: ModePerm -> ObjectFileType -getFiletype (ModePerm modeperm) = - case modeperm `shiftR` 12 of - _ -> error "filetype unknown" - --- | Git object file type -data ObjectFileType = - FileTypeDirectory - | FileTypeRegularFile - | FileTypeSymbolicLink - | FileTypeGitLink - deriving (Show,Eq) - --- | traditional unix permission for owner, group and permissions -data FilePermissions = FilePermissions - { getOwnerPerm :: {-# UNPACK #-} !Perm - , getGroupPerm :: {-# UNPACK #-} !Perm - , getOtherPerm :: {-# UNPACK #-} !Perm - } deriving (Show,Eq) - --- | a bitfield representing a typical unix permission: --- * bit 0 represents the read permission --- * bit 1 represents the write permission --- * bit 2 represents the execute permission -type Perm = Word8 - --- | Entity name -newtype EntName = EntName ByteString - deriving (Eq,Ord) -instance Show EntName where - show (EntName e) = UTF8.toString e -instance IsString EntName where - fromString s = entName $ UTF8.fromString s -instance Byteable EntName where - toBytes (EntName n) = n - -entName :: ByteString -> EntName -entName bs - | B.elem slash bs = error ("entity name " ++ show bs ++ " contains an invalid '/' character") - | otherwise = EntName bs - where slash = 47 - -entPathAppend :: EntPath -> EntName -> EntPath -entPathAppend l e = l ++ [e] - -type EntPath = [EntName] - --- | represent one entry in the tree --- (permission,file or directory name,blob or tree ref) --- name should maybe a filepath, but not sure about the encoding. -type TreeEnt = (ModePerm,EntName,Ref) - --- | an author or committer line --- has the format: name time timezone --- FIXME: should be a string, but I don't know if the data is stored --- consistantly in one encoding (UTF8) -data Person = Person - { personName :: ByteString - , personEmail :: ByteString - , personTime :: GitTime - } deriving (Show,Eq) - --- | Represent a root tree with zero to many tree entries. -data Tree = Tree { treeGetEnts :: [TreeEnt] } deriving (Show,Eq) - -instance Monoid Tree where - mempty = Tree [] - mappend (Tree e1) (Tree e2) = Tree (e1 ++ e2) - mconcat trees = Tree $ concatMap treeGetEnts trees - --- | Represent a binary blob. -data Blob = Blob { blobGetContent :: L.ByteString } deriving (Show,Eq) - --- | Represent a commit object. -data Commit = Commit - { commitTreeish :: Ref - , commitParents :: [Ref] - , commitAuthor :: Person - , commitCommitter :: Person - , commitEncoding :: Maybe ByteString - , commitExtras :: [CommitExtra] - , commitMessage :: ByteString - } deriving (Show,Eq) - -data CommitExtra = CommitExtra - { commitExtraKey :: ByteString - , commitExtraValue :: ByteString - } deriving (Show,Eq) - --- | Represent a signed tag. -data Tag = Tag - { tagRef :: Ref - , tagObjectType :: ObjectType - , tagBlob :: ByteString - , tagName :: Person - , tagS :: ByteString - } deriving (Show,Eq) - --- | Delta pointing to an offset. -data DeltaOfs = DeltaOfs Word64 Delta - deriving (Show,Eq) - --- | Delta pointing to a ref. -data DeltaRef = DeltaRef Ref Delta - deriving (Show,Eq) diff --git a/Data/Git/WorkTree.hs b/Data/Git/WorkTree.hs deleted file mode 100644 --- a/Data/Git/WorkTree.hs +++ /dev/null @@ -1,151 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} --- | --- Module : Data.Git.WorkTree --- License : BSD-style --- Maintainer : Vincent Hanquez --- Stability : experimental --- Portability : unix --- --- a load-on-demand, write-on-demand working tree. --- -module Data.Git.WorkTree - ( WorkTree - , EntType(..) - -- * Create new work trees - , workTreeNew - , workTreeFrom - -- * Modifications methods - , workTreeDelete - , workTreeSet - , workTreeFlush - ) where - -import Data.Git.Ref -import Data.Git.Types -import Data.Git.Storage.Object -import Data.Git.Storage -import Data.Git.Repository - ---import qualified Data.ByteString as B - -import qualified Data.Map as M - -import Control.Monad -import Control.Concurrent.MVar - -type Dir = M.Map EntName (ModePerm, TreeSt) -type TreeVar = MVar Dir -data TreeSt = TreeRef Ref | TreeLoaded TreeVar -type WorkTree = MVar TreeSt - -data EntType = EntDirectory | EntFile | EntExecutable - deriving (Show,Eq) - --- | Create a new worktree -workTreeNew :: IO WorkTree -workTreeNew = newMVar M.empty >>= newMVar . TreeLoaded - --- | Create a worktree from a tree reference. -workTreeFrom :: Ref -> IO WorkTree -workTreeFrom ref = newMVar (TreeRef ref) - --- | delete a path from a working tree --- --- if the path doesn't exist, no error is raised -workTreeDelete :: Git -> WorkTree -> EntPath -> IO () -workTreeDelete git wt path = diveFromRoot git wt path dive - where dive _ [] = error "internal error: delete: empty dive" - dive varCurrent [file] = modifyMVar_ varCurrent (return . M.delete file) - dive varCurrent (x:xs) = do - evarChild <- loadOrGetTree git x varCurrent $ \m -> return (m, Right ()) - case evarChild of - Left varChild -> dive varChild xs - Right () -> return () - --- | Set a file in this working tree to a specific ref. --- --- The ref should point to a valid blob or tree object, and --- it's safer to write the referenced tree or blob object first. -workTreeSet :: Git -> WorkTree -> EntPath -> (EntType, Ref) -> IO () -workTreeSet git wt path (entType, entRef) = diveFromRoot git wt path dive - where dive :: TreeVar -> EntPath -> IO () - dive _ [] = error "internal error: set: empty dive" - dive varCurrent [file] = modifyMVar_ varCurrent (return . M.insert file (entTypeToPerm entType, TreeRef entRef)) - dive varCurrent (x:xs) = do - evarChild <- loadOrGetTree git x varCurrent $ \m -> do - -- create an empty tree - v <- newMVar M.empty - return (M.insert x (entTypeToPerm EntDirectory, TreeLoaded v) m, Left v) - case evarChild of - Left varChild -> dive varChild xs - Right () -> return () - -{- -workTreeFlushAt :: Git -> WorkTree -> EntPath -> IO () -workTreeFlushAt git wt path = do - undefined --} - --- | Flush the worktree by creating all the necessary trees in the git store --- and return the root ref of the work tree. -workTreeFlush :: Git -> WorkTree -> IO Ref -workTreeFlush git wt = do - -- write all the trees that need to be written - -- switch to modifyMVar - wtVal <- takeMVar wt - case wtVal of - TreeRef ref -> putMVar wt wtVal >> return ref - TreeLoaded var -> do - ref <- writeTreeRecursively (TreeLoaded var) - putMVar wt $ TreeRef ref - return ref - where writeTreeRecursively (TreeRef ref) = return ref - writeTreeRecursively (TreeLoaded var) = do - c <- readMVar var - ents <- forM (M.toList c) $ \(bs, (mperm, entSt)) -> do - ref <- writeTreeRecursively entSt - return (mperm, bs, ref) - setTree ents - - setTree ents = setObject git (toObject $ Tree ents) - ------ helpers ----- - -loadTreeVar :: Git -> Ref -> IO TreeVar -loadTreeVar git treeRef = do - (Tree ents) <- getTree git treeRef - let t = foldr (\(m,b,r) acc -> M.insert b (m,TreeRef r) acc) M.empty ents - newMVar t - -entTypeToPerm :: EntType -> ModePerm -entTypeToPerm EntDirectory = ModePerm 0o040000 -entTypeToPerm EntExecutable = ModePerm 0o100755 -entTypeToPerm EntFile = ModePerm 0o100644 - -loadOrGetTree :: Git -> EntName -> TreeVar -> (Dir -> IO (Dir, Either TreeVar a)) -> IO (Either TreeVar a) -loadOrGetTree git x varCurrent onMissing = - modifyMVar varCurrent $ \m -> do - case M.lookup x m of - Nothing -> onMissing m - Just (_, treeSt) -> -- check perm to see if it is a directory - case treeSt of - TreeRef ref -> do - -- replace the ref by a loaded tree - var <- loadTreeVar git ref - return (M.adjust (\(perm,_) -> (perm, TreeLoaded var)) x m, Left var) - TreeLoaded var -> return (m, Left var) - -diveFromRoot :: Git -> WorkTree -> EntPath - -> (TreeVar -> EntPath -> IO ()) - -> IO () -diveFromRoot git wt path dive - | path == [] = return () - | otherwise = do - -- switch to modifyMVar - wtVal <- takeMVar wt - current <- case wtVal of - TreeLoaded var -> return var - TreeRef ref -> loadTreeVar git ref - putMVar wt $ TreeLoaded current - dive current path - diff --git a/Hit/Hit.hs b/Hit/Hit.hs --- a/Hit/Hit.hs +++ b/Hit/Hit.hs @@ -1,4 +1,7 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Hit -- License : BSD-style @@ -31,11 +34,11 @@ import qualified Data.HashTable.IO as H import qualified Data.Hashable as Hashable -import Data.Algorithm.Patience as AP (Item(..)) +import Data.Git.Diff.Patience as AP (Item(..)) type HashTable k v = H.CuckooHashTable k v -instance Hashable.Hashable Ref where +instance Hashable.Hashable (Ref SHA1) where hashWithSalt salt = Hashable.hashWithSalt salt . toBinary verifyPack pref git = do @@ -76,7 +79,7 @@ modifyIORef leftParsed (\i -> i-1) setObj_ refs offsets tree x - dumpTree :: HashTable Word64 Ref -> HashTable Ref (PackedObjectInfo, Maybe (ObjectPtr, Int)) -> M.Map Ref () -> IO () + dumpTree :: HashTable Word64 (Ref SHA1) -> HashTable (Ref SHA1) (PackedObjectInfo SHA1, Maybe (ObjectPtr SHA1, Int)) -> M.Map (Ref SHA1) () -> IO () dumpTree offsets tree refs = do forM_ (M.toAscList refs) $ \(ref, ()) -> do ent <- fromJust <$> H.lookup tree ref @@ -165,13 +168,14 @@ return () where author = commitAuthor commit +showDiff :: Revision -> Revision -> Git SHA1 -> IO () showDiff rev1 rev2 git = do ref1 <- maybe (error "revision cannot be found") id <$> resolveRevision git rev1 ref2 <- maybe (error "revision cannot be found") id <$> resolveRevision git rev2 diffList <- getDiffWith (defaultDiff 5) ([]) ref1 ref2 git mapM_ showADiff diffList where - showADiff :: HitDiff -> IO () + showADiff :: GitDiff SHA1 -> IO () showADiff hd = do printFileName $ hFileName hd printFileMode $ hFileMode hd @@ -181,20 +185,20 @@ printFileName :: EntPath -> IO () printFileName filename = putStrLn $ "Hit.Diff on file: " ++ (show filename) - printFileMode :: HitFileMode -> IO () + printFileMode :: GitFileMode -> IO () printFileMode (NewMode (ModePerm m)) = printf "new file mode: %06o\n" m printFileMode (OldMode (ModePerm m)) = printf "old file mode: %06o\n" m printFileMode (UnModifiedMode (ModePerm m)) = printf "current file mode: %06o\n" m printFileMode (ModifiedMode (ModePerm o) (ModePerm n)) = printf "file mode: %06o -> %06o\n" o n - printFileRef :: HitFileRef -> IO () + printFileRef :: GitFileRef SHA1 -> IO () printFileRef (NewRef r) = putStrLn $ "+++ new/" ++ (show r) printFileRef (OldRef r) = putStrLn $ "--- old/" ++ (show r) printFileRef (UnModifiedRef r) = putStrLn $ "=== cur/" ++ (show r) printFileRef (ModifiedRef o n) = do putStrLn $ "+++ new/" ++ (show n) putStrLn $ "--- old/" ++ (show o) - printFileDiff :: HitFileContent -> IO () + printFileDiff :: GitFileContent -> IO () printFileDiff NewBinaryFile = putStrLn "Binary file created" printFileDiff OldBinaryFile = putStrLn "Binary file deleted" printFileDiff ModifiedBinaryFile = putStrLn "Binary file modified" @@ -226,7 +230,7 @@ main = do args <- getArgs case args of - ["verify-pack",ref] -> withCurrentRepo $ verifyPack (fromHexString ref) + ["verify-pack",ref] -> withCurrentRepo $ verifyPack (fromHexString @SHA1 ref) ["cat-file",ty,ref] -> withCurrentRepo $ catFile ty (fromHexString ref) ["ls-tree",rev] -> withCurrentRepo $ lsTree (fromString rev) "" ["ls-tree",rev,path] -> withCurrentRepo $ lsTree (fromString rev) path diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,53 +1,6 @@ Hit === -Hit is a reimplementation of some git operations in pure haskell. - - -what it does do: - -* read loose objects, and packed objects. -* write new loose objects -* git like operations available: commit, cat-file, verify-pack, rev-list, ls-tree. - -what is doesn't do: - -* reimplement the whole of git. -* checkout's index reading/writing, fetching, merging, diffing. - -The main functions for users are available from the Data.Git module. - -The essential functions are: - -* withRepo: create a new git context and execute a function with the context. functional equivalent of withFile but for git repository. -* withCurrentRepo: similar to withRepo but found the repository from the user current directory. -* resolveRevision: turns a git revision (e.g. HEAD, 0a24^^^~3) into a SHA1 reference. -* resolvePath: from a commit ref and a path, it will gives the tree or blob reference of the object at the specific path (see example). -* getObject: from a SHA1 reference, gives a high level object (Commit, Blob, Tree, Tag, Delta) from the git repository. if called with resolveDelta set, it will resolves deltas to be simple objects with the deltas applied. -* getObjectRaw: similar to getObject but gives a raw representation (lazy bytestring) of the object. -* getCommit: similar to getObject but gives back a commit. -* getTree: similar to getObject but gives back a tree. - -API Example ------------ - -resolving path of the README file and returning the reference to the blob : - - {-# LANGUAGE OverloadedStrings #-} - import Data.Git.Repository - - showPathRef commitRef = withRepo ".git" $ \git -> do - ref <- maybe (error "inexistent object at this path") id `fmap` resolvePath git commitRef ["README"] - putStrLn ("README has the reference: " ++ show ref) - - -catting an object from a ref: - - import Data.Git.Repository - - catFile ref = withRepo ".git" $ \git -> do - obj <- maybe (error "not a valid object") id `fmap` getObjectRaw git ref True - L.putStrLn (oiData obj) - +Git like feature program using the git library -more examples on how to use api can be found in Hit.hs. +For the library, look at the 'git' packages, which is mostly compatible with 'hit' diff --git a/Tests/Repo.hs b/Tests/Repo.hs deleted file mode 100644 --- a/Tests/Repo.hs +++ /dev/null @@ -1,59 +0,0 @@ -import Test.Tasty -import Test.Tasty.QuickCheck - -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString as B - -import Control.Applicative -import Control.Monad - -import Data.Git.Storage.Object -import Data.Git.Storage.Loose -import Data.Git.Storage -import Data.Git.Ref -import Data.Git.Types -import Data.Git.Repository - -import Data.Maybe - -import Text.Bytedump -import System.Exit - -onLocalRepo f = do - fpath <- findRepoMaybe - case fpath of - Nothing -> putStrLn "cannot run this test without repository. clone the original repository for test" - Just _ -> withCurrentRepo f - -doLocalMarshallEq git = do - prefixes <- looseEnumeratePrefixes (gitRepoPath git) - forM prefixes $ \prefix -> do - refs <- looseEnumerateWithPrefix (gitRepoPath git) prefix - forM refs $ \ref -> do - raw <- looseReadRaw (gitRepoPath git) ref - obj <- looseRead (gitRepoPath git) ref - let content = looseMarshall obj - let raw2 = looseUnmarshallRaw content - let hashed = hashLBS content - if ref /= hashed - then return $ Just (ref, hashed, raw, raw2) - else return Nothing - -printDiff (actualRef, gotRef, (actualHeader, actualRaw), (gotHeader, gotRaw)) = do - putStrLn "=========== difference found" - putStrLn ("ref expected: " ++ show actualRef) - putStrLn ("ref got : " ++ show gotRef) - putStrLn ("header expected: " ++ show actualHeader) - putStrLn ("header got : " ++ show gotHeader) - putStrLn "raw diff:" - putStrLn $ dumpDiffLBS actualRaw gotRaw - -printLocalMarshallError l - | null l = putStrLn "local marshall: [OK]" - | otherwise = putStrLn ("local marshall: [" ++ show (length l) ++ " errors]") - >> mapM_ printDiff l - >> exitFailure - -main = onLocalRepo $ \git -> do - doLocalMarshallEq git >>= printLocalMarshallError . catMaybes . concat - return () diff --git a/Tests/Tests.hs b/Tests/Tests.hs deleted file mode 100644 --- a/Tests/Tests.hs +++ /dev/null @@ -1,110 +0,0 @@ -import Test.Tasty.QuickCheck -import Test.Tasty - -import qualified Data.ByteString.Lazy as L -import qualified Data.ByteString as B - -import Control.Applicative -import Control.Monad - -import Data.Git.Storage.Object -import Data.Git.Storage.Loose -import Data.Git.Ref -import Data.Git.Types -import Data.Hourglass - -import Data.Maybe - --- for arbitrary instance to generate only data that are writable --- to disk. i.e. no deltas. -data ObjNoDelta = ObjNoDelta Object - deriving (Eq) - -instance Show ObjNoDelta where - show (ObjNoDelta o) = show o - -arbitraryBS size = B.pack . map fromIntegral <$> replicateM size (choose (0,255) :: Gen Int) -arbitraryBSno0 size = B.pack . map fromIntegral <$> replicateM size (choose (1,255) :: Gen Int) -arbitraryBSasciiNoSpace size = B.pack . map fromIntegral <$> replicateM size (choose (0x21,0x7f) :: Gen Int) -arbitraryBSascii size = B.pack . map fromIntegral <$> replicateM size (choose (0x20,0x7f) :: Gen Int) -arbitraryBSnoangle size = B.pack . map fromIntegral <$> replicateM size (choose (0x40,0x7f) :: Gen Int) - -arbitraryEntname size = entName . B.pack . map fromIntegral <$> replicateM size range - where range :: Gen Int - range = oneof [ choose (0x21, 0x2e) -- remove 0x2f (slash) - , choose (0x30, 0x7f) - ] - -instance Arbitrary Ref where - arbitrary = fromBinary <$> arbitraryBS 20 - -arbitraryMsg = arbitraryBSno0 1 -arbitraryLazy = L.fromChunks . (:[]) <$> arbitraryBS 40 - -arbitraryRefList :: Gen [Ref] -arbitraryRefList = replicateM 2 arbitrary - -arbitraryEnt :: Gen TreeEnt -arbitraryEnt = liftM3 (,,) arbitrary (arbitraryEntname 23) arbitrary -arbitraryEnts = choose (1,2) >>= \i -> replicateM i arbitraryEnt - -instance Arbitrary TimezoneOffset where - arbitrary = TimezoneOffset <$> choose (-11*60, 12*60) -instance Arbitrary Elapsed where - arbitrary = Elapsed . Seconds <$> choose (0,2^32-1) -instance Arbitrary GitTime where - arbitrary = GitTime <$> arbitrary <*> arbitrary -instance Arbitrary ModePerm where - arbitrary = ModePerm <$> elements [ 0o644, 0o664, 0o755, 0 ] - -arbitraryName = liftM3 Person (arbitraryBSnoangle 16) - (arbitraryBSnoangle 16) - arbitrary - -arbitraryObjTypeNoDelta = oneof [return TypeTree,return TypeBlob,return TypeCommit,return TypeTag] - -arbitrarySmallList = frequency [ (2, return []), (1, resize 3 arbitrary) ] - -instance Arbitrary Commit where - arbitrary = Commit <$> arbitrary <*> arbitraryRefList <*> arbitraryName <*> arbitraryName <*> return Nothing <*> arbitrarySmallList <*> arbitraryMsg - -instance Arbitrary CommitExtra where - arbitrary = CommitExtra <$> arbitraryBSasciiNoSpace 80 <*> arbitraryMsg - -instance Arbitrary Tree where - arbitrary = Tree <$> arbitraryEnts - -instance Arbitrary Blob where - arbitrary = Blob <$> arbitraryLazy - -instance Arbitrary Tag where - arbitrary = Tag <$> arbitrary <*> arbitraryObjTypeNoDelta <*> arbitraryBSascii 20 <*> arbitraryName <*> arbitraryMsg - -instance Arbitrary ObjNoDelta where - arbitrary = ObjNoDelta <$> oneof - [ toObject <$> (arbitrary :: Gen Commit) - , toObject <$> (arbitrary :: Gen Tree) - , toObject <$> (arbitrary :: Gen Blob) - , toObject <$> (arbitrary :: Gen Tag) - ] - -prop_object_marshalling_id (ObjNoDelta obj) = obj `assertEq` (looseUnmarshall $ looseMarshall obj) - where assertEq a b - | show a == show b = True - | otherwise = error ("not equal:\n" ++ show a ++ "\ngot: " ++ show b) - -refTests = - [ testProperty "hexadecimal" (marshEqual (fromHex . toHex)) - , testProperty "binary" (marshEqual (fromBinary . toBinary)) - ] - where - marshEqual t ref = ref == t ref - -objTests = - [ testProperty "unmarshall.marshall==id" prop_object_marshalling_id - ] - -main = defaultMain $ testGroup "hit" - [ testGroup "ref marshalling" refTests - , testGroup "object marshalling" objTests - ] diff --git a/hit.cabal b/hit.cabal --- a/hit.cabal +++ b/hit.cabal @@ -1,15 +1,11 @@ Name: hit -Version: 0.6.3 -Synopsis: Git operations in haskell +Version: 0.7.0 +Synopsis: Git like program in haskell Description: . - An haskell implementation of git storage operations, allowing users - to manipulate git repositories (read and write). - . - This implementation is fully interoperable with the main C implementation. + Small haskell executable usable example using the git library . - This is stricly only manipulating the git store (what's inside the .git directory), - and doesn't do anything with the index or your working directory files. + Library component is available at 'git' . License: BSD3 License-file: LICENSE @@ -19,107 +15,28 @@ Category: Development Stability: experimental Build-Type: Simple -Homepage: http://github.com/vincenthz/hit +Homepage: https://github.com/vincenthz/hit Cabal-Version: >=1.8 data-files: README.md -extra-source-files: Tests/*.hs -Flag executable - Description: Build the executable - Default: False - Flag debug Description: Add some debugging options Default: False -Library - Build-Depends: base >= 4 && < 5 - , mtl - , bytestring >= 0.9 - , byteable - , attoparsec >= 0.10.1 - , parsec >= 3 - , containers - , system-filepath - , system-fileio - , cryptohash - , vector - , random - , zlib - , zlib-bindings >= 0.1 && < 0.2 - , hourglass >= 0.2 - , unix-compat - , utf8-string - , patience - Exposed-modules: Data.Git - Data.Git.Types - Data.Git.Storage - Data.Git.Storage.PackIndex - Data.Git.Storage.Pack - Data.Git.Storage.Object - Data.Git.Storage.Loose - Data.Git.Named - Data.Git.Delta - Data.Git.Ref - Data.Git.Revision - Data.Git.Repository - Data.Git.Diff - Other-modules: Data.Git.Internal - Data.Git.Config - Data.Git.Storage.FileReader - Data.Git.Storage.FileWriter - Data.Git.Storage.CacheFile - Data.Git.Path - Data.Git.WorkTree - ghc-options: -Wall -fno-warn-missing-signatures - Executable Hit Main-Is: Hit.hs hs-source-dirs: Hit ghc-options: -Wall -fno-warn-orphans -fno-warn-missing-signatures if flag(debug) ghc-options: -rtsopts -auto-all -caf-all - if flag(executable) - Build-depends: base >= 4 && < 5 - , mtl + Build-depends: base >= 4 && < 7 , containers , hashable >= 1.2 , hashtables , bytestring - , attoparsec >= 0.10.1 - , parsec >= 3 - , filepath - , directory - , hit , hourglass - , patience - Buildable: True - else - Buildable: False - -Test-Suite test-unit - type: exitcode-stdio-1.0 - hs-source-dirs: Tests - Main-Is: Tests.hs - Build-depends: base >= 3 && < 7 - , bytestring - , tasty - , tasty-quickcheck - , hourglass - , hit - -Test-Suite test-repository - type: exitcode-stdio-1.0 - hs-source-dirs: Tests - Main-Is: Repo.hs - Build-depends: base >= 3 && < 7 - , bytestring - , tasty - , tasty-quickcheck - , hourglass - , bytedump >= 1.0 - , hit + , git >= 0.3.0 source-repository head type: git - location: git://github.com/vincenthz/hit + location: https://github.com/vincenthz/hit