hit-0.6.3/0000755000000000000000000000000012453446436010505 5ustar0000000000000000hit-0.6.3/hit.cabal0000644000000000000000000000775112453446436012267 0ustar0000000000000000Name: hit Version: 0.6.3 Synopsis: Git operations in haskell Description: . An haskell implementation of git storage operations, allowing users to manipulate git repositories (read and write). . This implementation is fully interoperable with the main C implementation. . This is stricly only manipulating the git store (what's inside the .git directory), and doesn't do anything with the index or your working directory files. . License: BSD3 License-file: LICENSE Copyright: Vincent Hanquez Author: Vincent Hanquez Maintainer: Vincent Hanquez Category: Development Stability: experimental Build-Type: Simple Homepage: http://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 , 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 source-repository head type: git location: git://github.com/vincenthz/hit hit-0.6.3/LICENSE0000644000000000000000000000273212453446436011516 0ustar0000000000000000Copyright (c) 2010-2014 Vincent Hanquez All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of the author nor the names of his contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. hit-0.6.3/README.md0000644000000000000000000000377612453446436012001 0ustar0000000000000000Hit === 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) more examples on how to use api can be found in Hit.hs. hit-0.6.3/Setup.hs0000644000000000000000000000005612453446436012142 0ustar0000000000000000import Distribution.Simple main = defaultMain hit-0.6.3/Data/0000755000000000000000000000000012453446436011356 5ustar0000000000000000hit-0.6.3/Data/Git.hs0000644000000000000000000000267412453446436012446 0ustar0000000000000000-- | -- 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 hit-0.6.3/Data/Git/0000755000000000000000000000000012453446436012101 5ustar0000000000000000hit-0.6.3/Data/Git/Config.hs0000644000000000000000000000570612453446436013652 0ustar0000000000000000-- | -- 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 hit-0.6.3/Data/Git/Delta.hs0000644000000000000000000000627712453446436013502 0ustar0000000000000000-- | -- 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 hit-0.6.3/Data/Git/Diff.hs0000644000000000000000000002721712453446436013316 0ustar0000000000000000-- | -- 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 hit-0.6.3/Data/Git/Internal.hs0000644000000000000000000000214512453446436014213 0ustar0000000000000000-- | -- 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 hit-0.6.3/Data/Git/Named.hs0000644000000000000000000001730712453446436013471 0ustar0000000000000000-- | -- 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 hit-0.6.3/Data/Git/Path.hs0000644000000000000000000000307712453446436013340 0ustar0000000000000000-- | -- 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")) hit-0.6.3/Data/Git/Ref.hs0000644000000000000000000001033712453446436013155 0ustar0000000000000000-- | -- 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 hit-0.6.3/Data/Git/Repository.hs0000644000000000000000000003026212453446436014617 0ustar0000000000000000{-# 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 hit-0.6.3/Data/Git/Revision.hs0000644000000000000000000000547612453446436014247 0ustar0000000000000000-- | -- 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 hit-0.6.3/Data/Git/Storage.hs0000644000000000000000000003400512453446436014043 0ustar0000000000000000{-# 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 hit-0.6.3/Data/Git/Types.hs0000644000000000000000000001446512453446436013553 0ustar0000000000000000-- | -- 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) hit-0.6.3/Data/Git/WorkTree.hs0000644000000000000000000001237312453446436014205 0ustar0000000000000000{-# 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 hit-0.6.3/Data/Git/Storage/0000755000000000000000000000000012453446436013505 5ustar0000000000000000hit-0.6.3/Data/Git/Storage/CacheFile.hs0000644000000000000000000000326012453446436015645 0ustar0000000000000000{-# 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 hit-0.6.3/Data/Git/Storage/FileReader.hs0000644000000000000000000002036212453446436016046 0ustar0000000000000000-- | -- 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 hit-0.6.3/Data/Git/Storage/FileWriter.hs0000644000000000000000000000351012453446436016114 0ustar0000000000000000-- | -- 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 hit-0.6.3/Data/Git/Storage/Loose.hs0000644000000000000000000001576412453446436015137 0ustar0000000000000000-- | -- 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 hit-0.6.3/Data/Git/Storage/Object.hs0000644000000000000000000002643712453446436015263 0ustar0000000000000000{-# 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 hit-0.6.3/Data/Git/Storage/Pack.hs0000644000000000000000000001461612453446436014727 0ustar0000000000000000-- | -- 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" hit-0.6.3/Data/Git/Storage/PackIndex.hs0000644000000000000000000001721012453446436015710 0ustar0000000000000000-- | -- 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) hit-0.6.3/Hit/0000755000000000000000000000000012453446436011231 5ustar0000000000000000hit-0.6.3/Hit/Hit.hs0000644000000000000000000002507412453446436012321 0ustar0000000000000000{-# LANGUAGE BangPatterns #-} -- | -- Module : Hit -- License : BSD-style -- Maintainer : Vincent Hanquez -- Stability : experimental -- Portability : unix -- module Main where import System.Environment import Control.Applicative ((<$>)) import Control.Monad import Data.IORef import Data.Maybe import Data.Git.Storage.Pack import Data.Git.Storage.Object import Data.Git.Storage import Data.Git.Types import Data.Git.Ref import Data.Git.Repository import Data.Git.Revision import Data.Git.Diff import Data.Hourglass import Data.Word import qualified Data.Set as S import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Char8 as BC import Text.Printf import qualified Data.Map as M import qualified Data.HashTable.IO as H import qualified Data.Hashable as Hashable import Data.Algorithm.Patience as AP (Item(..)) type HashTable k v = H.CuckooHashTable k v instance Hashable.Hashable Ref where hashWithSalt salt = Hashable.hashWithSalt salt . toBinary verifyPack pref git = do offsets <- H.new tree <- H.new refs <- newIORef M.empty entries <- fromIntegral <$> packReadHeader (gitRepoPath git) pref leftParsed <- newIORef entries -- enumerate all objects either directly in tree for fully formed objects -- or a list of delta to resolves packEnumerateObjects (gitRepoPath git) pref entries (setObj leftParsed refs offsets tree) readIORefAndReplace refs M.empty >>= dumpTree offsets tree where readIORefAndReplace ioref emptyVal = do v <- readIORef ioref writeIORef ioref emptyVal return v setObj_ refs offsets tree (!info, objData) | objectTypeIsDelta (poiType info) = do (!ty, !ref, !ptr, !lenChain) <- do let loc = Packed pref (poiOffset info) objInfo <- maybe (error "cannot find delta chain") id <$> getObjectRawAt git loc True let (ty, sz, _) = oiHeader objInfo let !ref = objectHash ty sz (oiData objInfo) let ptr = head $ oiChains objInfo -- it's safe since deltas always have a non empty valid chain return (ty, ref, ptr, (length $ oiChains objInfo)) H.insert tree ref (info { poiType = ty }, Just (ptr, lenChain)) | otherwise = do let !ref = objectHash (poiType info) (poiActualSize info) objData modifyIORef refs (M.insert ref ()) H.insert offsets (poiOffset info) ref H.insert tree ref (info,Nothing) setObj leftParsed refs offsets tree x = do parsed <- readIORef leftParsed when ((parsed `mod` 256) == 0) $ putStrLn (show parsed ++ " left to parse") modifyIORef leftParsed (\i -> i-1) setObj_ refs offsets tree x dumpTree :: HashTable Word64 Ref -> HashTable Ref (PackedObjectInfo, Maybe (ObjectPtr, Int)) -> M.Map Ref () -> IO () dumpTree offsets tree refs = do forM_ (M.toAscList refs) $ \(ref, ()) -> do ent <- fromJust <$> H.lookup tree ref printEnt offsets ref ent -- print one line about the entry -- format is [ ] printEnt _ ref (info,Nothing) = do printf "%s %-6s %d %d %d\n" (show ref) (objectTypeMarshall $ poiType info) (poiActualSize info) (poiSize info) (poiOffset info) printEnt offsets ref (info,Just (parentOffset, lenChain)) = do parentRef <- case parentOffset of PtrRef r -> return r PtrOfs off -> do let poff = poiOffset info - off maybe (error "cannot find delta's parent in pack ?") id <$> H.lookup offsets poff printf "%s %-6s %d %d %d %d %s\n" (show ref) (objectTypeMarshall $ poiType info) (poiActualSize info) (poiSize info) (poiOffset info) (lenChain) (show parentRef) catFile ty ref git = do let expectedType = case ty of "commit" -> Just TypeCommit "blob" -> Just TypeBlob "tag" -> Just TypeTag "tree" -> Just TypeTree "-t" -> Nothing _ -> error "unknown type request" mobj <- getObjectRaw git ref True case mobj of Nothing -> error "not a valid object" Just obj -> let (objty, _, _) = oiHeader obj in case expectedType of Nothing -> putStrLn $ objectTypeMarshall objty Just ety -> do when (ety /= objty) $ error "not expected type" LC.putStrLn (oiData obj) lsTree revision _ git = do ref <- maybe (error "revision cannot be found") id <$> resolveRevision git revision tree <- resolveTreeish git ref case tree of Just t -> do htree <- buildHTree git t mapM_ (showTreeEnt) htree _ -> error "cannot build a tree from this reference" where showTreeEnt (ModePerm p,n,TreeDir r _) = printf "%06o tree %s %s\n" p (show r) (show n) showTreeEnt (ModePerm p,n,TreeFile r) = printf "%06o blob %s %s\n" p (show r) (show n) revList revision git = do ref <- maybe (error "revision cannot be found") id <$> resolveRevision git revision loopTillEmpty ref where loopTillEmpty ref = do commit <- getCommit git ref putStrLn $ show ref -- this behave like rev-list --first-parent. -- otherwise the parents need to be organized and printed -- in a reverse chronological fashion. case commitParents commit of [] -> return () (p:_) -> loopTillEmpty p getLog revision git = do ref <- maybe (error "revision cannot be found") id <$> resolveRevision git revision commit <- getCommit git ref printCommit ref commit where printCommit ref commit = do mapM_ putStrLn [ ("commit: " ++ show ref) , ("author: " ++ BC.unpack (personName author) ++ " <" ++ BC.unpack (personEmail author) ++ ">") , ("date: " ++ timePrint ISO8601_DateAndTime (personTime author) ++ " (" ++ timePrint ISO8601_DateAndTime (personTime author) ++ ")") , "" , BC.unpack $ commitMessage commit ] return () where author = commitAuthor commit 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 hd = do printFileName $ hFileName hd printFileMode $ hFileMode hd printFileRef $ hFileRef hd printFileDiff $ hFileContent hd printFileName :: EntPath -> IO () printFileName filename = putStrLn $ "Hit.Diff on file: " ++ (show filename) printFileMode :: HitFileMode -> 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 (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 NewBinaryFile = putStrLn "Binary file created" printFileDiff OldBinaryFile = putStrLn "Binary file deleted" printFileDiff ModifiedBinaryFile = putStrLn "Binary file modified" printFileDiff UnModifiedFile = putStrLn "No changes in the file's content" printFileDiff (NewTextFile l) = mapM_ (printFileLine "+") l printFileDiff (OldTextFile l) = mapM_ (printFileLine "-") l printFileDiff (ModifiedFile fDiff) = mapM_ printFilteredDiff fDiff printFilteredDiff :: FilteredDiff -> IO () printFilteredDiff (NormalLine l) = case l of (Both (TextLine on ol) (TextLine nn _ )) -> printf "%4d %4d %s\n" on nn (LC.unpack ol) (New (TextLine nn nl)) -> printf " %4d +%s\n" nn (LC.unpack nl) (Old (TextLine on ol) ) -> printf "%4d -%s\n" on (LC.unpack ol) printFilteredDiff _ = putStrLn " [...]" printFileLine :: String -> TextLine -> IO () printFileLine prefix (TextLine _ line) = putStrLn $ prefix ++ (LC.unpack line) showRefs git = do putStrLn "[BRANCHES]" heads <- branchList git mapM_ (putStrLn . refNameRaw) $ S.toList heads putStrLn "[TAGS]" tags <- tagList git mapM_ (putStrLn . refNameRaw) $ S.toList tags main = do args <- getArgs case args of ["verify-pack",ref] -> withCurrentRepo $ verifyPack (fromHexString ref) ["cat-file",ty,ref] -> withCurrentRepo $ catFile ty (fromHexString ref) ["ls-tree",rev] -> withCurrentRepo $ lsTree (fromString rev) "" ["ls-tree",rev,path] -> withCurrentRepo $ lsTree (fromString rev) path ["rev-list",rev] -> withCurrentRepo $ revList (fromString rev) ["log",rev] -> withCurrentRepo $ getLog (fromString rev) ["diff",rev1,rev2] -> withCurrentRepo $ showDiff (fromString rev1) (fromString rev2) ["tag"] -> withCurrentRepo $ showRefs ["show-refs"] -> withCurrentRepo $ showRefs ["read-config"] -> withCurrentRepo $ \git -> configGetAll git >>= putStrLn . show ["config",section,value] -> withCurrentRepo $ \git -> configGet git section value >>= putStrLn . show cmd : [] -> error ("unknown command: " ++ cmd) [] -> error "no args" _ -> error "unknown command line arguments" hit-0.6.3/Tests/0000755000000000000000000000000012453446436011607 5ustar0000000000000000hit-0.6.3/Tests/Repo.hs0000644000000000000000000000364012453446436013053 0ustar0000000000000000import 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 () hit-0.6.3/Tests/Tests.hs0000644000000000000000000000751612453446436013256 0ustar0000000000000000import 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 ]