1. Stefan Saasen
  2. git-in-haskell-from-the-bottom-up

Commits

Stefan Saasen  committed 9962892

Rename Blob to Object where it is being used to refer to the actual file 'blob' instead of the git object type

  • Participants
  • Parent commits 443bf08
  • Branches master

Comments (0)

Files changed (7)

File src/Git/Repository.hs

View file
 import qualified Data.ByteString as B
 import Text.Printf                                          (printf)
 import Git.Common                                           (GitRepository(..), ObjectId, WithRepository)
-import Git.Store.Blob
+import Git.Store.Object
 import Git.Store.ObjectStore
 import Git.Store.Index
 import System.FilePath
         repo <- ask
         blob <- liftIO $ readBlob repo sha' -- readBlob :: GitRepository -> ObjectId -> IO (Maybe Blob)
         maybe (return Nothing) walk blob
-    where walk  (Blob _ BTree sha1)                = do
+    where walk  (Object _ BTree sha1)                = do
                                                       repo <- ask
                                                       liftIO $ readTree repo sha1
-          walk  c@(Blob _ BCommit _)               = do
+          walk  c@(Object _ BCommit _)               = do
                                                         let maybeCommit = parseCommit $ getBlobContent c
                                                         maybe (return Nothing) extractTree maybeCommit
           walk _                                   = return Nothing

File src/Git/Store/Blob.hs

