hit 0.5.3 → 0.5.4
raw patch · 9 files changed
+346/−336 lines, 9 files
Files
- Data/Git/Delta.hs +45/−45
- Data/Git/Diff.hs +53/−34
- Data/Git/Ref.hs +42/−44
- Data/Git/Repository.hs +15/−15
- Data/Git/Revision.hs +10/−10
- Data/Git/Storage.hs +141/−150
- Data/Git/Types.hs +36/−36
- Hit/Hit.hs +3/−1
- hit.cabal +1/−1
Data/Git/Delta.hs view
@@ -6,12 +6,12 @@ -- Portability : unix -- module Data.Git.Delta- ( Delta(..)- , DeltaCmd(..)- , deltaParse- , deltaRead- , deltaApply- ) where+ ( Delta(..)+ , DeltaCmd(..)+ , deltaParse+ , deltaRead+ , deltaApply+ ) where import Data.Attoparsec import qualified Data.Attoparsec as A@@ -26,13 +26,13 @@ -- | a delta is a source size, a destination size and a list of delta cmd data Delta = Delta Word64 Word64 [DeltaCmd]- deriving (Show,Eq)+ 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)+ 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:@@ -40,35 +40,35 @@ -- * otherwise, we copy from delta. -- * extensions are not handled. deltaParse = do- srcSize <- getDeltaHdrSize- resSize <- getDeltaHdrSize- dcmds <- many (anyWord8 >>= parseWithCmd)- return $ Delta srcSize resSize dcmds- where- getDeltaHdrSize = do- z <- A.takeWhile (\w -> w `testBit` 7)- l <- anyWord8- return $ unbytes 0 $ (map (\w -> w `clearBit` 7) (B.unpack z) ++ [l])- -- use a foldl ..- unbytes _ [] = 0- unbytes sh (x:xs) = (fromIntegral x) `shiftL` sh + unbytes (sh+7) xs- -- parse one command, either an extension, a copy from src, or a copy from delta.- parseWithCmd cmd- | cmd == 0 = error "delta extension not supported"- | cmd `testBit` 7 = do- o1 <- word8cond (cmd `testBit` 0) 0- o2 <- word8cond (cmd `testBit` 1) 8- o3 <- word8cond (cmd `testBit` 2) 16 - o4 <- word8cond (cmd `testBit` 3) 24- s1 <- word8cond (cmd `testBit` 4) 0- s2 <- word8cond (cmd `testBit` 5) 8- s3 <- word8cond (cmd `testBit` 6) 16 - let offset = o1 .|. o2 .|. o3 .|. o4- let size = s1 .|. s2 .|. s3- return $ DeltaSrc offset (if size == 0 then 0x10000 else size)- | otherwise = DeltaCopy <$> A.take (fromIntegral cmd)- word8cond cond sh = do- if cond then (flip shiftL sh . fromIntegral) <$> anyWord8 else return 0+ 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@@ -76,9 +76,9 @@ -- | 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+ | L.length src /= fromIntegral srcSize = error "source size do not match"+ | otherwise = -- FIXME use a bytestring builder here.+ L.fromChunks $ concatMap resolve deltaCmds+ where resolve (DeltaSrc o s) = L.toChunks $ takeAt (fromIntegral s) (fromIntegral o) src+ resolve (DeltaCopy b) = [b]+ takeAt sz at = L.take sz . L.drop at
Data/Git/Diff.hs view
@@ -5,6 +5,8 @@ -- Stability : experimental -- Portability : unix --+-- Basic Git diff methods.+-- module Data.Git.Diff (@@ -33,10 +35,13 @@ import Data.Algorithm.Patience as AP (Item(..), diff) -data BlobContent = FileContent [L.ByteString] | BinaryContent L.ByteString+-- | 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.+-- | This is a blob description at a given state (revision) data BlobState = BlobState { bsFilename :: BS.ByteString , bsMode :: Int@@ -44,14 +49,21 @@ , 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 references-data BlobStateDiff = OnlyOld BlobState- | OnlyNew BlobState- | OldAndNew BlobState BlobState+-- | 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 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)@@ -68,9 +80,8 @@ let bs = L.take 512 file in getBinaryStat bs > 0.0 -buildListForDiff :: Git -> Revision -> IO [BlobState]-buildListForDiff git revision = do- ref <- maybe (error "revision cannot be found") id <$> resolveRevision git revision+buildListForDiff :: Git -> Ref -> IO [BlobState]+buildListForDiff git ref = do commit <- getCommit git ref tree <- resolveTreeish git $ commitTreeish commit case tree of@@ -93,28 +104,35 @@ return $ l1 ++ l2 catBlobFile :: Ref -> IO L.ByteString- catBlobFile ref = do- mobj <- getObjectRaw git ref True+ catBlobFile blobRef = do+ mobj <- getObjectRaw git blobRef True case mobj of Nothing -> error "not a valid object" Just obj -> return $ oiData obj -- | generate a diff list between two revisions with a given diff helper.--- Useful to extract any kind of information from two different revisions:+--+-- 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--- you even can get a 'full' diff: see defaultDiff+--+-- > 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- -> Revision -- ^ commit revision- -> Revision -- ^ commit revision+ -> Ref -- ^ commit reference (the original state)+ -> Ref -- ^ commit reference (the new state) -> Git -- ^ repository -> IO a-getDiffWith f acc rev1 rev2 git = do- commit1 <- buildListForDiff git rev1- commit2 <- buildListForDiff git rev2+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]@@ -128,8 +146,6 @@ in (OldAndNew bs1 bs2):(doDiffWith xs1 subxs2) Nothing -> (OnlyOld bs1):(doDiffWith xs1 xs2) -- -- | This is an example of how you can use Hit to get all of information -- between different revision. data HitDiffContent = HitDiffAddition BlobState@@ -148,27 +164,30 @@ -- | A default Diff getter which returns all diff information (Mode, Content -- and Binary).--- gitDiff = getDiffWith defaultDiff-getDiff :: Revision -- ^ commit revision- -> Revision -- ^ commit revision- -> Git -- ^ repository+--+-- > getDiff = getDiffWith defaultDiff+getDiff :: Ref -- ^ commit ref+ -> Ref -- ^ commit ref+ -> Git -- ^ repository -> IO [HitDiff] getDiff = getDiffWith defaultDiff [] --- | A defaiult diff helper. It is an example about how you can write your own+-- | 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 :: BlobStateDiff -> [HitDiff] -> [HitDiff] defaultDiff (OnlyOld old ) acc = (HitDiff (bsFilename old) ([HitDiffDeletion old])):acc defaultDiff (OnlyNew new) acc = (HitDiff (bsFilename new) ([HitDiffAddition new])):acc defaultDiff (OldAndNew old new) acc =+ let theDiffMode = if (bsMode old) == (bsMode new) then [] else [HitDiffMode (bsMode old) (bsMode new)] in case ((bsRef old) == (bsRef new)) of -- If the reference is the same, then there is no difference- True -> acc- False -> let theDiffMode = if (bsMode old) == (bsMode new) then [] else [HitDiffMode (bsMode old) (bsMode new)]- theDiff = createANewDiff (bsContent old) (bsContent new)- in if (onlyBothDiff $ Prelude.head theDiff)- then (HitDiff (bsFilename old) ((HitDiffRefs (bsRef old) (bsRef new)):theDiffMode)):acc- else (HitDiff (bsFilename old) ( theDiff ++ ((HitDiffRefs (bsRef old) (bsRef new)):theDiffMode))):acc+ True -> if Prelude.null theDiffMode+ then acc+ else (HitDiff (bsFilename old) theDiffMode):acc+ False -> let theDiff = createANewDiff (bsContent old) (bsContent new) in+ if (onlyBothDiff $ Prelude.head theDiff)+ then (HitDiff (bsFilename old) ((HitDiffRefs (bsRef old) (bsRef new)):theDiffMode)):acc+ else (HitDiff (bsFilename old) ( theDiff ++ ((HitDiffRefs (bsRef old) (bsRef new)):theDiffMode))):acc where createANewDiff :: BlobContent -> BlobContent -> [HitDiffContent] createANewDiff (FileContent a) (FileContent b) = [HitDiffChange (diff a b)]
Data/Git/Ref.hs view
@@ -45,19 +45,19 @@ -- | represent a git reference (SHA1) newtype Ref = Ref ByteString- deriving (Eq,Ord,Data,Typeable)+ deriving (Eq,Ord,Data,Typeable) instance Show Ref where- show = BC.unpack . toHex+ 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)+ deriving (Show,Eq,Data,Typeable) -- | Reference wasn't found data RefNotFound = RefNotFound Ref- deriving (Show,Eq,Data,Typeable)+ deriving (Show,Eq,Data,Typeable) instance Exception RefInvalid instance Exception RefNotFound@@ -69,36 +69,35 @@ -- 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+ | 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+ 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@@ -108,15 +107,14 @@ -- | 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+ 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@@ -126,8 +124,8 @@ -- and returns a ref. fromBinary :: ByteString -> Ref fromBinary b- | B.length b == 20 = Ref b- | otherwise = throw $ RefInvalid b -- should hexify the ref here+ | 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
Data/Git/Repository.hs view
@@ -9,21 +9,21 @@ -- Portability : unix -- module Data.Git.Repository- ( Git- , HTree- , HTreeEnt(..)- , getCommitMaybe- , getCommit- , getTreeMaybe- , getTree- , rewrite- , buildHTree- , resolvePath- , resolveTreeish- , resolveRevision- , initRepo- , isRepo- ) where+ ( Git+ , HTree+ , HTreeEnt(..)+ , getCommitMaybe+ , getCommit+ , getTreeMaybe+ , getTree+ , rewrite+ , buildHTree+ , resolvePath+ , resolveTreeish+ , resolveRevision+ , initRepo+ , isRepo+ ) where import Control.Applicative ((<$>)) import Control.Monad
Data/Git/Revision.hs view
@@ -20,12 +20,12 @@ -- | A modifier to a revision, which is -- a function apply of a revision data RevModifier =- RevModParent Int -- ^ parent accessor ^<n> and ^- | RevModParentFirstN Int -- ^ parent accessor ~<n>- | RevModAtType String -- ^ @{type} accessor- | RevModAtDate String -- ^ @{date} accessor- | RevModAtN Int -- ^ @{n} accessor- deriving (Eq,Data,Typeable)+ RevModParent Int -- ^ parent accessor ^<n> and ^+ | RevModParentFirstN Int -- ^ parent accessor ~<n>+ | RevModAtType String -- ^ @{type} accessor+ | RevModAtDate String -- ^ @{date} accessor+ | RevModAtN Int -- ^ @{n} accessor+ deriving (Eq,Data,Typeable) instance Show RevModifier where show (RevModParent 1) = "^"@@ -44,11 +44,11 @@ -- * type -- * date data Revision = Revision String [RevModifier]- deriving (Eq,Data,Typeable)+ deriving (Eq,Data,Typeable) -- | Exception when a revision cannot be resolved to a reference data RevisionNotFound = RevisionNotFound Revision- deriving (Show,Eq,Data,Typeable)+ deriving (Show,Eq,Data,Typeable) instance Show Revision where show (Revision s ms) = s ++ concatMap show ms@@ -56,8 +56,8 @@ instance IsString Revision where fromString = revFromString -revFromString s = either (error.show) id $ parse parser "" s where- parser = do+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
Data/Git/Storage.hs view
@@ -74,11 +74,11 @@ -- | 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 :: PackedRef- }+ { gitRepoPath :: FilePath+ , indexReaders :: IORef [(Ref, PackIndexReader)]+ , packReaders :: IORef [(Ref, FileReader)]+ , packedNamed :: PackedRef+ } -- | open a new git repository context openRepo :: FilePath -> IO Git@@ -88,9 +88,9 @@ -- | 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+ mapM_ (closeIndexReader . snd) =<< readIORef ireaders+ mapM_ (fileReaderClose . snd) =<< readIORef preaders+ where closeIndexReader (PackIndexReader _ fr) = fileReaderClose fr -- | Find the git repository from the current directory. --@@ -102,12 +102,12 @@ 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 </> "..")+ 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. --@@ -115,20 +115,19 @@ -- 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 </> "..")+ 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@@ -142,153 +141,148 @@ -- | 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 </>))- [ "branches", "hooks", "info"- , "logs", "objects", "refs"- , "refs"</> "heads", "refs"</> "tags"]- return $ and ([dir] ++ subDirs)+ dir <- isDirectory path+ subDirs <- mapM (isDirectory . (path </>))+ [ "branches", "hooks", "info"+ , "logs", "objects", "refs"+ , "refs"</> "heads", "refs"</> "tags"]+ return $ and ([dir] ++ subDirs) -- | initialize a new repository at a specific location. initRepo :: FilePath -> IO () initRepo path = do- exists <- 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"]+ 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"+ 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"+ 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+ 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+ 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+ 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+ 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)+ 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+ 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 + | 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)+ 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+ 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)+ (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)+ 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+ 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+ 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)@@ -299,23 +293,21 @@ -- | 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+ 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+ 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)+ where toObj (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData) -- | get an object from repository using a ref. getObject :: Git -- ^ repository@@ -323,8 +315,7 @@ -> 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)+ 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.
Data/Git/Types.hs view
@@ -43,13 +43,13 @@ -- | type of a git object. data ObjectType =- TypeTree- | TypeBlob- | TypeCommit- | TypeTag- | TypeDeltaOff- | TypeDeltaRef- deriving (Show,Eq,Data,Typeable)+ TypeTree+ | TypeBlob+ | TypeCommit+ | TypeTag+ | TypeDeltaOff+ | TypeDeltaRef+ deriving (Show,Eq,Data,Typeable) -- | Git time is number of seconds since unix epoch with a timezone data GitTime = GitTime Integer Int@@ -71,20 +71,20 @@ -- | 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+ 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)+ 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) -- | represent one entry in the tree -- (permission,file or directory name,blob or tree ref)@@ -114,14 +114,14 @@ -- | 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)+ { commitTreeish :: Ref+ , commitParents :: [Ref]+ , commitAuthor :: Person+ , commitCommitter :: Person+ , commitEncoding :: Maybe ByteString+ , commitExtras :: [CommitExtra]+ , commitMessage :: ByteString+ } deriving (Show,Eq) data CommitExtra = CommitExtra { commitExtraKey :: ByteString@@ -130,17 +130,17 @@ -- | Represent a signed tag. data Tag = Tag- { tagRef :: Ref- , tagObjectType :: ObjectType- , tagBlob :: ByteString- , tagName :: Person- , tagS :: ByteString- } deriving (Show,Eq)+ { 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)+ deriving (Show,Eq) -- | Delta pointing to a ref. data DeltaRef = DeltaRef Ref Delta- deriving (Show,Eq)+ deriving (Show,Eq)
Hit/Hit.hs view
@@ -164,7 +164,9 @@ where author = commitAuthor commit showDiff rev1 rev2 git = do- diffList <- getDiff rev1 rev2 git+ ref1 <- maybe (error "revision cannot be found") id <$> resolveRevision git rev1+ ref2 <- maybe (error "revision cannot be found") id <$> resolveRevision git rev2+ diffList <- getDiff ref1 ref2 git mapM_ showADiff diffList where showADiff :: HitDiff -> IO ()
hit.cabal view
@@ -1,5 +1,5 @@ Name: hit-Version: 0.5.3+Version: 0.5.4 Synopsis: Git operations in haskell Description: .