githash-0.1.3.1/src/0000755000000000000000000000000013414667753012276 5ustar0000000000000000githash-0.1.3.1/test/0000755000000000000000000000000013354125663012456 5ustar0000000000000000githash-0.1.3.1/src/GitHash.hs0000644000000000000000000001704713414667753014172 0ustar0000000000000000{-# 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 ", giBranch gi, "@", giHash gi -- > , " (", giCommitDate gi, ")" -- > , " (", show (giCommitCount gi), " commits in HEAD)" -- > , dirty, "] ", msg ] -- > dirty | giDirty gi = " (uncommitted files present)" -- > | otherwise = "" -- > gi = $$tGitInfoCwd -- > -- > 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! -- -- WARNING: None of this will work in a git repository without any commits. -- -- @since 0.1.0.0 module GitHash ( -- * Types GitInfo , GitHashException (..) -- ** Getters , giHash , giBranch , giDirty , giCommitDate , giCommitCount , giCommitMessage -- * Creators , getGitInfo , getGitRoot -- * Template Haskell , tGitInfo , tGitInfoCwd , tGitInfoTry , tGitInfoCwdTry ) where import Control.Exception import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as B8 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] , _giCommitMessage :: !String } 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 -- | The message of the most recent commit. -- -- @since 0.1.1.0 giCommitMessage :: GitInfo -> String giCommitMessage = _giCommitMessage -- | 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"] _giCommitMessage <- run ["log", "-1", "--pretty=%B"] 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 (normalise . takeWhile (/= '\n')) `fmap` (runGit dir ["rev-parse", "--show-toplevel"]) runGit :: FilePath -> [String] -> IO (Either GitHashException String) runGit root args = do let cp = (proc "git" args) { cwd = Just root } eres <- try $ readCreateProcessWithExitCode cp "" return $ case eres of Left e -> Left $ GHEGitRunException root args e Right (ExitSuccess, out, _) -> Right out Right (ec@ExitFailure{}, out, err) -> 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 | GHEGitRunException !FilePath ![String] !IOException deriving (Show, Eq, Typeable) instance Exception GitHashException -- | Load up the 'GitInfo' value at compile time for the given -- directory. Compilation fails if no info is available. -- -- @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 -- | Try to load up the 'GitInfo' value at compile time for the given -- directory. -- -- @since 0.1.2.0 tGitInfoTry :: FilePath -> Q (TExp (Either String GitInfo)) tGitInfoTry fp = unsafeTExpCoerce $ do egi <- runIO $ do eroot <- getGitRoot fp case eroot of Left e -> return $ Left $ show e Right root -> do einfo <- getGitInfo root case einfo of Left e -> return $ Left $ show e Right info -> return $ Right info case egi of Left _ -> return () Right gi -> mapM_ addDependentFile (_giFiles gi) lift (egi :: Either String 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 "." -- | Try to load up the 'GitInfo' value at compile time for the current -- working directory. -- -- @since 0.1.2.0 tGitInfoCwdTry :: Q (TExp (Either String GitInfo)) tGitInfoCwdTry = tGitInfoTry "." githash-0.1.3.1/test/Spec.hs0000644000000000000000000000005413326544064013702 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} githash-0.1.3.1/test/GitHashSpec.hs0000644000000000000000000000072013354125603015145 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module GitHashSpec ( spec ) where import GitHash import Test.Hspec spec :: Spec spec = do describe "tGitInfoCwd" $ do it "makes vaguely sane git info for this repository" $ do let gi = $$tGitInfoCwd length (giHash gi)`shouldNotBe` 128 giBranch gi `shouldNotBe` [] seq (giDirty gi) () `shouldBe` () giCommitDate gi `shouldNotBe` [] giCommitCount gi `shouldSatisfy` (>= 1) githash-0.1.3.1/test/NormalRepoSpec.hs0000644000000000000000000000351313354125663015705 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} module NormalRepoSpec ( spec ) where import Control.Exception import Control.Monad import qualified Data.ByteString as SB import GitHash import System.Directory import System.FilePath import System.Process import Test.Hspec import UnliftIO.Temporary spec :: Spec spec = around setupGitRepo $ do describe "getGitInfo" $ do it "it makes sensible git info for a regular git repository" $ \fp -> do errOrGi <- getGitInfo fp case errOrGi of Left err -> expectationFailure $ show err Right gi -> do length (giHash gi) `shouldNotBe` 128 giBranch gi `shouldBe` "master" giDirty gi `shouldBe` False giCommitDate gi `shouldNotBe` [] giCommitCount gi `shouldBe` 1 giCommitMessage gi `shouldBe` "Initial commit" describe "getGitRoot" $ do it "it gets the expected git root for a regular git repository" $ \fp -> getGitRoot fp `shouldReturn` Right fp setupGitRepo :: (FilePath -> IO ()) -> IO () setupGitRepo runTest = withSystemTempDirectory "normal" $ \fp -> do createDirectoryIfMissing True fp let runGit args = void $ readCreateProcess ((proc "git" args) {cwd = Just fp}) "" runGit ["init"] SB.writeFile (fp "README.md") "This is a readme, you should read it." runGit ["add", "README.md"] runGit [ "-c" , "user.name='Test User'" , "-c" , "user.email='test@example.com'" , "commit" , "-m" , "Initial commit" ] runTest fp githash-0.1.3.1/test/RepoWithASubmoduleSpec.hs0000644000000000000000000000520213354125663017346 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} module RepoWithASubmoduleSpec ( spec ) where import Control.Exception import Control.Monad import qualified Data.ByteString as SB import GitHash import System.Directory import System.FilePath import System.Process import Test.Hspec import UnliftIO.Temporary spec :: Spec spec = around setupGitRepo $ do describe "getGitInfo" $ do it "it makes sensible git info for a both the parent and the child module" $ \(fp1, fp2) -> do let sensible fp = do errOrGi <- getGitInfo fp case errOrGi of Left err -> expectationFailure $ show err Right gi -> do length (giHash gi) `shouldNotBe` 128 giBranch gi `shouldBe` "master" giDirty gi `shouldBe` False giCommitDate gi `shouldNotBe` [] giCommitCount gi `shouldBe` 1 giCommitMessage gi `shouldBe` "Initial commit" sensible fp1 sensible fp2 describe "getGitRoot" $ do it "it gets the expected git root for a both the parent and the child module" $ \(fp1, fp2) -> do getGitRoot fp1 `shouldReturn` Right fp1 getGitRoot fp2 `shouldReturn` Right fp2 setupGitRepo :: ((FilePath, FilePath) -> IO ()) -> IO () setupGitRepo runTest = withSystemTempDirectory "with-submodule" $ \fp -> do let fp1 = fp "1" fp2 = fp "2" createDirectoryIfMissing True fp1 createDirectoryIfMissing True fp2 let runGitIn d args = void $ readCreateProcess ((proc "git" args) {cwd = Just d}) "" runGit1 = runGitIn fp1 runGit2 = runGitIn fp2 runGit1 ["init"] runGit2 ["init"] SB.writeFile (fp2 "README.md") "This is a readme, you should read it." runGit2 ["add", "README.md"] runGit2 [ "-c" , "user.name='Test User'" , "-c" , "user.email='test@example.com'" , "commit" , "-m" , "Initial commit" ] runGit1 ["submodule", "add", fp2, "2"] runGit1 [ "-c" , "user.name='Test User'" , "-c" , "user.email='test@example.com'" , "commit" , "-m" , "Initial commit" ] runTest (fp1, fp2) githash-0.1.3.1/LICENSE0000644000000000000000000000273713326544064012514 0ustar0000000000000000Copyright (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. githash-0.1.3.1/Setup.hs0000644000000000000000000000005613326544064013133 0ustar0000000000000000import Distribution.Simple main = defaultMain githash-0.1.3.1/githash.cabal0000644000000000000000000000301513414671101014077 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.31.1. -- -- see: https://github.com/sol/hpack -- -- hash: e259226f20bb47090315089e5ac66234ed83b30d011b5f6dc29b4f74f8134b58 name: githash version: 0.1.3.1 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 extra-source-files: README.md ChangeLog.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 NormalRepoSpec RepoWithASubmoduleSpec Paths_githash hs-source-dirs: test build-depends: base >=4.9.1 && <5 , bytestring , directory , filepath , githash , hspec , process , template-haskell , temporary , unliftio default-language: Haskell2010 githash-0.1.3.1/README.md0000644000000000000000000000202013326544064012747 0ustar0000000000000000# 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! githash-0.1.3.1/ChangeLog.md0000644000000000000000000000075513414667753013667 0ustar0000000000000000# ChangeLog for githash ## 0.1.3.1 * Clean up some warnings (addresses [fpco/optparse-simple#11](https://github.com/fpco/optparse-simple/issues/11)) ## 0.1.3.0 * Catch exceptions thrown by `readCreateProcessWithExitCode` to deal with missing `git` executable [#7](https://github.com/snoyberg/githash/issues/7) ## 0.1.2.0 * Add `tGitInfoTry` and `tGitInfoCwdTry` ## 0.1.1.0 * Add message of the most recent commit ## 0.1.0.1 * Update the test suite ## 0.1.0.0 * Initial release