{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}

-- |
-- Module      :  $Header$
-- Copyright   :  (c) 2015 Adam C. Foltzer
-- License     :  BSD3
-- Maintainer  :  acfoltzer@galois.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 Development.GitRev
-- >
-- > panic :: String -> a
-- > panic msg = error panicMsg
-- >   where panicMsg =
-- >           concat [ "[panic ", $(gitBranch), "@", $(gitHash)
-- >                  , " (", $(gitCommitDate), ")"
-- >                  , " (", $(gitCommitCount), " commits in HEAD)"
-- >                  , dirty, "] ", msg ]
-- >         dirty | $(gitDirty) = " (uncommitted files present)"
-- >               | otherwise   = ""
-- >
-- > main = panic "oh no!"
--
-- > % cabal exec runhaskell Example.hs
-- > Example.hs: [panic master@2ae047ba5e4a6f0f3e705a43615363ac006099c1 (Mon Jan 11 11:50:59 2016 -0800) (14 commits in HEAD) (uncommitted files present)] oh no!

module Development.GitRev
  ( gitBranch
  , gitCommitCount
  , gitCommitDate
  , gitDescribe
  , gitDirty
  , gitDirtyTracked
  , gitHash
  ) where

import Control.Exception
import Control.Monad
import Data.Maybe
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import System.Directory
import System.Exit
import System.FilePath
import System.Process

import Prelude ()
import Prelude.Compat

-- | Run git with the given arguments and no stdin, returning the
-- stdout output. If git isn't available or something goes wrong,
-- return the second argument.
runGit :: [String] -> String -> IndexUsed -> Q String
runGit :: [String] -> String -> IndexUsed -> Q String
runGit [String]
args String
def IndexUsed
useIdx = do
  let oops :: SomeException -> IO (ExitCode, String, String)
      oops :: SomeException -> IO (ExitCode, String, String)
oops SomeException
_e = (ExitCode, String, String) -> IO (ExitCode, String, String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ExitCode
ExitFailure Int
1, String
def, String
"")
  Bool
gitFound <- IO Bool -> Q Bool
forall a. IO a -> Q a
runIO (IO Bool -> Q Bool) -> IO Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ Maybe String -> Bool
forall a. Maybe a -> Bool
isJust (Maybe String -> Bool) -> IO (Maybe String) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Maybe String)
findExecutable String
"git"
  if Bool
gitFound
    then do
      -- a lot of bookkeeping to record the right dependencies
      String
pwd <- IO String -> Q String
forall a. IO a -> Q a
runIO IO String
getDotGit
      let hd :: String
hd         = String
pwd String -> String -> String
</> String
".git" String -> String -> String
</> String
"HEAD"
          index :: String
index      = String
pwd String -> String -> String
</> String
".git" String -> String -> String
</> String
"index"
          packedRefs :: String
packedRefs = String
pwd String -> String -> String
</> String
".git" String -> String -> String
</> String
"packed-refs"
      Bool
