Run.hs

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

module HWM.CLI.Command.Run
  ( runScript,
    ScriptOptions (..),
  )
where

import Control.Concurrent.Async
import Control.Monad.Error.Class (MonadError (..))
import Data.List (intersect)
import qualified Data.Map as M
import qualified Data.Set as S
import qualified Data.Text as T
import Data.Traversable (for)
import HWM.Core.Common (Name)
import HWM.Core.Formatting (Color (..), Format (..), Status (Checked, Invalid), chalk, genMaxLen, padDots, statusIcon)
import HWM.Core.Pkg (Pkg (..))
import HWM.Core.Result (Issue (..), IssueDetails (..), Severity (..))
import HWM.Domain.Config (Config (..))
import HWM.Domain.ConfigT (ConfigT, askWorkspaceGroups, config)
import HWM.Domain.Matrix (BuildEnvironment (..), getBuildEnvironment, getBuildEnvroments)
import HWM.Domain.Workspace (resolveTargets)
import HWM.Integrations.Toolchain.Stack (createEnvYaml, stackPath)
import HWM.Runtime.Cache (prepareDir)
import HWM.Runtime.Logging (logError, logRoot)
import HWM.Runtime.Process (inheritRun, silentRun)
import HWM.Runtime.UI (putLine, runSpinner, sectionEnvironments, sectionWorkspace, statusIndicator)
import Relude

data ScriptOptions = ScriptOptions
  { scriptName :: Name,
    scriptTargets :: [Name],
    scriptEnvs :: [Name],
    scriptOptions :: [Text]
  }
  deriving (Show)

getEnvs :: [Name] -> ConfigT [BuildEnvironment]
getEnvs ["all"] = getBuildEnvroments
getEnvs names = for names (getBuildEnvironment . Just)

runScript :: ScriptOptions -> ConfigT ()
runScript ScriptOptions {..} = do
  prepareDir logRoot
  cfg <- asks config
  case M.lookup scriptName (scripts cfg) of
    Just script -> do
      envs <- getEnvs scriptEnvs
      ws <- askWorkspaceGroups
      targets <- fmap (S.toList . S.fromList) (resolveTargets ws scriptTargets)
      for_ envs (createEnvYaml . buildName)
      let multi = length envs > 1
      let cmdTemplate = if null scriptOptions then script else T.unwords (script : scriptOptions)
      let padding = genMaxLen (map format envs)
      let run = runCommand padding multi cmdTemplate targets

      if multi
        then do
          when multi $ do
            sectionWorkspace $ do
              putLine $ padDots 16 "targets" <> if null scriptTargets then chalk Yellow "None (Global Scope)" else chalk Cyan (T.unwords scriptTargets)
            sectionEnvironments (for_ (map buildName envs) (run . Just))
        else run Nothing
    Nothing -> throwError $ fromString $ toString $ "Script not found: " <> scriptName

runCommand :: Int -> Bool -> Text -> [Pkg] -> Maybe Name -> ConfigT ()
runCommand padding multi scripts targets envName = do
  benv@BuildEnvironment {..} <- getBuildEnvironment envName
  let supported = targets `intersect` buildPkgs
  cmd <- resolveCommand scripts supported
  yamlPath <- stackPath envName
  if multi
    then do
      let env = format benv
      (success, content) <- silentRun yamlPath cmd (async (runSpinner padding env))
      statusIndicator padding env (statusIcon (if success then Checked else Invalid))
      unless success $ do
        path <- logError buildName [("ENVIRONMENT", format benv), ("COMMAND", format cmd)] content
        throwError
          Issue
            { issueTopic = buildName,
              issueMessage = "Command failed",
              issueSeverity = SeverityError,
              issueDetails = Just CommandIssue {issueCommand = format cmd, issueLogFile = path}
            }
      putLine ""
    else do
      sectionWorkspace $ do
        putLine $ padDots 16 "targets" <> if null supported then chalk Yellow "None (Global Scope)" else chalk Cyan (T.unwords $ format . pkgName <$> supported)
      sectionEnvironments $ putLine $ format benv
      putLine ""
      putLine ("❯ " <> cmd)
      inheritRun yamlPath cmd
      putLine ""

resolveCommand :: Text -> [Pkg] -> ConfigT Text
resolveCommand cmd targets = do
  let hasPlaceholder = "{TARGET}" `T.isInfixOf` cmd
      hasTargets = not (null targets)
      targetsStr = T.unwords (map (format . pkgName) targets)
  let result = case (hasPlaceholder, hasTargets) of
        (True, True) -> Right $ T.replace "{TARGET}" targetsStr cmd
        (True, False) -> Left "Missing Target! This command requires specific targets (e.g. --target app1)."
        (False, True) -> Left "Target Not Allowed! This command is Global-only and does not support specific targets."
        (False, False) -> Right cmd
  case result of
    Left err -> throwError $ fromString err
    Right c -> pure c