{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module GitHash
(
GitInfo
, GitHashException (..)
, giHash
, giBranch
, giDirty
, giCommitDate
, giCommitCount
, giCommitMessage
, giDescribe
, giTag
, giFiles
, 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 ((forall (m :: * -> *). Quote m => GitInfo -> m Exp)
-> (forall (m :: * -> *). Quote m => GitInfo -> Code m GitInfo)
-> Lift GitInfo
forall t.
(forall (m :: * -> *). Quote m => t -> m Exp)
-> (forall (m :: * -> *). Quote m => t -> Code m t) -> Lift t
forall (m :: * -> *). Quote m => GitInfo -> m Exp
forall (m :: * -> *). Quote m => GitInfo -> Code m GitInfo
$clift :: forall (m :: * -> *). Quote m => GitInfo -> m Exp
lift :: forall (m :: * -> *). Quote m => GitInfo -> m Exp
$cliftTyped :: forall (m :: * -> *). Quote m => GitInfo -> Code m GitInfo
liftTyped :: forall (m :: * -> *). Quote m => GitInfo -> Code m GitInfo
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
$cshowsPrec :: Int -> GitInfo -> ShowS
showsPrec :: Int -> GitInfo -> ShowS
$cshow :: GitInfo -> String
show :: GitInfo -> String
$cshowList :: [GitInfo] -> ShowS
showList :: [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
giFiles :: GitInfo -> [FilePath]
giFiles :: GitInfo -> [String]
giFiles = GitInfo -> [String]
_giFiles
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"
ehdRef <- IO ByteString -> IO (Either IOException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO ByteString -> IO (Either IOException ByteString))
-> IO ByteString -> IO (Either IOException ByteString)
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
B.readFile String
hd
files1 <-
case ehdRef of
Left IOException
e
| IOException -> Bool
isDoesNotExistError IOException
e -> [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
| Bool
otherwise -> GitHashException -> IO [String]
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (GitHashException -> IO [String])
-> GitHashException -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> IOException -> GitHashException
GHECouldn'tReadFile String
hd IOException
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
refExists <- String -> IO Bool
doesFileExist String
ref
return $ if refExists then [hd,ref] else [hd]
(ByteString, ByteString)
_hash -> [String] -> IO [String]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [String
hd]
indexExists <- doesFileExist index
let files2 = if Bool
indexExists then [String
index] else []
packedExists <- doesFileExist packedRefs
let files3 = if Bool
packedExists then [String
packedRefs] else []
return $ concat [files1, files2, 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
gitPath <- IO ByteString -> IO (Either IOException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO ByteString -> IO (Either IOException ByteString))
-> IO ByteString -> IO (Either IOException ByteString)
forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
B.readFile String
git
case gitPath of
Left IOException
e
| Bool
otherwise -> GitHashException -> IO [String]
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO (GitHashException -> IO [String])
-> GitHashException -> IO [String]
forall a b. (a -> b) -> a -> b
$ String -> IOException -> GitHashException
GHECouldn'tReadFile String
git IOException
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. (HasCallStack, 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
isDir <- String -> IO Bool
doesDirectoryExist String
git
if isDir then getGitFilesRegular git else getGitFilesForWorktree 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
eres <- String -> [String] -> IO (Either GitHashException String)
runGit String
root [String]
args
case eres of
Left GitHashException
e -> GitHashException -> IO String
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO GitHashException
e
Right String
str -> String -> IO String
forall a. a -> IO a
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
_giFiles <- String -> IO [String]
getGitFiles (String
root String -> ShowS
</> String
".git")
_giHash <- run ["rev-parse", "HEAD"]
_giBranch <- run ["rev-parse", "--abbrev-ref", "HEAD"]
dirtyString <- run ["status", "--porcelain"]
let _giDirty = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (String
dirtyString :: String)
commitCount <- run ["rev-list", "HEAD", "--count"]
_giCommitCount <-
case readMaybe commitCount of
Maybe Int
Nothing -> GitHashException -> IO Int
forall e a. (HasCallStack, 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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
x
_giCommitDate <- run ["log", "HEAD", "-1", "--format=%cd"]
_giCommitMessage <- run ["log", "-1", "--pretty=%B"]
_giDescribe <- run ["describe", "--always", "--long"]
_giTag <- run ["describe", "--always", "--tags"]
return GitInfo {..}
getGitRoot :: FilePath -> IO (Either GitHashException FilePath)
getGitRoot :: String -> IO (Either GitHashException String)
getGitRoot String
dir = ShowS
-> Either GitHashException String -> Either GitHashException String
forall a b.
(a -> b) -> Either GitHashException a -> Either GitHashException b
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 a b. (a -> b) -> IO a -> IO b
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 = Just root }
eres <- IO (ExitCode, String, String)
-> IO (Either IOException (ExitCode, String, String))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (ExitCode, String, String)
-> IO (Either IOException (ExitCode, String, String)))
-> IO (ExitCode, String, String)
-> IO (Either IOException (ExitCode, String, String))
forall a b. (a -> b) -> a -> b
$ CreateProcess -> String -> IO (ExitCode, String, String)
readCreateProcessWithExitCode CreateProcess
cp String
""
return $ case eres of
Left IOException
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] -> IOException -> GitHashException
GHEGitRunException String
root [String]
args IOException
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
$cshowsPrec :: Int -> GitHashException -> ShowS
showsPrec :: Int -> GitHashException -> ShowS
$cshow :: GitHashException -> String
show :: GitHashException -> String
$cshowList :: [GitHashException] -> ShowS
showList :: [GitHashException] -> ShowS
Show, GitHashException -> GitHashException -> Bool
(GitHashException -> GitHashException -> Bool)
-> (GitHashException -> GitHashException -> Bool)
-> Eq GitHashException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: GitHashException -> GitHashException -> Bool
== :: GitHashException -> GitHashException -> Bool
$c/= :: GitHashException -> GitHashException -> Bool
/= :: GitHashException -> GitHashException -> Bool
Eq, Typeable)
instance Exception GitHashException
tGitInfo :: FilePath -> SpliceQ GitInfo
tGitInfo :: String -> SpliceQ GitInfo
tGitInfo String
fp = Q Exp -> SpliceQ GitInfo
forall a (m :: * -> *). Quote m => m Exp -> Splice m a
unsafeSpliceCoerce (Q Exp -> SpliceQ GitInfo) -> Q Exp -> SpliceQ GitInfo
forall a b. (a -> b) -> a -> b
$ do
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 a b. IO a -> (a -> IO b) -> IO b
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. (HasCallStack, Exception e) => e -> IO a
throwIO String -> IO String
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return IO String
-> (String -> IO (Either GitHashException GitInfo))
-> IO (Either GitHashException GitInfo)
forall a b. IO a -> (a -> IO b) -> IO b
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 a b. IO a -> (a -> IO b) -> IO b
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. (HasCallStack, Exception e) => e -> IO a
throwIO GitInfo -> IO GitInfo
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return
mapM_ addDependentFile (_giFiles gi)
lift (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
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
eroot <- String -> IO (Either GitHashException String)
getGitRoot String
fp
case eroot of
Left GitHashException
e -> Either String GitInfo -> IO (Either String GitInfo)
forall a. a -> IO a
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
einfo <- String -> IO (Either GitHashException GitInfo)
getGitInfo String
root
case einfo of
Left GitHashException
e -> Either String GitInfo -> IO (Either String GitInfo)
forall a. a -> IO a
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 a. a -> IO a
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 egi of
Left String
_ -> () -> Q ()
forall a. a -> Q a
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)
lift (egi :: Either String GitInfo)
tGitInfoCwd :: SpliceQ GitInfo
tGitInfoCwd :: SpliceQ GitInfo
tGitInfoCwd = String -> SpliceQ GitInfo
tGitInfo String
"."
tGitInfoCwdTry :: SpliceQ (Either String GitInfo)
tGitInfoCwdTry :: SpliceQ (Either String GitInfo)
tGitInfoCwdTry = String -> SpliceQ (Either String GitInfo)
tGitInfoTry String
"."