diff --git a/Data/Git/Ref.hs b/Data/Git/Ref.hs --- a/Data/Git/Ref.hs +++ b/Data/Git/Ref.hs @@ -5,22 +5,29 @@ -- Stability : experimental -- Portability : unix -- +{-# LANGUAGE DeriveDataTypeable #-} module Data.Git.Ref - ( Ref - , isHex - , isHexString - , fromHex - , fromHexString - , fromBinary - , toBinary - , toHex - , toHexString - , refPrefix - , cmpPrefix - , toFilePathParts - , hash - , hashLBS - ) where + ( Ref + -- * Exceptions + , RefInvalid(..) + , RefNotFound(..) + -- * convert from bytestring and string + , isHex + , isHexString + , fromHex + , fromHexString + , fromBinary + , toBinary + , toHex + , toHexString + -- * Misc function related to ref + , refPrefix + , cmpPrefix + , toFilePathParts + -- * Hash ByteString types to a ref + , hash + , hashLBS + ) where import Control.Monad (forM_) import qualified Crypto.Hash.SHA1 as SHA1 @@ -31,16 +38,30 @@ import qualified Data.ByteString.Char8 as BC import Data.Bits import Data.Char (isHexDigit) +import Data.Data import Foreign.Storable +import Control.Exception (Exception, throw) -- | represent a git reference (SHA1) newtype Ref = Ref ByteString - deriving (Eq,Ord) + deriving (Eq,Ord,Data,Typeable) instance Show Ref where show = BC.unpack . toHex +-- | Invalid Reference exception raised when +-- using something that is not a ref as a ref. +data RefInvalid = RefInvalid ByteString + deriving (Show,Eq,Data,Typeable) + +-- | Reference wasn't found +data RefNotFound = RefNotFound Ref + deriving (Show,Eq,Data,Typeable) + +instance Exception RefInvalid +instance Exception RefNotFound + isHex = and . map isHexDigit . BC.unpack isHexString = and . map isHexDigit @@ -49,7 +70,7 @@ fromHex :: ByteString -> Ref fromHex s | B.length s == 40 = Ref $ B.unsafeCreate 20 populateRef - | otherwise = error ("not a valid hex ref: " ++ show s) + | otherwise = throw $ RefInvalid s where populateRef ptr = forM_ [0..19] $ \i -> do let v = (unhex (B.unsafeIndex s (i*2+0)) `shiftL` 4) .|. unhex (B.unsafeIndex s (i*2+1)) @@ -77,7 +98,7 @@ unhex 0x64 = 13 unhex 0x65 = 14 unhex 0x66 = 15 -- 'f' - unhex _ = error "error fromHex: not a valid hex character" + unhex _ = throw $ RefInvalid s -- | take a hexadecimal string that represent a reference -- and turn into a ref @@ -106,7 +127,7 @@ fromBinary :: ByteString -> Ref fromBinary b | B.length b == 20 = Ref b - | otherwise = error "not a valid binary ref" + | otherwise = throw $ RefInvalid b -- should hexify the ref here -- | turn a reference into a binary bytestring toBinary :: Ref -> ByteString @@ -127,4 +148,5 @@ -- | hash a bytestring into a reference hash = Ref . SHA1.hash +-- | hash a lazy bytestring into a reference hashLBS = Ref . SHA1.hashlazy diff --git a/Data/Git/Repository.hs b/Data/Git/Repository.hs --- a/Data/Git/Repository.hs +++ b/Data/Git/Repository.hs @@ -1,5 +1,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} -- | -- Module : Data.Git.Repository -- License : BSD-style @@ -11,7 +12,9 @@ ( Git , HTree , HTreeEnt(..) + , getCommitMaybe , getCommit + , getTreeMaybe , getTree , rewrite , buildHTree @@ -24,9 +27,11 @@ import Control.Applicative ((<$>)) import Control.Monad +import Control.Exception (Exception, throw) import Data.Maybe (fromMaybe) import Data.List (find) +import Data.Data import Data.ByteString (ByteString) @@ -45,24 +50,35 @@ data HTreeEnt = TreeDir Ref HTree | TreeFile Ref type HTree = [(Int,ByteString,HTreeEnt)] +-- | Exception when trying to convert an object pointed by 'Ref' to +-- a type that is different +data InvalidType = InvalidType Ref ObjectType + deriving (Show,Eq,Data,Typeable) + +instance Exception InvalidType + -- should be a standard function that do that... mapJustM f (Just o) = f o mapJustM _ Nothing = return Nothing -- | get a specified commit -getCommit :: Git -> Ref -> IO (Maybe Commit) -getCommit git ref = getObject git ref True >>= mapJustM unwrap - where - unwrap (objectToCommit -> Just c@(Commit {})) = return $ Just c - unwrap _ = return Nothing +getCommitMaybe :: Git -> Ref -> IO (Maybe Commit) +getCommitMaybe git ref = maybe Nothing objectToCommit <$> getObject git ref True +-- | get a specified commit but raises an exception if doesn't exists or type is not appropriate +getCommit :: Git -> Ref -> IO Commit +getCommit git ref = maybe err id . objectToCommit <$> getObject_ git ref True + where err = throw $ InvalidType ref TypeCommit + -- | get a specified tree -getTree :: Git -> Ref -> IO (Maybe Tree) -getTree git ref = getObject git ref True >>= mapJustM unwrap - where - unwrap (objectToTree -> Just c@(Tree {})) = return $ Just c - unwrap _ = return Nothing +getTreeMaybe :: Git -> Ref -> IO (Maybe Tree) +getTreeMaybe git ref = maybe Nothing objectToTree <$> getObject git ref True +-- | get a specified tree but raise +getTree :: Git -> Ref -> IO Tree +getTree git ref = maybe err id . objectToTree <$> getObject_ git ref True + where err = throw $ InvalidType ref TypeTree + -- | try to resolve a string to a specific commit ref -- for example: HEAD, HEAD^, master~3, shortRef resolveRevision :: Git -> Revision -> IO (Maybe Ref) @@ -124,11 +140,7 @@ modf (RevModParentFirstN (n-1):xs) (head parentRefs) modf (_:_) _ = error "unimplemented revision modifier" - getParentRefs ref = do - obj <- getCommit git ref - case obj of - Just (Commit { commitParents = parents }) -> return parents - Nothing -> error "reference in commit chain doesn't exists" + getParentRefs ref = commitParents <$> getCommit git ref -- | returns a tree from a ref that might be either a commit, a tree or a tag. resolveTreeish :: Git -> Ref -> IO (Maybe Tree) @@ -162,8 +174,8 @@ resolveParents nbParent ref >>= process . reverse where resolveParents :: Int -> Ref -> IO [ (Ref, Commit) ] - resolveParents 0 ref = (:[]) . (,) ref . fromMaybe (error "commit cannot be found") <$> getCommit git ref - resolveParents n ref = do commit <- fromMaybe (error "commit cannot be found") <$> getCommit git ref + resolveParents 0 ref = (:[]) . (,) ref <$> getCommit git ref + resolveParents n ref = do commit <- getCommit git ref case commitParents commit of [parentRef] -> liftM ((ref,commit) :) (resolveParents (n-1) parentRef) _ -> return [(ref,commit)] @@ -185,13 +197,9 @@ obj <- getObjectType git ref case obj of Just TypeBlob -> return (perm, ent, TreeFile ref) - Just TypeTree -> do - ctree <- getTree git ref - case ctree of - Nothing -> error "unknown reference in tree object: no such child" - Just t -> do - dir <- buildHTree git t - return (perm, ent, TreeDir ref dir) + Just TypeTree -> do ctree <- getTree git ref + dir <- buildHTree git ctree + return (perm, ent, TreeDir ref dir) Just _ -> error "wrong type embedded in tree object" Nothing -> error "unknown reference in tree object" @@ -200,23 +208,17 @@ -> Ref -- ^ commit reference -> [ByteString] -- ^ paths -> IO (Maybe Ref) -resolvePath git commitRef paths = do - commit <- getCommit git commitRef - case commit of - Just (Commit { commitTreeish = tree }) -> resolve tree paths - Nothing -> error ("not a valid commit ref: " ++ show commitRef) - where +resolvePath git commitRef paths = + getCommit git commitRef >>= \commit -> resolve (commitTreeish commit) paths + where resolve :: Ref -> [ByteString] -> IO (Maybe Ref) resolve treeRef [] = return $ Just treeRef resolve treeRef (x:xs) = do - tree <- getTree git treeRef - case tree of - Just (Tree ents) -> do - let cEnt = treeEntRef <$> findEnt x ents - if xs == [] - then return cEnt - else maybe (return Nothing) (\z -> resolve z xs) cEnt - Nothing -> error ("not a valid tree ref: " ++ show treeRef) + (Tree ents) <- getTree git treeRef + let cEnt = treeEntRef <$> findEnt x ents + if xs == [] + then return cEnt + else maybe (return Nothing) (\z -> resolve z xs) cEnt findEnt x = find (\(_, b, _) -> b == x) treeEntRef (_,_,r) = r diff --git a/Data/Git/Revision.hs b/Data/Git/Revision.hs --- a/Data/Git/Revision.hs +++ b/Data/Git/Revision.hs @@ -5,22 +5,27 @@ -- Stability : experimental -- Portability : unix -- +{-# LANGUAGE DeriveDataTypeable #-} module Data.Git.Revision - ( Revision(..) - , RevModifier(..) - , fromString - ) where + ( Revision(..) + , RevModifier(..) + , RevisionNotFound(..) + , fromString + ) where import Text.Parsec import Data.String +import Data.Data +-- | A modifier to a revision, which is +-- a function apply of a revision data RevModifier = RevModParent Int -- ^ parent accessor ^ and ^ | RevModParentFirstN Int -- ^ parent accessor ~ | RevModAtType String -- ^ @{type} accessor | RevModAtDate String -- ^ @{date} accessor | RevModAtN Int -- ^ @{n} accessor - deriving (Eq) + deriving (Eq,Data,Typeable) instance Show RevModifier where show (RevModParent 1) = "^" @@ -30,8 +35,20 @@ show (RevModAtDate s) = "@{" ++ s ++ "}" show (RevModAtN s) = "@{" ++ show s ++ "}" +-- | A git revision. this can be many things: +-- * a shorten ref +-- * a ref +-- * a named branch or tag +-- followed by optional modifiers 'RevModifier' that can represent: +-- * parenting +-- * type +-- * date data Revision = Revision String [RevModifier] - deriving (Eq) + deriving (Eq,Data,Typeable) + +-- | Exception when a revision cannot be resolved to a reference +data RevisionNotFound = RevisionNotFound Revision + deriving (Show,Eq,Data,Typeable) instance Show Revision where show (Revision s ms) = s ++ concatMap show ms diff --git a/Data/Git/Storage.hs b/Data/Git/Storage.hs --- a/Data/Git/Storage.hs +++ b/Data/Git/Storage.hs @@ -27,6 +27,7 @@ , getObjectRaw , getObjectRawAt , getObject + , getObject_ , getObjectAt , getObjectType -- * setting objects @@ -303,6 +304,15 @@ getObject git ref resolveDelta = maybe Nothing toObj <$> getObjectRaw git ref resolveDelta where toObj (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData) + +-- | Just like 'getObject' but will raise a RefNotFound exception if the +-- reference cannot be found. +getObject_ :: Git -- ^ repository + -> Ref -- ^ the object's reference to + -> Bool -- ^ whether to resolve deltas if found + -> IO Object -- ^ returned object if found +getObject_ git ref resolveDelta = maybe (throwIO $ RefNotFound ref) return + =<< getObject git ref resolveDelta -- | set an object in the store and returns the new ref -- this is always going to create a loose object. diff --git a/Data/Git/Types.hs b/Data/Git/Types.hs --- a/Data/Git/Types.hs +++ b/Data/Git/Types.hs @@ -5,6 +5,7 @@ -- Stability : experimental -- Portability : unix -- +{-# LANGUAGE DeriveDataTypeable #-} module Data.Git.Types ( -- * Type of types @@ -36,6 +37,7 @@ import Data.Git.Delta import Data.Time.Clock import Data.Time.Clock.POSIX +import Data.Data -- | type of a git object. data ObjectType = @@ -45,7 +47,7 @@ | TypeTag | TypeDeltaOff | TypeDeltaRef - deriving (Show,Eq) + deriving (Show,Eq,Data,Typeable) -- | Git time is number of seconds since unix epoch data GitTime = GitTime Integer Int diff --git a/Hit/Hit.hs b/Hit/Hit.hs --- a/Hit/Hit.hs +++ b/Hit/Hit.hs @@ -31,131 +31,128 @@ type HashTable k v = H.CuckooHashTable k v instance Hashable.Hashable Ref where - hash = Hashable.hash . toBinary + hashWithSalt salt = Hashable.hashWithSalt salt . toBinary verifyPack pref git = do - offsets <- H.new - tree <- H.new - refs <- newIORef M.empty - entries <- fromIntegral <$> packReadHeader (gitRepoPath git) pref - leftParsed <- newIORef entries - -- enumerate all objects either directly in tree for fully formed objects - -- or a list of delta to resolves - packEnumerateObjects (gitRepoPath git) pref entries (setObj leftParsed refs offsets tree) - readIORefAndReplace refs M.empty >>= dumpTree offsets tree - where - readIORefAndReplace ioref emptyVal = do - v <- readIORef ioref - writeIORef ioref emptyVal - return v + offsets <- H.new + tree <- H.new + refs <- newIORef M.empty + entries <- fromIntegral <$> packReadHeader (gitRepoPath git) pref + leftParsed <- newIORef entries + -- enumerate all objects either directly in tree for fully formed objects + -- or a list of delta to resolves + packEnumerateObjects (gitRepoPath git) pref entries (setObj leftParsed refs offsets tree) + readIORefAndReplace refs M.empty >>= dumpTree offsets tree + where + readIORefAndReplace ioref emptyVal = do + v <- readIORef ioref + writeIORef ioref emptyVal + return v - setObj_ refs offsets tree (!info, objData) - | objectTypeIsDelta (poiType info) = do - (!ty, !ref, !ptr, !lenChain) <- do - let loc = Packed pref (poiOffset info) - objInfo <- maybe (error "cannot find delta chain") id <$> getObjectRawAt git loc True - let (ty, sz, _) = oiHeader objInfo - let !ref = objectHash ty sz (oiData objInfo) - let ptr = head $ oiChains objInfo -- it's safe since deltas always have a non empty valid chain - return (ty, ref, ptr, (length $ oiChains objInfo)) - H.insert tree ref (info { poiType = ty }, Just (ptr, lenChain)) - | otherwise = do - let !ref = objectHash (poiType info) (poiActualSize info) objData - modifyIORef refs (M.insert ref ()) - H.insert offsets (poiOffset info) ref - H.insert tree ref (info,Nothing) + setObj_ refs offsets tree (!info, objData) + | objectTypeIsDelta (poiType info) = do + (!ty, !ref, !ptr, !lenChain) <- do + let loc = Packed pref (poiOffset info) + objInfo <- maybe (error "cannot find delta chain") id <$> getObjectRawAt git loc True + let (ty, sz, _) = oiHeader objInfo + let !ref = objectHash ty sz (oiData objInfo) + let ptr = head $ oiChains objInfo -- it's safe since deltas always have a non empty valid chain + return (ty, ref, ptr, (length $ oiChains objInfo)) + H.insert tree ref (info { poiType = ty }, Just (ptr, lenChain)) + | otherwise = do + let !ref = objectHash (poiType info) (poiActualSize info) objData + modifyIORef refs (M.insert ref ()) + H.insert offsets (poiOffset info) ref + H.insert tree ref (info,Nothing) - setObj leftParsed refs offsets tree x = do - parsed <- readIORef leftParsed - when ((parsed `mod` 256) == 0) $ putStrLn (show parsed ++ " left to parse") - modifyIORef leftParsed (\i -> i-1) - setObj_ refs offsets tree x + setObj leftParsed refs offsets tree x = do + parsed <- readIORef leftParsed + when ((parsed `mod` 256) == 0) $ putStrLn (show parsed ++ " left to parse") + modifyIORef leftParsed (\i -> i-1) + setObj_ refs offsets tree x - dumpTree :: HashTable Word64 Ref -> HashTable Ref (PackedObjectInfo, Maybe (ObjectPtr, Int)) -> M.Map Ref () -> IO () - dumpTree offsets tree refs = do - forM_ (M.toAscList refs) $ \(ref, ()) -> do - ent <- fromJust <$> H.lookup tree ref - printEnt offsets ref ent + dumpTree :: HashTable Word64 Ref -> HashTable Ref (PackedObjectInfo, Maybe (ObjectPtr, Int)) -> M.Map Ref () -> IO () + dumpTree offsets tree refs = do + forM_ (M.toAscList refs) $ \(ref, ()) -> do + ent <- fromJust <$> H.lookup tree ref + printEnt offsets ref ent - -- print one line about the entry - -- format is [ ] - printEnt _ ref (info,Nothing) = do - printf "%s %-6s %d %d %d\n" (show ref) - (objectTypeMarshall $ poiType info) - (poiActualSize info) - (poiSize info) - (poiOffset info) + -- print one line about the entry + -- format is [ ] + printEnt _ ref (info,Nothing) = do + printf "%s %-6s %d %d %d\n" (show ref) + (objectTypeMarshall $ poiType info) + (poiActualSize info) + (poiSize info) + (poiOffset info) - printEnt offsets ref (info,Just (parentOffset, lenChain)) = do - parentRef <- case parentOffset of - PtrRef r -> return r - PtrOfs off -> do - let poff = poiOffset info - off - maybe (error "cannot find delta's parent in pack ?") id <$> H.lookup offsets poff - printf "%s %-6s %d %d %d %d %s\n" (show ref) - (objectTypeMarshall $ poiType info) - (poiActualSize info) - (poiSize info) - (poiOffset info) - (lenChain) - (show parentRef) + printEnt offsets ref (info,Just (parentOffset, lenChain)) = do + parentRef <- case parentOffset of + PtrRef r -> return r + PtrOfs off -> do + let poff = poiOffset info - off + maybe (error "cannot find delta's parent in pack ?") id <$> H.lookup offsets poff + printf "%s %-6s %d %d %d %d %s\n" (show ref) + (objectTypeMarshall $ poiType info) + (poiActualSize info) + (poiSize info) + (poiOffset info) + (lenChain) + (show parentRef) catFile ty ref git = do - let expectedType = case ty of - "commit" -> Just TypeCommit - "blob" -> Just TypeBlob - "tag" -> Just TypeTag - "tree" -> Just TypeTree - "-t" -> Nothing - _ -> error "unknown type request" - mobj <- getObjectRaw git ref True - case mobj of - Nothing -> error "not a valid object" - Just obj -> - let (objty, _, _) = oiHeader obj in - case expectedType of - Nothing -> putStrLn $ objectTypeMarshall objty - Just ety -> do - when (ety /= objty) $ error "not expected type" - LC.putStrLn (oiData obj) + let expectedType = case ty of + "commit" -> Just TypeCommit + "blob" -> Just TypeBlob + "tag" -> Just TypeTag + "tree" -> Just TypeTree + "-t" -> Nothing + _ -> error "unknown type request" + mobj <- getObjectRaw git ref True + case mobj of + Nothing -> error "not a valid object" + Just obj -> + let (objty, _, _) = oiHeader obj in + case expectedType of + Nothing -> putStrLn $ objectTypeMarshall objty + Just ety -> do + when (ety /= objty) $ error "not expected type" + LC.putStrLn (oiData obj) lsTree revision _ git = do - ref <- maybe (error "revision cannot be found") id <$> resolveRevision git revision - tree <- resolveTreeish git ref - case tree of - Just t -> do - htree <- buildHTree git t - 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) + ref <- maybe (error "revision cannot be found") id <$> resolveRevision git revision + tree <- resolveTreeish git ref + case tree of + Just t -> do + htree <- buildHTree git t + 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) revList revision git = do - ref <- maybe (error "revision cannot be found") id <$> resolveRevision git revision - loopTillEmpty ref - where loopTillEmpty ref = do - obj <- getCommit git ref - case obj of - Just (Commit { commitParents = parents }) -> do - putStrLn $ show ref - -- this behave like rev-list --first-parent. - -- otherwise the parents need to be organized and printed - -- in a reverse chronological fashion. - case parents of - [] -> return () - (p:_) -> loopTillEmpty p - Nothing -> error ("commit reference " ++ show ref ++ " in commit chain doesn't exists") + ref <- maybe (error "revision cannot be found") id <$> resolveRevision git revision + loopTillEmpty ref + where loopTillEmpty ref = do + commit <- getCommit git ref + putStrLn $ show ref + -- this behave like rev-list --first-parent. + -- otherwise the parents need to be organized and printed + -- in a reverse chronological fashion. + case commitParents commit of + [] -> return () + (p:_) -> loopTillEmpty p main = do - args <- getArgs - case args of - ["verify-pack",ref] -> withCurrentRepo $ verifyPack (fromHexString ref) - ["cat-file",ty,ref] -> withCurrentRepo $ catFile ty (fromHexString ref) - ["ls-tree",rev] -> withCurrentRepo $ lsTree (fromString rev) "" - ["ls-tree",rev,path] -> withCurrentRepo $ lsTree (fromString rev) path - ["rev-list",rev] -> withCurrentRepo $ revList (fromString rev) - cmd : [] -> error ("unknown command: " ++ cmd) - [] -> error "no args" - _ -> error "unknown command line arguments" + args <- getArgs + case args of + ["verify-pack",ref] -> withCurrentRepo $ verifyPack (fromHexString ref) + ["cat-file",ty,ref] -> withCurrentRepo $ catFile ty (fromHexString ref) + ["ls-tree",rev] -> withCurrentRepo $ lsTree (fromString rev) "" + ["ls-tree",rev,path] -> withCurrentRepo $ lsTree (fromString rev) path + ["rev-list",rev] -> withCurrentRepo $ revList (fromString rev) + 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 @@ -29,6 +29,7 @@ arbitraryBS size = B.pack . map fromIntegral <$> replicateM size (choose (0,255) :: Gen Int) arbitraryBSno0 size = B.pack . map fromIntegral <$> replicateM size (choose (1,255) :: Gen Int) +arbitraryBSasciiNoSpace size = B.pack . map fromIntegral <$> replicateM size (choose (0x21,0x7f) :: Gen Int) arbitraryBSascii size = B.pack . map fromIntegral <$> replicateM size (choose (0x20,0x7f) :: Gen Int) arbitraryBSnoangle size = B.pack . map fromIntegral <$> replicateM size (choose (0x40,0x7f) :: Gen Int) @@ -72,7 +73,7 @@ arbitrary = Commit <$> arbitrary <*> arbitraryRefList <*> arbitraryName <*> arbitraryName <*> return Nothing <*> arbitrarySmallList <*> arbitraryMsg instance Arbitrary CommitExtra where - arbitrary = CommitExtra <$> arbitraryBSascii 80 <*> arbitraryMsg + arbitrary = CommitExtra <$> arbitraryBSasciiNoSpace 80 <*> arbitraryMsg instance Arbitrary Tree where arbitrary = Tree <$> arbitraryEnts diff --git a/hit.cabal b/hit.cabal --- a/hit.cabal +++ b/hit.cabal @@ -1,5 +1,5 @@ Name: hit -Version: 0.4.3 +Version: 0.5.0 Synopsis: Git operations in haskell Description: . @@ -77,7 +77,7 @@ Build-depends: base >= 4 && < 5 , mtl , containers - , hashable + , hashable >= 1.2 , hashtables , bytestring , attoparsec >= 0.10.1