Interaction.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE OverloadedStrings #-}

module Interaction (interactWithProcess, expect, respond) where

import Conduit
import Data.Conduit.Process.Typed
import qualified Data.Text.IO as Text (putStr, putStrLn)
import RIO hiding (log)
import qualified RIO.Text as Text
import qualified RIO.Text.Partial as Text
import Prelude hiding (log)

interactWithProcess :: String -> ConduitM Text Text (ResourceT IO) () -> IO ()
interactWithProcess command interactor = do
  let processConfig =
        shell command
          & setStdout createSource
          & setStdin createSink
  withProcessWait_ processConfig \process ->
    runConduitRes $
      getStdout process
        .| decodeUtf8C
        .| interactor
        .| unlinesC
        .| encodeUtf8C
        .| getStdin process

expect :: MonadIO m => Text -> ConduitT Text o m ()
expect text = loop
  where
    loop = do
      -- TODO this doesn't play nicely when the underlying program uses stderr
      --      we'd need to capture their stderr as well to solve this.
      log $ dim <> "Waiting for '" <> text <> "'" <> reset
      -- TODO Ideally, we'd be able to time out if we never have the message we expect.
      --      However, we can't do this inside a conduit. The solution would be to make a custom source that is able to time out on reading the process handle.
      value <- await
      log erase
      case value of
        Just v -> go v
        Nothing -> do
          liftIO . Text.putStrLn $
            "Expected '" <> text <> "' but reached end of input"
          exitFailure
    go x = do
      if text `Text.isInfixOf` x
        then do
          log . Text.replace text (underline <> text <> reset) $ x
          return ()
        else do
          log x
          loop

respond :: MonadIO m => Text -> ConduitT i Text m ()
respond text = do
  liftIO . Text.putStrLn $ bold <> text <> reset
  yield text

log :: MonadIO m => Text -> m ()
log text = do
  liftIO (Text.putStr text)
  hFlush stdout

bold :: Text
bold = "\ESC[1m"

dim :: Text
dim = "\ESC[2m"

underline :: Text
underline = "\ESC[4m"

reset :: Text
reset = "\ESC[0m"

erase :: Text
erase = "\r\ESC[K"