@@ -0,0 +1,180 @@
1+{-# LANGUAGE LambdaCase #-}
2+{-# LANGUAGE MultiWayIf #-}
6+-- Copyright : (c) 2015 Adam C. Foltzer
8+-- Maintainer : acfoltzer@galois.com
9+-- Stability : provisional
10+-- Portability : portable
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.
17+-- > {-# LANGUAGE TemplateHaskell #-}
18+-- > import Development.GitRev
20+-- > panic :: String -> a
21+-- > panic msg = error panicMsg
23+-- > concat [ "[panic ", $(gitBranch), "@", $(gitHash)
24+-- > , " (", $(gitCommitDate), ")"
25+-- > , " (", $(gitCommitCount), " commits in HEAD)"
26+-- > , dirty, "] ", msg ]
27+-- > dirty | $(gitDirty) = " (uncommitted files present)"
30+-- > main = panic "oh no!"
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!
35+module Development.GitRev
45+import Control.Exception
48+import Language.Haskell.TH
49+import Language.Haskell.TH.Syntax
50+import System.Directory
52+import System.FilePath
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"
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
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
79+ ("ref: ", relRef) -> do
80+ let ref = pwd </> ".git" </> relRef
81+ refExists <- runIO $ doesFileExist ref
82+ when refExists $ addDependentFile ref
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
91+ packedExists <- runIO $ doesFileExist packedRefs
92+ when packedExists $ addDependentFile packedRefs
94+ (code, out, _err) <- readProcessWithExitCode "git" args "" `catch` oops
96+ ExitSuccess -> return (takeWhile (/= '\n') out)
97+ ExitFailure _ -> return def
100+-- | Determine where our @.git@ directory is, in case we're in a
102+getDotGit :: IO FilePath
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
112+ splitAt 8 `fmap` readFile dotGit >>= \case
113+ ("gitdir: ", relDir) -> do
114+ isRelDir <- doesDirectoryExist relDir
120+-- | Get the root directory of the Git repo.
121+getGitRoot :: IO FilePath
123+ pwd <- getCurrentDirectory
125+ readProcessWithExitCode "git" ["rev-parse", "--show-toplevel"] ""
127+ ExitSuccess -> return $ takeWhile (/= '\n') out
128+ ExitFailure _ -> return pwd -- later steps will fail, that's fine
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
135+-- | Return the hash of the current git commit, or @UNKNOWN@ if not in
139+ stringE =<< runGit ["rev-parse", "HEAD"] "UNKNOWN" IdxNotUsed
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
146+ stringE =<< runGit ["rev-parse", "--abbrev-ref", "HEAD"] "UNKNOWN" IdxNotUsed
148+-- | Return the long git description for the current git commit, or
149+-- @UNKNOWN@ if not in a git repository.
152+ stringE =<< runGit ["describe", "--long", "--always"] "UNKNOWN" IdxNotUsed
154+-- | Return @True@ if there are non-committed files present in the
158+ output <- runGit ["status", "--porcelain"] "" IdxUsed
160+ "" -> conE falseName
163+-- | Return @True@ if there are non-commited changes to tracked files
164+-- present in the repository
165+gitDirtyTracked :: ExpQ
167+ output <- runGit ["status", "--porcelain","--untracked-files=no"] "" IdxUsed
169+ "" -> conE falseName
172+-- | Return the number of commits in the current head
173+gitCommitCount :: ExpQ
175+ stringE =<< runGit ["rev-list", "HEAD", "--count"] "UNKNOWN" IdxNotUsed
177+-- | Return the commit date of the current head
178+gitCommitDate :: ExpQ
180+ stringE =<< runGit ["log", "HEAD", "-1", "--format=%cd"] "UNKNOWN" IdxNotUsed