{-# 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
  { ScriptOptions -> Text
scriptName :: Name,
    ScriptOptions -> [Text]
scriptTargets :: [Name],
    ScriptOptions -> [Text]
scriptEnvs :: [Name],
    ScriptOptions -> [Text]
scriptOptions :: [Text]
  }
  deriving (Int -> ScriptOptions -> ShowS
[ScriptOptions] -> ShowS
ScriptOptions -> String
(Int -> ScriptOptions -> ShowS)
-> (ScriptOptions -> String)
-> ([ScriptOptions] -> ShowS)
-> Show ScriptOptions
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScriptOptions -> ShowS
showsPrec :: Int -> ScriptOptions -> ShowS
$cshow :: ScriptOptions -> String
show :: ScriptOptions -> String
$cshowList :: [ScriptOptions] -> ShowS
showList :: [ScriptOptions] -> ShowS
Show)

getEnvs :: [Name] -> ConfigT [BuildEnvironment]
getEnvs :: [Text] -> ConfigT [BuildEnvironment]
getEnvs [Text
"all"] = ConfigT [BuildEnvironment]
forall env (m :: * -> *).
(MonadReader env m, Has env Matrix, Has env [WorkspaceGroup],
 MonadIO m, MonadError Issue m) =>
m [BuildEnvironment]
getBuildEnvroments
getEnvs [Text]
names = [Text]
-> (Text -> ConfigT BuildEnvironment) -> ConfigT [BuildEnvironment]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
t a -> (a -> f b) -> f (t b)
for [Text]
names (Maybe Text -> ConfigT BuildEnvironment
forall env (m :: * -> *).
(MonadReader env m, Has env Matrix, Has env [WorkspaceGroup],
 Has env Cache, MonadIO m, MonadError Issue m) =>
Maybe Text -> m BuildEnvironment
getBuildEnvironment (Maybe Text -> ConfigT BuildEnvironment)
-> (Text -> Maybe Text) -> Text -> ConfigT BuildEnvironment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
forall a. a -> Maybe a
Just)

runScript :: ScriptOptions -> ConfigT ()
runScript :: ScriptOptions -> ConfigT ()
runScript ScriptOptions {[Text]
Text
scriptName :: ScriptOptions -> Text
scriptTargets :: ScriptOptions -> [Text]
scriptEnvs :: ScriptOptions -> [Text]
scriptOptions :: ScriptOptions -> [Text]
scriptName :: Text
scriptTargets :: [Text]
scriptEnvs :: [Text]
scriptOptions :: [Text]
..} = do
  String -> ConfigT ()
forall (m :: * -> *). MonadIO m => String -> m ()
prepareDir String
logRoot
  Config
cfg <- (ConfigEnv -> Config) -> ConfigT Config
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks ConfigEnv -> Config
forall (m :: * -> *). Env m -> Config
config
  case Text -> Map Text Text -> Maybe Text
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
scriptName (Config -> Map Text Text
scripts Config
cfg) of
    Just Text
script -> do
      [BuildEnvironment]
envs <- [Text] -> ConfigT [BuildEnvironment]
getEnvs [Text]
scriptEnvs
      [WorkspaceGroup]
ws <- ConfigT [WorkspaceGroup]
askWorkspaceGroups
      [Pkg]
targets <- ([Pkg] -> [Pkg]) -> ConfigT [Pkg] -> ConfigT [Pkg]
forall a b. (a -> b) -> ConfigT a -> ConfigT b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Set Pkg -> [Pkg]
forall a. Set a -> [a]
S.toList (Set Pkg -> [Pkg]) -> ([Pkg] -> Set Pkg) -> [Pkg] -> [Pkg]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Pkg] -> Set Pkg
forall a. Ord a => [a] -> Set a
S.fromList) ([WorkspaceGroup] -> [Text] -> ConfigT [Pkg]
forall (m :: * -> *).
(MonadIO m, MonadError Issue m) =>
[WorkspaceGroup] -> [Text] -> m [Pkg]
resolveTargets [WorkspaceGroup]
ws [Text]
scriptTargets)
      [BuildEnvironment]
-> (BuildEnvironment -> ConfigT ()) -> ConfigT ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [BuildEnvironment]
envs (Text -> ConfigT ()
createEnvYaml (Text -> ConfigT ())
-> (BuildEnvironment -> Text) -> BuildEnvironment -> ConfigT ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BuildEnvironment -> Text
buildName)
      let multi :: Bool
multi = [BuildEnvironment] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BuildEnvironment]
envs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
      let cmdTemplate :: Text
cmdTemplate = if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
scriptOptions then Text
script else [Text] -> Text
T.unwords (Text
script Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
scriptOptions)
      let padding :: Int
padding = [Text] -> Int
genMaxLen ((BuildEnvironment -> Text) -> [BuildEnvironment] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map BuildEnvironment -> Text
forall a. Format a => a -> Text
format [BuildEnvironment]
envs)
      let run :: Maybe Text -> ConfigT ()
