-- ------------------------------------------------------ --
-- Copyright © 2019 Colin Woodbury <colin@fosskers.ca>
-- Copyright © 2015-2020 Lars Kuhtz <lakuhtz@gmail.com>
-- Copyright © 2014 AlephCloud Systems, Inc.
-- ------------------------------------------------------ --
{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# OPTIONS_HADDOCK show-extensions #-}
-- | This module contains a @Setup.hs@ script that hooks into the cabal build
-- process at the end of the configuration phase and generates a module with
-- package information for each component of the cabal package.
--
-- The modules are created in the /autogen/ build directories where also the
-- @Path_@ modules are created by cabal's simple build setup.
--
-- = Usage as Setup Script
--
-- There are three ways how this module can be used:
--
-- 1. Copy the code of this module into a file called @Setup.hs@ in the root
-- directory of your package.
--
-- 2. If the /configuration-tools/ package is already installed in the system
-- where the build is done, following code can be used as @Setup.hs@ script:
--
-- > module Main (main) where
-- >
-- > import Configuration.Utils.Setup
--
-- 3. For usage within a more complex @Setup.hs@ script you shall import this
-- module qualified and use the 'mkPkgInfoModules' function. For example:
--
-- > module Main (main) where
-- >
-- > import qualified Configuration.Utils.Setup as ConfTools
-- >
-- > main :: IO ()
-- > main = defaultMainWithHooks (ConfTools.mkPkgInfoModules simpleUserHooks)
-- >
--
-- With all methods the field @Build-Type@ in the package description (cabal) file
-- must be set to @Custom@:
--
-- > Build-Type: Custom
--
--
-- = Integration With "Configuration.Utils"
--
-- You can integrate the information provided by the @PkgInfo@ modules with the
-- command line interface of an application by importing the respective module
-- for the component and using the
-- 'Configuration.Utils.runWithPkgInfoConfiguration' function from the module
-- "Configuration.Utils" as show in the following example:
--
-- > {-# LANGUAGE OverloadedStrings #-}
-- > {-# LANGUAGE FlexibleInstances #-}
-- >
-- > module Main
-- > ( main
-- > ) where
-- >
-- > import Configuration.Utils
-- > import PkgInfo
-- >
-- > instance FromJSON (() -> ()) where parseJSON _ = pure id
-- >
-- > mainInfo :: ProgramInfo ()
-- > mainInfo = programInfo "Hello World" (pure id) ()
-- >
-- > main :: IO ()
-- > main = runWithPkgInfoConfiguration mainInfo pkgInfo . const $ putStrLn "hello world"
--
-- With that the resulting application supports the following additional command
-- line options:
--
-- [@--version@, @-v@]
-- prints the version of the application and exits.
--
-- [@--info@, @-i@]
-- prints a short info message for the application and exits.
--
-- [@--long-info@]
-- print a detailed info message for the application and exits.
-- Beside component name, package name, version, revision, and copyright
-- the message also contain information about the compiler that
-- was used for the build, the build architecture, build flags,
-- the author, the license type, and a list of all direct and
-- indirect dependencies along with their licenses and copyrights.
--
-- [@--license@]
-- prints the text of the lincense of the application and exits.
--
module Main
( main
, mkPkgInfoModules
) where
import qualified Distribution.Compat.Graph as Graph
import qualified Distribution.InstalledPackageInfo as I
import Distribution.PackageDescription
import Distribution.Pretty
import Distribution.Simple
import Distribution.Simple.BuildPaths
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.PackageIndex
import Distribution.Simple.Setup
import Distribution.Simple.Utils (createDirectoryIfMissingVerbose)
import Distribution.Text
import Distribution.Utils.Path
import Distribution.Utils.ShortText
import System.Process
import Control.Applicative
import Control.Monad
import qualified Data.ByteString as B
import Data.ByteString.Char8 (pack)
import Data.Char (isSpace)
import Data.List (intercalate)
import Data.Monoid
import Prelude hiding (readFile, writeFile)
import System.Directory
( canonicalizePath
, doesDirectoryExist
, doesFileExist
, getCurrentDirectory
)
import System.Exit (ExitCode(ExitSuccess))
#if MIN_VERSION_Cabal(3,14,0)
import System.FilePath (isDrive, takeDirectory)
#else
import System.FilePath (isDrive, takeDirectory, (</>))
#endif
-- | Include this function when your setup doesn't contain any
-- extra functionality.
--
main :: IO ()
main = defaultMainWithHooks (mkPkgInfoModules simpleUserHooks)
-- | Modifies the given record of hooks by adding functionality that
-- creates a package info module for each component of the cabal package.
--
-- This function is intended for usage in more complex @Setup.hs@ scripts.
-- If your setup doesn't contain any other function you can just import
-- the 'main' function from this module.
--
-- The modules are created in the /autogen/ build directories where also the
-- @Path_@ modules are created by cabal's simple build setup.
--
mkPkgInfoModules
:: UserHooks
-> UserHooks
mkPkgInfoModules hooks = hooks
{ postConf = mkPkgInfoModulesPostConf (postConf hooks)
}
-- -------------------------------------------------------------------------- --
-- Compat Implementations
prettyLicense :: I.InstalledPackageInfo -> String
prettyLicense = either prettyShow prettyShow . I.license
#if !MIN_VERSION_Cabal(3,14,0)
interpretSymbolicPath :: Maybe () -> FilePath -> FilePath
interpretSymbolicPath _ p = p
#endif
-- -------------------------------------------------------------------------- --
-- Cabal 2.0
mkPkgInfoModulesPostConf
:: (Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO ())
-> Args
-> ConfigFlags
-> PackageDescription
-> LocalBuildInfo
-> IO ()
mkPkgInfoModulesPostConf hook args flags pkgDesc bInfo = do
mapM_ (updatePkgInfoModule pkgDesc bInfo flags) $ Graph.toList $ componentGraph bInfo
hook args flags pkgDesc bInfo
updatePkgInfoModule
:: PackageDescription
-> LocalBuildInfo
-> ConfigFlags
-> ComponentLocalBuildInfo
-> IO ()
updatePkgInfoModule pkgDesc bInfo flags clbInfo = do
createDirectoryIfMissingVerbose verbosity True dirName
moduleBytes <- pkgInfoModule moduleName cName pkgDesc bInfo
updateFile fileName moduleBytes
-- legacy module
legacyModuleBytes <- pkgInfoModule legacyModuleName cName pkgDesc bInfo
updateFile legacyFileName legacyModuleBytes
where
verbosity = fromFlag $ configVerbosity flags
dirName = interpretSymbolicPath Nothing $ autogenComponentModulesDir bInfo clbInfo
cName = unUnqualComponentName <$> componentNameString (componentLocalName clbInfo)
moduleName = pkgInfoModuleName
fileName = dirName </> moduleName <> ".hs"
legacyModuleName = legacyPkgInfoModuleName cName
legacyFileName = dirName </> legacyModuleName <> ".hs"
-- -------------------------------------------------------------------------- --
-- Generate PkgInfo Module
pkgInfoModuleName :: String
pkgInfoModuleName = "PkgInfo"
updateFile :: FilePath -> B.ByteString -> IO ()
updateFile fileName content = do
x <- doesFileExist fileName
if | not x -> update
| otherwise -> do
oldRevisionFile <- B.readFile fileName
when (oldRevisionFile /= content) update
where
update = B.writeFile fileName content
legacyPkgInfoModuleName :: Maybe String -> String
legacyPkgInfoModuleName Nothing = "PkgInfo"
legacyPkgInfoModuleName (Just cn) = "PkgInfo_" <> map tr cn
where
tr '-' = '_'
tr c = c
trim :: String -> String
trim = f . f
where f = reverse . dropWhile isSpace
getVCS :: IO (Maybe KnownRepoType)
getVCS = getCurrentDirectory >>= getVcsOfDir
where
getVcsOfDir d = do
canonicDir <- canonicalizePath d
doesDirectoryExist (canonicDir </> ".hg") >>= \x0 -> if x0
then return (Just Mercurial)
else doesDirectoryExist (canonicDir </> ".git") >>= \x1 -> if x1
then return $ Just Git
else if isDrive canonicDir
then return Nothing
else getVcsOfDir (takeDirectory canonicDir)
pkgInfoModule
:: String
-> Maybe String
-> PackageDescription
-> LocalBuildInfo
-> IO B.ByteString
pkgInfoModule moduleName cName pkgDesc bInfo = do
(tag, revision, branch) <- getVCS >>= \case
Just Mercurial -> hgInfo
Just Git -> gitInfo
_ -> noVcsInfo
let vcsBranch = if branch == "default" || branch == "master" then "" else branch
vcsVersion = intercalate "-" . filter (/= "") $ [tag, revision, vcsBranch]
flags = map (unFlagName . fst) . filter snd . unFlagAssignment . configConfigurationsFlags . configFlags $ bInfo
licenseString <- licenseFilesText pkgDesc
return $ B.intercalate "\n"
[ "{-# LANGUAGE OverloadedStrings #-}"
, "{-# LANGUAGE RankNTypes #-}"
, ""
, "module " <> pack moduleName <> " " <> deprecatedMsg <> " where"
, ""
, " import Data.String (IsString)"
, " import Data.Monoid"
, " import Prelude hiding ((<>))"
, ""
, " name :: IsString a => Maybe a"
, " name = " <> maybe "Nothing" (\x -> "Just \"" <> pack x <> "\"") cName
, ""
, " tag :: IsString a => a"
, " tag = \"" <> pack tag <> "\""
, ""
, " revision :: IsString a => a"
, " revision = \"" <> pack revision <> "\""
, ""
, " branch :: IsString a => a"
, " branch = \"" <> pack branch <> "\""
, ""
, " branch' :: IsString a => a"
, " branch' = \"" <> pack vcsBranch <> "\""
, ""
, " vcsVersion :: IsString a => a"
, " vcsVersion = \"" <> pack vcsVersion <> "\""
, ""
, " compiler :: IsString a => a"
, " compiler = \"" <> (pack . display . compilerId . compiler) bInfo <> "\""
, ""
, " flags :: IsString a => [a]"
, " flags = " <> (pack . show) flags
, ""
, " optimisation :: IsString a => a"
, " optimisation = \"" <> (displayOptimisationLevel . withOptimization) bInfo <> "\""
, ""
, " arch :: IsString a => a"
, " arch = \"" <> (pack . display . hostPlatform) bInfo <> "\""
, ""
, " license :: IsString a => a"
, " license = \"" <> (pack . prettyShow . license) pkgDesc <> "\""
, ""
, " licenseText :: IsString a => a"
, " licenseText = " <> (pack . show) licenseString
, ""
, " copyright :: IsString a => a"
, " copyright = " <> (pack . show . copyright) pkgDesc
, ""
, " author :: IsString a => a"
, " author = \"" <> (pack . fromShortText . author) pkgDesc <> "\""
, ""
, " homepage :: IsString a => a"
, " homepage = \"" <> (pack . fromShortText . homepage) pkgDesc <> "\""
, ""
, " package :: IsString a => a"
, " package = \"" <> (pack . display . package) pkgDesc <> "\""
, ""
, " packageName :: IsString a => a"
, " packageName = \"" <> (pack . display . packageName) pkgDesc <> "\""
, ""
, " packageVersion :: IsString a => a"
, " packageVersion = \"" <> (pack . display . packageVersion) pkgDesc <> "\""
, ""
, " dependencies :: IsString a => [a]"
, " dependencies = " <> (pack . show . map (display . packageId) . allPackages . installedPkgs) bInfo
, ""
, " dependenciesWithLicenses :: IsString a => [a]"
, " dependenciesWithLicenses = " <> (pack . show . map pkgIdWithLicense . allPackages . installedPkgs) bInfo
, ""
, " versionString :: (Monoid a, IsString a) => a"
, " versionString = case name of"
, " Nothing -> package <> \" (revision \" <> vcsVersion <> \")\""
, " Just n -> n <> \"-\" <> packageVersion <> \" (package \" <> package <> \" revision \" <> vcsVersion <> \")\""
, ""
, " info :: (Monoid a, IsString a) => a"
, " info = versionString <> \"\\n\" <> copyright"
, ""
, " longInfo :: (Monoid a, IsString a) => a"
, " longInfo = info <> \"\\n\\n\""
, " <> \"Author: \" <> author <> \"\\n\""
, " <> \"License: \" <> license <> \"\\n\""
, " <> \"Homepage: \" <> homepage <> \"\\n\""
, " <> \"Build with: \" <> compiler <> \" (\" <> arch <> \")\" <> \"\\n\""
, " <> \"Build flags: \" <> mconcat (map (\\x -> \" \" <> x) flags) <> \"\\n\""
, " <> \"Optimisation: \" <> optimisation <> \"\\n\\n\""
, " <> \"Dependencies:\\n\" <> mconcat (map (\\x -> \" \" <> x <> \"\\n\") dependenciesWithLicenses)"
, ""
, " pkgInfo :: (Monoid a, IsString a) => (a, a, a, a)"
, " pkgInfo ="
, " ( info"
, " , longInfo"
, " , versionString"
, " , licenseText"
, " )"
, ""
]
where
displayOptimisationLevel NoOptimisation = "none"
displayOptimisationLevel NormalOptimisation = "normal"
displayOptimisationLevel MaximumOptimisation = "maximum"
deprecatedMsg = if moduleName /= pkgInfoModuleName
then "{-# DEPRECATED \"Update to Cabal 2.0 or later and use just PkgInfo as module name.\" #-}"
else ""
licenseFilesText :: PackageDescription -> IO B.ByteString
licenseFilesText pkgDesc =
B.intercalate "\n------------------------------------------------------------\n" <$> mapM fileTextStr
(licenseFiles pkgDesc)
where
fileText file = doesFileExist file >>= \x -> if x
then B.readFile file
else return ""
fileTextStr = fileText . getSymbolicPath
hgInfo :: IO (String, String, String)
hgInfo = do
tag <- trim <$> readProcess "hg" ["id", "-r", "max(ancestors(\".\") and tag())", "-t"] ""
rev <- trim <$> readProcess "hg" ["id", "-i"] ""
branch <- trim <$> readProcess "hg" ["id", "-b"] ""
return (tag, rev, branch)
gitInfo :: IO (String, String, String)
gitInfo = do
tag <- do
(exitCode, out, _err) <- readProcessWithExitCode "git" ["describe", "--exact-match", "--tags", "--abbrev=0"] ""
case exitCode of
ExitSuccess -> return $ trim out
_ -> return ""
rev <- trim <$> readProcess "git" ["rev-parse", "--short", "HEAD"] ""
branch <- trim <$> readProcess "git" ["rev-parse", "--abbrev-ref", "HEAD"] ""
return (tag, rev, branch)
noVcsInfo :: IO (String, String, String)
noVcsInfo = return ("", "", "")
pkgIdWithLicense :: I.InstalledPackageInfo -> String
pkgIdWithLicense a = (display . packageId) a
++ " ["
++ prettyLicense a
++ (if cr /= "" then ", " ++ cr else "")
++ "]"
where
cr = (unwords . words . fromShortText . I.copyright) a