{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}

module HWM.Runtime.Process
  ( silentRun,
    inheritRun,
  )
where

import Control.Concurrent.Async
import qualified Data.Text as T
import GHC.IO (evaluate)
import Relude
import System.Environment (getEnvironment)
import qualified System.IO as TIO
import System.Process.Typed

provideYamlPath :: (MonadIO m) => String -> m [(String, String)]
provideYamlPath :: forall (m :: * -> *). MonadIO m => String -> m [(String, String)]
provideYamlPath String
yamlPath = do
  [(String, String)]
currentEnv <- IO [(String, String)] -> m [(String, String)]
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO [(String, String)]
getEnvironment
  [(String, String)] -> m [(String, String)]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((String
"STACK_YAML", String
yamlPath) (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: [(String, String)]
currentEnv)

silentRun :: (MonadIO m) => FilePath -> Text -> IO (Async a) -> m (Bool, Text)
silentRun :: forall (m :: * -> *) a.
MonadIO m =>
String -> Text -> IO (Async a) -> m (Bool, Text)
silentRun String
yamlPath Text
cmd IO (Async a)
spinnerM = do
  [(String, String)]
targetEnv <- String -> m [(String, String)]
forall (m :: * -> *). MonadIO m => String -> m [(String, String)]
provideYamlPath String
yamlPath
  let pc :: ProcessConfig () Handle Handle
pc = [(String, String)]
-> ProcessConfig () Handle Handle -> ProcessConfig () Handle Handle
forall stdin stdout stderr.
[(String, String)]
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setEnv [(String, String)]
targetEnv (ProcessConfig () Handle Handle -> ProcessConfig () Handle Handle)
-> ProcessConfig () Handle Handle -> ProcessConfig () Handle Handle
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STOutput Handle
-> ProcessConfig () () Handle -> ProcessConfig () Handle Handle
forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout StreamSpec 'STOutput Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
createPipe (ProcessConfig () () Handle -> ProcessConfig () Handle Handle)
-> ProcessConfig () () Handle -> ProcessConfig () Handle Handle
forall a b. (a -> b) -> a -> b
$ StreamSpec 'STOutput Handle
-> ProcessConfig () () () -> ProcessConfig () () Handle
forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr StreamSpec 'STOutput Handle
forall (anyStreamType :: StreamType).
StreamSpec anyStreamType Handle
createPipe (ProcessConfig () () () -> ProcessConfig () () Handle)
-> ProcessConfig () () () -> ProcessConfig () () Handle
forall a b. (a -> b) -> a -> b
$ String -> ProcessConfig () () ()
shell (Text -> String
forall a. ToString a => a -> String
toString Text
cmd)
  IO (Bool, Text) -> m (Bool, Text)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
    (IO (Bool, Text) -> m (Bool, Text))
-> IO (Bool, Text) -> m (Bool, Text)
forall a b. (a -> b) -> a -> b
$ ProcessConfig () Handle Handle
-> (Process () Handle Handle -> IO (Bool, Text)) -> IO (Bool, Text)
forall (m :: * -> *) stdin stdout stderr a.
MonadUnliftIO m =>
ProcessConfig stdin stdout stderr
-> (Process stdin stdout stderr -> m a) -> m a
withProcessWait ProcessConfig () Handle Handle
pc
    ((Process () Handle Handle -> IO (Bool, Text)) -> IO (Bool, Text))
-> (Process () Handle Handle -> IO (Bool, Text)) -> IO (Bool, Text)
forall a b. (a -> b) -> a -> b
$ \Process () Handle Handle
p -> do
      Async a
spinner <- IO (Async a)
spinnerM
      ExitCode
status <- Process () Handle Handle -> IO ExitCode
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m ExitCode
waitExitCode Process () Handle Handle
p
      Async String
errCapture <- IO String -> IO (Async String)
forall a. IO a -> IO (Async a)
async (IO String -> IO (Async String)) -> IO String -> IO (Async String)
forall a b. (a -> b) -> a -> b
$ do
        String
content <- Handle -> IO String
TIO.hGetContents (Process () Handle Handle -> Handle
forall stdin stdout stderr. Process stdin stdout stderr -> stderr
getStderr Process () Handle Handle
p)
        String -> IO String
forall a. a -> IO a
evaluate (String -> String
forall a. NFData a => a -> a
force String
content)
      Async a -> IO ()
forall a. Async a -> IO ()
cancel Async a
spinner
      String
rawLogsText <- Async String -> IO String
forall a. Async a -> IO a
wait Async String
errCapture
      let logsText :: Text
logsText = String -> Text
T.pack String
rawLogsText
      case ExitCode
status of
        ExitCode
ExitSuccess -> do
          (Bool, Text) -> IO (Bool, Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
True, Text
logsText)
        ExitCode
_ -> do
          (Bool, Text) -> IO (Bool, Text)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
False, Text
logsText)

inheritRun :: (MonadIO m) => FilePath -> Text -> m ()
inheritRun :: forall (m :: * -> *). MonadIO m => String -> Text -> m ()
inheritRun String
yamlPath Text
cmd = do
  [(String, String)]
targetEnv <- String -> m [(String, String)]
forall (m :: * -> *). MonadIO m => String -> m [(String, String)]
provideYamlPath String
yamlPath
  let processConfig :: ProcessConfig () () ()
processConfig = [(String, String)]
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdout stderr.
[(String, String)]
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setEnv [(String, String)]
targetEnv (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () () -> ProcessConfig () () ()
forall a b. (a -> b) -> a -> b
$ String -> [String] -> ProcessConfig () () ()
proc String
"/bin/sh" [String
"-c", Text -> String
forall a. ToString a => a -> String
toString Text
cmd]
  IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ProcessConfig () () () -> IO ()
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr -> m ()
runProcess_ ProcessConfig () () ()
processConfig)