hit 0.5.0 → 0.5.1
raw patch · 7 files changed
+396/−114 lines, 7 filesdep +patiencedep −blaze-builderdep ~bytestring
Dependencies added: patience
Dependencies removed: blaze-builder
Dependency ranges changed: bytestring
Files
- Data/Git/Diff.hs +183/−0
- Data/Git/Repository.hs +87/−88
- Data/Git/Storage.hs +22/−1
- Data/Git/Storage/Object.hs +19/−20
- Data/Git/Types.hs +12/−2
- Hit/Hit.hs +68/−0
- hit.cabal +5/−3
+ Data/Git/Diff.hs view
@@ -0,0 +1,183 @@+-- |+-- Module : Data.Git.Diff+-- License : BSD-style+-- Maintainer : Nicolas DI PRIMA <nicolas@di-prima.fr>+-- 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
Data/Git/Repository.hs view
@@ -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
Data/Git/Storage.hs view
@@ -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)
Data/Git/Storage/Object.hs view
@@ -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
Data/Git/Types.hs view
@@ -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
Hit/Hit.hs view
@@ -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"
hit.cabal view
@@ -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