add catCommit, with commit object parser

Git/CatFile.hs

@@ -1,6 +1,6 @@
 {- git cat-file interface
  -
- - Copyright 2011, 2013 Joey Hess <id@joeyh.name>
+ - Copyright 2011-2016 Joey Hess <id@joeyh.name>
  -
  - Licensed under the GNU GPL version 3 or higher.
  -}
@@ -13,6 +13,7 @@ module Git.CatFile (
 	catFile,
 	catFileDetails,
 	catTree,
+	catCommit,
 	catObject,
 	catObjectDetails,
 ) where
@@ -20,6 +21,10 @@ module Git.CatFile (
 import System.IO
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Lazy.Char8 as L8
+import qualified Data.Map as M
+import Data.String
+import Data.Char
 import Data.Tuple.Utils
 import Numeric
 import System.Posix.Types
@@ -110,3 +115,43 @@ catTree h treeref = go <$> catObjectDetails h treeref
 		let (modestr, file) = separate (== ' ') (decodeBS b)
 		in (file, readmode modestr)
 	readmode = fromMaybe 0 . fmap fst . headMaybe . readOct
+
+catCommit :: CatFileHandle -> Ref -> IO (Maybe Commit)
+catCommit h commitref = go <$> catObjectDetails h commitref
+  where
+	go (Just (b, _, CommitObject)) = parseCommit b
+	go _ = Nothing
+
+parseCommit :: L.ByteString -> Maybe Commit
+parseCommit b = Commit
+	<$> (extractSha . L8.unpack =<< field "tree")
+	<*> (parsemetadata <$> field "author")
+	<*> (parsemetadata <$> field "committer")
+	<*> Just (L8.unpack $ L.intercalate (L.singleton nl) message)
+  where
+	field n = M.lookup (fromString n) fields
+	fields = M.fromList ((map breakfield) header)
+	breakfield l =
+		let (k, sp_v) = L.break (== sp) l
+		in (k, L.drop 1 sp_v)
+	(header, message) = separate L.null ls
+	ls = L.split nl b
+
+	-- author and committer lines have the form: "name <email> date"
+	-- The email is always present, even if empty "<>"
+	parsemetadata l = CommitMetaData
+		{ commitName = whenset $ L.init name_sp
+		, commitEmail = whenset email
+		, commitDate = whenset $ L.drop 2 gt_sp_date
+		}
+	  where
+		(name_sp, rest) = L.break (== lt) l
+		(email, gt_sp_date) = L.break (== gt) (L.drop 1 rest)
+		whenset v
+			| L.null v = Nothing
+			| otherwise = Just (L8.unpack v)
+
+	nl = fromIntegral (ord '\n')
+	sp = fromIntegral (ord ' ')
+	lt = fromIntegral (ord '<')
+	gt = fromIntegral (ord '>')

Git/Env.hs

@@ -10,6 +10,7 @@
 module Git.Env where
 
 import Git
+import Git.Types
 import Utility.Env
 
 {- Adjusts the gitEnv of a Repo. Copies the system environment if the repo
@@ -36,3 +37,18 @@ adjustGitEnv g adj = do
 
 addGitEnv :: Repo -> String -> String -> IO Repo
 addGitEnv g var val = adjustGitEnv g (addEntry var val)
+
+{- Use with any action that makes a commit to set metadata. -}
+commitWithMetaData :: CommitMetaData -> CommitMetaData -> (Repo -> IO a) -> Repo -> IO a
+commitWithMetaData authormetadata committermetadata a g =
+	a =<< adjustGitEnv g adj
+  where
+	adj = mkadj "AUTHOR" authormetadata
+		. mkadj "COMMITTER" committermetadata
+	mkadj p md = go "NAME" commitName
+		. go "EMAIL" commitEmail
+		. go "DATE" commitDate
+	  where
+		go s getv = case getv md of
+			Nothing -> id
+			Just v -> addEntry ("GIT_" ++ p ++ "_" ++ s) v

Git/Types.hs

@@ -97,3 +97,18 @@ toBlobType 0o100644 = Just FileBlob
 toBlobType 0o100755 = Just ExecutableBlob
 toBlobType 0o120000 = Just SymlinkBlob
 toBlobType _ = Nothing
+
+data Commit = Commit
+	{ commitTree :: Sha
+	, commitAuthorMetaData :: CommitMetaData
+	, commitCommitterMetaData :: CommitMetaData
+	, commitMessage :: String
+	}
+	deriving (Show)
+
+data CommitMetaData = CommitMetaData
+	{ commitName :: Maybe String
+	, commitEmail :: Maybe String
+	, commitDate :: Maybe String -- In raw git form, "epoch -tzoffset"
+	}
+	deriving (Show)