{-# 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
  ProcessConfig () () () -> IO P
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr
-> m (Process stdin stdout stderr)
startProcess ProcessConfig () () ()
processConfig IO P -> (P -> IO ExitCode) -> IO ExitCode
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= P -> IO ExitCode
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 <- ProcessConfig () () () -> IO P
forall (m :: * -> *) stdin stdout stderr.
MonadIO m =>
ProcessConfig stdin stdout stderr
-> m (Process stdin stdout stderr)
startProcess ProcessConfig () () ()
processConfig
  ProcessHandle -> IO ProcessHandle
forall a. a -> IO a
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 :: ProcessHandle -> P
processHandleProcess :: P
..} = P -> IO ExitCode
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
runSettingCommand :: Command
runSettingExtraEnv :: Map String String
runSettingWorkingDir :: Maybe (Path Abs Dir)
runSettingCommand :: RunSettings -> Command
runSettingExtraEnv :: RunSettings -> Map String String
runSettingWorkingDir :: RunSettings -> Maybe (Path Abs Dir)
..} = do
  let RunSettings Command
_ Map String String
_ Maybe (Path Abs Dir)
_ = RunSettings
forall a. HasCallStack => a
undefined
  -- Set up the environment
  [(String, String)]
env <- IO [(String, String)]
System.getEnvironment
  let envForProcess :: [(String, String)]
envForProcess = Map String String -> [(String, String)]
forall k a. Map k a -> [(k, a)]
M.toList (Map String String -> [(String, String)])
-> Map String String -> [(String, String)]
forall a b. (a -> b) -> a -> b
$ Map String String -> Map String String -> Map String String
forall k a. Ord k => Map k a -> Map k a -> Map k a
M.union Map String String
runSettingExtraEnv ([(String, String)] -> Map String String
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
    CommandScript String
s -> do
      -- Write the script to a file
      Path Abs Dir
systemTempDir <- IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getTempDir
      Path Abs Dir -> IO ()
forall (m :: * -> *) b. MonadIO m => Path b Dir -> m ()
ensureDir Path Abs Dir
systemTempDir
      Path Abs Dir
tempDir <- Path Abs Dir -> String -> IO (Path Abs Dir)
forall (m :: * -> *) b.
MonadIO m =>
Path b Dir -> String -> m (Path Abs Dir)
createTempDir Path Abs Dir
systemTempDir String
"feedback"
      Path Abs File
scriptFile <- Path Abs Dir -> String -> IO (Path Abs File)
forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> String -> m (Path Abs File)
resolveFile Path Abs Dir
tempDir String
"feedback-script.sh"
      String -> ByteString -> IO ()
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 <- Path Abs File -> IO Permissions
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
      Path Abs File -> Permissions -> IO ()
forall (m :: * -> *) b t.
MonadIO m =>
Path b t -> Permissions -> m ()
setPermissions Path Abs File
scriptFile Permissions
newPermissions

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

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

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