{-# 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
  , giFiles
    -- * 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 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)

-- | 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

-- | The files used to determine whether recompilation is necessary in splices.
--
-- @since 0.1.7.0
giFiles :: GitInfo -> [FilePath]
giFiles :: GitInfo -> [String]
giFiles = GitInfo -> [String]
_giFiles

-- | Get a list of files from within a @.git@ directory.
getGitFilesRegular :: FilePath -> IO [FilePath]
-- [Note: Current implementation's limitation]
-- the current implementation doesn't work right if:
-- 1. the current branch's name contains Non-ASCII character (due to @B8.unpack@),
-- 2. the current branch is only in .git/packed-refs, or
-- 3. the current branch is a symbolic ref to another reference.
-- In these cases, the file with the name `ref` in the following
-- code cannot be found in the filesystem (in the cases 1 & 2),
-- or can be found but will not be updated on commit (in the case 3).
-- As a result, if a module uses @tGitInfo@ as TH macro
-- and the target git repo is in one of the conditions 1--3
-- at the time of compilation, content-change-free commits will fail to
-- trigger recompilation.
--
-- [Note: reftable]
-- In the near future, the technology called reftable may replace the
-- Git's reference management. This function's implementation does not
-- work with reftable, and therefore will need to be updated.
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 forall a b. (a -> b) -> a -> b
$ (Word8 -> Bool) -> ByteString -> ByteString
B.takeWhile (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Bool
isSmallASCIIControl) 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
hd,String
ref] else [String
hd]
          -- 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]
  where
    -- This is to quickly strip newline characters
    -- from the content of .git/HEAD.
    -- Git references don't include ASCII control char bytes:
    -- 0x00 -- 0x1F and 0x7F.
    -- .git/HEAD may contain some ASCII control bytes LF (0xA) and
    -- CR (0xD) before EOF, which should be ignored.
    isSmallASCIIControl :: Word8 -> Bool
    isSmallASCIIControl :: Word8 -> Bool
isSmallASCIIControl = (forall a. Ord a => a -> a -> Bool
<Word8
0x20)

-- | 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
"."