{-# 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 Data.Word (Word8)
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 -> (ByteString, ByteString))
-> ByteString -> (ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> ByteString
B.takeWhile (Bool -> Bool
not (Bool -> Bool) -> (Word8 -> Bool) -> Word8 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Bool
isSmallASCIIControl) 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
hd,String
ref] else [String
hd]
(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]
where
isSmallASCIIControl :: Word8 -> Bool
isSmallASCIIControl :: Word8 -> Bool
isSmallASCIIControl = (Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
<Word8
0x20)
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
"."