diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2015, Adam C. Foltzer +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +* Neither the name of gitrev nor the names of its + contributors may be used to endorse or promote products derived from + this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" +AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER +CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, +OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/gitrev.cabal b/gitrev.cabal new file mode 100644 --- /dev/null +++ b/gitrev.cabal @@ -0,0 +1,26 @@ +name: gitrev +version: 1.0.0 +synopsis: Compile git revision info into Haskell projects +homepage: https://github.com/acfoltzer/gitrev +license: BSD3 +license-file: LICENSE +author: Adam C. Foltzer +maintainer: acfoltzer@galois.com +category: Development +build-type: Simple +cabal-version: >=1.10 +description: 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. + +source-repository head + type: git + location: https://github.com/acfoltzer/gitrev.git + +library + build-depends: base >= 4.7 && < 5, + directory, + filepath, + template-haskell, + process + hs-source-dirs: src + default-language: Haskell2010 + exposed-modules: Development.GitRev diff --git a/src/Development/GitRev.hs b/src/Development/GitRev.hs new file mode 100644 --- /dev/null +++ b/src/Development/GitRev.hs @@ -0,0 +1,105 @@ +-- | +-- 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), dirty, "] ", msg ] +-- > dirty | $(gitDirty) = " (uncommitted files present)" +-- > | otherwise = "" +-- > +-- > main = panic "oh no!" +-- +-- > % cabal exec runhaskell Example.hs +-- > Example.hs: [panic master@4a0a592c37ad908889bd2a7a411923a903ed05a3 (uncommitted files present)] oh no! + +module Development.GitRev (gitHash, gitBranch, gitDirty) where + +import Control.Applicative +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 + +-- | 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 -> Q String +runGit args def = do + let oops :: SomeException -> IO (ExitCode, String, String) + oops _e = return (ExitFailure 1, def, "") + gitFound <- runIO $ isJust <$> findExecutable "git" + if gitFound + then do + -- a lot of bookkeeping to record the right dependencies + pwd <- runIO getCurrentDirectory + let hd = pwd ".git" "HEAD" + index = pwd ".git" "index" + packedRefs = pwd ".git" "packed-refs" + hdExists <- runIO $ doesFileExist hd + when hdExists $ 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 + hdRef <- runIO $ readFile hd + case splitAt 5 hdRef of + -- pointer to ref + ("ref: ", relRef) -> do + let ref = pwd ".git" relRef + refExists <- runIO $ doesFileExist ref + when refExists $ addDependentFile ref + -- detached head + _hash -> addDependentFile hd + -- add the index if it exists to set the dirty flag + indexExists <- runIO $ doesFileExist index + when indexExists $ addDependentFile 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 + packedExists <- runIO $ doesFileExist packedRefs + when packedExists $ addDependentFile packedRefs + runIO $ do + (code, out, _err) <- readProcessWithExitCode "git" args "" `catch` oops + case code of + ExitSuccess -> return (takeWhile (/= '\n') out) + ExitFailure _ -> return def + else return def + +-- | Return the hash of the current git commit, or @UNKNOWN@ if not in +-- a git repository +gitHash :: ExpQ +gitHash = + stringE =<< runGit ["rev-parse", "HEAD"] "UNKNOWN" + +-- | 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 = + stringE =<< runGit ["rev-parse", "--abbrev-ref", "HEAD"] "UNKNOWN" + +-- | Return @True@ if there are non-committed files present in the +-- repository +gitDirty :: ExpQ +gitDirty = do + output <- runGit ["status", "--porcelain"] "" + case output of + "" -> conE $ mkName "Prelude.False" + _ -> conE $ mkName "Prelude.True"