{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-unused-pattern-binds #-}

module Feedback.Common.Process where

import Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Feedback.Common.OptParse
import Path
import Path.IO
import System.Environment as System (getEnvironment)
import System.Exit
import System.Process.Typed as Typed
import UnliftIO.IO.File

data ProcessHandle = ProcessHandle
  { ProcessHandle -> P
processHandleProcess :: !P
  }

type P = Process () () ()

startProcessAndWait :: RunSettings -> IO ExitCode
startProcessAndWait :: RunSettings -> IO ExitCode
startProcessAndWait RunSettings
runSettings = do
  ProcessConfig () () ()
processConfig <- RunSettings -> IO (ProcessConfig () () ())
makeProcessConfigFor RunSettings
runSettings
  forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr
-> m (Process stdin stdout stderr)
startProcess ProcessConfig () () ()
processConfig forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m ExitCode
waitExitCode

startProcessHandle :: RunSettings -> IO ProcessHandle
startProcessHandle :: RunSettings -> IO ProcessHandle
startProcessHandle RunSettings
runSettings = do
  ProcessConfig () () ()
processConfig <- RunSettings -> IO (ProcessConfig () () ())
makeProcessConfigFor RunSettings
runSettings
  P
processHandleProcess <- forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr
-> m (Process stdin stdout stderr)
startProcess ProcessConfig () () ()
processConfig
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ProcessHandle {P
processHandleProcess :: P
processHandleProcess :: P
..}

waitProcessHandle :: ProcessHandle -> IO ExitCode
waitProcessHandle :: ProcessHandle -> IO ExitCode
waitProcessHandle ProcessHandle {P
processHandleProcess :: P
processHandleProcess :: ProcessHandle -> P
..} = forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m ExitCode
waitExitCode P
processHandleProcess

makeProcessConfigFor :: RunSettings -> IO (ProcessConfig () () ())
makeProcessConfigFor :: RunSettings -> IO (ProcessConfig () () ())
makeProcessConfigFor RunSettings {Maybe (Path Abs Dir)
Map String String
Command
runSettingWorkingDir :: RunSettings -> Maybe (Path Abs Dir)
runSettingExtraEnv :: RunSettings -> Map String String
runSettingCommand :: RunSettings -> Command
runSettingWorkingDir :: Maybe (Path Abs Dir)
runSettingExtraEnv :: Map String String
runSettingCommand :: Command
..} = do
  let RunSettings Command
_ Map String String
_ Maybe (Path Abs Dir)
_ = forall a. HasCallStack => a
undefined
  -- Set up the environment
  [(String, String)]
env <- IO [(String, String)]
System.getEnvironment
  let envForProcess :: [(String, String)]
envForProcess = forall k a. Map k a -> [(k, a)]
M.toList forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map String String
runSettingExtraEnv (forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(String, String)]
env)
  -- Set up the command
  String
commandString <- case Command
runSettingCommand of
    CommandArgs String
c -> forall (f :: * -> *) a. Applicative f => a -> f a
pure String
c
    CommandScript String
s -> do
      -- Write the script to a file
      Path Abs Dir
systemTempDir <- forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getTempDir
      Path Abs File
scriptFile <- forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs File)
resolveFile Path Abs Dir
systemTempDir String
"feedback-script.sh"
      forall (m :: * -> *). MonadIO m => String -> ByteString -> m ()
writeBinaryFileDurableAtomic (Path Abs File -> String
fromAbsFile Path Abs File
scriptFile) (Text -> ByteString
TE.encodeUtf8 (String -> Text
T.pack String
s))
      -- Make the script executable
      Permissions
oldPermissions <- forall (m :: * -> *) b t. MonadIO m => Path b t -> m Permissions
getPermissions Path Abs File
scriptFile
      let newPermissions :: Permissions
newPermissions = Bool -> Permissions -> Permissions
setOwnerExecutable Bool
True Permissions
oldPermissions
      forall (m :: * -> *) b t.
MonadIO m =>
Path b t -> Permissions -> m ()
setPermissions Path Abs File
scriptFile Permissions
newPermissions

      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path Abs File -> String
fromAbsFile Path Abs File
scriptFile

  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$
    forall stdout stdin stdout0 stderr.
StreamSpec 'STOutput stdout
-> ProcessConfig stdin stdout0 stderr
-> ProcessConfig stdin stdout stderr
setStdout forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
inherit
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall stderr stdin stdout stderr0.
StreamSpec 'STOutput stderr
-> ProcessConfig stdin stdout stderr0
-> ProcessConfig stdin stdout stderr
setStderr forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
inherit
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin forall (anyStreamType :: StreamType). StreamSpec anyStreamType ()
nullStream -- TODO make this configurable?
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall stdin stdout stderr.
[(String, String)]
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setEnv [(String, String)]
envForProcess
      forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall stdin stdout stderr.
String
-> ProcessConfig stdin stdout stderr
-> ProcessConfig stdin stdout stderr
setWorkingDir forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> String
fromAbsDir) Maybe (Path Abs Dir)
runSettingWorkingDir
      forall a b. (a -> b) -> a -> b
$ String -> ProcessConfig () () ()
shell String
commandString

stopProcessHandle :: ProcessHandle -> IO ()
stopProcessHandle :: ProcessHandle -> IO ()
stopProcessHandle ProcessHandle {P
processHandleProcess :: P
processHandleProcess :: ProcessHandle -> P
..} = do
  forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
Process stdin stdout stderr -> m ()
stopProcess P
processHandleProcess
  -- No need to cancel the waiter thread.
  forall (f :: * -> *) a. Applicative f => a -> f a
pure ()