Artifacts.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HWM.CLI.Command.Release.Artifacts
  ( ReleaseArchiveOptions (..),
    parseCLI,
    runReleaseArchive,
  )
where

import Control.Monad.Error.Class (MonadError (throwError))
import Data.Traversable (for)
import HWM.Core.Common (Name)
import HWM.Core.Formatting (Format (format), Status (..), formatList, statusIcon)
import HWM.Core.Parsing (Parse (..), ParseCLI (..), parseLS)
import HWM.Core.Result (fromEither)
import HWM.Domain.Build (BuildFlag (GHCOptionsFlag), Builder (..), BuilderCommand (..))
import HWM.Domain.Config (Config (..))
import HWM.Domain.ConfigT (ConfigT, Env (..), getArchiveConfigs)
import HWM.Domain.Dispatcher (DispatcheCommand (..), dispatch)
import HWM.Domain.Environments (BuildEnvironment (..), getBuildEnvironment, overrideBuilder)
import HWM.Domain.Release (ArchiveFormat, ArtifactConfig (..), ReleaseArtifactConfigs, isArtifactEnabledInEnvironment, resolveArtifactConfig, selectedArtifacts)
import HWM.Domain.Schema (TargetScope (ScopePkgs))
import HWM.Integrations.Toolchain.Github (ensureIsLatestTag)
import HWM.Runtime.Archive (ArchiveInfo (..), ArchivingPlan (..), createArchive)
import HWM.Runtime.Network (getGHUploadUrl, uploadToGitHub)
import HWM.Runtime.UI (indent, section, sectionTableM, uiSpace, uiSubPath)
import Options.Applicative (argument, help, long, metavar, option, showDefault, str, strOption, switch, value)
import Relude
import System.Directory (createDirectoryIfMissing, removePathForcibly)
import System.FilePath (joinPath)

-- | Options for 'hwm release archive'
data ReleaseArchiveOptions = ReleaseArchiveOptions
  { targetName :: Maybe Text,
    ghPublish :: Bool,
    outputDir :: FilePath,
    ovFormat :: Maybe [Text],
    ovGhcOptions :: Maybe [Text],
    ovNameTemplate :: Maybe Text,
    opsBuilder :: Maybe Builder
  }
  deriving (Show)

instance ParseCLI ReleaseArchiveOptions where
  parseCLI =
    ReleaseArchiveOptions
      <$> optional (argument str (metavar "TARGET" <> help "Name of the release target to build (default: all)"))
      <*> switch (long "github" <> help "Upload generated artifacts to a GitHub Release")
      <*> strOption
        ( long "output-dir"
            <> metavar "OUTPUT_DIR"
            <> help "Directory to output the release artifacts."
            <> value defaultOutputDir
            <> showDefault
        )
      <*> optional (option (parseLS <$> str) (long "format" <> metavar "FORMAT" <> help "Override the archive format for the release target. Supported: zip, tar.gz."))
      <*> (mkOptional . concat <$> many (option (parseLS <$> str) (long "ghc-options" <> metavar "GHC_OPTION" <> help "Override GHC options for the release target. Repeatable; also accepts comma-separated values.")))
      <*> optional (strOption (long "name-template" <> metavar "NAME_TEMPLATE" <> help "Override the name template for the release target. Use {name} and {version} as placeholders."))
      <*> optional (option (str >>= parse) (long "builder" <> metavar "BUILDER" <> help "Override the builder for the release target. Supported: cabal, stack, nix."))

genBindaryDir :: (MonadIO m, ToString a) => a -> m FilePath
genBindaryDir name = do
  let path = joinPath [".hwm/release/binaries", toString name]
  prepeareDir path
  pure path

defaultOutputDir :: FilePath
defaultOutputDir = ".hwm/dist"

prepeareDir :: (MonadIO m) => FilePath -> m ()
prepeareDir dir = liftIO $ do
  removePathForcibly dir
  createDirectoryIfMissing True dir

mkOptional :: [a] -> Maybe [a]
mkOptional [] = Nothing
mkOptional xs = Just xs