run = Int -> Bool -> Text -> [Pkg] -> Maybe Text -> ConfigT ()
runCommand Int
padding Bool
multi Text
cmdTemplate [Pkg]
targets

      if Bool
multi
        then do
          Bool -> ConfigT () -> ConfigT ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
multi (ConfigT () -> ConfigT ()) -> ConfigT () -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ do
            ConfigT () -> ConfigT ()
forall (m :: * -> *) a. MonadUI m => m a -> m ()
sectionWorkspace (ConfigT () -> ConfigT ()) -> ConfigT () -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ do
              Text -> ConfigT ()
forall (m :: * -> *). MonadUI m => Text -> m ()
putLine (Text -> ConfigT ()) -> Text -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
padDots Int
16 Text
"targets" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if [Text] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Text]
scriptTargets then Color -> Text -> Text
chalk Color
Yellow Text
"None (Global Scope)" else Color -> Text -> Text
chalk Color
Cyan ([Text] -> Text
T.unwords [Text]
scriptTargets)
            ConfigT () -> ConfigT ()
forall (m :: * -> *) a. MonadUI m => m a -> m ()
sectionEnvironments ([Text] -> (Text -> ConfigT ()) -> ConfigT ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ ((BuildEnvironment -> Text) -> [BuildEnvironment] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map BuildEnvironment -> Text
buildName [BuildEnvironment]
envs) (Maybe Text -> ConfigT ()
run (Maybe Text -> ConfigT ())
-> (Text -> Maybe Text) -> Text -> ConfigT ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
forall a. a -> Maybe a
Just))
        else Maybe Text -> ConfigT ()
run Maybe Text
forall a. Maybe a
Nothing
    Maybe Text
Nothing -> Issue -> ConfigT ()
forall a. Issue -> ConfigT a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Issue -> ConfigT ()) -> Issue -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ String -> Issue
forall a. IsString a => String -> a
fromString (String -> Issue) -> String -> Issue
forall a b. (a -> b) -> a -> b
$ Text -> String
forall a. ToString a => a -> String
toString (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Text
"Script not found: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
scriptName

runCommand :: Int -> Bool -> Text -> [Pkg] -> Maybe Name -> ConfigT ()
runCommand :: Int -> Bool -> Text -> [Pkg] -> Maybe Text -> ConfigT ()
runCommand Int
padding Bool
multi Text
scripts [Pkg]
targets Maybe Text
envName = do
  benv :: BuildEnvironment
benv@BuildEnvironment {[Pkg]
Maybe Extras
Text
BuildEnv
buildName :: BuildEnvironment -> Text
buildEnv :: BuildEnv
buildPkgs :: [Pkg]
buildName :: Text
buildExtraDeps :: Maybe Extras
buildResolver :: Text
buildResolver :: BuildEnvironment -> Text
buildExtraDeps :: BuildEnvironment -> Maybe Extras
buildPkgs :: BuildEnvironment -> [Pkg]
buildEnv :: BuildEnvironment -> BuildEnv
..} <- Maybe Text -> ConfigT BuildEnvironment
forall env (m :: * -> *).
(MonadReader env m, Has env Matrix, Has env [WorkspaceGroup],
 Has env Cache, MonadIO m, MonadError Issue m) =>
Maybe Text -> m BuildEnvironment
getBuildEnvironment Maybe Text
envName
  let supported :: [Pkg]
supported = [Pkg]
targets [Pkg] -> [Pkg] -> [Pkg]
forall a. Eq a => [a] -> [a] -> [a]
`intersect` [Pkg]
buildPkgs
  Text
cmd <- Text -> [Pkg] -> ConfigT Text
resolveCommand Text
scripts [Pkg]
supported
  String
yamlPath <- Maybe Text -> ConfigT String
stackPath Maybe Text
envName
  if Bool
multi
    then do
      let env :: Text
env = BuildEnvironment -> Text
forall a. Format a => a -> Text
format BuildEnvironment
benv
      (Bool
success, Text
content) <- String -> Text -> IO (Async ()) -> ConfigT (Bool, Text)
forall (m :: * -> *) a.
MonadIO m =>
String -> Text -> IO (Async a) -> m (Bool, Text)
silentRun String
yamlPath Text
cmd (IO () -> IO (Async ())
forall a. IO a -> IO (Async a)
async (Int -> Text -> IO ()
forall (m :: * -> *). MonadIO m => Int -> Text -> m ()
runSpinner Int
padding Text
env))
      Int -> Text -> Text -> ConfigT ()
forall (m :: * -> *). MonadIO m => Int -> Text -> Text -> m ()
statusIndicator Int
padding Text
env (Status -> Text
statusIcon (if Bool
success then Status
Checked else Status
Invalid))
      Bool -> ConfigT () -> ConfigT ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
success (ConfigT () -> ConfigT ()) -> ConfigT () -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ do
        String
path <- Text -> [(Text, Text)] -> Text -> ConfigT String
forall (m :: * -> *).
MonadIO m =>
Text -> [(Text, Text)] -> Text -> m String
logError Text
buildName [(Text
"ENVIRONMENT", BuildEnvironment -> Text
forall a. Format a => a -> Text
format BuildEnvironment
benv), (Text
"COMMAND", Text -> Text
forall a. Format a => a -> Text
format Text
cmd)] Text
content
        Issue -> ConfigT ()
forall a. Issue -> ConfigT a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
          Issue
            { issueTopic :: Text
issueTopic = Text
buildName,
              issueMessage :: Text
issueMessage = Text
"Command failed",
              issueSeverity :: Severity
issueSeverity = Severity
SeverityError,
              issueDetails :: Maybe IssueDetails
issueDetails = IssueDetails -> Maybe IssueDetails
forall a. a -> Maybe a
Just CommandIssue {issueCommand :: Text
issueCommand = Text -> Text
forall a. Format a => a -> Text
format Text
cmd, issueLogFile :: String
issueLogFile = String
path}
            }
      Text -> ConfigT ()
forall (m :: * -> *). MonadUI m => Text -> m ()
putLine Text
""
    else do
      ConfigT () -> ConfigT ()
forall (m :: * -> *) a. MonadUI m => m a -> m ()
sectionWorkspace (ConfigT () -> ConfigT ()) -> ConfigT () -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ do
        Text -> ConfigT ()
forall (m :: * -> *). MonadUI m => Text -> m ()
putLine (Text -> ConfigT ()) -> Text -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ Int -> Text -> Text
padDots Int
16 Text
"targets" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> if [Pkg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pkg]
supported then Color -> Text -> Text
chalk Color
Yellow Text
"None (Global Scope)" else Color -> Text -> Text
chalk Color
Cyan ([Text] -> Text
T.unwords ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ PkgName -> Text
forall a. Format a => a -> Text
format (PkgName -> Text) -> (Pkg -> PkgName) -> Pkg -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pkg -> PkgName
pkgName (Pkg -> Text) -> [Pkg] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Pkg]
supported)
      ConfigT () -> ConfigT ()
