diff --git a/Git/Blob.hs b/Git/Blob.hs new file mode 100644 --- /dev/null +++ b/Git/Blob.hs @@ -0,0 +1,67 @@ +{-# OPTIONS -Wall #-} + +module Git.Blob ( + readBlob + , prettyBlob + , findBlob +) where + +import Codec.Compression.Zlib +import Control.Applicative ((<$>)) +import Control.Monad +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as C +import Data.Maybe (listToMaybe) + +-- show-prefix, show-root use these +import System.FilePath +import System.Posix.Files + +import Git.Commit +import Git.Pack +import Git.PackIndex +import Git.Path +import Git.SHA + +------------------------------------------------------------ + +readBlob :: String -> IO (Maybe L.ByteString) +readBlob blob = do + let (bH,bT) = splitAt 2 blob + path <- gitPath ("objects" bH bT) + exists <- fileExist path + if exists + then Just . decompress <$> C.readFile path + else do + let sha = readDigestBS blob + fmap (packObjectPretty sha) <$> findInPackIdxs sha + +prettyBlob :: String -> C.ByteString -> C.ByteString +prettyBlob blob bs + | commitHeader `L.isPrefixOf` bs = C.concat [commitHeader, C.pack (blob ++ "\n"), commitPretty $ commitParse bs] + | otherwise = chomp bs + where + commitHeader = C.pack "commit " + chomp = C.takeWhile (/= '\n') + +------------------------------------------------------------ +-- findBlob +-- + +findBlob :: [String] -> IO [String] +findBlob [] = findBlob ["HEAD"] +findBlob (name:_) = do + mPath <- firstExist [name, + ("refs" name), + ("refs" "tags" name), + ("refs" "heads" name), + ("refs" "remotes" name), + ("refs" "remotes" name "HEAD")] + case mPath of + Just path -> do + bs <- gitDeref path + return [C.unpack bs] + Nothing -> return [name] + +firstExist :: [FilePath] -> IO (Maybe FilePath) +firstExist fs = listToMaybe <$> (filterM (fileExist <=< gitPath)) fs diff --git a/Git/Commit.hs b/Git/Commit.hs --- a/Git/Commit.hs +++ b/Git/Commit.hs @@ -1,3 +1,5 @@ +{-# OPTIONS -Wall #-} + module Git.Commit ( Commit(..), commitParse, @@ -5,16 +7,12 @@ ) where import qualified Data.ByteString.Lazy.Char8 as C -import Data.Digest.Pure.SHA (Digest, sha1, showDigest) -import Data.Time.Clock import Data.Time.Format import Data.Time.LocalTime import System.Locale -type Author = String - -type Date = String +------------------------------------------------------------ data Commit = Commit { commitParent :: C.ByteString, --Digest, @@ -29,21 +27,25 @@ -- commitParse -- -e = C.empty - +defCommit :: Commit defCommit = Commit e e e e e e + where + e = C.empty +commitParse :: C.ByteString -> Commit commitParse bs = commitParseLines defCommit (C.lines bs) +commitParseLines :: Commit -> [C.ByteString] -> Commit commitParseLines c [] = c - commitParseLines c (l:ls) | C.null l = c{commitMessage = C.unlines ls} | otherwise = commitParseLines (commitModLine c l) ls +commitModLine :: Commit -> C.ByteString -> Commit commitModLine c l = commitMod c (C.unpack hd) bdy where (hd:bdy) = C.words l +commitMod :: Commit -> [Char] -> [C.ByteString] -> Commit commitMod c hd bdy | hd == "commit" = c | hd == "parent" = c{commitParent = head bdy} @@ -59,7 +61,8 @@ -- commitPretty -- -commitPretty (Commit p a ad c cd m) = +commitPretty :: Commit -> C.ByteString +commitPretty (Commit _p a ad _c _cd m) = C.unlines [ C.concat [(C.pack "Author: "), a], C.concat [(C.pack "Date: "), f], diff --git a/Git/Pack.hs b/Git/Pack.hs --- a/Git/Pack.hs +++ b/Git/Pack.hs @@ -1,36 +1,168 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS -Wall #-} + module Git.Pack ( + -- * Types Pack(..), - packParse, - packPretty + PackObject(..), + PackObjectType, + + packPretty, + packObjectPretty, + + -- * Iteratee + packRead, + packReadObject, + + -- * Paths + packPath ) where +import Control.Applicative +import Data.Bits +import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy.Char8 as C import qualified Data.ByteString.Lazy as L -import Data.Binary.Get +import qualified Data.Iteratee as I +import Data.Iteratee.Binary +import Data.Iteratee.ZLib +import Data.Maybe (catMaybes) import Data.Word +import System.FilePath +import System.Posix.Types -data Pack = Pack { - packVersion :: Word32, - packNumObjects :: Word32 -} +import Git.Path ------------------------------------------------------------ --- packParse + +data Pack = Pack + { packVersion :: Int + , packNumObjects :: Int + , packObjects :: [PackObject] + } deriving (Show) + +data PackObjectType = OBJ_COMMIT + | OBJ_TREE + | OBJ_BLOB + | OBJ_TAG + | OBJ_OFS_DELTA Int + | OBJ_REF_DELTA [Word8] + deriving (Show, Eq) + +data PackObject = PackObject + { poType :: PackObjectType + , poSize :: Int + , poData :: ByteString + } deriving (Show) + +------------------------------------------------------------ + +-- | Generate the pathname for a given packfile +packPath :: String -> IO FilePath +packPath pack = gitPath ("objects" "pack" ("pack-" ++ pack ++ ".pack")) + +------------------------------------------------------------ +-- packReader (Iteratee) -- -packDeSerialize = do - ver <- getWord32be - n <- getWord32be - return (Pack ver n) +packRead :: FilePath -> IO (Maybe Pack) +packRead = I.fileDriverRandom packReader -packParse bs = runGet packDeSerialize bs' - where bs' = L.drop 4 bs +packReader :: I.Iteratee ByteString IO (Maybe Pack) +packReader = do + n <- I.heads "PACK" + if (n == 4) + then do + ver <- fromIntegral <$> endianRead4 MSB + num <- fromIntegral <$> endianRead4 MSB + os <- catMaybes <$> sequence (replicate num packObjectRead) + return $ Just (Pack ver num os) + else return Nothing +packReadObject :: FilePath -> FileOffset -> IO (Maybe PackObject) +packReadObject fp off = I.fileDriverRandom (packReadObject' off) fp + +packReadObject' :: FileOffset -> I.Iteratee ByteString IO (Maybe PackObject) +packReadObject' off = do + n <- I.heads "PACK" + if (n == 4) + then do + -- TODO: verify this is a known version, error otherwise + -- _ver <- fromIntegral <$> endianRead4 MSB + -- _num <- fromIntegral <$> endianRead4 MSB + I.seek off + packObjectRead + else return Nothing + +packObjectRead :: I.Iteratee ByteString IO (Maybe PackObject) +packObjectRead = do + x <- I.head + let t = parseOBJ $ (x .&. 0x70) `shiftR` 4 + sz = castEnum (x .&. 0x0f) + sz' <- if doNext x + then readSize 4 sz + else return sz + t' <- readBase t + d <- I.joinI $ enumInflate Zlib defaultDecompressParams I.stream2stream + return $ PackObject <$> t' <*> pure sz' <*> pure d + where + parseOBJ :: Word8 -> Maybe PackObjectType + parseOBJ 1 = Just OBJ_COMMIT + parseOBJ 2 = Just OBJ_TREE + parseOBJ 3 = Just OBJ_BLOB + parseOBJ 4 = Just OBJ_TAG + parseOBJ 6 = Just (OBJ_OFS_DELTA 0) + parseOBJ 7 = Just (OBJ_REF_DELTA []) + parseOBJ _ = Nothing + + doNext :: Word8 -> Bool + doNext x = (x .&. 0x80) /= 0 + + readSize :: Int -> Int -> I.Iteratee ByteString IO Int + readSize shft acc = do + x <- I.head + let sz = acc + (((castEnum (x .&. 0x7f)) :: Int) `shiftL` shft) + if doNext x + then readSize (shft+7) sz + else return sz + + readBase :: Maybe PackObjectType + -> I.Iteratee ByteString IO (Maybe PackObjectType) + readBase (Just (OBJ_OFS_DELTA 0)) = + Just . OBJ_OFS_DELTA <$> readOFSBase 0 0 + readBase (Just (OBJ_REF_DELTA [])) = + Just . OBJ_REF_DELTA <$> (sequence $ replicate 20 I.head) + readBase (Just t) = return (Just t) + readBase Nothing = return Nothing + + readOFSBase :: Int -> Int -> I.Iteratee ByteString IO Int + readOFSBase shft acc = do + x <- I.head + let bs = acc + (((castEnum (x .&. 0x7f)) :: Int) `shiftL` shft) + if doNext x + then readOFSBase (shft+7) (bs+1) + else return bs + + castEnum = toEnum . fromEnum + + +packObjectPretty :: ByteString -> PackObject -> L.ByteString +packObjectPretty sha PackObject{..} + | poType == OBJ_COMMIT = + C.concat [commitHeader, sha'c, C.pack "\n", poData'c] + | otherwise = poData'c + where + commitHeader = C.pack "commit " + sha'c = C.fromChunks [sha] + poData'c = C.fromChunks [poData] + ------------------------------------------------------------ -- packPretty -- -packPretty (Pack ver n) = +packPretty :: Pack -> L.ByteString +packPretty (Pack ver n _) = C.unlines [ C.concat [(C.pack "Version: "), C.pack (show ver)], C.concat [(C.pack "Num Objects: "), C.pack (show n)] diff --git a/Git/PackIndex.hs b/Git/PackIndex.hs new file mode 100644 --- /dev/null +++ b/Git/PackIndex.hs @@ -0,0 +1,219 @@ +{-# LANGUAGE RecordWildCards #-} +{-# OPTIONS -Wall #-} + +module Git.PackIndex ( + dumpRawPackIndex, + findInPackIdxs, + + -- * Paths + idxPath +) where + +import Control.Applicative ((<$>)) +import Control.Monad (msum) +import Data.Bits (shiftR) +import qualified Data.ByteString as BS +import Data.Word (Word32) +import Foreign.Ptr +import Foreign.Storable +import Data.Storable.Endian +import System.Directory +import System.FilePath +import System.IO.MMap +import System.Posix.Types +import Text.Printf + +import Git.SHA +import Git.Pack +import Git.Path + +------------------------------------------------------------ + +data IDX = IDX1 { + idx1Pack :: FilePath + , idx1Size :: Int + , idx1Fanout :: Ptr (BigEndian Word32) + , idx1Offsets :: Ptr (BigEndian Word32) + } | IDX2 { + idx2Pack :: FilePath + , idx2Size :: Int + , idx2Fanout :: Ptr (BigEndian Word32) + , idx2SHA1s :: Ptr (BigEndian Word32) + , idx2CRCs :: Ptr (BigEndian Word32) + , idx2Offsets :: Ptr (BigEndian Word32) + , idx264bOffsets :: Ptr (BigEndian Word32) + -- , idx2PackCSum :: Ptr (BigEndian Word32) + -- , idx2IdxCSum :: Ptr (BigEndian Word32) + } + +------------------------------------------------------------ +-- | Public API + +-- | Corresponding packfile path +idxPack :: IDX -> FilePath +idxPack IDX1{..} = idx1Pack +idxPack IDX2{..} = idx2Pack + +-- | Number of objects in the corresponding .pack file +idxSize :: IDX -> Int +idxSize IDX1{..} = idx1Size +idxSize IDX2{..} = idx2Size + +-- | Nth SHA1 +idxSha1 :: IDX -> Int -> IO BS.ByteString +idxSha1 idx@IDX1{..} n + | n > idx1Size = outOfRange idx n "(v1) SHA1" + | otherwise = do + let cs = idx1Offsets `plusPtr` (4 + (n * 24)) + BS.packCStringLen (cs, 20) +idxSha1 idx@IDX2{..} n + | n > idx2Size = outOfRange idx n "SHA1" + | otherwise = do + let cs = idx2SHA1s `plusPtr` (n * 20) + BS.packCStringLen (cs, 20) + +-- | Nth CRC +idxCRC :: IDX -> Int -> IO (Maybe Word32) +idxCRC idx@IDX1{..} n + | n > idx1Size = outOfRange idx n "(v1) CRC" + | otherwise = return Nothing +idxCRC idx@IDX2{..} n + | n > idx2Size = outOfRange idx n "CRC" + | otherwise = do + BE crc <- peekElemOff idx2CRCs n + return (Just crc) + +-- | Nth offset +idxOffset :: IDX -> Int -> IO FileOffset +idxOffset idx@IDX1{..} n + | n > idx1Size = outOfRange idx n "(v1) Offset" + | otherwise = do + BE off <- peekByteOff idx1Offsets (n * 24) + return . fromIntegral $ (off :: Word32) +idxOffset idx@IDX2{..} n + | n > idx2Size = outOfRange idx n "Offset" + | otherwise = do + BE off <- peekElemOff idx2Offsets n + return . fromIntegral $ off + +outOfRange :: IDX -> Int -> String -> IO a +outOfRange idx n s = error $ printf "%s: %s index %d out of range (size %d)" + (idxPack idx) s n (idxSize idx) + +------------------------------------------------------------ + +idxFiles :: IO [FilePath] +idxFiles = do + packDir <- gitPath ("objects" "pack") + map (packDir ) . filter isIdx <$> getDirectoryContents packDir + where + isIdx = (== ".idx") . takeExtension + +------------------------------------------------------------ + +idxFind :: IDX -> BS.ByteString -> IO (Maybe (IDX, Int)) +idxFind idx sha = idxFind' 0 (idxSize idx) + where + idxFind' lo hi + | lo >= hi = do + iSha <- idxSha1 idx lo + case (sha `compare` iSha) of + EQ -> return (Just (idx, lo)) + _ -> return Nothing + | otherwise = do + iSha <- idxSha1 idx i + case (sha `compare` iSha) of + EQ -> return (Just (idx, i)) + LT -> idxFind' lo i + GT -> idxFind' (i+1) hi + where + i = shiftR (lo + hi) 1 + +findInPackIdxs :: BS.ByteString -> IO (Maybe PackObject) +findInPackIdxs sha = do + idxs <- idxFiles + msum <$> mapM (findInPackIndex' sha) idxs + +findInPackIndex' :: BS.ByteString -> FilePath -> IO (Maybe PackObject) +findInPackIndex' sha fp = do + idx <- readIdx fp + m'i <- idxFind idx sha + case m'i of + Just (_, i) -> do + off <- idxOffset idx i + packReadObject (idxPack idx) off + Nothing -> return Nothing + +------------------------------------------------------------ +-- Debugging + +dumpIdx :: IDX -> IO () +dumpIdx idx@IDX1{..} = do + putStrLn $ idx1Pack ++ ": IDX Version 1" + dumpIdx' idx +dumpIdx idx@IDX2{..} = do + putStrLn $ idx2Pack ++ ": IDX Version 2" + dumpIdx' idx + +dumpIdx' :: IDX -> IO () +dumpIdx' idx = do + putStrLn $ show (idxSize idx) ++ " objects" + mapM_ f [0..(idxSize idx)-1] + where + f i = do + o <- fromIntegral <$> idxOffset idx i + let o' = printf "0x%04x" (o :: Int) + s <- idxSha1 idx i + c <- maybe "" ((" CRC: " ++) . show) <$> idxCRC idx i + putStrLn $ show i ++ ": " ++ o' ++ " SHA: " ++ showDigestBS s ++ c + +------------------------------------------------------------ + +-- | Generate the pathname for a given packfile +idxPath :: String -> IO FilePath +idxPath idx = gitPath ("objects" "pack" ("pack-" ++ idx ++ ".idx")) + +idxHeader :: Word32 +idxHeader = 0xff744f63 + +readIdx :: FilePath -> IO IDX +readIdx fp = do + (ptr, _rawsize, offset, size) <- mmapFilePtr fp ReadOnly Nothing + let start :: Ptr (BigEndian Word32) + start = ptr `plusPtr` offset + BE hdr <- peek start + if (hdr == idxHeader) + then do + BE ver <- peekElemOff start 1 + case ver of + 2 -> mkIDX2 fp start size + _ -> error "Unknown version" + else mkIDX1 fp start size + +dumpRawPackIndex :: FilePath -> IO String +dumpRawPackIndex fp = do + idx <- readIdx fp + dumpIdx idx + return "Woot" + +mkIDX1 :: FilePath -> Ptr (BigEndian Word32) -> Int -> IO IDX +mkIDX1 fp start _size = do + let pack = replaceExtension fp ".pack" + fanout = start + BE n <- peekElemOff fanout 255 + let n' = fromIntegral (n :: Word32) + let offsets = fanout `plusPtr` (256 * 4) + return (IDX1 pack n' fanout offsets) + +mkIDX2 :: FilePath -> Ptr (BigEndian Word32) -> Int -> IO IDX +mkIDX2 fp start _size = do + let pack = replaceExtension fp ".pack" + fanout = start `plusPtr` (2 * 4) + BE n <- peekElemOff fanout 255 + let n' = fromIntegral (n :: Word32) + let sha1s = fanout `plusPtr` (256 * 4) + crcs = sha1s `plusPtr` (n' * 20) + offsets = crcs `plusPtr` (n' * 4) + offset64s = offsets `plusPtr` (n' * 4) + return (IDX2 pack n' fanout sha1s crcs offsets offset64s) + diff --git a/Git/Path.hs b/Git/Path.hs new file mode 100644 --- /dev/null +++ b/Git/Path.hs @@ -0,0 +1,145 @@ +{-# OPTIONS -Wall #-} + +module Git.Path ( + -- * Generate paths in git dir + gitPath + , gitRoot + , gitDeref + + -- * General path handling + , pathExistOr +) where + +import Control.Monad ((<=<)) +import Control.Monad.Trans (liftIO) +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as C + +-- show-prefix, show-root use these +import System.FilePath hiding (normalise) +import System.Directory +import System.Posix.Files + +------------------------------------------------------------ +-- gitRoot +-- + +gitPath :: FilePath -> IO FilePath +gitPath f = do + root <- gitRoot + return $ root ".git" f + +gitRoot :: IO FilePath +gitRoot = do + mp <- liftIO $ gitRoot' "." + case mp of + Just path -> return (path ++ [pathSeparator]) + Nothing -> error "fatal: Not a git repository (or any of the parent directories)" + +gitRoot' :: FilePath -> IO (Maybe FilePath) +gitRoot' path = do + b <- fileExist path + case b of + True -> do + d <- dirIsRoot path + case d of + True -> return (Just (normalise path)) + False -> do + let newPath = ".." path + canPath <- canonicalizePath path + canNewPath <- canonicalizePath newPath + if (canPath == canNewPath) + then return Nothing + else gitRoot' newPath + False -> return Nothing + where + dirIsRoot p = liftIO $ fileExist (p ".git") + +------------------------------------------------------------ +-- deref +-- + +gitDeref :: String -> IO C.ByteString +gitDeref = deref <=< L.readFile <=< gitPath + where + deref bs + | refHeader `L.isPrefixOf` bs = gitDeref refPath + | otherwise = return (chomp bs) + where + refHeader = C.pack "ref: " + refPath = C.unpack (chomp $ L.drop 5 bs) + chomp = C.takeWhile (/= '\n') + +------------------------------------------------------------ +-- pathExistOr + +-- | Return the given path if it exists, else the result of applying the +-- modifier function +pathExistOr :: (FilePath -> IO FilePath) -> FilePath -> IO FilePath +pathExistOr f path = do + exists <- doesFileExist path + if exists + then return path + else f path + +------------------------------------------------------------ +-- normalise +-- + +-- NOTE: this is a modified version of normalise from filepath, +-- fixed to handle the case of a trailing dot. This version was +-- submitted via the libraries process as ticket #3975: +-- http://hackage.haskell.org/trac/ghc/ticket/3975 +-- which was applied on 08 Jan 2011. + +-- | Normalise a file +-- +-- * \/\/ outside of the drive can be made blank +-- +-- * \/ -> 'pathSeparator' +-- +-- * .\/ -> \"\" +-- +-- > Posix: normalise "/file/\\test////" == "/file/\\test/" +-- > Posix: normalise "/file/./test" == "/file/test" +-- > Posix: normalise "/test/file/../bob/fred/" == "/test/file/../bob/fred/" +-- > Posix: normalise "../bob/fred/" == "../bob/fred/" +-- > Posix: normalise "./bob/fred/" == "bob/fred/" +-- > Windows: normalise "c:\\file/bob\\" == "C:\\file\\bob\\" +-- > Windows: normalise "c:\\" == "C:\\" +-- > Windows: normalise "\\\\server\\test" == "\\\\server\\test" +-- > Windows: normalise "c:/file" == "C:\\file" +-- > normalise "." == "." +-- > Posix: normalise "./" == "./" +-- > Posix: normalise "./." == "./" +-- > Posix: normalise "bob/fred/." == "bob/fred/" +normalise :: FilePath -> FilePath +normalise path = joinDrive (normaliseDrive drv) (f pth) + ++ [pathSeparator | isDirPath pth] + where + (drv,pth) = splitDrive path + + isDirPath xs = lastSep xs + || not (null xs) && last xs == '.' && lastSep (init xs) + lastSep xs = not (null xs) && isPathSeparator (last xs) + + f = joinPath . dropDots [] . splitDirectories . propSep + + propSep (a:b:xs) + | isPathSeparator a && isPathSeparator b = propSep (a:xs) + propSep (a:xs) + | isPathSeparator a = pathSeparator : propSep xs + propSep (x:xs) = x : propSep xs + propSep [] = [] + + dropDots _ xs | all (==".") xs = ["."] + dropDots acc xs = dropDots' acc xs + + dropDots' acc (".":xs) = dropDots' acc xs + dropDots' acc (x:xs) = dropDots' (x:acc) xs + dropDots' acc [] = reverse acc + +--joinDrive = ++ +normaliseDrive :: FilePath -> FilePath +normaliseDrive = id + diff --git a/Git/SHA.hs b/Git/SHA.hs new file mode 100644 --- /dev/null +++ b/Git/SHA.hs @@ -0,0 +1,31 @@ +{-# OPTIONS -Wall #-} + +module Git.SHA ( + showDigestBS, + readDigestBS +) where + +import Data.Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Char +import Data.List (unfoldr) +import Numeric + +------------------------------------------------------------ +-- From Data.Digest.Pure.SHA + +-- |Prints out a bytestring in hexadecimal. Just for convenience. +showDigestBS :: ByteString -> String +showDigestBS bs = foldr paddedShowHex [] (BS.unpack bs) + where + paddedShowHex x xs = intToDigit (fromIntegral (x `shiftR` 4)) + : intToDigit (fromIntegral (x .&. 0xf)) + : xs + + +------------------------------------------------------------ +-- Read a string as a hex bytestring + +readDigestBS :: String -> ByteString +readDigestBS = BS.pack . map (fst . head . readHex) . takeWhile (not . null) . unfoldr (Just . splitAt 2) diff --git a/ght.cabal b/ght.cabal --- a/ght.cabal +++ b/ght.cabal @@ -1,43 +1,83 @@ Name: ght -Version: 0.3.1 + +Version: 0.4.0.1 + +Synopsis: Trivial routines for inspecting git repositories + +Description: + This is a bunch of trivial routines for inspecting git repositories. + It is in no way useful beyond that. + License: GPL License-file: GPL-2 Author: Conrad Parker Maintainer: Conrad Parker -Category: Development -Synopsis: Trivial routines for inspecting git repositories -Description: This is a bunch of trivial routines for inspecting git - repositories. It is in no way useful beyond that. Stability: experimental -Build-Type: Simple +Category: Development + Cabal-Version: >= 1.6 +Build-Type: Simple +flag splitBase + description: Use the split-up base package. + ------------------------------------------------------------ library - Build-Depends: base < 5, - data-default, - bytestring, - binary, - SHA, - old-locale, - time - Exposed-Modules: Git.Commit - Git.Pack + if flag(splitBase) + build-depends: + base >= 3 && < 6 + else + build-depends: + base < 3 + Build-Depends: + data-default, + bytestring, + binary, + SHA, + old-locale, + time, + iteratee, + iteratee-compress >= 0.3.0.0 && < 0.4, + mmap, + storable-endian + Exposed-Modules: + Git.Blob + Git.Commit + Git.Pack + Git.PackIndex + Git.Path + Git.SHA + ------------------------------------------------------------ -- ght tool -- Executable ght - Main-Is: ght.hs - Hs-Source-Dirs: ., tools - Build-Depends: base < 5, - bytestring, - data-default, - directory, - filepath, - mtl >= 2.0.0.0 && < 3, - SHA, - ui-command, - unix, - zlib + Main-Is: ght.hs + Hs-Source-Dirs: ., tools + + if flag(splitBase) + build-depends: + base >= 3 && < 6 + else + build-depends: + base < 3 + + Build-Depends: + bytestring, + data-default, + directory, + filepath, + mtl >= 2.0.0.0 && < 3, + SHA, + ui-command, + unix, + zlib + +------------------------------------------------------------------------ +-- Git repo +-- +source-repository head + type: git + location: git://github.com/kfish/ght.git diff --git a/tools/ght.hs b/tools/ght.hs --- a/tools/ght.hs +++ b/tools/ght.hs @@ -1,24 +1,30 @@ +{-# OPTIONS -fwarn-unused-imports #-} + module Main where -import Control.Monad (liftM, when) +import Control.Applicative ((<$>)) +import Control.Monad ((<=<), join) import Control.Monad.Trans (liftIO) import Data.Default -import Data.List (intersperse, sort) +import Data.List (sort) import UI.Command +import Git.Blob import Git.Commit import Git.Pack +import Git.PackIndex +import Git.Path +import Git.SHA -- show-prefix, show-root use these -import System.FilePath hiding (normalise) +import System.FilePath import System.Directory import System.Posix.Files -- show import System.IO (stdout) -import Codec.Compression.Zlib import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as C import Data.Digest.Pure.SHA (sha1, showDigest) @@ -36,12 +42,11 @@ cmdShortDesc = "Show path from top-level directory of repo" } -ghtShowPrefixHandler = do - path <- liftIO findRoot - cwd <- liftIO $ getCurrentDirectory - canPath <- liftIO $ canonicalizePath path +ghtShowPrefixHandler = liftIO $ do + canPath <- canonicalizePath =<< gitRoot + cwd <- getCurrentDirectory let relPath = makeRelative canPath cwd - liftIO $ putStrLn (relPath ++ [pathSeparator]) + putStrLn (relPath ++ [pathSeparator]) ------------------------------------------------------------ -- show-root @@ -56,106 +61,7 @@ cmdShortDesc = "Show path to top-level directory of repo" } -ghtShowRootHandler = do - path <- liftIO findRoot - liftIO $ putStrLn path - ------------------------------------------------------------- --- findRoot --- - -gitPath :: FilePath -> IO FilePath -gitPath f = do - root <- findRoot - return $ root ".git" f - -findRoot :: IO FilePath -findRoot = do - mp <- liftIO $ findRoot' "." - case mp of - Just path -> return (path ++ [pathSeparator]) - Nothing -> error "fatal: Not a git repository (or any of the parent directories)" - -findRoot' :: FilePath -> IO (Maybe FilePath) -findRoot' path = do - b <- fileExist path - case b of - True -> do - d <- dirIsRoot path - case d of - True -> return (Just (normalise path)) - False -> do - let newPath = ".." path - canPath <- canonicalizePath path - canNewPath <- canonicalizePath newPath - if (canPath == canNewPath) then - return Nothing - else findRoot' newPath - False -> return Nothing - -dirIsRoot path = do - let dotGit = path ".git" - liftIO $ fileExist dotGit - ------------------------------------------------------------- --- normalise --- - --- NOTE: this is a modified version of normalise from filepath, --- fixed to handle the case of a trailing dot. This version was --- submitted via the libraries process as ticket #3975: --- http://hackage.haskell.org/trac/ghc/ticket/3975 --- which was applied on 08 Jan 2011. - --- | Normalise a file --- --- * \/\/ outside of the drive can be made blank --- --- * \/ -> 'pathSeparator' --- --- * .\/ -> \"\" --- --- > Posix: normalise "/file/\\test////" == "/file/\\test/" --- > Posix: normalise "/file/./test" == "/file/test" --- > Posix: normalise "/test/file/../bob/fred/" == "/test/file/../bob/fred/" --- > Posix: normalise "../bob/fred/" == "../bob/fred/" --- > Posix: normalise "./bob/fred/" == "bob/fred/" --- > Windows: normalise "c:\\file/bob\\" == "C:\\file\\bob\\" --- > Windows: normalise "c:\\" == "C:\\" --- > Windows: normalise "\\\\server\\test" == "\\\\server\\test" --- > Windows: normalise "c:/file" == "C:\\file" --- > normalise "." == "." --- > Posix: normalise "./" == "./" --- > Posix: normalise "./." == "./" --- > Posix: normalise "bob/fred/." == "bob/fred/" -normalise :: FilePath -> FilePath -normalise path = joinDrive (normaliseDrive drv) (f pth) - ++ [pathSeparator | isDirPath pth] - where - (drv,pth) = splitDrive path - - isDirPath xs = lastSep xs - || not (null xs) && last xs == '.' && lastSep (init xs) - lastSep xs = not (null xs) && isPathSeparator (last xs) - - f = joinPath . dropDots [] . splitDirectories . propSep - - propSep (a:b:xs) - | isPathSeparator a && isPathSeparator b = propSep (a:xs) - propSep (a:xs) - | isPathSeparator a = pathSeparator : propSep xs - propSep (x:xs) = x : propSep xs - propSep [] = [] - - dropDots acc xs | all (==".") xs = ["."] - dropDots acc xs = dropDots' acc xs - - dropDots' acc (".":xs) = dropDots' acc xs - dropDots' acc (x:xs) = dropDots' (x:acc) xs - dropDots' acc [] = reverse acc - ---joinDrive = ++ -normaliseDrive = id +ghtShowRootHandler = liftIO $ putStrLn =<< gitRoot ------------------------------------------------------------ -- branch @@ -169,52 +75,24 @@ cmdExamples = [("Show branches available", "")] } -ghtBranchHandler = do - args <- appArgs - liftIO $ showBranches args +ghtBranchHandler = liftIO . showBranches =<< appArgs showBranches _ = do path <- gitPath $ "refs" "heads" branches <- getDirectoryContents path let branches' = filter (/= ".") branches let branches'' = filter (/= "..") branches' - hd <- derefFile "HEAD" + hd <- gitDeref "HEAD" mapM_ (showBranch hd) (sort branches'') showBranch hd b = do - ref <- derefFile $ "refs" "heads" b - if (ref == hd) then - putStr "* " + ref <- gitDeref $ "refs" "heads" b + if (ref == hd) + then putStr "* " else putStr " " putStrLn b ------------------------------------------------------------ --- findBlob --- - -findBlob [] = findBlob ["HEAD"] - -findBlob (name:_) = do - mPath <- firstExist [name, - ("refs" name), - ("refs" "tags" name), - ("refs" "heads" name), - ("refs" "remotes" name), - ("refs" "remotes" name "HEAD")] - case mPath of - Just path -> do - bs <- derefFile path - return [C.unpack bs] - Nothing -> return [name] - -firstExist :: [FilePath] -> IO (Maybe FilePath) -firstExist [] = return Nothing -firstExist (f:fs) = do - p <- gitPath f - b <- fileExist p - if b then return (Just f) else firstExist fs - ------------------------------------------------------------- -- log -- @@ -226,16 +104,12 @@ cmdExamples = [("Show log of current branch", ""), ("Show log of branch feature1", "feature1")] } -ghtLogHandler = do - args <- appArgs - b <- liftIO $ findBlob args - liftIO $ showLog b +ghtLogHandler = liftIO . showLog =<< liftIO . findBlob =<< appArgs showLog (blob:_) | blob == "" = return () | otherwise = do - d <- readBlob blob - let m'pb = prettyLog blob d + m'pb <- join . fmap (prettyLog blob) <$> readBlob blob case m'pb of Just c -> do let p = C.concat [commitHeader, C.pack (blob ++ "\n"), commitPretty c] @@ -264,25 +138,39 @@ cmdExamples = [("Show raw contents of pack pack-abcd.pack", "abcd")] } -ghtShowPackHandler = do - args <- appArgs - b <- liftIO $ findPack args - -- liftIO $ L.hPut stdout b - let p = prettyPack b - liftIO $ L.hPut stdout p +ghtShowPackHandler = mapM_ (liftIO . (putStrLn . show <=< packRead <=< pathExistOr packPath)) =<< appArgs -findPack (pack:_) = do - path <- gitPath ("objects" "pack" ("pack-" ++ pack ++ ".pack")) - b <- L.readFile path - return b +------------------------------------------------------------ +-- show-idx +-- -prettyPack bs - | packHeader `L.isPrefixOf` bs = packPretty $ packParse bs - | otherwise = error "Not a pack" - where - packHeader = C.pack "PACK" +ghtShowIdx = defCmd { + cmdName = "show-idx", + cmdHandler = ghtShowIdxHandler, + cmdCategory = "Blob management", + cmdShortDesc = "Show the raw dump of a pack index", + cmdExamples = [("Show raw contents of pack pack-abcd.idx", "abcd")] + } +ghtShowIdxHandler = mapM_ (liftIO . (putStrLn <=< dumpRawPackIndex <=< pathExistOr idxPath)) =<< appArgs + ------------------------------------------------------------ +-- find-idx +-- + +ghtFindIdx = defCmd { + cmdName = "find-idx", + cmdHandler = ghtFindIdxHandler, + cmdCategory = "Blob management", + cmdShortDesc = "Find a SHA in any pack index", + cmdExamples = [("Find SHA1 333fff", "333fff")] + } + +ghtFindIdxHandler = do + (sha:_) <- appArgs + liftIO $ print =<< findInPackIdxs (readDigestBS sha) + +------------------------------------------------------------ -- show-raw -- @@ -294,14 +182,9 @@ cmdExamples = [("Show raw contents of blob deadbeef", "deadbeef"), ("Show raw contents of branch feature1", "feature1")] } -ghtShowRawHandler = do - args <- appArgs - b <- liftIO $ findBlob args - liftIO $ showRawBlob b +ghtShowRawHandler = liftIO . showRawBlob =<< liftIO . findBlob =<< appArgs -showRawBlob (blob:_) = do - d <- readBlob blob - L.hPut stdout d +showRawBlob (blob:_) = maybe (putStrLn "Not found") (L.hPut stdout) =<< readBlob blob ------------------------------------------------------------ -- show @@ -315,41 +198,9 @@ cmdExamples = [("Show contents of blob deadbeef", "deadbeef"), ("Show contents of branch feature1", "feature1")] } -ghtShowHandler = do - args <- appArgs - b <- liftIO $ findBlob args - liftIO $ showBlob b - -readBlob blob = do - let (bH,bT) = splitAt 2 blob - path <- gitPath ("objects" bH bT) - b <- L.readFile path - return (decompress b) - -showBlob (blob:_) = do - d <- readBlob blob - let pb = prettyBlob blob d - L.hPut stdout pb - -prettyBlob blob bs - | commitHeader `L.isPrefixOf` bs = C.concat [commitHeader, C.pack (blob ++ "\n"), commitPretty $ commitParse bs] - | otherwise = chomp bs - where - commitHeader = C.pack "commit " - -derefFile f = do - path <- gitPath f - bs <- L.readFile path - deref bs - -deref bs - | refHeader `L.isPrefixOf` bs = derefFile refPath - | otherwise = return (chomp bs) - where - refHeader = C.pack "ref: " - refPath = C.unpack (chomp $ L.drop 5 bs) +ghtShowHandler = liftIO . showBlob =<< liftIO . findBlob =<< appArgs -chomp = C.takeWhile (/= '\n') +showBlob (blob:_) = maybe (putStrLn "Not found") (C.hPut stdout . prettyBlob blob) =<< readBlob blob ------------------------------------------------------------ -- hash-object @@ -363,9 +214,7 @@ cmdExamples = [("Compute the object ID of file.c", "file.c")] } -ghtHashObjectHandler = do - args <- appArgs - liftIO $ hashFile args +ghtHashObjectHandler = liftIO . hashFile =<< appArgs hashFile [] = return () @@ -393,7 +242,7 @@ appCategories = ["Reporting", "Blob management"], appSeeAlso = ["git"], appProject = "Ght", - appCmds = [ghtShowPrefix, ghtShowRoot, ghtShow, ghtLog, ghtShowRaw, ghtShowPack, ghtHashObject, ghtBranch] + appCmds = [ghtShowPrefix, ghtShowRoot, ghtShow, ghtLog, ghtShowRaw, ghtShowPack, ghtShowIdx, ghtFindIdx, ghtHashObject, ghtBranch] } longDesc = "This is a bunch of trivial routines for inspecting git repositories. It is in no way useful beyond that."