-{-# LANGUAGE OverloadedStrings #-}
-
-module Git.Store.Blob (
-    parseTree
-  , parseCommit
-  , parsePerson     -- Remove?
-  , parseBlob
-  , toCommit
-  , Commit(..)
-  , Blob(..)
-  , BlobType(..)
-  , Tree(..)
-  , TreeEntry(..)
-) where
-
-import Prelude hiding (take, takeWhile)
-import qualified Data.ByteString.Char8 as C
-import qualified Data.ByteString as B
-import Data.Attoparsec.ByteString.Char8
-import Control.Applicative ((<|>))
-import Git.Common                                           (eitherToMaybe, ObjectId)
-
-data BlobType = BTree | BCommit | BTag | BBlob deriving (Eq)
-
-instance Show BlobType where
-    show BTree      = "tree"
-    show BCommit    = "commit"
-    show BTag       = "tag"
-    show BBlob      = "blob"
-
-data Blob = Blob {
-    getBlobContent  :: B.ByteString
-  , objType         :: BlobType
-  , sha             :: ObjectId
-} deriving (Eq, Show)
-
-data Author = Author B.ByteString B.ByteString deriving (Eq, Show)
-data Commiter = Commiter B.ByteString B.ByteString deriving (Eq, Show)
-
-data Tree = Tree {
-    getObjectId :: ObjectId
-  , getEntries  :: [TreeEntry]
-} deriving (Eq, Show)
-
-data TreeEntry = TreeEntry {
-    getMode    :: C.ByteString
-  , getPath    :: C.ByteString
-  , getBlobSha :: C.ByteString
-} deriving (Eq, Show)
-
-data Commit = Commit {
-    getTree        :: B.ByteString
-  , getParents     :: [B.ByteString]
-  , getSha         :: B.ByteString
-  , getAuthor      :: Author
-  , getCommiter    :: Commiter
-  , getMessage     :: B.ByteString
-} deriving (Eq,Show)
-
-
-toCommit :: Blob -> Maybe Commit
-toCommit (Blob content BCommit _) = parseCommit content
-toCommit _ = Nothing
-
-parseBlob :: ObjectId -> C.ByteString -> Maybe Blob
-parseBlob sha1 blob = eitherToMaybe $ parseOnly (blobParser sha1) blob
-
--- header: "type size\0"
--- sha1 $ header ++ content
-blobParser :: ObjectId -> Parser Blob
-blobParser sha1 = do
-   objType' <- string "commit" <|> string "tree" <|> string "blob" <|> string "tag"
-   char ' '
-   _size <- takeWhile isDigit
-   nul
-   blob <- takeByteString
-   return $ Blob blob (obj objType') sha1
-   where obj "commit"   = BCommit
-         obj "tree"     = BTree
-         obj "tag"      = BTag
-         obj "blob"     = BBlob
-         obj _          = error "Invalid blob type" -- FIXME Let the parser fail
-
-
-parseTree :: ObjectId -> C.ByteString -> Maybe Tree
-parseTree sha' input = eitherToMaybe $ parseOnly (treeParser sha') input
-
-parseCommit :: C.ByteString -> Maybe Commit
-parseCommit input = eitherToMaybe $ parseOnly commitParser input
-
-{-
-from e.g. `ls-tree.c`, `tree-walk.c`
--}
-treeParser :: ObjectId -> Parser Tree
-treeParser sha' = do
-    entries <- many' treeEntryParser
-    return $ Tree sha' entries
-
-
--- | An entry in the tree has the following format:
---
--- @
--- mode SP path NUL sha1
--- @
---
--- E.g.
--- @
--- 100644 .ghci\NUL\208k\227\&0F\190\137A$\210\193\216j\247#\SI\ETBw;?
--- @
---
--- with:
---   * mode: octal
---   * SP: space
---   * path: filename
---   * NUL: null byte
---   * sha1: 20 byte of SHA1
-treeEntryParser :: Parser TreeEntry
-treeEntryParser = do
-    mode <- takeTill (== ' ')
-    space
-    path <- takeTill (== '\0')
-    nul
-    sha' <- take 20
-    return $ TreeEntry mode path sha'
-
-
-{-
-tree b5213cb334e855fb5c89edc99d54606377e15d70
-parent 3c1d7b88edaf2119aff47104de389867cad0f0fb
-author Stefan Saasen <stefan@saasen.me> 1361272292 +1100
-committer Stefan Saasen <stefan@saasen.me> 1361272292 +1100
-
-Remove git INSTALL instructions
-
--}
-commitParser :: Parser Commit
-commitParser = do
-    tree <- "tree " .*> take 40
-    space
-    parents <- many' parseParentCommit
-    author <- "author " .*> parsePerson
-    space
-    _commiter <- "committer " .*> parsePerson
-    space
-    space
-    message <- takeByteString
-    return $ Commit tree parents B.empty (Author (getPersonName author) (getPersonEmail author)) (Commiter "" "") message -- FIXME Use Commiter
-
-parseParentCommit :: Parser C.ByteString
-parseParentCommit = do
-   parent <- "parent " .*> take 40
-   space
-   return parent
-
-parsePerson :: Parser Person
-parsePerson = do
-    name <- takeWhile (/= '<')
-    email <- "<" .*> takeWhile (/= '>') <*. ">"
-    date <- takeTill (== '\n')
-    return $ Person name email date
-
-data Person = Person {
-    getPersonName   :: B.ByteString
-  , getPersonEmail  :: B.ByteString
-  , getDate         :: B.ByteString -- FIXME
-} deriving (Eq, Show)
-
-nul :: Parser Char
-nul = satisfy (== '\0')

File src/Git/Store/Object.hs

View file
+{-# LANGUAGE OverloadedStrings #-}
+
+module Git.Store.Object (
+    parseTree
+  , parseCommit
+  , parsePerson     -- Remove?
+  , parseObject
+  , toCommit
+  , Commit(..)
+  , Object(..)
+  , ObjectType(..)
+  , Tree(..)
+  , TreeEntry(..)
+) where
+
+import Prelude hiding (take, takeWhile)
+import qualified Data.ByteString.Char8 as C
+import qualified Data.ByteString as B
+import Data.Attoparsec.ByteString.Char8
+import Control.Applicative ((<|>))
+import Git.Common                                           (eitherToMaybe, ObjectId)
+
+data ObjectType = BTree | BCommit | BTag | BBlob deriving (Eq)
+
+instance Show ObjectType where
+    show BTree      = "tree"
+    show BCommit    = "commit"
+    show BTag       = "tag"
+    show BBlob      = "blob"
+
+data Object = Object {
+    getBlobContent  :: B.ByteString
+  , objType         :: ObjectType
+  , sha             :: ObjectId
+} deriving (Eq, Show)
+
+data Author = Author B.ByteString B.ByteString deriving (Eq, Show)
+data Commiter = Commiter B.ByteString B.ByteString deriving (Eq, Show)
+
+data Tree = Tree {
+    getObjectId :: ObjectId
+  , getEntries  :: [TreeEntry]
+} deriving (Eq, Show)
+
+data TreeEntry = TreeEntry {
+    getMode    :: C.ByteString
+  , getPath    :: C.ByteString
+  , getBlobSha :: C.ByteString
+} deriving (Eq, Show)
+
+data Commit = Commit {
+    getTree        :: B.ByteString
+  , getParents     :: [B.ByteString]
+  , getSha         :: B.ByteString
+  , getAuthor      :: Author
+  , getCommiter    :: Commiter
+  , getMessage     :: B.ByteString
+} deriving (Eq,Show)
+
+
+toCommit :: Object -> Maybe Commit
+toCommit (Object content BCommit _) = parseCommit content
+toCommit _ = Nothing
+
+parseObject :: ObjectId -> C.ByteString -> Maybe Object
+parseObject sha1 obj = eitherToMaybe $ parseOnly (objParser sha1) obj
+
+-- header: "type size\0"
+-- sha1 $ header ++ content
+objParser :: ObjectId -> Parser Object
+objParser sha1 = do
+   objType' <- string "commit" <|> string "tree" <|> string "blob" <|> string "tag"
+   char ' '
+   _size <- takeWhile isDigit
+   nul
+   content <- takeByteString
+   return $ Object content (obj objType') sha1
+   where obj "commit"   = BCommit
+         obj "tree"     = BTree
+         obj "tag"      = BTag
+         obj "blob"     = BBlob
+         obj _          = error "Invalid object type" -- FIXME Let the parser fail
+
+
+parseTree :: ObjectId -> C.ByteString -> Maybe Tree
+parseTree sha' input = eitherToMaybe $ parseOnly (treeParser sha') input
+
+parseCommit :: C.ByteString -> Maybe Commit
+parseCommit input = eitherToMaybe $ parseOnly commitParser input
+
+{-
+from e.g. `ls-tree.c`, `tree-walk.c`
+-}
+treeParser :: ObjectId -> Parser Tree
+treeParser sha' = do
+    entries <- many' treeEntryParser
+    return $ Tree sha' entries
+
+
+-- | An entry in the tree has the following format:
+--
+-- @
+-- mode SP path NUL sha1
+-- @
+--
+-- E.g.
+-- @
+-- 100644 .ghci\NUL\208k\227\&0F\190\137A$\210\193\216j\247#\SI\ETBw;?
+-- @
+--
+-- with:
+--   * mode: octal
+--   * SP: space
+--   * path: filename
+--   * NUL: null byte
+--   * sha1: 20 byte of SHA1
+treeEntryParser :: Parser TreeEntry
+treeEntryParser = do
+    mode <- takeTill (== ' ')
+    space
+    path <- takeTill (== '\0')
+    nul
+    sha' <- take 20
+    return $ TreeEntry mode path sha'
+
+
+{-
+tree b5213cb334e855fb5c89edc99d54606377e15d70
+parent 3c1d7b88edaf2119aff47104de389867cad0f0fb
+author Stefan Saasen <stefan@saasen.me> 1361272292 +1100
+committer Stefan Saasen <stefan@saasen.me> 1361272292 +1100
+
+Remove git INSTALL instructions
+
+-}
+commitParser :: Parser Commit
+commitParser = do
+    tree <- "tree " .*> take 40
+    space
+    parents <- many' parseParentCommit
+    author <- "author " .*> parsePerson
+    space
+    _commiter <- "committer " .*> parsePerson
+    space
+    space
+    message <- takeByteString
+    return $ Commit tree parents B.empty (Author (getPersonName author) (getPersonEmail author)) (Commiter "" "") message -- FIXME Use Commiter
+
+parseParentCommit :: Parser C.ByteString
+parseParentCommit = do
+   parent <- "parent " .*> take 40
+   space
+   return parent
+
+parsePerson :: Parser Person
+parsePerson = do
+    name <- takeWhile (/= '<')
+    email <- "<" .*> takeWhile (/= '>') <*. ">"
+    date <- takeTill (== '\n')
+    return $ Person name email date
+
+data Person = Person {
+    getPersonName   :: B.ByteString
+  , getPersonEmail  :: B.ByteString
+  , getDate         :: B.ByteString -- FIXME
+} deriving (Eq, Show)
+
+nul :: Parser Char
+nul = satisfy (== '\0')

File src/Git/Store/ObjectStore.hs

View file
 import Git.Pack.Delta                                       (patch)
 import Git.Common                                           (GitRepository(..), ObjectId, WithRepository, Ref(..))
 -- Tree
-import Git.Store.Blob
+import Git.Store.Object
 import System.FilePath
 import System.Directory
 import Data.Foldable                                        (forM_)
 
 -- header: "type size\0"
 -- sha1 $ header ++ content
-readBlob :: GitRepository -> ObjectId -> IO (Maybe Blob)
+readBlob :: GitRepository -> ObjectId -> IO (Maybe Object)
 readBlob GitRepository{..} sha = do
     let (path, name) = pathForObject getName sha
         filename     = path </> name
     exists <- doesFileExist filename
     if exists then do
         bs <- C.readFile filename
-        return $ parseBlob sha $ inflate bs
+        return $ parseObject sha $ inflate bs
     else return Nothing
     where inflate blob = B.concat . L.toChunks . Z.decompress $ L.fromChunks [blob]
 
 -- header: "type size\0"
 -- sha1 $ header ++ content
-encodeBlob :: BlobType -> C.ByteString -> (ObjectId, C.ByteString)
+encodeBlob :: ObjectType -> C.ByteString -> (ObjectId, C.ByteString)
 encodeBlob blobType content = do
     let header       = headerForBlob (C.pack $ show blobType)
         blob         = header `C.append` content
     where headerForBlob objType = objType `C.append` " " `C.append` C.pack (show $ C.length content) `C.append` "\0"
           hsh = toHex . SHA1.hash
 
-writeBlob :: GitRepository -> BlobType -> C.ByteString -> IO FilePath
+writeBlob :: GitRepository -> ObjectType -> C.ByteString -> IO FilePath
 writeBlob GitRepository{..} blobType content = do
     let (sha1, blob) = encodeBlob blobType content
         (path, name) = pathForObject getName sha1

File tests/src/Git/Store/BlobTest.hs

-{-# LANGUAGE OverloadedStrings #-}
-module Git.Store.BlobTest
-  (
-    main
-  , test
-  ) where
-
-import qualified Test.HUnit as H
-import Git.Store.Blob
-import Test.QuickCheck hiding ((.&.))
-import Test.Framework (Test, defaultMain, testGroup)
-import Test.Framework.Providers.QuickCheck2 (testProperty)
-import Test.Framework.Providers.HUnit
-import Data.Maybe
-
-main :: IO ()
-main = defaultMain [test]
-
-commit_1 = "tree b5213cb334e855fb5c89edc99d54606377e15d70\nparent 3c1d7b88edaf2119aff47104de389867cad0f0fb\nauthor Stefan Saasen <stefan@saasen.me> 1361272292 +1100\ncommitter Stefan Saasen <stefan@saasen.me> 1361272292 +1100\n\nRemove git INSTALL instructions\n"
-
-commit_no_parent = "tree 920512d27e4df0c79ca4a929bc5d4254b3d05c4c\nauthor Stefan Saasen <ssaasen@atlassian.com> 1362201640 +1100\ncommitter Stefan Saasen <ssaasen@atlassian.com> 1362201640 +1100\n\nAdd test.txt\n"
-
-commit_merge = "tree 639e28af470be85166a2bbfcaa2835fc68a257a5\nparent 7517fa2cf314c8c9f5e54aa5ae8fab514c88e2cf\nparent e5fe0a4bfbf1d28d41805c8e80e4ffd826c30ac9\nauthor Ludovic Landry <landry.ludovic+github@gmail.com> 1350079175 -0700\ncommitter Ludovic Landry <landry.ludovic+github@gmail.com> 1350079175 -0700\n\nMerge e5fe0a4bfbf1d28d41805c8e80e4ffd826c30ac9 into 7517fa2cf314c8c9f5e54aa5ae8fab514c88e2cf"
-
-tree_1 = "100644 M.hs\NUL\130N\229H6\233\249\USd\n\DC3I\223'\CANp;\165\158\150\&100644 RunMain.hs\NUL\240i\182\&3g\183\194\241-\131\187W\137\ESC\CAN\f\SOHX\180\174"
-
-test_parseValidCommit = H.assertBool
-    "A valid commit should be successfully parsed"
-    (isJust $ parseCommit commit_1)
-
-test_parseValidCommitTree = H.assertEqual
-    ""
-    "b5213cb334e855fb5c89edc99d54606377e15d70"
-    (getTree $ fromJust $ parseCommit commit_1)
-
-test_parseValidCommitParent = H.assertEqual
-    ""
-    "3c1d7b88edaf2119aff47104de389867cad0f0fb"
-    (head $ getParents $ fromJust $ parseCommit commit_1)
-
-test_parseValidCommitMerge = H.assertEqual
-    ""
-    ["7517fa2cf314c8c9f5e54aa5ae8fab514c88e2cf", "e5fe0a4bfbf1d28d41805c8e80e4ffd826c30ac9"]
-    (getParents $ fromJust $ parseCommit commit_merge)
-
-test_parseValidCommitRootWithoutParent = H.assertEqual
-    ""
-    []
-    (getParents $ fromJust $ parseCommit commit_no_parent)
-
-
-
--- =================================================================================
-
-test_parseValidTree = H.assertBool
-    "Should be able to parse a valid Tree blob"
-    (isJust $ parseTree "abc" tree_1)
-
-test_parseValidTreeEntries = H.assertEqual
-    "Should be able to parse a valid Tree blob"
-    (Just 2)
-    (fmap (length . getEntries) $ parseTree "abc" tree_1)
-
-test_parseValidTreeEntryPath = H.assertEqual
-    "Should be able to parse a valid Tree blob"
-    (Just "M.hs")
-    (fmap (getPath . head . getEntries) $ parseTree "abc" tree_1)
-
-test_parseValidTreeEntryMode = H.assertEqual
-    "Should be able to parse a valid Tree blob"
-    (Just "100644")
-    (fmap (getMode . head . getEntries) $ parseTree "abc" tree_1)
-
-test :: Test
-test = testGroup "Objects"
-    [
-        testCase "parseCommit/1"    test_parseValidCommit
-      , testCase "parseCommit/2"    test_parseValidCommitTree
-      , testCase "parseCommit/3"    test_parseValidCommitParent
-      , testCase "parseCommit/4"    test_parseValidCommitRootWithoutParent
-      , testCase "parseCommit/5"    test_parseValidCommitMerge
-      , testCase "parseTree/1"      test_parseValidTree
-      , testCase "parseTree/2"      test_parseValidTreeEntries
-      , testCase "parseTree/3"      test_parseValidTreeEntryPath
-      , testCase "parseTree/4"      test_parseValidTreeEntryMode
-    ]
-
-
-

File tests/src/Git/Store/ObjectTest.hs

View file
+{-# LANGUAGE OverloadedStrings #-}
+module Git.Store.ObjectTest
+  (
+    main
+  , test
+  ) where
+
+import qualified Test.HUnit as H
+import Git.Store.Object
+import Test.QuickCheck hiding ((.&.))
+import Test.Framework (Test, defaultMain, testGroup)
+import Test.Framework.Providers.QuickCheck2 (testProperty)
+import Test.Framework.Providers.HUnit
+import Data.Maybe
+
+main :: IO ()
+main = defaultMain [test]
+
+commit_1 = "tree b5213cb334e855fb5c89edc99d54606377e15d70\nparent 3c1d7b88edaf2119aff47104de389867cad0f0fb\nauthor Stefan Saasen <stefan@saasen.me> 1361272292 +1100\ncommitter Stefan Saasen <stefan@saasen.me> 1361272292 +1100\n\nRemove git INSTALL instructions\n"
+
+commit_no_parent = "tree 920512d27e4df0c79ca4a929bc5d4254b3d05c4c\nauthor Stefan Saasen <ssaasen@atlassian.com> 1362201640 +1100\ncommitter Stefan Saasen <ssaasen@atlassian.com> 1362201640 +1100\n\nAdd test.txt\n"
+
+commit_merge = "tree 639e28af470be85166a2bbfcaa2835fc68a257a5\nparent 7517fa2cf314c8c9f5e54aa5ae8fab514c88e2cf\nparent e5fe0a4bfbf1d28d41805c8e80e4ffd826c30ac9\nauthor Ludovic Landry <landry.ludovic+github@gmail.com> 1350079175 -0700\ncommitter Ludovic Landry <landry.ludovic+github@gmail.com> 1350079175 -0700\n\nMerge e5fe0a4bfbf1d28d41805c8e80e4ffd826c30ac9 into 7517fa2cf314c8c9f5e54aa5ae8fab514c88e2cf"
+
+tree_1 = "100644 M.hs\NUL\130N\229H6\233\249\USd\n\DC3I\223'\CANp;\165\158\150\&100644 RunMain.hs\NUL\240i\182\&3g\183\194\241-\131\187W\137\ESC\CAN\f\SOHX\180\174"
+
+test_parseValidCommit = H.assertBool
+    "A valid commit should be successfully parsed"
+    (isJust $ parseCommit commit_1)
+
+test_parseValidCommitTree = H.assertEqual
+    ""
+    "b5213cb334e855fb5c89edc99d54606377e15d70"
+    (getTree $ fromJust $ parseCommit commit_1)
+
+test_parseValidCommitParent = H.assertEqual
+    ""
+    "3c1d7b88edaf2119aff47104de389867cad0f0fb"
+    (head $ getParents $ fromJust $ parseCommit commit_1)
+
+test_parseValidCommitMerge = H.assertEqual
+    ""
+    ["7517fa2cf314c8c9f5e54aa5ae8fab514c88e2cf", "e5fe0a4bfbf1d28d41805c8e80e4ffd826c30ac9"]
+    (getParents $ fromJust $ parseCommit commit_merge)
+
+test_parseValidCommitRootWithoutParent = H.assertEqual
+    ""
+    []
+    (getParents $ fromJust $ parseCommit commit_no_parent)
+
+
+
+-- =================================================================================
+
+test_parseValidTree = H.assertBool
+    "Should be able to parse a valid Tree blob"
+    (isJust $ parseTree "abc" tree_1)
+
+test_parseValidTreeEntries = H.assertEqual
+    "Should be able to parse a valid Tree blob"
+    (Just 2)
+    (fmap (length . getEntries) $ parseTree "abc" tree_1)
+
+test_parseValidTreeEntryPath = H.assertEqual
+    "Should be able to parse a valid Tree blob"
+    (Just "M.hs")
+    (fmap (getPath . head . getEntries) $ parseTree "abc" tree_1)
+
+test_parseValidTreeEntryMode = H.assertEqual
+    "Should be able to parse a valid Tree blob"
+    (Just "100644")
+    (fmap (getMode . head . getEntries) $ parseTree "abc" tree_1)
+
+test :: Test
+test = testGroup "Objects"
+    [
+        testCase "parseCommit/1"    test_parseValidCommit
+      , testCase "parseCommit/2"    test_parseValidCommitTree
+      , testCase "parseCommit/3"    test_parseValidCommitParent
+      , testCase "parseCommit/4"    test_parseValidCommitRootWithoutParent
+      , testCase "parseCommit/5"    test_parseValidCommitMerge
+      , testCase "parseTree/1"      test_parseValidTree
+      , testCase "parseTree/2"      test_parseValidTreeEntries
+      , testCase "parseTree/3"      test_parseValidTreeEntryPath
+      , testCase "parseTree/4"      test_parseValidTreeEntryMode
+    ]
+
+
+

File tests/src/TestRunner.hs

View file
 
 import qualified Git.CommonTests
 import qualified Git.RemoteTests
-import qualified Git.Store.BlobTest
+import qualified Git.Store.ObjectTest
 import Test.Framework
 
 main ::
       [
           Git.CommonTests.test
         , Git.RemoteTests.test
-        , Git.Store.BlobTest.test
+        , Git.Store.ObjectTest.test
       ]
   ]