{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module GitHash
(
GitInfo
, GitHashException (..)
, giHash
, giBranch
, giDirty
, giCommitDate
, giCommitCount
, giCommitMessage
, getGitInfo
, getGitRoot
, tGitInfo
, tGitInfoCwd
, tGitInfoTry
, tGitInfoCwdTry
) where
import Control.Exception
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import Data.Typeable (Typeable)
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import System.Directory
import System.Exit
import System.FilePath
import System.IO.Error (isDoesNotExistError)
import System.Process
import Text.Read (readMaybe)
data GitInfo = GitInfo
{ _giHash :: !String
, _giBranch :: !String
, _giDirty :: !Bool
, _giCommitDate :: !String
, _giCommitCount :: !Int
, _giFiles :: ![FilePath]
, _giCommitMessage :: !String
}
deriving (Lift, Show)
giHash :: GitInfo -> String
giHash = _giHash
giBranch :: GitInfo -> String
giBranch = _giBranch
giDirty :: GitInfo -> Bool
giDirty = _giDirty
giCommitDate :: GitInfo -> String
giCommitDate = _giCommitDate
giCommitCount :: GitInfo -> Int
giCommitCount = _giCommitCount
giCommitMessage :: GitInfo -> String
giCommitMessage = _giCommitMessage
getGitInfo :: FilePath -> IO (Either GitHashException GitInfo)
getGitInfo root = try $ do
let hd = root </> ".git" </> "HEAD"
index = root </> ".git" </> "index"
packedRefs = root </> ".git" </> "packed-refs"
ehdRef <- try $ B.readFile hd
files1 <-
case ehdRef of
Left e
| isDoesNotExistError e -> return []
| otherwise -> throwIO $ GHECouldn'tReadFile hd e
Right hdRef -> do
case B.splitAt 5 hdRef of
("ref: ", relRef) -> do
let ref = root </> ".git" </> B8.unpack relRef
refExists <- doesFileExist ref
return $ if refExists then [ref] else []
_hash -> return [hd]
indexExists <- doesFileExist index
let files2 = if indexExists then [index] else []
packedExists <- doesFileExist packedRefs
let files3 = if packedExists then [packedRefs] else []
_giFiles = concat [files1, files2, files3]
run args = do
eres <- runGit root args
case eres of
Left e -> throwIO e
Right str -> return $ takeWhile (/= '\n') str
_giHash <- run ["rev-parse", "HEAD"]
_giBranch <- run ["rev-parse", "--abbrev-ref", "HEAD"]
dirtyString <- run ["status", "--porcelain"]
let _giDirty = not $ null (dirtyString :: String)
commitCount <- run ["rev-list", "HEAD", "--count"]
_giCommitCount <-
case readMaybe commitCount of
Nothing -> throwIO $ GHEInvalidCommitCount root commitCount
Just x -> return x
_giCommitDate <- run ["log", "HEAD", "-1", "--format=%cd"]
_giCommitMessage <- run ["log", "-1", "--pretty=%B"]
return GitInfo {..}
getGitRoot :: FilePath -> IO (Either GitHashException FilePath)
getGitRoot dir = fmap (normalise . takeWhile (/= '\n')) `fmap` (runGit dir ["rev-parse", "--show-toplevel"])
runGit :: FilePath -> [String] -> IO (Either GitHashException String)
runGit root args = do
let cp = (proc "git" args) { cwd = Just root }
eres <- try $ readCreateProcessWithExitCode cp ""
return $ case eres of
Left e -> Left $ GHEGitRunException root args e
Right (ExitSuccess, out, _) -> Right out
Right (ec@ExitFailure{}, out, err) -> Left $ GHEGitRunFailed root args ec out err
data GitHashException
= GHECouldn'tReadFile !FilePath !IOException
| GHEInvalidCommitCount !FilePath !String
| GHEGitRunFailed !FilePath ![String] !ExitCode !String !String
| GHEGitRunException !FilePath ![String] !IOException
deriving (Show, Eq, Typeable)
instance Exception GitHashException
tGitInfo :: FilePath -> Q (TExp GitInfo)
tGitInfo fp = unsafeTExpCoerce $ do
gi <- runIO $
getGitRoot fp >>=
either throwIO return >>=
getGitInfo >>=
either throwIO return
mapM_ addDependentFile (_giFiles gi)
lift (gi :: GitInfo)
tGitInfoTry :: FilePath -> Q (TExp (Either String GitInfo))
tGitInfoTry fp = unsafeTExpCoerce $ do
egi <- runIO $ do
eroot <- getGitRoot fp
case eroot of
Left e -> return $ Left $ show e
Right root -> do
einfo <- getGitInfo root
case einfo of
Left e -> return $ Left $ show e
Right info -> return $ Right info
case egi of
Left _ -> return ()
Right gi -> mapM_ addDependentFile (_giFiles gi)
lift (egi :: Either String GitInfo)
tGitInfoCwd :: Q (TExp GitInfo)
tGitInfoCwd = tGitInfo "."
tGitInfoCwdTry :: Q (TExp (Either String GitInfo))
tGitInfoCwdTry = tGitInfoTry "."