diff --git a/Data/Git/Diff.hs b/Data/Git/Diff.hs new file mode 100644 --- /dev/null +++ b/Data/Git/Diff.hs @@ -0,0 +1,183 @@ +-- | +-- Module : Data.Git.Diff +-- License : BSD-style +-- Maintainer : Nicolas DI PRIMA +-- Stability : experimental +-- Portability : unix +-- + +module Data.Git.Diff + ( + -- * Basic features + BlobContent(..) + , BlobState(..) + , BlobStateDiff(..) + , getDiffWith + -- * Default helpers + , HitDiffContent(..) + , HitDiff(..) + , defaultDiff + , getDiff + ) where + +import Control.Applicative ((<$>)) + +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.ByteString.Char8 as BS + +import Data.Algorithm.Patience as AP (Item(..), diff) + +data BlobContent = FileContent [L.ByteString] | BinaryContent L.ByteString + deriving (Show) + +-- | This is a blob description. +data BlobState = BlobState + { bsFilename :: BS.ByteString + , bsMode :: Int + , bsRef :: Ref + , bsContent :: BlobContent + } + deriving (Show) +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 + +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 + +buildListForDiff :: Git -> Revision -> IO [BlobState] +buildListForDiff git revision = do + ref <- maybe (error "revision cannot be found") id <$> resolveRevision git revision + commit <- getCommit git ref + tree <- resolveTreeish git $ commitTreeish commit + case tree of + Just t -> do htree <- buildHTree git t + buildTreeList htree (BS.empty) + _ -> error "cannot build a tree from this reference" + where + buildTreeList :: HTree -> BS.ByteString -> 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 (BS.append pathPrefix n) d r (FileContent $ L.lines content)) : listTail + True -> return $ (BlobState (BS.append pathPrefix n) d r (BinaryContent content)) : listTail + buildTreeList ((_,n,TreeDir _ subTree):xs) pathPrefix = do + l1 <- buildTreeList xs pathPrefix + l2 <- buildTreeList subTree (BS.concat [pathPrefix, n, BS.pack "/"]) + return $ l1 ++ l2 + + catBlobFile :: Ref -> IO L.ByteString + catBlobFile ref = do + mobj <- getObjectRaw git ref 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: +-- 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 :: (BlobStateDiff -> a -> a) -- ^ diff helper (State -> accumulator -> accumulator) + -> a -- ^ accumulator + -> Revision -- ^ commit revision + -> Revision -- ^ commit revision + -> Git -- ^ repository + -> IO a +getDiffWith f acc rev1 rev2 git = do + commit1 <- buildListForDiff git rev1 + commit2 <- buildListForDiff git rev2 + 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) + + + +-- | This is an example of how you can use Hit to get all of information +-- between different revision. +data HitDiffContent = HitDiffAddition BlobState + | HitDiffDeletion BlobState + | HitDiffChange [AP.Item L.ByteString] + | HitDiffBinChange + | HitDiffMode Int Int + | HitDiffRefs Ref Ref + deriving (Show) + +-- | This represents a diff. +data HitDiff = HitDiff + { hitFilename :: BS.ByteString + , hitDiff :: [HitDiffContent] + } deriving (Show) + +-- | 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 + -> IO [HitDiff] +getDiff = getDiffWith defaultDiff [] + +-- | A defaiult 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 = + 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 + where + createANewDiff :: BlobContent -> BlobContent -> [HitDiffContent] + createANewDiff (FileContent a) (FileContent b) = [HitDiffChange (diff a b)] + createANewDiff (BinaryContent a) (BinaryContent b) = if a /= b then [HitDiffBinChange] else [] + createANewDiff _ _ = [HitDiffBinChange] + + onlyBothDiff :: HitDiffContent -> Bool + onlyBothDiff (HitDiffBinChange) = False + onlyBothDiff (HitDiffChange l) = Prelude.all predicate l + where predicate (Both _ _) = True + predicate _ = False + onlyBothDiff _ = True diff --git a/Data/Git/Repository.hs b/Data/Git/Repository.hs --- a/Data/Git/Repository.hs +++ b/Data/Git/Repository.hs @@ -68,7 +68,7 @@ -- | 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 + where err = throw $ InvalidType ref TypeCommit -- | get a specified tree getTreeMaybe :: Git -> Ref -> IO (Maybe Tree) @@ -77,75 +77,75 @@ -- | 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 + 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 - ] + 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 M.lookup refty lookupCache of - Nothing -> onFailure - y -> return y + resolveNamedPrefix _ [] = return Nothing + resolveNamedPrefix lookupCache (x:xs) = followToRef (resolveNamedPrefix lookupCache xs) x + where followToRef onFailure refty = do + exists <- existsRefFile (gitRepoPath git) refty + if exists + then do refcont <- readRefFile (gitRepoPath git) refty + case refcont of + RefDirect ref -> return $ Just ref + RefLink refspecty -> followToRef onFailure refspecty + _ -> error "cannot handle reference content" + else case M.lookup refty lookupCache of + Nothing -> onFailure + y -> return y - namedResolvers = case prefix of - "HEAD" -> [ RefHead ] - "ORIG_HEAD" -> [ RefOrigHead ] - "FETCH_HEAD" -> [ RefFetchHead ] - _ -> [ RefTag prefix, RefBranch prefix, RefRemote prefix ] + namedResolvers = case prefix of + "HEAD" -> [ RefHead ] + "ORIG_HEAD" -> [ RefOrigHead ] + "FETCH_HEAD" -> [ RefFetchHead ] + _ -> [ RefTag prefix, RefBranch prefix, RefRemote prefix ] - 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 + 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" + 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 [] 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" + 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 + 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 +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 @@ -173,35 +173,35 @@ 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)] + 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 + 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 + 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" + 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 @@ -209,16 +209,15 @@ -> [ByteString] -- ^ paths -> IO (Maybe Ref) resolvePath git commitRef paths = - getCommit git commitRef >>= \commit -> resolve (commitTreeish commit) paths - where - resolve :: Ref -> [ByteString] -> 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 + getCommit git commitRef >>= \commit -> resolve (commitTreeish commit) paths + where resolve :: Ref -> [ByteString] -> 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 + findEnt x = find (\(_, b, _) -> b == x) + treeEntRef (_,_,r) = r diff --git a/Data/Git/Storage.hs b/Data/Git/Storage.hs --- a/Data/Git/Storage.hs +++ b/Data/Git/Storage.hs @@ -20,6 +20,8 @@ , findRepo , isRepo , initRepo + , getDescription + , setDescription , iterateIndexes , findReference , findReferencesWithPrefix @@ -69,7 +71,7 @@ -- | this is a cache representation of the packed-ref file type PackedRef = CacheFile (M.Map RefSpecTy Ref) --- | represent an git repo, with possibly already opened filereaders +-- | represent a git repo, with possibly already opened filereaders -- for indexes and packs data Git = Git { gitRepoPath :: FilePath @@ -157,6 +159,25 @@ [ "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) diff --git a/Data/Git/Storage/Object.hs b/Data/Git/Storage/Object.hs --- a/Data/Git/Storage/Object.hs +++ b/Data/Git/Storage/Object.hs @@ -59,8 +59,7 @@ import Data.Word import Text.Printf -import Blaze.ByteString.Builder -import Blaze.ByteString.Builder.Char8 +import Data.ByteString.Lazy.Builder hiding (word8) -- | location of an object in the database data ObjectLocation = NotFound | Loose Ref | Packed Ref Word64 @@ -238,47 +237,47 @@ treeWrite (Tree ents) = toLazyByteString $ mconcat $ concatMap writeTreeEnt ents where writeTreeEnt (perm,name,ref) = - [ fromString (printf "%o" perm) - , fromString " " - , fromByteString name - , fromString "\0" - , fromByteString $ toBinary ref + [ string7 (printf "%o" perm) + , string7 " " + , byteString name + , string7 "\0" + , byteString $ toBinary ref ] commitWrite (Commit tree parents author committer encoding extra msg) = toLazyByteString $ mconcat els where - toNamedRef s r = mconcat [fromString s, fromByteString (toHex r),eol] + toNamedRef s r = mconcat [string7 s, byteString (toHex r),eol] toParent = toNamedRef "parent " toCommitExtra :: CommitExtra -> [Builder] - toCommitExtra (CommitExtra k v) = [fromByteString k, eol] ++ - (concatMap (\l -> [fromByteString " ", fromByteString l, eol]) $ linesLast v) + 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 - ++ [fromByteString $ writeName "author" author, eol - ,fromByteString $ writeName "committer" committer, eol - ,maybe (fromByteString B.empty) (fromByteString) encoding -- FIXME need eol + ++ [byteString $ writeName "author" author, eol + ,byteString $ writeName "committer" committer, eol + ,maybe (byteString B.empty) (byteString) encoding -- FIXME need eol ] ++ concatMap toCommitExtra extra ++ [eol - ,fromByteString msg + ,byteString msg ] tagWrite (Tag ref ty tag tagger signature) = toLazyByteString $ mconcat els - where els = [ fromString "object ", fromByteString (toHex ref), eol - , fromString "type ", fromString (objectTypeMarshall ty), eol - , fromString "tag ", fromByteString tag, eol - , fromByteString $ writeName "tagger" tagger, eol + 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 - , fromByteString signature + , byteString signature ] -eol = fromString "\n" +eol = string7 "\n" blobWrite (Blob bData) = bData diff --git a/Data/Git/Types.hs b/Data/Git/Types.hs --- a/Data/Git/Types.hs +++ b/Data/Git/Types.hs @@ -21,6 +21,7 @@ , GitTime(..) , toUTCTime , toPOSIXTime + , toZonedTime -- * Pack delta types , DeltaOfs(..) , DeltaRef(..) @@ -36,6 +37,7 @@ import Data.Git.Ref import Data.Git.Delta import Data.Time.Clock +import Data.Time.LocalTime import Data.Time.Clock.POSIX import Data.Data @@ -49,15 +51,23 @@ | TypeDeltaRef deriving (Show,Eq,Data,Typeable) --- | Git time is number of seconds since unix epoch +-- | Git time is number of seconds since unix epoch with a timezone data GitTime = GitTime Integer Int deriving (Show,Eq) toUTCTime :: GitTime -> UTCTime -toUTCTime (GitTime seconds _) = posixSecondsToUTCTime $ fromIntegral seconds +toUTCTime = zonedTimeToUTC . toZonedTime toPOSIXTime :: GitTime -> POSIXTime toPOSIXTime = utcTimeToPOSIXSeconds . toUTCTime + +toZonedTime :: GitTime -> ZonedTime +toZonedTime (GitTime epoch tzHourMin) = zonedTime + where tz = minutesToTimeZone (signum h * minutes) + (h,m) = tzHourMin `divMod` 100 + minutes = abs h * 60 + m + utcTime = posixSecondsToUTCTime $ fromIntegral epoch + zonedTime = utcToZonedTime tz utcTime -- | the enum instance is useful when marshalling to pack file. instance Enum ObjectType where diff --git a/Hit/Hit.hs b/Hit/Hit.hs --- a/Hit/Hit.hs +++ b/Hit/Hit.hs @@ -20,6 +20,7 @@ import Data.Git.Ref import Data.Git.Repository import Data.Git.Revision +import Data.Git.Diff import Data.Word import qualified Data.ByteString.Lazy.Char8 as LC import qualified Data.ByteString.Char8 as BC @@ -28,6 +29,8 @@ 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 @@ -145,6 +148,69 @@ [] -> 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: " ++ show (toZonedTime $ personTime author) ++ " (" ++ show (toUTCTime $ personTime author) ++ ")") + , "" + , BC.unpack $ commitMessage commit + ] + return () + where author = commitAuthor commit + +showDiff rev1 rev2 git = do + diffList <- getDiff rev1 rev2 git + mapM_ showADiff diffList + where + showADiff :: HitDiff -> IO () + showADiff hd = do + let filename = BC.unpack $ hitFilename hd + putStrLn $ "Diff --hit old/" ++ filename ++ " new/" ++ filename + ppHitMode $ hitDiff hd + ppHitRefs $ hitDiff hd + ppHitDiff $ hitDiff hd + + ppHitMode :: [HitDiffContent] -> IO () + ppHitMode [] = return () + ppHitMode ((HitDiffMode old new):_ ) = printf "old mode %06o\nnew mode %06o\n" old new + ppHitMode (_ :xs) = ppHitMode xs + + ppHitRefs :: [HitDiffContent] -> IO () + ppHitRefs [] = return () + ppHitRefs ((HitDiffRefs old new):_ ) = printf "--- old: %s\n+++ new: %s\n" (show old) (show new) + ppHitRefs ((HitDiffAddition new):_ ) = printf "--- old: dev/null\n+++ new: %s\n" (show $ bsRef new) + ppHitRefs ((HitDiffDeletion old):_ ) = printf "--- old: %s\n+++ new: dev/null\n" (show $ bsRef old) + ppHitRefs (_ :xs) = ppHitRefs xs + + ppHitDiff :: [HitDiffContent] -> IO () + ppHitDiff [] = return () + ppHitDiff ((HitDiffAddition new):_ ) = + case bsContent new of + FileContent content -> printf "%s" (LC.unpack $ LC.concat $ doPPDiffLine "+" content) + _ -> return () + ppHitDiff ((HitDiffDeletion old):_ ) = + case bsContent old of + FileContent content -> printf "%s" (LC.unpack $ LC.concat $ doPPDiffLine "-" content) + _ -> return () + ppHitDiff ((HitDiffChange l ):_ ) = printf "%s" (LC.unpack $ LC.concat $ doPPDiff l) + ppHitDiff ((HitDiffBinChange ):_ ) = putStrLn "Binary files differ" + ppHitDiff (_ :xs) = ppHitDiff xs + + doPPDiff :: [Item LC.ByteString] -> [LC.ByteString] + doPPDiff [] = [] + doPPDiff ((Both a _):xs) = (doPPDiffLine " " [a]) ++ (doPPDiff xs) + doPPDiff ((Old a ):xs) = (doPPDiffLine "-" [a]) ++ (doPPDiff xs) + doPPDiff ((New b):xs) = (doPPDiffLine "+" [b]) ++ (doPPDiff xs) + + doPPDiffLine :: String -> [LC.ByteString] -> [LC.ByteString] + doPPDiffLine _ [] = [] + doPPDiffLine prefix (a:xs) = (LC.concat [LC.pack prefix,a,LC.pack "\n"]):(doPPDiffLine prefix xs) + main = do args <- getArgs case args of @@ -153,6 +219,8 @@ ["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) cmd : [] -> error ("unknown command: " ++ cmd) [] -> error "no args" _ -> error "unknown command line arguments" diff --git a/hit.cabal b/hit.cabal --- a/hit.cabal +++ b/hit.cabal @@ -1,5 +1,5 @@ Name: hit -Version: 0.5.0 +Version: 0.5.1 Synopsis: Git operations in haskell Description: . @@ -35,8 +35,7 @@ Library Build-Depends: base >= 4 && < 5 , mtl - , bytestring - , blaze-builder + , bytestring >= 0.10 , attoparsec >= 0.10.1 , parsec >= 3 , containers @@ -48,6 +47,7 @@ , zlib , zlib-bindings >= 0.1 && < 0.2 , time + , patience Exposed-modules: Data.Git Data.Git.Types Data.Git.Storage @@ -60,6 +60,7 @@ Data.Git.Ref Data.Git.Revision Data.Git.Repository + Data.Git.Diff Other-modules: Data.Git.Internal Data.Git.Storage.FileReader Data.Git.Storage.FileWriter @@ -85,6 +86,7 @@ , filepath , directory , hit + , patience Buildable: True else Buildable: False