diff --git a/Data/Git/Delta.hs b/Data/Git/Delta.hs --- a/Data/Git/Delta.hs +++ b/Data/Git/Delta.hs @@ -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 diff --git a/Data/Git/Diff.hs b/Data/Git/Diff.hs --- a/Data/Git/Diff.hs +++ b/Data/Git/Diff.hs @@ -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)] diff --git a/Data/Git/Ref.hs b/Data/Git/Ref.hs --- a/Data/Git/Ref.hs +++ b/Data/Git/Ref.hs @@ -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 diff --git a/Data/Git/Repository.hs b/Data/Git/Repository.hs --- a/Data/Git/Repository.hs +++ b/Data/Git/Repository.hs @@ -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 diff --git a/Data/Git/Revision.hs b/Data/Git/Revision.hs --- a/Data/Git/Revision.hs +++ b/Data/Git/Revision.hs @@ -20,12 +20,12 @@ -- | 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) + 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) = "^" @@ -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 diff --git a/Data/Git/Storage.hs b/Data/Git/Storage.hs --- a/Data/Git/Storage.hs +++ b/Data/Git/Storage.hs @@ -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. diff --git a/Data/Git/Types.hs b/Data/Git/Types.hs --- a/Data/Git/Types.hs +++ b/Data/Git/Types.hs @@ -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) diff --git a/Hit/Hit.hs b/Hit/Hit.hs --- a/Hit/Hit.hs +++ b/Hit/Hit.hs @@ -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 () diff --git a/hit.cabal b/hit.cabal --- a/hit.cabal +++ b/hit.cabal @@ -1,5 +1,5 @@ Name: hit -Version: 0.5.3 +Version: 0.5.4 Synopsis: Git operations in haskell Description: .