git.iko.soy/typeable/gitrev
on 09f84a2 help sign in
typeable/gitrev/src/Development/GitRev.hs
122 lines 4.6 kB history raw
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)
21-- > , " (", $(gitCommitCount), " commits in HEAD)"
22-- > , dirty, "] ", msg ]
23-- > dirty | $(gitDirty) = " (uncommitted files present)"
24-- > | otherwise = ""
25-- >
26-- > main = panic "oh no!"
27--
28-- > % cabal exec runhaskell Example.hs
29-- > Example.hs: [panic master@2702e69355c978805064543489c351b61ac6760b (6 commits in HEAD) (uncommitted files present)] oh no!
31module Development.GitRev (gitHash, gitBranch, gitDirty, gitCommitCount, gitCommitDate) where
33import Control.Applicative
34import Control.Exception
35import Control.Monad
36import Data.Maybe
37import Language.Haskell.TH
38import Language.Haskell.TH.Syntax
39import System.Directory
40import System.Exit
41import System.FilePath
42import System.Process
44-- | Run git with the given arguments and no stdin, returning the
45-- stdout output. If git isn't available or something goes wrong,
46-- return the second argument.
47runGit :: [String] -> String -> IndexUsed -> Q String
48runGit args def useIdx = do
49 let oops :: SomeException -> IO (ExitCode, String, String)
50 oops _e = return (ExitFailure 1, def, "")
51 gitFound <- runIO $ isJust <$> findExecutable "git"
52 if gitFound
53 then do
54 -- a lot of bookkeeping to record the right dependencies
55 pwd <- runIO getCurrentDirectory
56 let hd = pwd </> ".git" </> "HEAD"
57 index = pwd </> ".git" </> "index"
58 packedRefs = pwd </> ".git" </> "packed-refs"
59 hdExists <- runIO $ doesFileExist hd
60 when hdExists $ do
61 -- the HEAD file either contains the hash of a detached head
62 -- or a pointer to the file that contains the hash of the head
63 hdRef <- runIO $ readFile hd
64 case splitAt 5 hdRef of
65 -- pointer to ref
66 ("ref: ", relRef) -> do
67 let ref = pwd </> ".git" </> relRef
68 refExists <- runIO $ doesFileExist ref
69 when refExists $ addDependentFile ref
70 -- detached head
71 _hash -> addDependentFile hd
72 -- add the index if it exists to set the dirty flag
73 indexExists <- runIO $ doesFileExist index
74 when (indexExists && useIdx == IdxUsed) $ addDependentFile index
75 -- if the refs have been packed, the info we're looking for
76 -- might be in that file rather than the one-file-per-ref case
77 -- handled above
78 packedExists <- runIO $ doesFileExist packedRefs
79 when packedExists $ addDependentFile packedRefs
80 runIO $ do
81 (code, out, _err) <- readProcessWithExitCode "git" args "" `catch` oops
82 case code of
83 ExitSuccess -> return (takeWhile (/= '\n') out)
84 ExitFailure _ -> return def
85 else return def
87-- | Type to flag if the git index is used or not in a call to runGit
88data IndexUsed = IdxUsed -- ^ The git index is used
89 | IdxNotUsed -- ^ The git index is /not/ used
90 deriving (Eq)
92-- | Return the hash of the current git commit, or @UNKNOWN@ if not in
93-- a git repository
94gitHash :: ExpQ
95gitHash =
96 stringE =<< runGit ["rev-parse", "HEAD"] "UNKNOWN" IdxNotUsed
98-- | Return the branch (or tag) name of the current git commit, or @UNKNOWN@
99-- if not in a git repository. For detached heads, this will just be
100-- "HEAD"
101gitBranch :: ExpQ
102gitBranch =
103 stringE =<< runGit ["rev-parse", "--abbrev-ref", "HEAD"] "UNKNOWN" IdxNotUsed
105-- | Return @True@ if there are non-committed files present in the
106-- repository
107gitDirty :: ExpQ
108gitDirty = do
109 output <- runGit ["status", "--porcelain"] "" IdxUsed
110 case output of
111 "" -> conE $ mkName "Prelude.False"
112 _ -> conE $ mkName "Prelude.True"
114-- | Return the number of commits in the current head
115gitCommitCount :: ExpQ
116gitCommitCount =
117 stringE =<< runGit ["rev-list", "HEAD", "--count"] "UNKNOWN" IdxNotUsed
119-- | Return the commit date of the current head
120gitCommitDate :: ExpQ
121gitCommitDate =
122 stringE =<< runGit ["log", "HEAD", "-1", "--format=%cd"] "UNKNOWN"