hit 0.1.0 → 0.2.0
raw patch · 6 files changed
+160/−50 lines, 6 files
Files
- Data/Git/Loose.hs +5/−3
- Data/Git/Object.hs +119/−22
- Data/Git/Pack.hs +2/−2
- Data/Git/Repository.hs +32/−20
- Hit.hs +1/−2
- hit.cabal +1/−1
Data/Git/Loose.hs view
@@ -70,6 +70,8 @@ parseTag = parseTagHeader >> objectParseTag parseCommit = parseCommitHeader >> objectParseCommit parseBlob = parseBlobHeader >> objectParseBlob++parseObject :: L.ByteString -> Object parseObject = parseSuccess (parseTree <|> parseBlob <|> parseCommit <|> parseTag) where parseSuccess p = either error id . eitherResult . parse p @@ -118,9 +120,9 @@ looseEnumerateWithPrefixFilter repoPath prefix (const True) -- | marshall as lazy bytestring an object except deltas.-looseMarshall (DeltaOfs _ _) = error "cannot write delta offset as single object"-looseMarshall (DeltaRef _ _) = error "cannot write delta ref as single object"-looseMarshall obj = compress $ L.concat [ L.fromChunks [hdrB], objData ]+looseMarshall obj+ | objectIsDelta obj = error "cannot write delta object loose"+ | otherwise = compress $ L.concat [ L.fromChunks [hdrB], objData ] where objData = objectWrite obj hdrB = objectWriteHeader (objectToType obj) (fromIntegral $ L.length objData)
Data/Git/Object.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE ExistentialQuantification #-} -- | -- Module : Data.Git.Object -- License : BSD-style@@ -13,12 +14,28 @@ , ObjectData , ObjectPtr(..) , Object(..)+ , Tree(..)+ , Commit(..)+ , Blob(..)+ , Tag(..)+ , DeltaOfs(..)+ , DeltaRef(..) , ObjectInfo(..)+ , objectWrap , objectToType , objectTypeMarshall , objectTypeUnmarshall , objectTypeIsDelta+ , objectIsDelta+ , objectToTree+ , objectToCommit+ , objectToTag+ , objectToBlob -- * parsing function+ , treeParse+ , commitParse+ , tagParse+ , blobParse , objectParseTree , objectParseCommit , objectParseTag@@ -92,25 +109,51 @@ , oiChains :: [ObjectPtr] } deriving (Show,Eq) +class Objectable a where+ getType :: a -> ObjectType+ getRaw :: a -> L.ByteString+ isDelta :: a -> Bool++ toCommit :: a -> Maybe Commit+ toCommit = const Nothing+ toTree :: a -> Maybe Tree+ toTree = const Nothing+ toTag :: a -> Maybe Tag+ toTag = const Nothing+ toBlob :: a -> Maybe Blob+ toBlob = const Nothing+ -- | describe a git object, that could of 6 differents types: -- tree, blob, commit, tag and deltas (offset or ref). -- the deltas one are only available through packs.-data Object =- Tree [TreeEnt]- | Blob L.ByteString- | Commit Ref [Ref] Name Name ByteString- | Tag Ref ObjectType ByteString Name ByteString- | DeltaOfs Word64 Delta- | DeltaRef Ref Delta+data Object = forall a . Objectable a => Object a++objectWrap :: Objectable a => a -> Object+objectWrap a = Object a++data Tree = Tree { treeGetEnts :: [TreeEnt] } deriving (Show,Eq)+data Blob = Blob { blobGetContent :: L.ByteString } deriving (Show,Eq)+data Commit = Commit+ { commitTreeish :: Ref+ , commitParents :: [Ref]+ , commitAuthor :: Name+ , commitCommitter :: Name+ , commitMessage :: ByteString+ } deriving (Show,Eq)+data Tag = Tag+ { tagRef :: Ref+ , tagObjectType :: ObjectType+ , tagBlob :: ByteString+ , tagName :: Name+ , tagS :: ByteString+ } deriving (Show,Eq)+data DeltaOfs = DeltaOfs Word64 Delta deriving (Show,Eq)+data DeltaRef = DeltaRef Ref Delta+ deriving (Show,Eq) objectToType :: Object -> ObjectType-objectToType (Commit _ _ _ _ _) = TypeCommit-objectToType (Blob _) = TypeBlob-objectToType (Tree _) = TypeTree-objectToType (Tag _ _ _ _ _) = TypeTag-objectToType (DeltaOfs _ _) = TypeDeltaOff-objectToType (DeltaRef _ _) = TypeDeltaRef+objectToType (Object a) = getType a objectTypeMarshall :: ObjectType -> String objectTypeMarshall TypeTree = "tree"@@ -131,6 +174,21 @@ objectTypeIsDelta TypeDeltaRef = True objectTypeIsDelta _ = False +objectIsDelta :: Object -> Bool+objectIsDelta (Object a) = isDelta a++objectToTree :: Object -> Maybe Tree+objectToTree (Object a) = toTree a++objectToCommit :: Object -> Maybe Commit+objectToCommit (Object a) = toCommit a++objectToTag :: Object -> Maybe Tag+objectToTag (Object a) = toTag a++objectToBlob :: Object -> Maybe Blob+objectToBlob (Object a) = toBlob a+ -- | the enum instance is useful when marshalling to pack file. instance Enum ObjectType where fromEnum TypeCommit = 0x1@@ -160,14 +218,14 @@ referenceBin = fromBinary <$> P.take 20 -- | parse a tree content-objectParseTree = (Tree <$> parseEnts) where+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) -- | parse a blob content-objectParseBlob = (Blob <$> takeLazyByteString)+blobParse = (Blob <$> takeLazyByteString) -- | parse a commit content-objectParseCommit = do+commitParse = do tree <- string "tree " >> referenceHex skipChar '\n' parents <- many parseParentRef@@ -183,7 +241,7 @@ return tree -- | parse a tag content-objectParseTag = do+tagParse = do object <- string "object " >> referenceHex skipChar '\n' type_ <- objectTypeUnmarshall . BC.unpack <$> (string "type " >> takeTill ((==) 0x0a))@@ -206,12 +264,19 @@ skipChar '\n' return (name, email, time, timezone) +objectParseTree = objectWrap <$> treeParse+objectParseCommit = objectWrap <$> commitParse+objectParseTag = objectWrap <$> tagParse+objectParseBlob = objectWrap <$> blobParse+ -- header of loose objects, but also useful for any object to determine object's hash objectWriteHeader :: ObjectType -> Word64 -> ByteString objectWriteHeader ty sz = BC.pack (objectTypeMarshall ty ++ " " ++ show sz ++ [ '\0' ]) objectWrite :: Object -> L.ByteString-objectWrite (Tree ents) = L.fromChunks $ concat $ map writeTreeEnt ents where+objectWrite (Object a) = getRaw a++treeWrite (Tree ents) = L.fromChunks $ concat $ map writeTreeEnt ents where writeTreeEnt (perm,name,ref) = [ BC.pack $ printf "%o" perm , BC.singleton ' '@@ -220,7 +285,7 @@ , toBinary ref ] -objectWrite (Commit tree parents author committer msg) =+commitWrite (Commit tree parents author committer msg) = L.fromChunks [BC.unlines ls, B.singleton 0xa, msg] where ls = [ "tree " `BC.append` (toHex tree) ] ++@@ -228,7 +293,7 @@ [ writeName "author" author , writeName "committer" committer ] -objectWrite (Tag ref ty tag tagger signature) =+tagWrite (Tag ref ty tag tagger signature) = L.fromChunks [BC.unlines ls, B.singleton 0xa, signature] where ls = [ "object " `BC.append` (toHex ref)@@ -236,9 +301,41 @@ , "tag " `BC.append` tag , writeName "tagger" tagger ] -objectWrite (Blob bData) = bData+blobWrite (Blob bData) = bData -objectWrite _ = error "delta object are not supported here"+instance Objectable Blob where+ getType _ = TypeBlob+ getRaw = blobWrite+ isDelta = const False+ toBlob t = Just t++instance Objectable Commit where+ getType _ = TypeCommit+ getRaw = commitWrite+ isDelta = const False+ toCommit t = Just t++instance Objectable Tag where+ getType _ = TypeTag+ getRaw = tagWrite+ isDelta = const False+ toTag t = Just t++instance Objectable Tree where+ getType _ = TypeTree+ getRaw = treeWrite+ isDelta = const False+ toTree t = Just t++instance Objectable DeltaOfs where+ getType _ = TypeDeltaOff+ getRaw = error "delta offset cannot be marshalled"+ isDelta = const True++instance Objectable DeltaRef where+ getType _ = TypeDeltaRef+ getRaw = error "delta ref cannot be marshalled"+ isDelta = const True objectHash :: ObjectType -> Word64 -> L.ByteString -> Ref objectHash ty w lbs = hashLBS $ L.fromChunks (objectWriteHeader ty w : L.toChunks lbs)
Data/Git/Pack.hs view
@@ -117,8 +117,8 @@ packObjectFromRaw (TypeTree, Nothing, objData) = AL.maybeResult $ AL.parse objectParseTree objData packObjectFromRaw (TypeBlob, Nothing, objData) = AL.maybeResult $ AL.parse objectParseBlob objData packObjectFromRaw (TypeTag, Nothing, objData) = AL.maybeResult $ AL.parse objectParseTag objData-packObjectFromRaw (TypeDeltaOff, Just (PtrOfs o), objData) = DeltaOfs o <$> deltaRead objData-packObjectFromRaw (TypeDeltaRef, Just (PtrRef r), objData) = DeltaRef r <$> deltaRead objData+packObjectFromRaw (TypeDeltaOff, Just (PtrOfs o), objData) = objectWrap . DeltaOfs o <$> deltaRead objData+packObjectFromRaw (TypeDeltaRef, Just (PtrRef r), objData) = objectWrap . DeltaRef r <$> deltaRead objData packObjectFromRaw _ = error "can't happen unless someone change getNextObjectRaw" getNextObjectRaw :: FileReader -> IO PackedObjectRaw
Data/Git/Repository.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-} -- | -- Module : Data.Git.Repository -- License : BSD-style@@ -20,6 +21,8 @@ , findObjectRaw , findObjectRawAt , findObject+ , findCommit+ , findTree , findObjectAt , buildHTree , resolvePath@@ -246,6 +249,22 @@ where toObject (ObjectInfo { oiHeader = (ty, _, extra), oiData = objData }) = packObjectFromRaw (ty, extra, objData) +-- should be a standard function that do that...+mapJustM f (Just o) = f o+mapJustM _ Nothing = return Nothing++findCommit :: Git -> Ref -> IO (Maybe Commit)+findCommit git ref = findObject git ref True >>= mapJustM unwrap+ where+ unwrap (objectToCommit -> Just c@(Commit _ _ _ _ _)) = return $ Just c+ unwrap _ = return Nothing++findTree :: Git -> Ref -> IO (Maybe Tree)+findTree git ref = findObject git ref True >>= mapJustM unwrap+ where+ unwrap (objectToTree -> Just c@(Tree _ )) = return $ Just c+ unwrap _ = return Nothing+ -- | try to resolve a string to a specific commit ref -- for example: HEAD, HEAD^, master~3, shortRef resolveRevision :: Git -> Revision -> IO (Maybe Ref)@@ -287,32 +306,28 @@ modf (_:_) _ = error "unimplemented revision modifier" getParentRefs ref = do- obj <- findObject git ref True+ obj <- findCommit git ref case obj of Just (Commit _ parents _ _ _) -> return parents- Just _ -> error "wrong object type, expecting commit" Nothing -> error "reference in commit chain doesn't exists" -- | returns a tree from a ref that might be either a commit, a tree or a tag.-resolveTreeish :: Git -> Ref -> IO (Maybe Object)-resolveTreeish git ref = do- obj <- findObject git ref True- case obj of- Just (Commit tree _ _ _ _) -> resolveTreeish git tree- Just (Tree _) -> return obj- Just (Tag tref _ _ _ _) -> resolveTreeish git tref - Just _ -> return Nothing- Nothing -> return Nothing+resolveTreeish :: Git -> Ref -> IO (Maybe Tree)+resolveTreeish git ref = findObject git ref True >>= mapJustM recToTree where+ recToTree (objectToCommit -> Just (Commit tree _ _ _ _)) = resolveTreeish git tree+ recToTree (objectToTag -> Just (Tag tref _ _ _ _)) = resolveTreeish git tref+ recToTree (objectToTree -> Just t@(Tree _)) = return $ Just t+ recToTree _ = return Nothing -- | build a hierarchy tree from a tree object-buildHTree :: Git -> Object -> IO HTree+buildHTree :: Git -> Tree -> IO HTree buildHTree git (Tree ents) = mapM resolveTree ents where resolveTree (perm, ent, ref) = do obj <- findObjectType git ref case obj of Just TypeBlob -> return (perm, ent, TreeFile ref) Just TypeTree -> do- ctree <- findObject git ref True+ ctree <- findTree git ref case ctree of Nothing -> error "unknown reference in tree object: no such child" Just t -> do@@ -320,28 +335,25 @@ return (perm, ent, TreeDir ref dir) Just _ -> error "wrong type embedded in tree object" Nothing -> error "unknown reference in tree object"-buildHTree _ _ = error "cannot build a tree structure from anything else than a tree" -- | resolve the ref (tree or blob) related to a path at a specific commit ref resolvePath :: Git -> Ref -> [ByteString] -> IO (Maybe Ref) resolvePath git commitRef paths = do- commit <- findObject git commitRef True+ commit <- findCommit git commitRef case commit of Just (Commit tree _ _ _ _) -> resolve tree paths- Just _ -> error ("expecting commit object at " ++ show commitRef) Nothing -> error ("not a valid ref: " ++ show commitRef) where resolve :: Ref -> [ByteString] -> IO (Maybe Ref) resolve treeRef [] = return $ Just treeRef resolve treeRef (x:xs) = do- tree <- findObject git treeRef True+ tree <- findTree 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- Just _ -> error ("expecting tree object at " ++ show treeRef) Nothing -> error ("not a valid ref: " ++ show treeRef) findEnt x = find (\(_, b, _) -> b == x)@@ -354,7 +366,7 @@ subDirs <- mapM (doesDirectoryExist . (path </>)) ["branches","hooks","info" ,"logs","objects","refs"- ,"refs"</>"heads","refs"</>"remotes","refs"</>"tags"]+ ,"refs"</>"heads","refs"</>"tags"] return $ and ([dir] ++ subDirs) -- | initialize a new repository at a specific location.@@ -366,4 +378,4 @@ mapM_ (createDirectory . (path </>)) ["branches","hooks","info" ,"logs","objects","refs"- ,"refs"</>"heads","refs"</>"remotes","refs"</>"tags"]+ ,"refs"</>"heads","refs"</>"tags"]
Hit.hs view
@@ -134,7 +134,7 @@ ref <- maybe (error "revision cannot be found") id <$> resolveRevision git revision loopTillEmpty ref where loopTillEmpty ref = do- obj <- findObject git ref True+ obj <- findCommit git ref case obj of Just (Commit _ parents _ _ _) -> do putStrLn $ show ref@@ -144,7 +144,6 @@ case parents of [] -> return () (p:_) -> loopTillEmpty p- Just _ -> error "wrong object type, expecting commit" Nothing -> error "reference in commit chain doesn't exists" main = do
hit.cabal view
@@ -1,5 +1,5 @@ Name: hit-Version: 0.1.0+Version: 0.2.0 Synopsis: Git operations Description: Provides low level git operations License: BSD3