parseFormats :: [Text] -> ConfigT [ArchiveFormat]
parseFormats = fromEither "can't parse archive format" . traverse parse

validateTargetEnvironment :: Name -> (Name, ArtifactConfig) -> ConfigT ()
validateTargetEnvironment envName (target, cfg@ArtifactConfig {arcEnvironments = allowedEnvs}) =
  unless (isArtifactEnabledInEnvironment envName cfg)
    $ throwError
    $ fromString
    $ "Artifact '"
    <> toString target
    <> "' is not enabled for environment '"
    <> toString envName
    <> "'. Allowed environments: "
    <> (if maybe True null allowedEnvs then "<none>" else toString (formatList ", " (fromMaybe [] allowedEnvs)))

withOverrides :: ReleaseArchiveOptions -> ReleaseArtifactConfigs -> ConfigT [(Name, ArtifactConfig)]
withOverrides ReleaseArchiveOptions {..} cfgs = do
  parsedFormats <- traverse parseFormats ovFormat
  map (second (applyOverrieds parsedFormats)) <$> selectedArtifacts targetName cfgs
  where
    applyOverrieds formats cfg =
      cfg
        { arcFormats = fromMaybe (arcFormats cfg) formats,
          arcGhcOptions = fromMaybe (arcGhcOptions cfg) ovGhcOptions,
          arcNameTemplate = fromMaybe (arcNameTemplate cfg) ovNameTemplate
        }

runReleaseArchive :: ReleaseArchiveOptions -> ConfigT ()
runReleaseArchive ops@ReleaseArchiveOptions {..} = do
  if outputDir == defaultOutputDir
    then prepeareDir defaultOutputDir
    else liftIO $ createDirectoryIfMissing True outputDir
  cfg <- asks config
  version <- asks (cfgVersion . config)
  cfgs <- getArchiveConfigs >>= withOverrides ops
  ghTag <- if ghPublish then Just <$> ensureIsLatestTag version else pure Nothing
  uploadUrl <- maybe (pure Nothing) (fmap Just . getGHUploadUrl cfg) ghTag
  activeEnv <- getBuildEnvironment Nothing
  let defaultBuilder = buildBuilder activeEnv
  let builder = fromMaybe defaultBuilder opsBuilder
  traverse_ (validateTargetEnvironment (buildName activeEnv)) cfgs
  sectionTableM
    "artifacts"
    [ ("destination", pure $ maybe (format outputDir) format uploadUrl),
      ("version", pure $ format version <> maybe "" (\tag -> " (GitHub Release " <> tag <> ")") ghTag),
      ("targets", pure $ formatList "," (map fst cfgs)),
      ("builder", pure $ format builder)
    ]

  plans <- section "build" $ traverse (buildPkg outputDir builder) cfgs
  uiSpace

  section "archive" $ pure ()
  artifacts <- for plans $ \(name, plan) -> do
    archives <- createArchive version plan
    indent 1
      $ section name
      $ for_ archives
      $ \ArchiveInfo {..} -> do
        uiSubPath archivePath
        uiSubPath sha256Path
    pure (name, archives)

  for_ uploadUrl $ \url -> section "publish (Github)"
    $ for_ artifacts
    $ \(name, archives) -> section name $ for_ archives $ \ArchiveInfo {..} -> do
      uploadToGitHub url archivePath
      uiSubPath archivePath
      uploadToGitHub url sha256Path
      uiSubPath sha256Path

buildPkg :: FilePath -> Builder -> (Name, ArtifactConfig) -> ConfigT (Text, ArchivingPlan)
buildPkg outputDir builder (name, cfg@ArtifactConfig {..}) = do
  binaryDir <- genBindaryDir name
  (executableName, pkg) <- resolveArtifactConfig cfg
  env <- overrideBuilder builder <$> getBuildEnvironment Nothing
  dispatch (DispatcheCommand (BuildArtifact binaryDir) (ScopePkgs [pkg]) (map GHCOptionsFlag arcGhcOptions)) env
  pure (statusIcon Checked, ArchivingPlan {nameTemplate = arcNameTemplate, outDir = outputDir, sourceDir = binaryDir, name = executableName, archiveFormats = arcFormats})