{-# 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 (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
liftTyped :: forall (m :: * -> *). Quote m => GitInfo -> Code m GitInfo
$cliftTyped :: forall (m :: * -> *). Quote m => GitInfo -> Code m GitInfo
lift :: forall (m :: * -> *). Quote m => GitInfo -> m Exp
$clift :: forall (m :: * -> *). Quote m => GitInfo -> m Exp
Lift, Int -> GitInfo -> ShowS
[GitInfo] -> ShowS
GitInfo -> String
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 IOException ByteString
ehdRef <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
B.readFile String
hd
[String]
files1 <-
case Either IOException ByteString
ehdRef of
Left IOException
e
| IOException -> Bool
isDoesNotExistError IOException
e -> forall (m :: * -> *) a. Monad m => a -> m a
return []
| Bool
otherwise -> forall e a. Exception e => e -> IO a
throwIO 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
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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if Bool
refExists then [String
ref] else []
(ByteString, ByteString)
_hash -> 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 []
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 IOException ByteString
gitPath <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
B.readFile String
git
case Either IOException ByteString
gitPath of
Left IOException
e
| Bool
otherwise -> forall e a. Exception e => e -> IO a
throwIO 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 = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\n') (ByteString -> String
B8.unpack ByteString
gitdir)
String -> IO [String]
getGitFilesRegular String
path
(ByteString, ByteString)
_ -> forall e a. Exception e => e -> IO a
throwIO 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 = forall e a. Exception e => IO a -> IO (Either e a)
try 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 -> forall e a. Exception e => e -> IO a
throwIO GitHashException
e
Right String
str -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile (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 forall a b. (a -> b) -> a -> b
$ 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 forall a. Read a => String -> Maybe a
readMaybe String
commitCount of
Maybe Int
Nothing -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> String -> GitHashException
GHEInvalidCommitCount String
root String
commitCount
Just Int
x -> 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"]
forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ShowS
normalise forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\n')) 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 = forall a. a -> Maybe a
Just String
root }
Either IOException (ExitCode, String, String)
eres <- forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ CreateProcess -> String -> IO (ExitCode, String, String)
readCreateProcessWithExitCode CreateProcess
cp String
""
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Either IOException (ExitCode, String, String)
eres of
Left IOException
e -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String -> [String] -> IOException -> GitHashException
GHEGitRunException String
root [String]
args IOException
e
Right (ExitCode
ExitSuccess, String
out, String
_) -> forall a b. b -> Either a b
Right String
out
Right (ec :: ExitCode
ec@ExitFailure{}, String
out, String
err) -> forall a b. a -> Either a b
Left 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
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
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 -> SpliceQ GitInfo
tGitInfo String
fp = forall a (m :: * -> *). Quote m => m Exp -> Splice m a
unsafeSpliceCoerce forall a b. (a -> b) -> a -> b
$ do
GitInfo
gi <- forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$
String -> IO (Either GitHashException String)
getGitRoot String
fp forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
String -> IO (Either GitHashException GitInfo)
getGitInfo forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e a. Exception e => e -> IO a
throwIO forall (m :: * -> *) a. Monad m => a -> m a
return
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Q ()
addDependentFile (GitInfo -> [String]
_giFiles GitInfo
gi)
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift (GitInfo
gi :: GitInfo)
tGitInfoTry :: FilePath -> SpliceQ (Either String GitInfo)
tGitInfoTry :: String -> SpliceQ (Either String GitInfo)
tGitInfoTry String
fp = forall a (m :: * -> *). Quote m => m Exp -> Splice m a
unsafeSpliceCoerce forall a b. (a -> b) -> a -> b
$ do
Either String GitInfo
egi <- forall a. IO a -> Q a
runIO 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show GitHashException
e
Right GitInfo
info -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right GitInfo
info
case Either String GitInfo
egi of
Left String
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Right GitInfo
gi -> forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ String -> Q ()
addDependentFile (GitInfo -> [String]
_giFiles GitInfo
gi)
forall t (m :: * -> *). (Lift t, Quote m) => t -> m Exp
lift (Either String GitInfo
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
"."