@@ -0,0 +1,105 @@
1+-- |
2+-- Module : $Header$
3+-- Copyright : (c) 2015 Adam C. Foltzer
4+-- License : BSD3
5+-- Maintainer : acfoltzer@galois.com
6+-- Stability : provisional
7+-- Portability : portable
8+--
9+-- Some handy Template Haskell splices for including the current git
10+-- hash and branch in the code of your project. Useful for including
11+-- in panic messages, @--version@ output, or diagnostic info for more
12+-- informative bug reports.
13+--
14+-- > {-# LANGUAGE TemplateHaskell #-}
15+-- > import Development.GitRev
16+-- >
17+-- > panic :: String -> a
18+-- > panic msg = error panicMsg
19+-- > where panicMsg =
20+-- > concat [ "[panic ", $(gitBranch), "@", $(gitHash), dirty, "] ", msg ]
21+-- > dirty | $(gitDirty) = " (uncommitted files present)"
22+-- > | otherwise = ""
23+-- >
24+-- > main = panic "oh no!"
25+--
26+-- > % cabal exec runhaskell Example.hs
27+-- > Example.hs: [panic master@4a0a592c37ad908889bd2a7a411923a903ed05a3 (uncommitted files present)] oh no!
28+
29+module Development.GitRev (gitHash, gitBranch, gitDirty) where
30+
31+import Control.Applicative
32+import Control.Exception
33+import Control.Monad
34+import Data.Maybe
35+import Language.Haskell.TH
36+import Language.Haskell.TH.Syntax
37+import System.Directory
38+import System.Exit
39+import System.FilePath
40+import System.Process
41+
42+-- | Run git with the given arguments and no stdin, returning the
43+-- stdout output. If git isn't available or something goes wrong,
44+-- return the second argument.
45+runGit :: [String] -> String -> Q String
46+runGit args def = do
47+ let oops :: SomeException -> IO (ExitCode, String, String)
48+ oops _e = return (ExitFailure 1, def, "")
49+ gitFound <- runIO $ isJust <$> findExecutable "git"
50+ if gitFound
51+ then do
52+ -- a lot of bookkeeping to record the right dependencies
53+ pwd <- runIO getCurrentDirectory
54+ let hd = pwd </> ".git" </> "HEAD"
55+ index = pwd </> ".git" </> "index"
56+ packedRefs = pwd </> ".git" </> "packed-refs"
57+ hdExists <- runIO $ doesFileExist hd
58+ when hdExists $ do
59+ -- the HEAD file either contains the hash of a detached head
60+ -- or a pointer to the file that contains the hash of the head
61+ hdRef <- runIO $ readFile hd
62+ case splitAt 5 hdRef of
63+ -- pointer to ref
64+ ("ref: ", relRef) -> do
65+ let ref = pwd </> ".git" </> relRef
66+ refExists <- runIO $ doesFileExist ref
67+ when refExists $ addDependentFile ref
68+ -- detached head
69+ _hash -> addDependentFile hd
70+ -- add the index if it exists to set the dirty flag
71+ indexExists <- runIO $ doesFileExist index
72+ when indexExists $ addDependentFile index
73+ -- if the refs have been packed, the info we're looking for
74+ -- might be in that file rather than the one-file-per-ref case
75+ -- handled above
76+ packedExists <- runIO $ doesFileExist packedRefs
77+ when packedExists $ addDependentFile packedRefs
78+ runIO $ do
79+ (code, out, _err) <- readProcessWithExitCode "git" args "" `catch` oops
80+ case code of
81+ ExitSuccess -> return (takeWhile (/= '\n') out)
82+ ExitFailure _ -> return def
83+ else return def
84+
85+-- | Return the hash of the current git commit, or @UNKNOWN@ if not in
86+-- a git repository
87+gitHash :: ExpQ
88+gitHash =
89+ stringE =<< runGit ["rev-parse", "HEAD"] "UNKNOWN"
90+
91+-- | Return the branch (or tag) name of the current git commit, or @UNKNOWN@
92+-- if not in a git repository. For detached heads, this will just be
93+-- "HEAD"
94+gitBranch :: ExpQ
95+gitBranch =
96+ stringE =<< runGit ["rev-parse", "--abbrev-ref", "HEAD"] "UNKNOWN"
97+
98+-- | Return @True@ if there are non-committed files present in the
99+-- repository
100+gitDirty :: ExpQ
101+gitDirty = do
102+ output <- runGit ["status", "--porcelain"] ""
103+ case output of
104+ "" -> conE $ mkName "Prelude.False"
105+ _ -> conE $ mkName "Prelude.True"