diff --git a/Data/Git.hs b/Data/Git.hs --- a/Data/Git.hs +++ b/Data/Git.hs @@ -16,6 +16,13 @@ , Blob(..) , Tag(..) , GitTime(..) + , ModePerm(..) + + -- * Helper & type related to ModePerm + , ObjectFileType(..) + , FilePermissions(..) + , getPermission + , getFiletype -- * Revision , Revision diff --git a/Data/Git/Diff.hs b/Data/Git/Diff.hs --- a/Data/Git/Diff.hs +++ b/Data/Git/Diff.hs @@ -16,14 +16,16 @@ , BlobStateDiff(..) , getDiffWith -- * Default helpers - , HitDiffContent(..) , HitDiff(..) + , HitFileContent(..) + , FilteredDiff(..) + , HitFileRef(..) + , HitFileMode(..) + , TextLine(..) , defaultDiff , getDiff ) where -import Control.Applicative ((<$>)) - import Data.List (find, filter) import Data.Char (ord) import Data.Git @@ -44,7 +46,7 @@ -- | This is a blob description at a given state (revision) data BlobState = BlobState { bsFilename :: BS.ByteString - , bsMode :: Int + , bsMode :: ModePerm , bsRef :: Ref , bsContent :: BlobContent } @@ -65,21 +67,6 @@ | 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 -> Ref -> IO [BlobState] buildListForDiff git ref = do commit <- getCommit git ref @@ -109,7 +96,20 @@ case mobj of Nothing -> error "not a valid object" Just obj -> return $ oiData obj + getBinaryStat :: L.ByteString -> Double + getBinaryStat bs = L.foldl' (\acc w -> acc + if isBin $ ord w then 1 else 0) 0 bs / (fromIntegral $ L.length bs) + where + isBin :: Int -> Bool + isBin i + | i >= 0 && i <= 8 = True + | i == 12 = True + | i >= 14 && i <= 31 = True + | otherwise = False + isBinaryFile :: L.ByteString -> Bool + isBinaryFile file = let bs = L.take 512 file + in getBinaryStat bs > 0.0 + -- | generate a diff list between two revisions with a given diff helper. -- -- Useful to extract any kind of information from two different revisions. @@ -146,57 +146,141 @@ 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) +data TextLine = TextLine + { lineNumber :: Integer + , lineContent :: L.ByteString + } +instance Eq TextLine where + a == b = (lineContent a) == (lineContent b) + a /= b = not (a == b) +instance Ord TextLine where + compare a b = compare (lineContent a) (lineContent b) + a < b = (lineContent a) < (lineContent b) + a <= b = (lineContent a) <= (lineContent b) + a > b = b < a + a >= b = b <= a --- | This represents a diff. +data FilteredDiff = NormalLine (Item TextLine) | Separator + +data HitFileContent = NewBinaryFile + | OldBinaryFile + | NewTextFile [TextLine] + | OldTextFile [TextLine] + | ModifiedBinaryFile + | ModifiedFile [FilteredDiff] + | UnModifiedFile + +data HitFileMode = NewMode ModePerm + | OldMode ModePerm + | ModifiedMode ModePerm ModePerm + | UnModifiedMode ModePerm + +data HitFileRef = NewRef Ref + | OldRef Ref + | ModifiedRef Ref Ref + | UnModifiedRef Ref + +-- | This is a proposed diff records for a given file. +-- It contains useful information: +-- * the filename (with its path in the root project) +-- * a file diff (with the Data.Algorythm.Patience method) +-- * the file's mode (i.e. the file priviledge) +-- * the file's ref data HitDiff = HitDiff - { hitFilename :: BS.ByteString - , hitDiff :: [HitDiffContent] - } deriving (Show) + { hFileName :: BS.ByteString + , hFileContent :: HitFileContent + , hFileMode :: HitFileMode + , hFileRef :: HitFileRef + } -- | A default Diff getter which returns all diff information (Mode, Content --- and Binary). +-- and Binary) with a context of 5 lines. -- --- > getDiff = getDiffWith defaultDiff -getDiff :: Ref -- ^ commit ref - -> Ref -- ^ commit ref - -> Git -- ^ repository +-- > getDiff = getDiffWith (defaultDiff 5) [] +getDiff :: Ref + -> Ref + -> Git -> IO [HitDiff] -getDiff = getDiffWith defaultDiff [] +getDiff = getDiffWith (defaultDiff 5) [] -- | A default diff helper. It is an example about how you can write your own -- diff helper or you can use it if you want to get all of differences. -defaultDiff :: 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 -> 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)] - createANewDiff (BinaryContent a) (BinaryContent b) = if a /= b then [HitDiffBinChange] else [] - createANewDiff _ _ = [HitDiffBinChange] +defaultDiff :: Int -- ^ Number of line for context + -> BlobStateDiff + -> [HitDiff] -- ^ Accumulator + -> [HitDiff] -- ^ Accumulator with a new content +defaultDiff _ (OnlyOld old ) acc = + let oldMode = OldMode (bsMode old) + oldRef = OldRef (bsRef old) + oldContent = case bsContent old of + BinaryContent _ -> OldBinaryFile + FileContent l -> OldTextFile (Prelude.zipWith TextLine [1..] l) + in (HitDiff (bsFilename old) oldContent oldMode oldRef):acc +defaultDiff _ (OnlyNew new) acc = + let newMode = NewMode (bsMode new) + newRef = NewRef (bsRef new) + newContent = case bsContent new of + BinaryContent _ -> NewBinaryFile + FileContent l -> NewTextFile (Prelude.zipWith TextLine [1..] l) + in (HitDiff (bsFilename new) newContent newMode newRef):acc +defaultDiff context (OldAndNew old new) acc = + let mode = if (bsMode old) /= (bsMode new) then ModifiedMode (bsMode old) (bsMode new) + else UnModifiedMode (bsMode new) + ref = if (bsRef old) == (bsRef new) then UnModifiedRef (bsRef new) + else ModifiedRef (bsRef old) (bsRef new) + in case (mode, ref) of + ((UnModifiedMode _), (UnModifiedRef _)) -> acc + _ -> (HitDiff (bsFilename new) (content ref) mode ref):acc + where content :: HitFileRef -> HitFileContent + content (UnModifiedRef _) = UnModifiedFile + content _ = createDiff (bsContent old) (bsContent new) - onlyBothDiff :: HitDiffContent -> Bool - onlyBothDiff (HitDiffBinChange) = False - onlyBothDiff (HitDiffChange l) = Prelude.all predicate l - where predicate (Both _ _) = True - predicate _ = False - onlyBothDiff _ = True + createDiff :: BlobContent -> BlobContent -> HitFileContent + createDiff (FileContent a) (FileContent b) = + let linesA = Prelude.zipWith TextLine [1..] a + linesB = Prelude.zipWith TextLine [1..] b + in ModifiedFile $ diffGetContext context (diff linesA linesB) + createDiff _ _ = ModifiedBinaryFile + +-- Used by diffGetContext +data HitwebAccu = AccuBottom | AccuTop + +-- Context filter +diffGetContext :: Int -> [Item TextLine] -> [FilteredDiff] +diffGetContext 0 list = fmap NormalLine list +diffGetContext context list = + let (_, _, filteredDiff) = Prelude.foldr filterContext (0, AccuBottom, []) list + theList = removeTrailingBoth filteredDiff + in case Prelude.head theList of + (NormalLine (Both l1 _)) -> if (lineNumber l1) > 1 then Separator:theList + else theList + _ -> theList + where -- only keep 'context'. The file is annalyzed from the bottom to the top. + -- The accumulator here is a tuple3 with (the line counter, the + -- direction and the list of elements) + filterContext :: (Item TextLine) -> (Int, HitwebAccu, [FilteredDiff]) -> (Int, HitwebAccu, [FilteredDiff]) + filterContext (Both l1 l2) (c, AccuBottom, acc) = + if c < context then (c+1, AccuBottom, (NormalLine (Both l1 l2)):acc) + else (c , AccuBottom, (NormalLine (Both l1 l2)) + :((Prelude.take (context-1) acc) + ++ [Separator] + ++ (Prelude.drop (context+1) acc))) + filterContext (Both l1 l2) (c, AccuTop, acc) = + if c < context then (c+1, AccuTop , (NormalLine (Both l1 l2)):acc) + else (0 , AccuBottom, (NormalLine (Both l1 l2)):acc) + filterContext element (_, _, acc) = + (0, AccuTop, (NormalLine element):acc) + + startWithSeparator :: [FilteredDiff] -> Bool + startWithSeparator [] = False + startWithSeparator (Separator:_) = True + startWithSeparator ((NormalLine l):xs) = + case l of + (Both _ _) -> startWithSeparator xs + _ -> False + + removeTrailingBoth :: [FilteredDiff] -> [FilteredDiff] + removeTrailingBoth diffList = + let test = startWithSeparator diffList + in if test then Prelude.tail $ Prelude.dropWhile (\a -> not $ startWithSeparator [a]) diffList + else diffList diff --git a/Data/Git/Named.hs b/Data/Git/Named.hs --- a/Data/Git/Named.hs +++ b/Data/Git/Named.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -- | -- Module : Data.Git.Named -- License : BSD-style @@ -7,20 +5,31 @@ -- Stability : experimental -- Portability : unix -- +-- Manipulation of named references +-- * reading packed-refs file +-- * reading single heads/tags/remote file +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} module Data.Git.Named ( RefSpecTy(..) , RefContentTy(..) + , RefName(..) , readPackedRefs + -- * manipulating loosed name references , existsRefFile , writeRefFile , readRefFile + -- * listings looses name references + , headsList + , tagsList + , remotesList ) where import Control.Applicative ((<$>)) import qualified Filesystem as F import qualified Filesystem.Path.Rules as FP (posix, decode, encode, encodeString, decodeString) -import Filesystem.Path.CurrentOS +import Filesystem.Path.CurrentOS hiding (root) import Data.String import Data.Git.Path @@ -34,9 +43,9 @@ data RefSpecTy = RefHead | RefOrigHead | RefFetchHead - | RefBranch String - | RefTag String - | RefRemote String + | RefBranch RefName + | RefTag RefName + | RefRemote RefName | RefPatches String | RefStash | RefOther String @@ -48,6 +57,25 @@ | RefContentUnknown B.ByteString deriving (Show,Eq) +newtype RefName = RefName { refNameRaw :: String } + deriving (Show,Eq,Ord) + +instance IsString RefName where + fromString s + | isValidRefName s = RefName s + | otherwise = error ("invalid RefName " ++ show s) + +isValidRefName :: String -> Bool +isValidRefName s = not (or $ map isBadChar s) + where isBadChar :: Char -> Bool + isBadChar c = c <= ' ' || c >= toEnum 0x7f || c `elem` badAscii + badAscii = [ '~', '^', ':', '\\', '*', '?', '[' ] + +isValidRefFilepath :: FilePath -> Bool +isValidRefFilepath f + | valid f = isValidRefName $ encodeString f + | otherwise = False + -- FIXME BC.unpack/pack should be probably be utf8.toString, -- however i don't know if encoding is consistant. -- it should probably be overridable. @@ -59,9 +87,9 @@ toRefTy :: String -> RefSpecTy toRefTy s - | "refs/tags/" `isPrefixOf` s = RefTag $ drop 10 s - | "refs/heads/" `isPrefixOf` s = RefBranch $ drop 11 s - | "refs/remotes/" `isPrefixOf` s = RefRemote $ drop 13 s + | "refs/tags/" `isPrefixOf` s = RefTag $ RefName $ drop 10 s + | "refs/heads/" `isPrefixOf` s = RefBranch $ RefName $ drop 11 s + | "refs/remotes/" `isPrefixOf` s = RefRemote $ RefName $ drop 13 s | "refs/patches/" `isPrefixOf` s = RefPatches $ drop 13 s | "refs/stash" == s = RefStash | "HEAD" == s = RefHead @@ -70,9 +98,9 @@ | otherwise = RefOther $ s fromRefTy :: RefSpecTy -> String -fromRefTy (RefBranch h) = "refs/heads/" ++ h -fromRefTy (RefTag h) = "refs/tags/" ++ h -fromRefTy (RefRemote h) = "refs/remotes/" ++ h +fromRefTy (RefBranch h) = "refs/heads/" ++ refNameRaw h +fromRefTy (RefTag h) = "refs/tags/" ++ refNameRaw h +fromRefTy (RefRemote h) = "refs/remotes/" ++ refNameRaw h fromRefTy (RefPatches h) = "refs/patches/" ++ h fromRefTy RefStash = "refs/stash" fromRefTy RefHead = "HEAD" @@ -81,9 +109,9 @@ fromRefTy (RefOther h) = h toPath :: FilePath -> RefSpecTy -> FilePath -toPath gitRepo (RefBranch h) = gitRepo "refs" "heads" fromString h -toPath gitRepo (RefTag h) = gitRepo "refs" "tags" fromString h -toPath gitRepo (RefRemote h) = gitRepo "refs" "remotes" fromString h +toPath gitRepo (RefBranch h) = gitRepo "refs" "heads" fromString (refNameRaw h) +toPath gitRepo (RefTag h) = gitRepo "refs" "tags" fromString (refNameRaw h) +toPath gitRepo (RefRemote h) = gitRepo "refs" "remotes" fromString (refNameRaw h) toPath gitRepo (RefPatches h) = gitRepo "refs" "patches" fromString h toPath gitRepo RefStash = gitRepo "refs" "stash" toPath gitRepo RefHead = gitRepo "HEAD" @@ -91,6 +119,7 @@ toPath gitRepo RefFetchHead = gitRepo "FETCH_HEAD" toPath gitRepo (RefOther h) = gitRepo fromString h +readPackedRefs :: FilePath -> IO [(RefSpecTy, Ref)] readPackedRefs gitRepo = do exists <- F.isFile (packedRefsPath gitRepo) if exists then readLines else return [] @@ -101,16 +130,32 @@ name = FP.encodeString FP.posix $ pathDecode $ B.tail r in (toRefTy name, fromHex ref) : a -{- -headsList gitRepo = getDirectoryContentNoDots (headsPath gitRepo) -tagsList gitRepo = getDirectoryContentNoDots (tagsPath gitRepo) -remotesList gitRepo = getDirectoryContentNoDots (remotesPath gitRepo) -remoteList gitRepo remote = getDirectoryContentNoDots (remotePath gitRepo remote) +listRefs :: FilePath -> IO [RefName] +listRefs root = listRefsAcc [] root + where listRefsAcc acc dir = do + files <- F.listDirectory dir + getRefsRecursively dir acc files + getRefsRecursively _ acc [] = return acc + getRefsRecursively dir acc (x:xs) = do + isDir <- F.isDirectory x + extra <- if isDir + then listRefsAcc [] dir + else let r = stripRoot x + in if isValidRefFilepath r + then return [fromString $ encodeString r] + else return [] + getRefsRecursively dir (extra ++ acc) xs + stripRoot p = maybe (error "stripRoot invalid") id $ stripPrefix root p -writeRef path ref = B.writeFile path (B.concat [toHex ref, B.singleton 0xa]) -readRef path = fromHex . B.take 40 <$> B.readFile path --} +headsList :: FilePath -> IO [RefName] +headsList gitRepo = listRefs (headsPath gitRepo) +tagsList :: FilePath -> IO [RefName] +tagsList gitRepo = listRefs (tagsPath gitRepo) + +remotesList :: FilePath -> IO [RefName] +remotesList gitRepo = listRefs (remotesPath gitRepo) + existsRefFile :: FilePath -> RefSpecTy -> IO Bool existsRefFile gitRepo specty = F.isFile $ toPath gitRepo specty @@ -128,16 +173,3 @@ | "ref: " `B.isPrefixOf` content = RefLink $ toRefTy $ FP.encodeString FP.posix $ pathDecode $ head $ BC.lines $ B.drop 5 content | B.length content < 42 = RefDirect $ fromHex $ B.take 40 content | otherwise = RefContentUnknown content - -{- -headExists gitRepo name = doesFileExist (headPath gitRepo name) -headRead gitRepo name = readRef (headPath gitRepo name) -headWrite gitRepo name ref = writeRef (headPath gitRepo name) ref - -tagExists gitRepo name = doesFileExist (tagPath gitRepo name) -tagRead gitRepo name = readRef (tagPath gitRepo name) -tagWrite gitRepo name ref = writeRef (tagPath gitRepo name) ref - -specialRead gitRepo name = readRefAndFollow gitRepo (specialPath gitRepo name) -specialExists gitRepo name = doesFileExist (specialPath gitRepo name) --} diff --git a/Data/Git/Path.hs b/Data/Git/Path.hs --- a/Data/Git/Path.hs +++ b/Data/Git/Path.hs @@ -14,9 +14,9 @@ import Data.Git.Ref import Data.String -headsPath gitRepo = gitRepo "refs" "heads" -tagsPath gitRepo = gitRepo "refs" "tags" -remotesPath gitRepo = gitRepo "refs" "remotes" +headsPath gitRepo = gitRepo "refs" "heads" "" +tagsPath gitRepo = gitRepo "refs" "tags" "" +remotesPath gitRepo = gitRepo "refs" "remotes" "" packedRefsPath gitRepo = gitRepo "packed-refs" headPath gitRepo name = headsPath gitRepo fromString name diff --git a/Data/Git/Repository.hs b/Data/Git/Repository.hs --- a/Data/Git/Repository.hs +++ b/Data/Git/Repository.hs @@ -48,7 +48,7 @@ -- | hierarchy tree, either a reference to a blob (file) or a tree (directory). data HTreeEnt = TreeDir Ref HTree | TreeFile Ref -type HTree = [(Int,ByteString,HTreeEnt)] +type HTree = [(ModePerm,ByteString,HTreeEnt)] -- | Exception when trying to convert an object pointed by 'Ref' to -- a type that is different @@ -108,8 +108,7 @@ "HEAD" -> [ RefHead ] "ORIG_HEAD" -> [ RefOrigHead ] "FETCH_HEAD" -> [ RefFetchHead ] - _ -> [ RefTag prefix, RefBranch prefix, RefRemote prefix ] - + _ -> map (flip ($) (RefName prefix)) [RefTag,RefBranch,RefRemote] tryResolvers :: [IO (Maybe Ref)] -> IO Ref tryResolvers [] = return $ fromHexString prefix 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 @@ -161,10 +161,13 @@ objectToBlob _ = Nothing octal :: Parser Int -octal = B.foldl' step 0 `fmap` takeWhile1 isOct where - isOct w = w >= 0x30 && w <= 0x37 +octal = B.foldl' step 0 `fmap` takeWhile1 isOct + where isOct w = w >= 0x30 && w <= 0x37 step a w = a * 8 + fromIntegral (w - 0x30) +modeperm :: Parser ModePerm +modeperm = ModePerm . fromIntegral <$> octal + tillEOL :: Parser ByteString tillEOL = PC.takeWhile ((/= '\n')) @@ -179,7 +182,7 @@ -- | parse a tree content treeParse = Tree <$> parseEnts where parseEnts = atEnd >>= \end -> if end then return [] else liftM2 (:) parseEnt parseEnts - parseEnt = liftM3 (,,) octal (PC.char ' ' >> takeTill ((==) 0)) (word8 0 >> referenceBin) + parseEnt = liftM3 (,,) modeperm (PC.char ' ' >> takeTill ((==) 0)) (word8 0 >> referenceBin) -- | parse a blob content blobParse = (Blob <$> takeLazyByteString) @@ -250,7 +253,7 @@ objectWrite _ = error "delta cannot be marshalled" treeWrite (Tree ents) = toLazyByteString $ mconcat $ concatMap writeTreeEnt ents - where writeTreeEnt (perm,name,ref) = + where writeTreeEnt (ModePerm perm,name,ref) = [ string7 (printf "%o" perm) , string7 " " , byteString name diff --git a/Data/Git/Types.hs b/Data/Git/Types.hs --- a/Data/Git/Types.hs +++ b/Data/Git/Types.hs @@ -17,6 +17,12 @@ , Blob(..) , Tag(..) , Person(..) + -- * modeperm type + , ModePerm(..) + , FilePermissions(..) + , ObjectFileType(..) + , getPermission + , getFiletype -- * time type , GitTime(..) , toUTCTime @@ -30,6 +36,7 @@ ) where import Data.Word +import Data.Bits import Data.Monoid import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as L @@ -41,6 +48,7 @@ import Data.Time.Clock.POSIX import Data.Data + -- | type of a git object. data ObjectType = TypeTree @@ -86,10 +94,46 @@ toEnum 0x7 = TypeDeltaRef toEnum n = error ("not a valid object: " ++ show n) +newtype ModePerm = ModePerm Word32 + deriving (Show,Eq) + +getPermission :: ModePerm -> FilePermissions +getPermission (ModePerm modeperm) = + let owner = (modeperm .&. 0x700) `shiftR` 6 + group = (modeperm .&. 0x70) `shiftR` 3 + other = modeperm .&. 0x7 + in FilePermissions (fromIntegral owner) (fromIntegral group) (fromIntegral other) + +getFiletype :: ModePerm -> ObjectFileType +getFiletype (ModePerm modeperm) = + case modeperm `shiftR` 12 of + _ -> error "filetype unknown" + +-- | Git object file type +data ObjectFileType = + FileTypeDirectory + | FileTypeRegularFile + | FileTypeSymbolicLink + | FileTypeGitLink + deriving (Show,Eq) + +-- | traditional unix permission for owner, group and permissions +data FilePermissions = FilePermissions + { getOwnerPerm :: {-# UNPACK #-} !Perm + , getGroupPerm :: {-# UNPACK #-} !Perm + , getOtherPerm :: {-# UNPACK #-} !Perm + } deriving (Show,Eq) + +-- | a bitfield representing a typical unix permission: +-- * bit 0 represents the read permission +-- * bit 1 represents the write permission +-- * bit 2 represents the execute permission +type Perm = Word8 + -- | represent one entry in the tree -- (permission,file or directory name,blob or tree ref) -- name should maybe a filepath, but not sure about the encoding. -type TreeEnt = (Int,ByteString,Ref) +type TreeEnt = (ModePerm,ByteString,Ref) -- | an author or committer line -- has the format: name time timezone diff --git a/Hit/Hit.hs b/Hit/Hit.hs --- a/Hit/Hit.hs +++ b/Hit/Hit.hs @@ -19,6 +19,7 @@ import Data.Git.Types import Data.Git.Ref import Data.Git.Repository +import Data.Git.Named import Data.Git.Revision import Data.Git.Diff import Data.Word @@ -132,8 +133,8 @@ mapM_ (showTreeEnt) htree _ -> error "cannot build a tree from this reference" where - showTreeEnt (p,n,TreeDir r _) = printf "%06o tree %s %s\n" p (show r) (BC.unpack n) - showTreeEnt (p,n,TreeFile r) = printf "%06o blob %s %s\n" p (show r) (BC.unpack n) + showTreeEnt (ModePerm p,n,TreeDir r _) = printf "%06o tree %s %s\n" p (show r) (BC.unpack n) + showTreeEnt (ModePerm p,n,TreeFile r) = printf "%06o blob %s %s\n" p (show r) (BC.unpack n) revList revision git = do ref <- maybe (error "revision cannot be found") id <$> resolveRevision git revision @@ -166,53 +167,61 @@ showDiff rev1 rev2 git = do ref1 <- maybe (error "revision cannot be found") id <$> resolveRevision git rev1 ref2 <- maybe (error "revision cannot be found") id <$> resolveRevision git rev2 - diffList <- getDiff ref1 ref2 git + diffList <- getDiffWith (defaultDiff 5) ([]) ref1 ref2 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 + printFileName $ hFileName hd + printFileMode $ hFileMode hd + printFileRef $ hFileRef hd + printFileDiff $ hFileContent hd - ppHitMode :: [HitDiffContent] -> IO () - ppHitMode [] = return () - ppHitMode ((HitDiffMode old new):_ ) = printf "old mode %06o\nnew mode %06o\n" old new - ppHitMode (_ :xs) = ppHitMode xs + printFileName :: BC.ByteString -> IO () + printFileName filename = putStrLn $ "Hit.Diff on file: " ++ (BC.unpack filename) - 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 + printFileMode :: HitFileMode -> IO () + printFileMode (NewMode (ModePerm m)) = printf "new file mode: %06o\n" m + printFileMode (OldMode (ModePerm m)) = printf "old file mode: %06o\n" m + printFileMode (UnModifiedMode (ModePerm m)) = printf "current file mode: %06o\n" m + printFileMode (ModifiedMode (ModePerm o) (ModePerm n)) = printf "file mode: %06o -> %06o\n" o n - 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 + printFileRef :: HitFileRef -> IO () + printFileRef (NewRef r) = putStrLn $ "+++ new/" ++ (show r) + printFileRef (OldRef r) = putStrLn $ "--- old/" ++ (show r) + printFileRef (UnModifiedRef r) = putStrLn $ "=== cur/" ++ (show r) + printFileRef (ModifiedRef o n) = do putStrLn $ "+++ new/" ++ (show n) + putStrLn $ "--- old/" ++ (show o) - 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) + printFileDiff :: HitFileContent -> IO () + printFileDiff NewBinaryFile = putStrLn "Binary file created" + printFileDiff OldBinaryFile = putStrLn "Binary file deleted" + printFileDiff ModifiedBinaryFile = putStrLn "Binary file modified" + printFileDiff UnModifiedFile = putStrLn "No changes in the file's content" + printFileDiff (NewTextFile l) = mapM_ (printFileLine "+") l + printFileDiff (OldTextFile l) = mapM_ (printFileLine "-") l + printFileDiff (ModifiedFile fDiff) = mapM_ printFilteredDiff fDiff - doPPDiffLine :: String -> [LC.ByteString] -> [LC.ByteString] - doPPDiffLine _ [] = [] - doPPDiffLine prefix (a:xs) = (LC.concat [LC.pack prefix,a,LC.pack "\n"]):(doPPDiffLine prefix xs) + printFilteredDiff :: FilteredDiff -> IO () + printFilteredDiff (NormalLine l) = + case l of + (Both (TextLine on ol) (TextLine nn _ )) -> printf "%4d %4d %s\n" on nn (LC.unpack ol) + (New (TextLine nn nl)) -> printf " %4d +%s\n" nn (LC.unpack nl) + (Old (TextLine on ol) ) -> printf "%4d -%s\n" on (LC.unpack ol) + printFilteredDiff _ = putStrLn " [...]" + printFileLine :: String -> TextLine -> IO () + printFileLine prefix (TextLine _ line) = putStrLn $ prefix ++ (LC.unpack line) + + +showRefs git = do + putStrLn "[HEADS]" + heads <- headsList (gitRepoPath git) + mapM_ (putStrLn . show) heads + putStrLn "[TAGS]" + tags <- tagsList (gitRepoPath git) + mapM_ (putStrLn . show) tags + main = do args <- getArgs case args of @@ -223,6 +232,7 @@ ["rev-list",rev] -> withCurrentRepo $ revList (fromString rev) ["log",rev] -> withCurrentRepo $ getLog (fromString rev) ["diff",rev1,rev2] -> withCurrentRepo $ showDiff (fromString rev1) (fromString rev2) + ["show-refs"] -> withCurrentRepo $ showRefs cmd : [] -> error ("unknown command: " ++ cmd) [] -> error "no args" _ -> error "unknown command line arguments" diff --git a/Tests/Tests.hs b/Tests/Tests.hs --- a/Tests/Tests.hs +++ b/Tests/Tests.hs @@ -61,6 +61,9 @@ m <- (* 30) <$> choose (0,1) return (h * 100 + m - 1200) +instance Arbitrary ModePerm where + arbitrary = ModePerm <$> elements [ 0o644, 0o664, 0o755, 0 ] + arbitraryName = liftM3 Person (arbitraryBSnoangle 16) (arbitraryBSnoangle 16) arbitrary diff --git a/hit.cabal b/hit.cabal --- a/hit.cabal +++ b/hit.cabal @@ -1,5 +1,5 @@ Name: hit -Version: 0.5.4 +Version: 0.5.5 Synopsis: Git operations in haskell Description: .