{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
-- |
-- Module      :  $Header$
-- Copyright   :  (c) 2018 Michael Snoyman, 2015 Adam C. Foltzer
-- License     :  BSD3
-- Maintainer  :  michael@snoyman.com
-- Stability   :  provisional
-- Portability :  portable
--
-- Some handy Template Haskell splices for including the current git
-- hash and branch in the code of your project. Useful for including
-- in panic messages, @--version@ output, or diagnostic info for more
-- informative bug reports.
--
-- > {-# LANGUAGE TemplateHaskell #-}
-- > import GitHash
-- >
-- > panic :: String -> a
-- > panic msg = error panicMsg
-- >   where panicMsg =
-- >           concat [ "[panic ", giBranch gi, "@", giHash gi
-- >                  , " (", giCommitDate gi, ")"
-- >                  , " (", show (giCommitCount gi), " commits in HEAD)"
-- >                  , dirty, "] ", msg ]
-- >         dirty | giDirty gi = " (uncommitted files present)"
-- >               | otherwise   = ""
-- >         gi = $$tGitInfoCwd
-- >
-- > main = panic "oh no!"
--
-- > % stack runghc Example.hs
-- > Example.hs: [panic master@2ae047ba5e4a6f0f3e705a43615363ac006099c1 (Mon Jan 11 11:50:59 2016 -0800) (14 commits in HEAD) (uncommitted files present)] oh no!
--
-- WARNING: None of this will work in a git repository without any commits.
--
-- @since 0.1.0.0
module GitHash
  ( -- * Types
    GitInfo
  , GitHashException (..)
    -- ** Getters
  , giHash
  , giBranch
  , giDirty
  , giCommitDate
  , giCommitCount
  , giCommitMessage
  , giDescribe
  , giTag
    -- * Creators
  , getGitInfo
  , getGitRoot
    -- * Template Haskell
  , 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)

-- | Various pieces of information about a Git repository.
--
-- @since 0.1.0.0
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)

-- | The hash of the most recent commit.
--
-- @since 0.1.0.0
giHash :: GitInfo -> String
giHash :: GitInfo -> String
giHash = GitInfo -> String
_giHash

-- | The hash of the most recent commit.
--
-- @since 0.1.0.0
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

-- | The message of the most recent commit.
--
-- @since 0.1.1.0
giCommitMessage :: GitInfo -> String
giCommitMessage :: GitInfo -> String
giCommitMessage = GitInfo -> String
_giCommitMessage

-- | The output of @git describe --always@ for the most recent commit.
--
-- @since 0.1.4.0
giDescribe :: GitInfo -> String
giDescribe :: GitInfo -> String
giDescribe = GitInfo -> String
_giDescribe

-- | The output of @git describe --always --tags@ for the most recent commit.
--
-- @since 0.1.5.0
giTag :: GitInfo -> String
giTag :: GitInfo -> String
giTag = GitInfo -> String
_giTag

-- | Get a list of files from within a @.git@ directory.
getGitFilesRegular :: FilePath -> IO [FilePath]
getGitFilesRegular :: String -> IO [String]
getGitFilesRegular String
git = do
  -- a lot of bookkeeping to record the right dependencies
  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
        -- the HEAD file either contains the hash of a detached head
        -- or a pointer to the file that contains the hash of the head
        case Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
5 ByteString
hdRef of
          -- pointer to ref
          (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 []
          -- detached head
          (ByteString, ByteString)
_hash -> forall (m :: * -> *) a. Monad m => a -> m a
return [String
hd]
  -- add the index if it exists to set the dirty flag
  Bool
indexExists <- String -> IO Bool
doesFileExist String
index
  let files2 :: [String]
files2 = if Bool
indexExists then [String
index] else []
  -- if the refs have been packed, the info we're looking for
  -- might be in that file rather than the one-file-per-ref case
  -- handled above
  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]

-- | Get a list of dependent files from a @.git@ file representing a
-- git-worktree.
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 ->
      -- the .git file contains the absolute path to the git
      -- directory's root.
      case Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
8 ByteString
rootPath of
        -- path to root
        (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)
          -- The .git file points to a .git directory which we can just
          -- treat like a non git-worktree one.
          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)


-- | Get a list of dependent git related files.
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

-- | Get the 'GitInfo' for the given root directory. Root directory
-- should be the directory containing the @.git@ directory.
--
-- @since 0.1.0.0
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
..}

-- | Get the root directory of the Git repo containing the given file
-- path.
--
-- @since 0.1.0.0
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

-- | Exceptions which can occur when using this library's functions.
--
-- @since 0.1.0.0
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

-- | Load up the 'GitInfo' value at compile time for the given
-- directory. Compilation fails if no info is available.
--
-- @since 0.1.0.0
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) -- adding type sig to make the unsafe look slightly better

-- | Try to load up the 'GitInfo' value at compile time for the given
-- directory.
--
-- @since 0.1.2.0
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) -- adding type sig to make the unsafe look slightly better

-- | Load up the 'GitInfo' value at compile time for the current
-- working directory.
--
-- @since 0.1.0.0
tGitInfoCwd :: SpliceQ GitInfo
tGitInfoCwd :: SpliceQ GitInfo
tGitInfoCwd = String -> SpliceQ GitInfo
tGitInfo String
"."

-- | Try to load up the 'GitInfo' value at compile time for the current
-- working directory.
--
-- @since 0.1.2.0
tGitInfoCwdTry :: SpliceQ (Either String GitInfo)
tGitInfoCwdTry :: SpliceQ (Either String GitInfo)
tGitInfoCwdTry = String -> SpliceQ (Either String GitInfo)
tGitInfoTry String
"."