{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module GitHash
(
GitInfo
, GitHashException (..)
, giHash
, giBranch
, giDirty
, giCommitDate
, giCommitCount
, giCommitMessage
, giDescribe
, giTag
, 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 Language.Haskell.TH.Syntax.Compat
import System.Directory
import System.Exit
import System.FilePath
import System.IO.Error (isDoesNotExistError)
import System.Process
import Text.Read (readMaybe)
data GitInfo = GitInfo
{ GitInfo -> String
_giHash :: !String
, GitInfo -> String
_giBranch :: !String
, GitInfo -> Bool
_giDirty :: !Bool
, GitInfo -> String
_giCommitDate :: !String
, GitInfo -> Int
_giCommitCount :: !Int
, GitInfo -> [String]
_giFiles :: ![FilePath]
, GitInfo -> String
_giCommitMessage :: !String
, GitInfo -> String
_giDescribe :: !String
, GitInfo -> String
_giTag :: !String
}
deriving (GitInfo -> Q Exp
GitInfo -> Q (TExp GitInfo)
(GitInfo -> Q Exp) -> (GitInfo -> Q (TExp GitInfo)) -> Lift GitInfo
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: GitInfo -> Q (TExp GitInfo)
$cliftTyped :: GitInfo -> Q (TExp GitInfo)
lift :: GitInfo -> Q Exp
$clift :: GitInfo -> Q Exp
Lift, Int -> GitInfo -> ShowS
[GitInfo] -> ShowS
GitInfo -> String
(Int -> GitInfo -> ShowS)
-> (GitInfo -> String) -> ([GitInfo] -> ShowS) -> Show GitInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GitInfo] -> ShowS
$cshowList :: [GitInfo] -> ShowS
show :: GitInfo -> String
$cshow :: GitInfo -> String
showsPrec :: Int -> GitInfo -> ShowS
$cshowsPrec :: Int -> GitInfo -> ShowS
Show)
giHash :: GitInfo -> String
giHash :: GitInfo -> String
giHash = GitInfo -> String
_giHash
giBranch :: GitInfo -> String
giBranch :: GitInfo -> String
giBranch = GitInfo -> String
_giBranch
giDirty :: GitInfo -> Bool
giDirty :: GitInfo -> Bool
giDirty = GitInfo -> Bool
_giDirty
giCommitDate :: GitInfo -> String
giCommitDate :: GitInfo -> String
giCommitDate = GitInfo -> String
_giCommitDate
giCommitCount :: GitInfo -> Int
giCommitCount :: GitInfo -> Int
giCommitCount = GitInfo -> Int
_giCommitCount
giCommitMessage :: GitInfo -> String
giCommitMessage :: GitInfo -> String
giCommitMessage = GitInfo -> String
_giCommitMessage
giDescribe :: GitInfo -> String
giDescribe :: GitInfo -> String
giDescribe = GitInfo -> String
_giDescribe
giTag :: GitInfo -> String
giTag :: GitInfo -> String
giTag = GitInfo -> String
_giTag
getGitFilesRegular :: FilePath -> IO [FilePath]
getGitFilesRegular :: String -> IO [String]
getGitFilesRegular String
git = do
let hd :: String
hd = String
git String -> ShowS
</> String
"HEAD"
index :: String
index = String
git String -> ShowS
</> String
"index"
packedRefs :: String
packedRefs = String
git String -> ShowS
</> String
"packed-refs"
Either IOError ByteString
ehdRef <- IO ByteString -> IO (Either IOError ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO ByteString -> IO (Either IOError ByteString))
-> IO ByteString -> IO (Either IOError ByteString)
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
B.readFile String
hd
[String]
files1 <-
case Either IOError ByteString
ehdRef of
Left IOError
e
| IOError -> Bool
isDoesNotExistError IOError
e -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return []
| Bool
otherwise -> GitHashException -> IO [String]
forall e a. Exception e => e -> IO a
throwIO (GitHashException -> IO [String])
-> GitHashException -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> IOError -> GitHashException
GHECouldn'tReadFile String
hd IOError
e
Right ByteString
hdRef -> do
case Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
5 ByteString
hdRef of
(ByteString
"ref: ", ByteString
relRef) -> do
let ref :: String
ref = String
git String -> ShowS
</> ByteString -> String
B8.unpack ByteString
relRef
Bool
refExists <- String -> IO Bool
doesFileExist String
ref
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ if Bool
refExists then [String
ref] else []
(ByteString, ByteString)
_hash -> [String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return [String
hd]
Bool
indexExists <- String -> IO Bool
doesFileExist String
index
let files2 :: [String]
files2 = if Bool
indexExists then [String
index] else []
Bool
packedExists <- String -> IO Bool
doesFileExist String
packedRefs
let files3 :: [String]
files3 = if Bool
packedExists then [String
packedRefs] else []
[String] -> IO [String]
forall (m :: * -> *) a. Monad m => a -> m a
return ([String] -> IO [String]) -> [String] -> IO [String]
forall a b. (a -> b) -> a -> b
$ [[String]] -> [String]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[String]
files1, [String]
files2, [String]
files3]
getGitFilesForWorktree :: FilePath -> IO [FilePath]
getGitFilesForWorktree :: String -> IO [String]
getGitFilesForWorktree String
git = do
Either IOError ByteString
gitPath <- IO ByteString -> IO (Either IOError ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO ByteString -> IO (Either IOError ByteString))
-> IO ByteString -> IO (Either IOError ByteString)
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
B.readFile String
git
case Either IOError ByteString
gitPath of
Left IOError
e
| Bool
otherwise -> GitHashException -> IO [String]
forall e a. Exception e => e -> IO a
throwIO (GitHashException -> IO [String])
-> GitHashException -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> IOError -> GitHashException
GHECouldn'tReadFile String
git IOError
e
Right ByteString
rootPath ->
case Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
8 ByteString
rootPath of
(ByteString
"gitdir: ", ByteString
gitdir) -> do
let path :: String
path = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') (ByteString -> String
B8.unpack ByteString
gitdir)
String -> IO [String]
getGitFilesRegular String
path
(ByteString, ByteString)
_ -> GitHashException -> IO [String]
forall e a. Exception e => e -> IO a
throwIO (GitHashException -> IO [String])
-> GitHashException -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> GitHashException
GHEInvalidGitFile (ByteString -> String
B8.unpack ByteString
rootPath)
getGitFiles :: FilePath -> IO [FilePath]
getGitFiles :: String -> IO [String]
getGitFiles String
git = do
Bool
isDir <- String -> IO Bool
doesDirectoryExist String
git
if Bool
isDir then String -> IO [String]
getGitFilesRegular String
git else String -> IO [String]
getGitFilesForWorktree String
git
getGitInfo :: FilePath -> IO (Either GitHashException GitInfo)
getGitInfo :: String -> IO (Either GitHashException GitInfo)
getGitInfo String
root = IO GitInfo -> IO (Either GitHashException GitInfo)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO GitInfo -> IO (Either GitHashException GitInfo))
-> IO GitInfo -> IO (Either GitHashException GitInfo)
forall a b. (a -> b) -> a -> b
$ do
let run :: [String] -> IO String
run [String]
args = do
Either GitHashException String
eres <- String -> [String] -> IO (Either GitHashException String)
runGit String
root [String]
args
case Either GitHashException String
eres of
Left GitHashException
e -> GitHashException -> IO String
forall e a. Exception e => e -> IO a
throwIO GitHashException
e
Right String
str -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') String
str
[String]
_giFiles <- String -> IO [String]
getGitFiles (String
root String -> ShowS
</> String
".git")
String
_giHash <- [String] -> IO String
run [String
"rev-parse", String
"HEAD"]
String
_giBranch <- [String] -> IO String
run [String
"rev-parse", String
"--abbrev-ref", String
"HEAD"]
String
dirtyString <- [String] -> IO String
run [String
"status", String
"--porcelain"]
let _giDirty :: Bool
_giDirty = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String
dirtyString :: String)
String
commitCount <- [String] -> IO String
run [String
"rev-list", String
"HEAD", String
"--count"]
Int
_giCommitCount <-
case String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe String
commitCount of
Maybe Int
Nothing -> GitHashException -> IO Int
forall e a. Exception e => e -> IO a
throwIO (GitHashException -> IO Int) -> GitHashException -> IO Int
forall a b. (a -> b) -> a -> b
$ String -> String -> GitHashException
GHEInvalidCommitCount String
root String
commitCount
Just Int
x -> Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
x
String
_giCommitDate <- [String] -> IO String
run [String
"log", String
"HEAD", String
"-1", String
"--format=%cd"]
String
_giCommitMessage <- [String] -> IO String
run [String
"log", String
"-1", String
"--pretty=%B"]
String
_giDescribe <- [String] -> IO String
run [String
"describe", String
"--always", String
"--long"]
String
_giTag <- [String] -> IO String
run [String
"describe", String
"--always", String
"--tags"]
GitInfo -> IO GitInfo
forall (m :: * -> *) a. Monad m => a -> m a
return GitInfo :: String
-> String
-> Bool
-> String
-> Int
-> [String]
-> String
-> String
-> String
-> GitInfo
GitInfo {Bool
Int
String
[String]
_giTag :: String
_giDescribe :: String
_giCommitMessage :: String
_giCommitDate :: String
_giCommitCount :: Int
_giDirty :: Bool
_giBranch :: String
_giHash :: String
_giFiles :: [String]
_giTag :: String
_giDescribe :: String
_giCommitMessage :: String
_giFiles :: [String]
_giCommitCount :: Int
_giCommitDate :: String
_giDirty :: Bool
_giBranch :: String
_giHash :: String
..}
getGitRoot :: FilePath -> IO (Either GitHashException FilePath)
getGitRoot :: String -> IO (Either GitHashException String)
getGitRoot String
dir = ShowS
-> Either GitHashException String -> Either GitHashException String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ShowS
normalise ShowS -> ShowS -> ShowS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n')) (Either GitHashException String -> Either GitHashException String)
-> IO (Either GitHashException String)
-> IO (Either GitHashException String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (String -> [String] -> IO (Either GitHashException String)
runGit String
dir [String
"rev-parse", String
"--show-toplevel"])
runGit :: FilePath -> [String] -> IO (Either GitHashException String)
runGit :: String -> [String] -> IO (Either GitHashException String)
runGit String
root [String]
args = do
let cp :: CreateProcess
cp = (String -> [String] -> CreateProcess
proc String
"git" [String]
args) { cwd :: Maybe String
cwd = String -> Maybe String
forall a. a -> Maybe a
Just String
root }
Either IOError (ExitCode, String, String)
eres <- IO (ExitCode, String, String)
-> IO (Either IOError (ExitCode, String, String))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (ExitCode, String, String)
-> IO (Either IOError (ExitCode, String, String)))
-> IO (ExitCode, String, String)
-> IO (Either IOError (ExitCode, String, String))
forall a b. (a -> b) -> a -> b
$ CreateProcess -> String -> IO (ExitCode, String, String)
readCreateProcessWithExitCode CreateProcess
cp String
""
Either GitHashException String
-> IO (Either GitHashException String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either GitHashException String
-> IO (Either GitHashException String))
-> Either GitHashException String
-> IO (Either GitHashException String)
forall a b. (a -> b) -> a -> b
$ case Either IOError (ExitCode, String, String)
eres of
Left IOError
e -> GitHashException -> Either GitHashException String
forall a b. a -> Either a b
Left (GitHashException -> Either GitHashException String)
-> GitHashException -> Either GitHashException String
forall a b. (a -> b) -> a -> b
$ String -> [String] -> IOError -> GitHashException
GHEGitRunException String
root [String]
args IOError
e
Right (ExitCode
ExitSuccess, String
out, String
_) -> String -> Either GitHashException String
forall a b. b -> Either a b
Right String
out
Right (ec :: ExitCode
ec@ExitFailure{}, String
out, String
err) -> GitHashException -> Either GitHashException String
forall a b. a -> Either a b
Left (GitHashException -> Either GitHashException String)
-> GitHashException -> Either GitHashException String
forall a b. (a -> b) -> a -> b
$ String
-> [String] -> ExitCode -> String -> String -> GitHashException
GHEGitRunFailed String
root [String]
args ExitCode
ec String
out String
err
data GitHashException
= GHECouldn'tReadFile !FilePath !IOException
| GHEInvalidCommitCount !FilePath !String
| GHEInvalidGitFile !String
| GHEGitRunFailed !FilePath ![String] !ExitCode !String !String
| GHEGitRunException !FilePath ![String] !IOException
deriving (Int -> GitHashException -> ShowS
[GitHashException] -> ShowS
GitHashException -> String
(Int -> GitHashException -> ShowS)
-> (GitHashException -> String)
-> ([GitHashException] -> ShowS)
-> Show GitHashException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [GitHashException] -> ShowS
$cshowList :: [GitHashException] -> ShowS
show :: GitHashException -> String
$cshow :: GitHashException -> String
showsPrec :: Int -> GitHashException -> ShowS
$cshowsPrec :: Int -> GitHashException -> ShowS
Show, GitHashException -> GitHashException -> Bool
(GitHashException -> GitHashException -> Bool)
-> (GitHashException -> GitHashException -> Bool)
-> Eq GitHashException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: GitHashException -> GitHashException -> Bool
$c/= :: GitHashException -> GitHashException -> Bool
== :: GitHashException -> GitHashException -> Bool
$c== :: GitHashException -> GitHashException -> Bool
Eq, Typeable)
instance Exception GitHashException
tGitInfo :: FilePath -> SpliceQ GitInfo
tGitInfo :: String -> Q (TExp GitInfo)
tGitInfo String
fp = Q Exp -> Q (TExp GitInfo)
forall a (m :: * -> *). Quote m => m Exp -> Splice m a
unsafeSpliceCoerce (Q Exp -> Q (TExp GitInfo)) -> Q Exp -> Q (TExp GitInfo)
forall a b. (a -> b) -> a -> b
$ do
GitInfo
gi <- IO GitInfo -> Q GitInfo
forall a. IO a -> Q a
runIO (IO GitInfo -> Q GitInfo) -> IO GitInfo -> Q GitInfo
forall a b. (a -> b) -> a -> b
$
String -> IO (Either GitHashException String)
getGitRoot String
fp IO (Either GitHashException String)
-> (Either GitHashException String -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(GitHashException -> IO String)
-> (String -> IO String)
-> Either GitHashException String
-> IO String
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either GitHashException -> IO String
forall e a. Exception e => e -> IO a
throwIO String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return IO String
-> (String -> IO (Either GitHashException GitInfo))
-> IO (Either GitHashException GitInfo)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
String -> IO (Either GitHashException GitInfo)
getGitInfo IO (Either GitHashException GitInfo)
-> (Either GitHashException GitInfo -> IO GitInfo) -> IO GitInfo
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
(GitHashException -> IO GitInfo)
-> (GitInfo -> IO GitInfo)
-> Either GitHashException GitInfo
-> IO GitInfo
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either GitHashException -> IO GitInfo
forall e a. Exception e => e -> IO a
throwIO GitInfo -> IO GitInfo
forall (m :: * -> *) a. Monad m => a -> m a
return
(String -> Q ()) -> [String] -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Q ()
addDependentFile (GitInfo -> [String]
_giFiles GitInfo
gi)
GitInfo -> Q Exp
forall t. Lift t => t -> Q Exp
lift (GitInfo
gi :: GitInfo)
tGitInfoTry :: FilePath -> SpliceQ (Either String GitInfo)
tGitInfoTry :: String -> SpliceQ (Either String GitInfo)
tGitInfoTry String
fp = Q Exp -> SpliceQ (Either String GitInfo)
forall a (m :: * -> *). Quote m => m Exp -> Splice m a
unsafeSpliceCoerce (Q Exp -> SpliceQ (Either String GitInfo))
-> Q Exp -> SpliceQ (Either String GitInfo)
forall a b. (a -> b) -> a -> b
$ do
Either String GitInfo
egi <- IO (Either String GitInfo) -> Q (Either String GitInfo)
forall a. IO a -> Q a
runIO (IO (Either String GitInfo) -> Q (Either String GitInfo))
-> IO (Either String GitInfo) -> Q (Either String GitInfo)
forall a b. (a -> b) -> a -> b
$ do
Either GitHashException String
eroot <- String -> IO (Either GitHashException String)
getGitRoot String
fp
case Either GitHashException String
eroot of
Left GitHashException
e -> Either String GitInfo -> IO (Either String GitInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String GitInfo -> IO (Either String GitInfo))
-> Either String GitInfo -> IO (Either String GitInfo)
forall a b. (a -> b) -> a -> b
$ String -> Either String GitInfo
forall a b. a -> Either a b
Left (String -> Either String GitInfo)
-> String -> Either String GitInfo
forall a b. (a -> b) -> a -> b
$ GitHashException -> String
forall a. Show a => a -> String
show GitHashException
e
Right String
root -> do
Either GitHashException GitInfo
einfo <- String -> IO (Either GitHashException GitInfo)
getGitInfo String
root
case Either GitHashException GitInfo
einfo of
Left GitHashException
e -> Either String GitInfo -> IO (Either String GitInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String GitInfo -> IO (Either String GitInfo))
-> Either String GitInfo -> IO (Either String GitInfo)
forall a b. (a -> b) -> a -> b
$ String -> Either String GitInfo
forall a b. a -> Either a b
Left (String -> Either String GitInfo)
-> String -> Either String GitInfo
forall a b. (a -> b) -> a -> b
$ GitHashException -> String
forall a. Show a => a -> String
show GitHashException
e
Right GitInfo
info -> Either String GitInfo -> IO (Either String GitInfo)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String GitInfo -> IO (Either String GitInfo))
-> Either String GitInfo -> IO (Either String GitInfo)
forall a b. (a -> b) -> a -> b
$ GitInfo -> Either String GitInfo
forall a b. b -> Either a b
Right GitInfo
info
case Either String GitInfo
egi of
Left String
_ -> () -> Q ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Right GitInfo
gi -> (String -> Q ()) -> [String] -> Q ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Q ()
addDependentFile (GitInfo -> [String]
_giFiles GitInfo
gi)
Either String GitInfo -> Q Exp
forall t. Lift t => t -> Q Exp
lift (Either String GitInfo
egi :: Either String GitInfo)
tGitInfoCwd :: SpliceQ GitInfo
tGitInfoCwd :: Q (TExp GitInfo)
tGitInfoCwd = String -> Q (TExp GitInfo)
tGitInfo String
"."
tGitInfoCwdTry :: SpliceQ (Either String GitInfo)
tGitInfoCwdTry :: SpliceQ (Either String GitInfo)
tGitInfoCwdTry = String -> SpliceQ (Either String GitInfo)
tGitInfoTry String
"."