githash (empty) → 0.1.0.0

raw patch · 8 files changed

+339/−0 lines, 8 filesdep +basedep +bytestringdep +directorysetup-changed

Dependencies added: base, bytestring, directory, filepath, githash, hspec, process, template-haskell, temporary

Files

• ChangeLog.md +5/−0
• LICENSE +28/−0
• README.md +22/−0
• Setup.hs +2/−0
• githash.cabal +62/−0
• src/GitHash.hs +206/−0
• test/GitHashSpec.hs +13/−0
• test/Spec.hs +1/−0

@@ -0,0 +1,5 @@+# ChangeLog for githash++## 0.1.0.0++* Initial release

@@ -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.+

@@ -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!

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -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 <https://www.stackage.org/package/githash>+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

@@ -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 "."

@@ -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)

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}