diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# ChangeLog for githash + +## 0.1.0.0 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) 2018, Michael Snoyman, 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/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,22 @@ +# githash + +[![Build Status](https://travis-ci.org/snoyberg/githash.svg?branch=master)](https://travis-ci.org/snoyberg/githash) +[![Build status](https://ci.appveyor.com/api/projects/status/g5asio63nfjjhx50/branch/master?svg=true)](https://ci.appveyor.com/project/snoyberg/githash/branch/master) + +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. + +Most of the complication in the `GitHash` module is due to the various +places the current git hash might be stored: + +1. Detached HEAD: the hash is in `.git/HEAD` +2. On a branch or tag: the hash is in a file pointed to by `.git/HEAD` +in a location like `.git/refs/heads` +3. On a branch or tag but in a repository with packed refs: the hash is +in `.git/packed-refs` + +These situations all arise under normal development workflows, but +there might be further scenarios that cause problems. Let me know if +you run into them! 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/githash.cabal b/githash.cabal new file mode 100644 --- /dev/null +++ b/githash.cabal @@ -0,0 +1,62 @@ +-- This file has been generated from package.yaml by hpack version 0.28.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 391f23a7714fa5cdd1e4919cca1972387f65d007ebba0047608a34231d283619 + +name: githash +version: 0.1.0.0 +synopsis: Compile git revision info into Haskell projects +description: Please see the README and documentation at +category: Development +homepage: https://github.com/snoyberg/githash#readme +bug-reports: https://github.com/snoyberg/githash/issues +author: Michael Snoyman, Adam C. Foltzer +maintainer: michael@snoyman.com +license: BSD3 +license-file: LICENSE +build-type: Simple +cabal-version: >= 1.10 +extra-source-files: + ChangeLog.md + README.md + +source-repository head + type: git + location: https://github.com/snoyberg/githash + +library + exposed-modules: + GitHash + other-modules: + Paths_githash + hs-source-dirs: + src + build-depends: + base >=4.9.1 && <5 + , bytestring + , directory + , filepath + , process + , template-haskell + default-language: Haskell2010 + +test-suite githash-spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + GitHashSpec + Paths_githash + hs-source-dirs: + test + build-depends: + base >=4.9.1 && <5 + , bytestring + , directory + , filepath + , githash + , hspec + , process + , template-haskell + , temporary + default-language: Haskell2010 diff --git a/src/GitHash.hs b/src/GitHash.hs new file mode 100644 --- /dev/null +++ b/src/GitHash.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : $Header$ +-- Copyright : (c) 2018 Michael Snoyman, 2015 Adam C. Foltzer +-- License : BSD3 +-- Maintainer : michael@snoyman.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 GitHash +-- > +-- > panic :: String -> a +-- > panic msg = error panicMsg +-- > where panicMsg = +-- > concat [ "[panic ", $(gitBranch), "@", $(gitHash) +-- > , " (", $(gitCommitDate), ")" +-- > , " (", $(gitCommitCount), " commits in HEAD)" +-- > , dirty, "] ", msg ] +-- > dirty | $(gitDirty) = " (uncommitted files present)" +-- > | otherwise = "" +-- > +-- > main = panic "oh no!" +-- +-- > % stack runghc Example.hs +-- > Example.hs: [panic master@2ae047ba5e4a6f0f3e705a43615363ac006099c1 (Mon Jan 11 11:50:59 2016 -0800) (14 commits in HEAD) (uncommitted files present)] oh no! +-- +-- @since 0.1.0.0 +module GitHash + ( -- * Types + GitInfo + , GitHashException (..) + -- ** Getters + , giHash + , giBranch + , giDirty + , giCommitDate + , giCommitCount + -- * Creators + , getGitInfo + , getGitRoot + -- * Template Haskell + , tGitInfo + , tGitInfoCwd + ) where + +import Control.Applicative +import Control.Exception +import Control.Monad +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as B8 +import Data.Maybe +import Data.Typeable (Typeable) +import Language.Haskell.TH +import Language.Haskell.TH.Syntax +import System.Directory +import System.Exit +import System.FilePath +import System.IO.Error (isDoesNotExistError) +import System.Process +import Text.Read (readMaybe) + +-- | Various pieces of information about a Git repository. +-- +-- @since 0.1.0.0 +data GitInfo = GitInfo + { _giHash :: !String + , _giBranch :: !String + , _giDirty :: !Bool + , _giCommitDate :: !String + , _giCommitCount :: !Int + , _giFiles :: ![FilePath] + } + deriving (Lift, Show) + +-- | The hash of the most recent commit. +-- +-- @since 0.1.0.0 +giHash :: GitInfo -> String +giHash = _giHash + +-- | The hash of the most recent commit. +-- +-- @since 0.1.0.0 +giBranch :: GitInfo -> String +giBranch = _giBranch + +giDirty :: GitInfo -> Bool +giDirty = _giDirty + +giCommitDate :: GitInfo -> String +giCommitDate = _giCommitDate + +giCommitCount :: GitInfo -> Int +giCommitCount = _giCommitCount + +-- | Get the 'GitInfo' for the given root directory. Root directory +-- should be the directory containing the @.git@ directory. +-- +-- @since 0.1.0.0 +getGitInfo :: FilePath -> IO (Either GitHashException GitInfo) +getGitInfo root = try $ do + -- a lot of bookkeeping to record the right dependencies + let hd = root ".git" "HEAD" + index = root ".git" "index" + packedRefs = root ".git" "packed-refs" + ehdRef <- try $ B.readFile hd + files1 <- + case ehdRef of + Left e + | isDoesNotExistError e -> return [] + | otherwise -> throwIO $ GHECouldn'tReadFile hd e + Right hdRef -> 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 + case B.splitAt 5 hdRef of + -- pointer to ref + ("ref: ", relRef) -> do + let ref = root ".git" B8.unpack relRef + refExists <- doesFileExist ref + return $ if refExists then [ref] else [] + -- detached head + _hash -> return [hd] + -- add the index if it exists to set the dirty flag + indexExists <- doesFileExist index + let files2 = if indexExists then [index] else [] + -- 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 <- doesFileExist packedRefs + let files3 = if packedExists then [packedRefs] else [] + + _giFiles = concat [files1, files2, files3] + run args = do + eres <- runGit root args + case eres of + Left e -> throwIO e + Right str -> return $ takeWhile (/= '\n') str + + _giHash <- run ["rev-parse", "HEAD"] + _giBranch <- run ["rev-parse", "--abbrev-ref", "HEAD"] + + dirtyString <- run ["status", "--porcelain"] + let _giDirty = not $ null (dirtyString :: String) + + commitCount <- run ["rev-list", "HEAD", "--count"] + _giCommitCount <- + case readMaybe commitCount of + Nothing -> throwIO $ GHEInvalidCommitCount root commitCount + Just x -> return x + + _giCommitDate <- run ["log", "HEAD", "-1", "--format=%cd"] + + return GitInfo {..} + +-- | Get the root directory of the Git repo containing the given file +-- path. +-- +-- @since 0.1.0.0 +getGitRoot :: FilePath -> IO (Either GitHashException FilePath) +getGitRoot dir = fmap (takeWhile (/= '\n')) `fmap` (runGit dir ["rev-parse", "--show-toplevel"]) + +runGit root args = do + let cp = (proc "git" args) { cwd = Just root } + (ec, out, err) <- readCreateProcessWithExitCode cp "" + case ec of + ExitSuccess -> return $ Right out + ExitFailure _ -> return $ Left $ GHEGitRunFailed root args ec out err + +-- | Exceptions which can occur when using this library's functions. +-- +-- @since 0.1.0.0 +data GitHashException + = GHECouldn'tReadFile !FilePath !IOException + | GHEInvalidCommitCount !FilePath !String + | GHEGitRunFailed !FilePath ![String] !ExitCode !String !String + deriving (Show, Typeable) +instance Exception GitHashException + +-- | Load up the 'GitInfo' value at compile time for the given +-- directory. +-- +-- @since 0.1.0.0 +tGitInfo :: FilePath -> Q (TExp GitInfo) +tGitInfo fp = unsafeTExpCoerce $ do + gi <- runIO $ + getGitRoot fp >>= + either throwIO return >>= + getGitInfo >>= + either throwIO return + mapM_ addDependentFile (_giFiles gi) + lift (gi :: GitInfo) -- adding type sig to make the unsafe look slightly better + +-- | Load up the 'GitInfo' value at compile time for the current +-- working directory. +-- +-- @since 0.1.0.0 +tGitInfoCwd :: Q (TExp GitInfo) +tGitInfoCwd = tGitInfo "." diff --git a/test/GitHashSpec.hs b/test/GitHashSpec.hs new file mode 100644 --- /dev/null +++ b/test/GitHashSpec.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE TemplateHaskell #-} +module GitHashSpec + ( spec + ) where + +import GitHash +import Test.Hspec + +spec :: Spec +spec = do + it "sanity" $ do + let gi = $$tGitInfoCwd + giCommitCount gi `shouldSatisfy` (>= 1) diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}