Setup.hs

-- ------------------------------------------------------ --
-- Copyright © 2019-2023 Kadena LLC <chainweb-dev@kadena.io>
-- Copyright © 2019 Colin Woodbury <colin@fosskers.ca>
-- Copyright © 2015-2018 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
) 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.Text
import Distribution.Types.LocalBuildInfo
import Distribution.Types.UnqualComponentName
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.Maybe (fromMaybe)
import Data.Monoid

import System.Directory
    (canonicalizePath, createDirectoryIfMissing, doesDirectoryExist,
    doesFileExist, getCurrentDirectory)
import System.Environment (lookupEnv)
import System.Exit (ExitCode(ExitSuccess))
import System.FilePath (isDrive, takeDirectory, (</>))

-- | 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

ft :: ShortText -> String
ft = fromShortText

-- -------------------------------------------------------------------------- --
-- 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) $ Graph.toList $ componentGraph bInfo
    hook args flags pkgDesc bInfo

updatePkgInfoModule :: PackageDescription -> LocalBuildInfo -> ComponentLocalBuildInfo -> IO ()
updatePkgInfoModule pkgDesc bInfo clbInfo = do
    createDirectoryIfMissing True dirName
    moduleBytes <- pkgInfoModule moduleName cName pkgDesc bInfo
    updateFile fileName moduleBytes

    -- legacy module
    legacyModuleBytes <- pkgInfoModule legacyModuleName cName pkgDesc bInfo
    updateFile legacyFileName legacyModuleBytes

  where
    dirName = 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

-- -------------------------------------------------------------------------- --
-- VCS

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)

-- | Returns tag, revision, and branch name.
--
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)

-- | Returns tag, revision, and branch name.
--
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)

-- | Returns tag, revision, and branch name.
--
gitlabCiVcsInfo :: IO (Maybe (String, String, String))
gitlabCiVcsInfo = do
    lookupEnv "CI_COMMIT_SHORT_SHA" >>= \case
        Nothing -> return Nothing
        Just _ -> do
            rev <- fromMaybe "" <$> lookupEnv "CI_COMMIT_SHORT_SHA"
            branch <- fromMaybe "" <$> lookupEnv "CI_COMMIT_REF_NAME"
            tag <- fromMaybe "" <$> lookupEnv "CI_COMMIT_TAG"
            return $ Just (tag, rev, branch)

-- | The file format is revision, branch, and tag separate by newline
-- characters.
--
fileVcsInfo :: IO (Maybe (String, String, String))
fileVcsInfo = do
    doesFileExist ".vcs-info" >>= \x -> if x
    then do
        (rev : branch : tag : _) <- (<> ["", "", ""]) . lines <$> readFile ".vcs-info"
        return $ Just (tag, rev, branch)
    else return Nothing

-- | Returns tag, revision, and branch name.
--
noVcsInfo :: IO (String, String, String)
noVcsInfo = return ("", "", "")

-- | Returns tag, revision, and branch name.
--
getVcsInfo :: IO (String, String, String)
getVcsInfo = getVCS >>= \case
    Just Mercurial -> hgInfo
    Just Git -> gitInfo
    _ -> gitlabCiVcsInfo >>= \case
        Just a -> return a
        Nothing -> fileVcsInfo >>= \case
            Just a -> return a
            Nothing -> noVcsInfo

-- -------------------------------------------------------------------------- --
-- Generate Module

pkgInfoModule :: String -> Maybe String -> PackageDescription -> LocalBuildInfo -> IO B.ByteString
pkgInfoModule moduleName cName pkgDesc bInfo = do
    (tag, revision, branch) <- getVcsInfo

    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 . ft . author) pkgDesc <> "\""
            , ""
            , "    homepage :: IsString a => a"
            , "    homepage = \"" <> (pack . ft . 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
    fileTextStr = fileText . getSymbolicPath
    fileText file = doesFileExist file >>= \x -> if x
        then B.readFile file
        else return ""

pkgIdWithLicense :: I.InstalledPackageInfo -> String
pkgIdWithLicense a = (display . packageId) a
    ++ " ["
    ++ prettyLicense a
    ++ (if cr /= "" then ", " ++ cr else "")
    ++ "]"
  where
    cr = (unwords . words . ft . I.copyright) a