forall (m :: * -> *) a. MonadUI m => m a -> m ()
sectionEnvironments (ConfigT () -> ConfigT ()) -> ConfigT () -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ Text -> ConfigT ()
forall (m :: * -> *). MonadUI m => Text -> m ()
putLine (Text -> ConfigT ()) -> Text -> ConfigT ()
forall a b. (a -> b) -> a -> b
$ BuildEnvironment -> Text
forall a. Format a => a -> Text
format BuildEnvironment
benv
      Text -> ConfigT ()
forall (m :: * -> *). MonadUI m => Text -> m ()
putLine Text
""
      Text -> ConfigT ()
forall (m :: * -> *). MonadUI m => Text -> m ()
putLine (Text
"❯ " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cmd)
      String -> Text -> ConfigT ()
forall (m :: * -> *). MonadIO m => String -> Text -> m ()
inheritRun String
yamlPath Text
cmd
      Text -> ConfigT ()
forall (m :: * -> *). MonadUI m => Text -> m ()
putLine Text
""

resolveCommand :: Text -> [Pkg] -> ConfigT Text
resolveCommand :: Text -> [Pkg] -> ConfigT Text
resolveCommand Text
cmd [Pkg]
targets = do
  let hasPlaceholder :: Bool
hasPlaceholder = Text
"{TARGET}" Text -> Text -> Bool
`T.isInfixOf` Text
cmd
      hasTargets :: Bool
hasTargets = Bool -> Bool
not ([Pkg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Pkg]
targets)
      targetsStr :: Text
targetsStr = [Text] -> Text
T.unwords ((Pkg -> Text) -> [Pkg] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map (PkgName -> Text
forall a. Format a => a -> Text
format (PkgName -> Text) -> (Pkg -> PkgName) -> Pkg -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pkg -> PkgName
pkgName) [Pkg]
targets)
  let result :: Either String Text
result = case (Bool
hasPlaceholder, Bool
hasTargets) of
        (Bool
True, Bool
True) -> Text -> Either String Text
forall a b. b -> Either a b
Right (Text -> Either String Text) -> Text -> Either String Text
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> Text -> Text
Text -> Text -> Text -> Text
T.replace Text
"{TARGET}" Text
targetsStr Text
cmd
        (Bool
True, Bool
False) -> String -> Either String Text
forall a b. a -> Either a b
Left String
"Missing Target! This command requires specific targets (e.g. --target app1)."
        (Bool
False, Bool
True) -> String -> Either String Text
forall a b. a -> Either a b
Left String
"Target Not Allowed! This command is Global-only and does not support specific targets."
        (Bool
False, Bool
False) -> Text -> Either String Text
forall a b. b -> Either a b
Right Text
cmd
  case Either String Text
result of
    Left String
err -> Issue -> ConfigT Text
forall a. Issue -> ConfigT a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Issue -> ConfigT Text) -> Issue -> ConfigT Text
forall a b. (a -> b) -> a -> b
$ String -> Issue
forall a. IsString a => String -> a
fromString String
err
    Right Text
c -> Text -> ConfigT Text
forall a. a -> ConfigT a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
c