ght 0.3.1 → 0.4.0.1

raw patch · 8 files changed

+745/−259 lines, 8 filesdep +iterateedep +iteratee-compressdep +mmapdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: iteratee, iteratee-compress, mmap, storable-endian

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Git/Blob.hs +67/−0
• Git/Commit.hs +12/−9
• Git/Pack.hs +147/−15
• Git/PackIndex.hs +219/−0
• Git/Path.hs +145/−0
• Git/SHA.hs +31/−0
• ght.cabal +67/−27
• tools/ght.hs +57/−208

@@ -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

@@ -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],

@@ -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)]

@@ -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)+    

@@ -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+

@@ -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)

@@ -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 <conrad@metadecks.org> Maintainer:          Conrad Parker <conrad@metadecks.org>-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

@@ -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."