@@ -1,180 +0,0 @@
1−{-# LANGUAGE LambdaCase #-}
2−{-# LANGUAGE MultiWayIf #-}
3−
4−-- |
5−-- Module : $Header$
6−-- Copyright : (c) 2015 Adam C. Foltzer
7−-- License : BSD3
8−-- Maintainer : acfoltzer@galois.com
9−-- Stability : provisional
10−-- Portability : portable
11−--
12−-- Some handy Template Haskell splices for including the current git
13−-- hash and branch in the code of your project. Useful for including
14−-- in panic messages, @--version@ output, or diagnostic info for more
15−-- informative bug reports.
16−--
17−-- > {-# LANGUAGE TemplateHaskell #-}
18−-- > import Development.GitRev
19−-- >
20−-- > panic :: String -> a
21−-- > panic msg = error panicMsg
22−-- > where panicMsg =
23−-- > concat [ "[panic ", $(gitBranch), "@", $(gitHash)
24−-- > , " (", $(gitCommitDate), ")"
25−-- > , " (", $(gitCommitCount), " commits in HEAD)"
26−-- > , dirty, "] ", msg ]
27−-- > dirty | $(gitDirty) = " (uncommitted files present)"
28−-- > | otherwise = ""
29−-- >
30−-- > main = panic "oh no!"
31−--
32−-- > % cabal exec runhaskell Example.hs
33−-- > Example.hs: [panic master@2ae047ba5e4a6f0f3e705a43615363ac006099c1 (Mon Jan 11 11:50:59 2016 -0800) (14 commits in HEAD) (uncommitted files present)] oh no!
34−
35−module Development.GitRev
36− ( gitBranch
37− , gitCommitCount
38− , gitCommitDate
39− , gitDescribe
40− , gitDirty
41− , gitDirtyTracked
42− , gitHash
43− ) where
44−
45−import Control.Exception
46−import Control.Monad
47−import Data.Maybe
48−import Language.Haskell.TH
49−import Language.Haskell.TH.Syntax
50−import System.Directory
51−import System.Exit
52−import System.FilePath
53−import System.Process
54−
55−import Prelude ()
56−import Prelude.Compat
57−
58−-- | Run git with the given arguments and no stdin, returning the
59−-- stdout output. If git isn't available or something goes wrong,
60−-- return the second argument.
61−runGit :: [String] -> String -> IndexUsed -> Q String
62−runGit args def useIdx = do
63− let oops :: SomeException -> IO (ExitCode, String, String)
64− oops _e = return (ExitFailure 1, def, "")
65− gitFound <- runIO $ isJust <$> findExecutable "git"
66− if gitFound
67− then do
68− -- a lot of bookkeeping to record the right dependencies
69− pwd <- runIO getDotGit
70− let hd = pwd </> ".git" </> "HEAD"
71− index = pwd </> ".git" </> "index"
72− packedRefs = pwd </> ".git" </> "packed-refs"
73− hdExists <- runIO $ doesFileExist hd
74− when hdExists $ do
75− -- the HEAD file either contains the hash of a detached head
76− -- or a pointer to the file that contains the hash of the head
77− splitAt 5 `fmap` runIO (readFile hd) >>= \case
78− -- pointer to ref
79− ("ref: ", relRef) -> do
80− let ref = pwd </> ".git" </> relRef
81− refExists <- runIO $ doesFileExist ref
82− when refExists $ addDependentFile ref
83− -- detached head
84− _hash -> addDependentFile hd
85− -- add the index if it exists to set the dirty flag
86− indexExists <- runIO $ doesFileExist index
87− when (indexExists && useIdx == IdxUsed) $ addDependentFile index
88− -- if the refs have been packed, the info we're looking for
89− -- might be in that file rather than the one-file-per-ref case
90− -- handled above
91− packedExists <- runIO $ doesFileExist packedRefs
92− when packedExists $ addDependentFile packedRefs
93− runIO $ do
94− (code, out, _err) <- readProcessWithExitCode "git" args "" `catch` oops
95− case code of
96− ExitSuccess -> return (takeWhile (/= '\n') out)
97− ExitFailure _ -> return def
98− else return def
99−
100−-- | Determine where our @.git@ directory is, in case we're in a
101−-- submodule.
102−getDotGit :: IO FilePath
103−getDotGit = do
104− pwd <- getGitRoot
105− let dotGit = pwd </> ".git"
106− oops = return dotGit -- it's gonna fail, that's fine
107− isDir <- doesDirectoryExist dotGit
108− isFile <- doesFileExist dotGit
109− if | isDir -> return dotGit
110− | not isFile -> oops
111− | isFile ->
112− splitAt 8 `fmap` readFile dotGit >>= \case
113− ("gitdir: ", relDir) -> do
114− isRelDir <- doesDirectoryExist relDir
115− if isRelDir
116− then return relDir
117− else oops
118− _ -> oops
119−
120−-- | Get the root directory of the Git repo.
121−getGitRoot :: IO FilePath
122−getGitRoot = do
123− pwd <- getCurrentDirectory
124− (code, out, _) <-
125− readProcessWithExitCode "git" ["rev-parse", "--show-toplevel"] ""
126− case code of
127− ExitSuccess -> return $ takeWhile (/= '\n') out
128− ExitFailure _ -> return pwd -- later steps will fail, that's fine
129−
130−-- | Type to flag if the git index is used or not in a call to runGit
131−data IndexUsed = IdxUsed -- ^ The git index is used
132− | IdxNotUsed -- ^ The git index is /not/ used
133− deriving (Eq)
134−
135−-- | Return the hash of the current git commit, or @UNKNOWN@ if not in
136−-- a git repository
137−gitHash :: ExpQ
138−gitHash =
139− stringE =<< runGit ["rev-parse", "HEAD"] "UNKNOWN" IdxNotUsed
140−
141−-- | Return the branch (or tag) name of the current git commit, or @UNKNOWN@
142−-- if not in a git repository. For detached heads, this will just be
143−-- "HEAD"
144−gitBranch :: ExpQ
145−gitBranch =
146− stringE =<< runGit ["rev-parse", "--abbrev-ref", "HEAD"] "UNKNOWN" IdxNotUsed
147−
148−-- | Return the long git description for the current git commit, or
149−-- @UNKNOWN@ if not in a git repository.
150−gitDescribe :: ExpQ
151−gitDescribe =
152− stringE =<< runGit ["describe", "--long", "--always"] "UNKNOWN" IdxNotUsed
153−
154−-- | Return @True@ if there are non-committed files present in the
155−-- repository
156−gitDirty :: ExpQ
157−gitDirty = do
158− output <- runGit ["status", "--porcelain"] "" IdxUsed
159− case output of
160− "" -> conE falseName
161− _ -> conE trueName
162−
163−-- | Return @True@ if there are non-commited changes to tracked files
164−-- present in the repository
165−gitDirtyTracked :: ExpQ
166−gitDirtyTracked = do
167− output <- runGit ["status", "--porcelain","--untracked-files=no"] "" IdxUsed
168− case output of
169− "" -> conE falseName
170− _ -> conE trueName
171−
172−-- | Return the number of commits in the current head
173−gitCommitCount :: ExpQ
174−gitCommitCount =
175− stringE =<< runGit ["rev-list", "HEAD", "--count"] "UNKNOWN" IdxNotUsed
176−
177−-- | Return the commit date of the current head
178−gitCommitDate :: ExpQ
179−gitCommitDate =
180− stringE =<< runGit ["log", "HEAD", "-1", "--format=%cd"] "UNKNOWN" IdxNotUsed