Set the environment for a given loop

feedback/src/Feedback/Common/OptParse.hs

@@ -28,6 +28,7 @@ import Paths_feedback
 
 data LoopSettings = LoopSettings
   { loopSettingCommand :: !String,
+    loopSettingExtraEnv :: !(Map String String),
     loopSettingOutputSettings :: !OutputSettings
   }
   deriving (Show, Eq, Generic)
@@ -36,6 +37,7 @@ combineToLoopSettings :: Flags -> Environment -> Maybe OutputConfiguration -> Lo
 combineToLoopSettings Flags {..} Environment {} mDefaultOutputConfig LoopConfiguration {..} = do
   let loopSettingCommand = loopConfigCommand
   let outputConfig = liftA2 (<>) loopConfigOutputConfiguration mDefaultOutputConfig
+  let loopSettingExtraEnv = loopConfigExtraEnv
   let loopSettingOutputSettings = combineToOutputSettings flagOutputFlags outputConfig
   pure LoopSettings {..}
 
@@ -65,6 +67,7 @@ instance HasCodec Configuration where
 
 data LoopConfiguration = LoopConfiguration
   { loopConfigCommand :: !String,
+    loopConfigExtraEnv :: !(Map String String),
     loopConfigOutputConfiguration :: !(Maybe OutputConfiguration)
   }
   deriving stock (Show, Eq, Generic)
@@ -78,19 +81,23 @@ instance HasCodec LoopConfiguration where
           object "LoopConfiguration" $
             LoopConfiguration
               <$> requiredField "command" "the command to run on change" .= loopConfigCommand
+              <*> optionalFieldWithOmittedDefault "env" M.empty "extra environment variables to set" .= loopConfigExtraEnv
               <*> optionalField "output" "output configuration for this loop" .= loopConfigOutputConfiguration
     where
       f = \case
         Left c -> makeLoopConfiguration c
         Right loopConfig -> loopConfig
-      g loopConfig@(LoopConfiguration c mOutputConfig) = case mOutputConfig of
-        Nothing -> Left c
-        Just _ -> Right loopConfig
+      g loopConfig =
+        let c = loopConfigCommand loopConfig
+         in if loopConfig == makeLoopConfiguration c
+              then Left c
+              else Right loopConfig
 
 makeLoopConfiguration :: String -> LoopConfiguration
 makeLoopConfiguration c =
   LoopConfiguration
     { loopConfigCommand = c,
+      loopConfigExtraEnv = M.empty,
       loopConfigOutputConfiguration = Nothing
     }
 

feedback/src/Feedback/Common/Process.hs

@@ -2,6 +2,9 @@
 
 module Feedback.Common.Process where
 
+import Data.Map as M
+import qualified Data.Map as M
+import System.Environment (getEnvironment)
 import System.Exit
 import System.Process.Typed as Typed
 import UnliftIO
@@ -13,26 +16,30 @@ data ProcessHandle = ProcessHandle
 
 type P = Process () () ()
 
-startProcessAndWait :: String -> IO ExitCode
-startProcessAndWait command = do
-  let processConfig = processConfigFor command
+startProcessAndWait :: Map String String -> String -> IO ExitCode
+startProcessAndWait extraEnv command = do
+  processConfig <- makeProcessConfigFor extraEnv command
   startProcess processConfig >>= waitExitCode
 
-startProcessHandle :: (ExitCode -> IO ()) -> String -> IO ProcessHandle
-startProcessHandle waiterFunc command = do
-  let processConfig = processConfigFor command
+startProcessHandle :: (ExitCode -> IO ()) -> Map String String -> String -> IO ProcessHandle
+startProcessHandle waiterFunc extraEnv command = do
+  processConfig <- makeProcessConfigFor extraEnv command
   processHandleProcess <- startProcess processConfig
   processHandleWaiter <- async $ do
     ec <- waitExitCode processHandleProcess
     waiterFunc ec
   pure ProcessHandle {..}
 
-processConfigFor :: String -> ProcessConfig () () ()
-processConfigFor =
-  setStdout inherit
-    . setStderr inherit
-    . setStdin closed -- TODO make this configurable?
-    . shell
+makeProcessConfigFor :: Map String String -> String -> IO (ProcessConfig () () ())
+makeProcessConfigFor extraEnv command = do
+  env <- getEnvironment
+  let envForProcess = M.toList $ M.union extraEnv (M.fromList env)
+  pure $
+    setStdout inherit
+      . setStderr inherit
+      . setStdin closed -- TODO make this configurable?
+      . setEnv envForProcess
+      $ shell command
 
 stopProcessHandle :: ProcessHandle -> IO ()
 stopProcessHandle ProcessHandle {..} = do

feedback/src/Feedback/Loop.hs

@@ -6,6 +6,7 @@ module Feedback.Loop where
 
 import Control.Monad
 import Data.List
+import Data.Map (Map)
 import qualified Data.Text as T
 import Data.Word
 import Feedback.Common.OptParse
@@ -38,7 +39,7 @@ runFeedbackLoop = do
         $ \event -> do
           writeChan eventChan event
     concurrently_
-      (processWorker loopSettingCommand eventChan outputChan)
+      (processWorker loopSettingExtraEnv loopSettingCommand eventChan outputChan)
       (outputWorker loopSettingOutputSettings outputChan)
     stopListeningAction
 
@@ -72,8 +73,8 @@ isHiddenIn curdir ad =
     Nothing -> False
     Just rp -> "." `isPrefixOf` toFilePath rp
 
-processWorker :: String -> Chan FS.Event -> Chan Output -> IO ()
-processWorker command eventChan outputChan = do
+processWorker :: Map String String -> String -> Chan FS.Event -> Chan Output -> IO ()
+processWorker extraEnv command eventChan outputChan = do
   let sendOutput = writeChan outputChan
   currentProcessVar <- newEmptyMVar
   let startNewProcess = do
@@ -84,6 +85,7 @@ processWorker command eventChan outputChan = do
         processHandle <-
           startProcessHandle
             endFunc
+            extraEnv
             command
         putMVar currentProcessVar processHandle
         sendOutput $ OutputProcessStarted command

feedback/src/Feedback/Test.hs

@@ -21,7 +21,7 @@ runFeedbackTest = do
     put [indicatorChunk "testing ", " ", loopNameChunk loopName]
     put [indicatorChunk "starting", " ", commandChunk loopSettingCommand]
     start <- getMonotonicTimeNSec
-    ec <- startProcessAndWait loopSettingCommand
+    ec <- startProcessAndWait loopSettingExtraEnv loopSettingCommand
     end <- getMonotonicTimeNSec
     put $ exitCodeChunks ec
     let duration = end - start