hdExists  <- IO Bool -> Q Bool
forall a. IO a -> Q a
runIO (IO Bool -> Q Bool) -> IO Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
hd
      Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hdExists (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ 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
        Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
5 (String -> (String, String)) -> Q String -> Q (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` IO String -> Q String
forall a. IO a -> Q a
runIO (String -> IO String
readFile String
hd) Q (String, String) -> ((String, String) -> Q ()) -> Q ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          -- pointer to ref
          (String
"ref: ", String
relRef) -> do
            let ref :: String
ref = String
pwd String -> String -> String
</> String
".git" String -> String -> String
</> String
relRef
            Bool
refExists <- IO Bool -> Q Bool
forall a. IO a -> Q a
runIO (IO Bool -> Q Bool) -> IO Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
ref
            Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
refExists (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
addDependentFile String
ref
          -- detached head
          (String, String)
_hash -> String -> Q ()
addDependentFile String
hd
      -- add the index if it exists to set the dirty flag
      Bool
indexExists <- IO Bool -> Q Bool
forall a. IO a -> Q a
runIO (IO Bool -> Q Bool) -> IO Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
index
      Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
indexExists Bool -> Bool -> Bool
&& IndexUsed
useIdx IndexUsed -> IndexUsed -> Bool
forall a. Eq a => a -> a -> Bool
== IndexUsed
IdxUsed) (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
addDependentFile String
index
      -- 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 <- IO Bool -> Q Bool
forall a. IO a -> Q a
runIO (IO Bool -> Q Bool) -> IO Bool -> Q Bool
forall a b. (a -> b) -> a -> b
$ String -> IO Bool
doesFileExist String
packedRefs
      Bool -> Q () -> Q ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
packedExists (Q () -> Q ()) -> Q () -> Q ()
forall a b. (a -> b) -> a -> b
$ String -> Q ()
addDependentFile String
packedRefs
      IO String -> Q String
forall a. IO a -> Q a
runIO (IO String -> Q String) -> IO String -> Q String
forall a b. (a -> b) -> a -> b
$ do
        (ExitCode
code, String
out, String
_err) <- String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"git" [String]
args String
"" IO (ExitCode, String, String)
-> (SomeException -> IO (ExitCode, String, String))
-> IO (ExitCode, String, String)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> IO (ExitCode, String, String)
oops
        case ExitCode
code of
          ExitCode
ExitSuccess   -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return ((Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') String
out)
          ExitFailure Int
_ -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
def
    else String -> Q String
forall (m :: * -> *) a. Monad m => a -> m a
return String
def

-- | Determine where our @.git@ directory is, in case we're in a
-- submodule.
getDotGit :: IO FilePath
getDotGit :: IO String
getDotGit = do
  String
pwd <- IO String
getGitRoot
  let dotGit :: String
dotGit = String
pwd String -> String -> String
</> String
".git"
      oops :: IO String
oops = String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
dotGit -- it's gonna fail, that's fine
  Bool
isDir <- String -> IO Bool
doesDirectoryExist String
dotGit
  Bool
isFile <- String -> IO Bool
doesFileExist String
dotGit
  if | Bool
isDir -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
dotGit
     | Bool -> Bool
not Bool
isFile -> IO String
oops
     | Bool
isFile ->
         Int -> String -> (String, String)
forall a. Int -> [a] -> ([a], [a])
splitAt Int
8 (String -> (String, String)) -> IO String -> IO (String, String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> IO String
readFile String
dotGit IO (String, String) -> ((String, String) -> IO String) -> IO String
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
           (String
"gitdir: ", String
relDir) -> do
             Bool
isRelDir <- String -> IO Bool
doesDirectoryExist String
relDir
             if Bool
isRelDir
               then String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
relDir
               else IO String
oops
           (String, String)
_ -> IO String
oops

-- | Get the root directory of the Git repo.
getGitRoot :: IO FilePath
getGitRoot :: IO String
getGitRoot = do
  String
pwd <- IO String
getCurrentDirectory
  (ExitCode
code, String
out, String
_) <-
    String -> [String] -> String -> IO (ExitCode, String, String)
readProcessWithExitCode String
"git" [String
"rev-parse", String
"--show-toplevel"] String
""
  case ExitCode
code of
    ExitCode
ExitSuccess   -> 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) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\n') String
out
    ExitFailure Int
_ -> String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return String
pwd -- later steps will fail, that's fine

-- | Type to flag if the git index is used or not in a call to runGit
data IndexUsed = IdxUsed -- ^ The git index is used
               | IdxNotUsed -- ^ The git index is /not/ used
    deriving (IndexUsed -> IndexUsed -> Bool
(IndexUsed -> IndexUsed -> Bool)
-> (IndexUsed -> IndexUsed -> Bool) -> Eq IndexUsed
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: IndexUsed -> IndexUsed -> Bool
$c/= :: IndexUsed -> IndexUsed -> Bool
== :: IndexUsed -> IndexUsed -> Bool
$c== :: IndexUsed -> IndexUsed -> Bool
Eq)

-- | Return the hash of the current git commit, or @UNKNOWN@ if not in
-- a git repository
gitHash :: ExpQ
gitHash :: ExpQ
gitHash =
  String -> ExpQ
stringE (String -> ExpQ) -> Q String -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [String] -> String -> IndexUsed -> Q String
runGit [String
"rev-parse", String
"HEAD"] String
"UNKNOWN" IndexUsed
IdxNotUsed

-- | Return the branch (or tag) name of the current git commit, or @UNKNOWN@
-- if not in a git repository. For detached heads, this will just be
-- "HEAD"
gitBranch :: ExpQ
gitBranch :: ExpQ
gitBranch =
  String -> ExpQ
stringE (String -> ExpQ) -> Q String -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [String] -> String -> IndexUsed -> Q String
runGit [String
"rev-parse", String
"--abbrev-ref", String
"HEAD"] String
"UNKNOWN" IndexUsed
IdxNotUsed

-- | Return the long git description for the current git commit, or
-- @UNKNOWN@ if not in a git repository.
gitDescribe :: ExpQ
gitDescribe :: ExpQ
gitDescribe =
  String -> ExpQ
stringE (String -> ExpQ) -> Q String -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [String] -> String -> IndexUsed -> Q String
runGit [String
"describe", String
"--long", String
"--always"] String
"UNKNOWN" IndexUsed
IdxNotUsed

-- | Return @True@ if there are non-committed files present in the
-- repository
gitDirty :: ExpQ
gitDirty :: ExpQ
gitDirty = do
  String
output <- [String] -> String -> IndexUsed -> Q String
runGit [String
"status", String
"--porcelain"] String
"" IndexUsed
IdxUsed
  case String
output of
    String
"" -> Name -> ExpQ
conE Name
falseName
    String
_  -> Name -> ExpQ
conE Name
trueName

-- | Return @True@ if there are non-commited changes to tracked files
-- present in the repository
gitDirtyTracked :: ExpQ
gitDirtyTracked :: ExpQ
gitDirtyTracked = do
  String
output <- [String] -> String -> IndexUsed -> Q String
runGit [String
"status", String
"--porcelain",String
"--untracked-files=no"] String
"" IndexUsed
IdxUsed
  case String
output of
    String
"" -> Name -> ExpQ
conE Name
falseName
    String
_  -> Name -> ExpQ
conE Name
trueName

-- | Return the number of commits in the current head
gitCommitCount :: ExpQ
gitCommitCount :: ExpQ
gitCommitCount =
  String -> ExpQ
stringE (String -> ExpQ) -> Q String -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [String] -> String -> IndexUsed -> Q String
runGit [String
"rev-list", String
"HEAD", String
"--count"] String
"UNKNOWN" IndexUsed
IdxNotUsed

-- | Return the commit date of the current head
gitCommitDate :: ExpQ
gitCommitDate :: ExpQ
gitCommitDate =
  String -> ExpQ
stringE (String -> ExpQ) -> Q String -> ExpQ
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [String] -> String -> IndexUsed -> Q String
runGit [String
"log", String
"HEAD", String
"-1", String
"--format=%cd"] String
"UNKNOWN" IndexUsed
IdxNotUsed