githash-0.1.7.0/src/0000755000000000000000000000000014444502175012267 5ustar0000000000000000githash-0.1.7.0/test/0000755000000000000000000000000014444502175012457 5ustar0000000000000000githash-0.1.7.0/src/GitHash.hs0000644000000000000000000002527714444502175014167 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 , giTag , giFiles -- * 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 Data.Word (Word8) import Language.Haskell.TH import Language.Haskell.TH.Syntax import Language.Haskell.TH.Syntax.Compat 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 , _giTag :: !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 -- | The output of @git describe --always --tags@ for the most recent commit. -- -- @since 0.1.5.0 giTag :: GitInfo -> String giTag = _giTag -- | The files used to determine whether recompilation is necessary in splices. -- -- @since 0.1.7.0 giFiles :: GitInfo -> [FilePath] giFiles = _giFiles -- | Get a list of files from within a @.git@ directory. getGitFilesRegular :: FilePath -> IO [FilePath] -- [Note: Current implementation's limitation] -- the current implementation doesn't work right if: -- 1. the current branch's name contains Non-ASCII character (due to @B8.unpack@), -- 2. the current branch is only in .git/packed-refs, or -- 3. the current branch is a symbolic ref to another reference. -- In these cases, the file with the name `ref` in the following -- code cannot be found in the filesystem (in the cases 1 & 2), -- or can be found but will not be updated on commit (in the case 3). -- As a result, if a module uses @tGitInfo@ as TH macro -- and the target git repo is in one of the conditions 1--3 -- at the time of compilation, content-change-free commits will fail to -- trigger recompilation. -- -- [Note: reftable] -- In the near future, the technology called reftable may replace the -- Git's reference management. This function's implementation does not -- work with reftable, and therefore will need to be updated. 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 $ B.takeWhile (not . isSmallASCIIControl) hdRef of -- pointer to ref ("ref: ", relRef) -> do let ref = git B8.unpack relRef refExists <- doesFileExist ref return $ if refExists then [hd,ref] else [hd] -- 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] where -- This is to quickly strip newline characters -- from the content of .git/HEAD. -- Git references don't include ASCII control char bytes: -- 0x00 -- 0x1F and 0x7F. -- .git/HEAD may contain some ASCII control bytes LF (0xA) and -- CR (0xD) before EOF, which should be ignored. isSmallASCIIControl :: Word8 -> Bool isSmallASCIIControl = (<0x20) -- | 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", "--long"] _giTag <- run ["describe", "--always", "--tags"] 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 -> SpliceQ GitInfo tGitInfo fp = unsafeSpliceCoerce $ 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 -> SpliceQ (Either String GitInfo) tGitInfoTry fp = unsafeSpliceCoerce $ 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 :: SpliceQ GitInfo tGitInfoCwd = tGitInfo "." -- | Try to load up the 'GitInfo' value at compile time for the current -- working directory. -- -- @since 0.1.2.0 tGitInfoCwdTry :: SpliceQ (Either String GitInfo) tGitInfoCwdTry = tGitInfoTry "." githash-0.1.7.0/test/Spec.hs0000644000000000000000000000005414444502175013704 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} githash-0.1.7.0/test/GitHashSpec.hs0000644000000000000000000000144114444502175015155 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.7.0/test/NormalRepoSpec.hs0000644000000000000000000000372614444502175015714 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` initialBranchName 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", "--initial-branch", initialBranchName] 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 initialBranchName :: String initialBranchName = "main" githash-0.1.7.0/test/RepoWithASubmoduleSpec.hs0000644000000000000000000000554014444502175017354 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` initialBranchName 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", "--initial-branch", initialBranchName] runGit2 ["init", "--initial-branch", initialBranchName] 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 ["-c", "protocol.file.allow=always", "submodule", "add", fp2, "2"] runGit1 [ "-c" , "user.name='Test User'" , "-c" , "user.email='test@example.com'" , "commit" , "-m" , "Initial commit" ] runTest (fp1, fp2) initialBranchName :: String initialBranchName = "main" githash-0.1.7.0/test/WorktreeRepoSpec.hs0000644000000000000000000000427014444502175016261 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.7.0/README.md0000644000000000000000000000167514444502175012770 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.7.0/ChangeLog.md0000644000000000000000000000275614444502175013663 0ustar0000000000000000# ChangeLog for githash ## 0.1.7.0 * Expose giFiles to users. ## 0.1.6.3 * Specify protocol.file.allow=always for latest git [#28](https://github.com/snoyberg/githash/pull/28) ## 0.1.6.2 * Fixed bugs; now this library's Template Haskell functions are much more likely on recompilation to detect Git update that doesn't affect workspace: e.g. `git switch -c ` (equivalently `git checkout -b `) and `git commit --amend --only`. Implemented in [#23](https://github.com/snoyberg/githash/pull/23). ## 0.1.6.1 * [Support template-haskell 2.17](https://github.com/snoyberg/githash/pull/22) ## 0.1.6.0 * Always include patchlevel and hash in git-describe output * Don't let user's configured initial branch name break tests ## 0.1.5.0 * Add git tag output via git-describe ## 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 githash-0.1.7.0/LICENSE0000644000000000000000000000273714444502175012516 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.7.0/Setup.hs0000644000000000000000000000005614444502175013135 0ustar0000000000000000import Distribution.Simple main = defaultMain githash-0.1.7.0/githash.cabal0000644000000000000000000000276714444502201014115 0ustar0000000000000000cabal-version: 1.12 -- This file has been generated from package.yaml by hpack version 0.35.1. -- -- see: https://github.com/sol/hpack name: githash version: 0.1.7.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 , th-compat 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 , th-compat , unliftio default-language: Haskell2010