githash-0.1.4.0/src/0000755000000000000000000000000013641264660012266 5ustar0000000000000000githash-0.1.4.0/test/0000755000000000000000000000000013641264660012456 5ustar0000000000000000githash-0.1.4.0/src/GitHash.hs0000644000000000000000000002161413641264660014155 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 , giDescribe -- * 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 , _giDescribe :: !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 -- | The output of @git describe --always@ for the most recent commit. -- -- @since 0.1.4.0 giDescribe :: GitInfo -> String giDescribe = _giDescribe -- | Get a list of files from within a @.git@ directory. getGitFilesRegular :: FilePath -> IO [FilePath] getGitFilesRegular git = do -- a lot of bookkeeping to record the right dependencies let hd = git "HEAD" index = git "index" packedRefs = 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 = 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 [] return $ concat [files1, files2, files3] -- | Get a list of dependent files from a @.git@ file representing a -- git-worktree. getGitFilesForWorktree :: FilePath -> IO [FilePath] getGitFilesForWorktree git = do gitPath <- try $ B.readFile git case gitPath of Left e | otherwise -> throwIO $ GHECouldn'tReadFile git e Right rootPath -> -- the .git file contains the absolute path to the git -- directory's root. case B.splitAt 8 rootPath of -- path to root ("gitdir: ", gitdir) -> do let path = takeWhile (/= '\n') (B8.unpack gitdir) -- The .git file points to a .git directory which we can just -- treat like a non git-worktree one. getGitFilesRegular path _ -> throwIO $ GHEInvalidGitFile (B8.unpack rootPath) -- | Get a list of dependent git related files. getGitFiles :: FilePath -> IO [FilePath] getGitFiles git = do isDir <- doesDirectoryExist git if isDir then getGitFilesRegular git else getGitFilesForWorktree git -- | 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 let run args = do eres <- runGit root args case eres of Left e -> throwIO e Right str -> return $ takeWhile (/= '\n') str _giFiles <- getGitFiles (root ".git") _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"] _giDescribe <- run ["describe", "--always"] 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 | GHEInvalidGitFile !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.4.0/test/Spec.hs0000644000000000000000000000005413641262336013701 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} githash-0.1.4.0/test/GitHashSpec.hs0000644000000000000000000000144113641264660015154 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} module GitHashSpec ( spec ) where import GitHash import System.Directory (doesDirectoryExist) import Test.Hspec spec :: Spec spec = do describe "tGitInfoCwd" $ do it "makes vaguely sane git info for this repository" $ do let egi = $$tGitInfoCwdTry gitDirExists <- doesDirectoryExist ".git" case egi of Left _ -> gitDirExists `shouldBe` False Right gi -> do -- Doesn't work with cabal gitDirExists `shouldBe` True length (giHash gi)`shouldNotBe` 128 giBranch gi `shouldNotBe` [] seq (giDirty gi) () `shouldBe` () giCommitDate gi `shouldNotBe` [] giCommitCount gi `shouldSatisfy` (>= 1) giDescribe gi `shouldStartWith` "githash-" githash-0.1.4.0/test/NormalRepoSpec.hs0000644000000000000000000000355613641264660015714 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} module NormalRepoSpec ( spec ) where 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" length (giDescribe gi) `shouldBe` 7 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.4.0/test/RepoWithASubmoduleSpec.hs0000644000000000000000000000525513641264660017356 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} module RepoWithASubmoduleSpec ( spec ) where 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" length (giDescribe gi) `shouldBe` 7 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.4.0/test/WorktreeRepoSpec.hs0000644000000000000000000000427013641264660016260 0ustar0000000000000000{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} module WorktreeRepoSpec ( spec ) where 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 git-worktree 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` "worktree-branch" giDirty gi `shouldBe` True giCommitDate gi `shouldNotBe` [] giCommitCount gi `shouldBe` 1 giCommitMessage gi `shouldBe` "Initial commit" length (giDescribe gi) `shouldBe` 7 describe "getGitRoot" $ do it "it gets the expected git root for a git-worktree repository" $ \fp -> getGitRoot fp `shouldReturn` Right fp setupGitRepo :: (FilePath -> IO ()) -> IO () setupGitRepo runTest = withSystemTempDirectory "normal" $ \fp -> do let fp1 = fp "1" fp2 = fp "2" createDirectoryIfMissing True fp1 createDirectoryIfMissing True fp2 let runGit args = void $ readCreateProcess ((proc "git" args) {cwd = Just fp1}) "" runGit ["init"] SB.writeFile (fp1 "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" ] runGit ["branch", "worktree-branch"] runGit ["worktree", "add", fp2, "worktree-branch"] SB.writeFile (fp2 "README.md") "This is a readme that has been modified." runTest fp2 githash-0.1.4.0/LICENSE0000644000000000000000000000273713641262336012513 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 githash 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.4.0/Setup.hs0000644000000000000000000000005613641262336013132 0ustar0000000000000000import Distribution.Simple main = defaultMain githash-0.1.4.0/githash.cabal0000644000000000000000000000304413641265332014110 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.33.0. -- -- see: https://github.com/sol/hpack -- -- hash: d5c62b9ed845682638a72f717272a1a46871ad89fc816b8f602622a6a2e17941 name: githash version: 0.1.4.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 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 WorktreeRepoSpec 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.4.0/README.md0000644000000000000000000000167513641264753012772 0ustar0000000000000000# githash [![Build Status](https://dev.azure.com/snoyberg/githash/_apis/build/status/snoyberg.githash?branchName=master)](https://dev.azure.com/snoyberg/githash/_build/latest?definitionId=11&branchName=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.4.0/ChangeLog.md0000644000000000000000000000133413641264660013651 0ustar0000000000000000# ChangeLog for githash ## 0.1.4.0 * Add git-describe output ## 0.1.3.3 * Add git-worktree support [#13](https://github.com/snoyberg/githash/issues/13) ## 0.1.3.2 * Test suite works outside of a Git repo [#12](https://github.com/snoyberg/githash/issues/12) ## 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