diff --git a/core-program.cabal b/core-program.cabal --- a/core-program.cabal +++ b/core-program.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: core-program -version: 0.6.6.0 +version: 0.6.7.1 synopsis: Opinionated Haskell Interoperability description: A library to help build command-line programs, both tools and longer-running daemons. @@ -63,6 +63,7 @@ , exceptions , filepath , fsnotify + , githash , hashable >=1.2 , hourglass , mtl diff --git a/lib/Core/Program/Arguments.hs b/lib/Core/Program/Arguments.hs --- a/lib/Core/Program/Arguments.hs +++ b/lib/Core/Program/Arguments.hs @@ -1003,7 +1003,13 @@ buildVersion :: Version -> Doc ann buildVersion version = - pretty (projectNameFrom version) - <+> "v" - <> pretty (versionNumberFrom version) - <> hardline + let + project = projectNameFrom version + number = versionNumberFrom version + description = gitDescriptionFrom version + in + pretty project + <+> pretty number + <> if null description + then hardline + else "," <+> pretty description <> hardline diff --git a/lib/Core/Program/Metadata.hs b/lib/Core/Program/Metadata.hs --- a/lib/Core/Program/Metadata.hs +++ b/lib/Core/Program/Metadata.hs @@ -1,4 +1,6 @@ {-# LANGUAGE DeriveLift #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} @@ -13,6 +15,9 @@ , versionNumberFrom , projectNameFrom , projectSynopsisFrom + , gitHashFrom + , gitDescriptionFrom + , gitBranchFrom -- * Splice , fromPackage @@ -21,14 +26,14 @@ , __LOCATION__ ) where -import Core.Data +import Core.Data.Structures import Core.System.Base (IOMode (..), withFile) import Core.System.Pretty import Core.Text -import qualified Data.List as List (find, isSuffixOf) -import Data.Maybe (fromMaybe) +import Data.List qualified as List (find, isSuffixOf) import Data.String import GHC.Stack (HasCallStack, SrcLoc (..), callStack, getCallStack) +import GitHash import Language.Haskell.TH (Q, runIO) import Language.Haskell.TH.Syntax (Exp (..), Lift) import System.Directory (listDirectory) @@ -54,16 +59,29 @@ For more complex usage you can populate a 'Version' object using the 'fromPackage' splice below. You can then call various accessors like 'versionNumberFrom' to access individual fields. + +@since 0.6.7 -} data Version = Version { projectNameFrom :: String , projectSynopsisFrom :: String , versionNumberFrom :: String + , gitHashFrom :: String + , gitDescriptionFrom :: String + , gitBranchFrom :: String } deriving (Show, Lift) emptyVersion :: Version -emptyVersion = Version "" "" "0" +emptyVersion = + Version + { projectNameFrom = "" + , projectSynopsisFrom = "" + , versionNumberFrom = "0" + , gitHashFrom = "" + , gitDescriptionFrom = "" + , gitBranchFrom = "" + } instance IsString Version where fromString x = emptyVersion {versionNumberFrom = x} @@ -88,30 +106,85 @@ @ \{\-\# LANGUAGE TemplateHaskell \#\-\} -version :: 'Version' version = $('fromPackage') +version :: 'Version' +version = $('fromPackage') main :: 'IO' () main = do context <- 'Core.Program.Execute.configure' version 'Core.Program.Execute.None' ('Core.Program.Arguments.simpleConfig' ... + 'Core.Program.Execute.executeWith' context program + +program :: 'Core.Program.Execute.Program' 'Core.Program.Execute.None' () +program = do + ... @ -(Using Template Haskell slows down compilation of this file, but the upside of -this technique is that it avoids linking the Haskell build machinery into your -executable, saving you about 10 MB in the size of the resultant binary) +In addition to metadata from the Haskell package, we also extract information +from the Git repository the code was built within, if applicable. When the +program is built within a source code checkout (as is typical in continuous +integration & continuous deployment systems) then the repository is queried +for the SHA1 hash, branch name, and for whether the checkout is clean. + +The resultant @--version@ output might look like the following: + +@ +\$ __ping --version__ +ip-utils v2.0.1.9, f18ec7b +@ + +If, on the other hand, you had been developing locally you'll see this: + +@ +\$ __ping --version__ +ip-utils v2.0.1.9, f18ec7b (dirty) +@ + +signifying that there are uncommitted files in your local tree. + +If you are building the program from a relese tarball, this mechanism will +omit reporting any information about the state of a Git repository as it is +not to hand. + +@since 0.6.7 -} fromPackage :: Q Exp fromPackage = do pairs <- readCabalFile - let name = fromMaybe "" . lookupKeyValue "name" $ pairs - let synopsis = fromMaybe "" . lookupKeyValue "synopsis" $ pairs - let version = fromMaybe "" . lookupKeyValue "version" $ pairs + let name = case lookupKeyValue "name" pairs of + Nothing -> "" + Just value -> value + let synopsis = case lookupKeyValue "synopsis" pairs of + Nothing -> "" + Just value -> value + let version = case lookupKeyValue "version" pairs of + Nothing -> "" + Just value -> "v" <> value + possibleInfo <- readGitRepository + + let full = case possibleInfo of + Nothing -> "" + Just info -> giHash info + let short = case possibleInfo of + Nothing -> "" + Just info -> + let short' = take 7 (giHash info) + in if giDirty info + then short' ++ " (dirty)" + else short' + let branch = case possibleInfo of + Nothing -> "" + Just info -> giBranch info + let result = Version { projectNameFrom = fromRope name , projectSynopsisFrom = fromRope synopsis , versionNumberFrom = fromRope version + , gitHashFrom = full + , gitDescriptionFrom = short + , gitBranchFrom = branch } -- I would have preferred @@ -191,6 +264,8 @@ This isn't the full stack trace, just information about the current line. If you want more comprehensive stack trace you need to add 'HasCallStack' constraints everywhere, and then... + +@since 0.4.3 -} -- This works because the call stack has the most recent frame at the head of @@ -225,3 +300,31 @@ pretty (srcLocFile loc) <> ":" <> pretty (show (srcLocStartLine loc)) + +{- | +Information about the revision from which this piece of software was built. +The most useful field here is the \"short\", human-readable for via +'gitShortFrom', which can be used augment telemetry, for example. + +@since 0.6.7 +-} + +{- | +This is a splice which extracts a 'Commit' object based on the repository in +which the build was run. Like the 'fromPackage' splice, this also uses the +evil @TemplateHaskell@ extension. + +Note that if the application was compiled was done using a release tarball and +not built from source the values returned will be empty placeholders. + +@since 0.6.7 +-} +readGitRepository :: Q (Maybe GitInfo) +readGitRepository = do + runIO $ do + getGitRoot "." >>= \case + Left _ -> pure Nothing + Right path -> do + getGitInfo path >>= \case + Left _ -> pure Nothing + Right value -> pure (Just value)