-- | Provides types for typical "IO" processes.
module Shrun.IO.Types
  ( Stderr (..),
    CommandResult (..),
    ReadHandleResult (..),
    readHandleResultToStderr,
    readHandle,
  )
where

import Data.Time.Relative (RelativeTime)
import Effects.FileSystem.HandleReader
  ( MonadHandleReader (hIsClosed),
    hGetNonBlocking,
    hIsReadable,
  )
import Shrun.Data.Text (UnlinedText)
import Shrun.Data.Text qualified as ShrunText
import Shrun.Prelude

-- | Newtype wrapper for stderr.
newtype Stderr = MkStderr {Stderr -> List UnlinedText
unStderr :: List UnlinedText}
  deriving stock (Stderr -> Stderr -> Bool
(Stderr -> Stderr -> Bool)
-> (Stderr -> Stderr -> Bool) -> Eq Stderr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Stderr -> Stderr -> Bool
== :: Stderr -> Stderr -> Bool
$c/= :: Stderr -> Stderr -> Bool
/= :: Stderr -> Stderr -> Bool
Eq, Int -> Stderr -> ShowS
[Stderr] -> ShowS
Stderr -> String
(Int -> Stderr -> ShowS)
-> (Stderr -> String) -> ([Stderr] -> ShowS) -> Show Stderr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Stderr -> ShowS
showsPrec :: Int -> Stderr -> ShowS
$cshow :: Stderr -> String
show :: Stderr -> String
$cshowList :: [Stderr] -> ShowS
showList :: [Stderr] -> ShowS
Show)

-- | Result of running a command.
data CommandResult
  = CommandSuccess RelativeTime
  | CommandFailure RelativeTime Stderr
  deriving stock (CommandResult -> CommandResult -> Bool
(CommandResult -> CommandResult -> Bool)
-> (CommandResult -> CommandResult -> Bool) -> Eq CommandResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CommandResult -> CommandResult -> Bool
== :: CommandResult -> CommandResult -> Bool
$c/= :: CommandResult -> CommandResult -> Bool
/= :: CommandResult -> CommandResult -> Bool
Eq, Int -> CommandResult -> ShowS
[CommandResult] -> ShowS
CommandResult -> String
(Int -> CommandResult -> ShowS)
-> (CommandResult -> String)
-> ([CommandResult] -> ShowS)
-> Show CommandResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CommandResult -> ShowS
showsPrec :: Int -> CommandResult -> ShowS
$cshow :: CommandResult -> String
show :: CommandResult -> String
$cshowList :: [CommandResult] -> ShowS
showList :: [CommandResult] -> ShowS
Show)

-- | Result from reading a handle. The ordering is based on:
--
-- @
-- 'ReadErr' _ < 'ReadNoData' < 'ReadSuccess'
-- @
--
-- The 'Semigroup' instance is based on this ordering, taking the greatest
-- element. For identical constructors, the left argument is taken.
data ReadHandleResult
  = -- | Error encountered while trying to read a handle.
    ReadErr (List UnlinedText)
  | -- | Successfully read data from the handle.
    ReadSuccess (List UnlinedText)
  | -- | Successfully read no data from the handle.
    ReadNoData
  deriving stock (ReadHandleResult -> ReadHandleResult -> Bool
(ReadHandleResult -> ReadHandleResult -> Bool)
-> (ReadHandleResult -> ReadHandleResult -> Bool)
-> Eq ReadHandleResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ReadHandleResult -> ReadHandleResult -> Bool
== :: ReadHandleResult -> ReadHandleResult -> Bool
$c/= :: ReadHandleResult -> ReadHandleResult -> Bool
/= :: ReadHandleResult -> ReadHandleResult -> Bool
Eq, Int -> ReadHandleResult -> ShowS
[ReadHandleResult] -> ShowS
ReadHandleResult -> String
(Int -> ReadHandleResult -> ShowS)
-> (ReadHandleResult -> String)
-> ([ReadHandleResult] -> ShowS)
-> Show ReadHandleResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReadHandleResult -> ShowS
showsPrec :: Int -> ReadHandleResult -> ShowS
$cshow :: ReadHandleResult -> String
show :: ReadHandleResult -> String
$cshowList :: [ReadHandleResult] -> ShowS
showList :: [ReadHandleResult] -> ShowS
Show)

instance Semigroup ReadHandleResult where
  ReadSuccess List UnlinedText
l <> :: ReadHandleResult -> ReadHandleResult -> ReadHandleResult
<> ReadHandleResult
_ = List UnlinedText -> ReadHandleResult
ReadSuccess List UnlinedText
l
  ReadHandleResult
_ <> ReadSuccess List UnlinedText
r = List UnlinedText -> ReadHandleResult
ReadSuccess List UnlinedText
r
  ReadErr List UnlinedText
l <> ReadHandleResult
_ = List UnlinedText -> ReadHandleResult
ReadErr List UnlinedText
l
  ReadHandleResult
_ <> ReadErr List UnlinedText
r = List UnlinedText -> ReadHandleResult
ReadErr List UnlinedText
r
  ReadHandleResult
_ <> ReadHandleResult
_ = ReadHandleResult
ReadNoData

instance Monoid ReadHandleResult where
  mempty :: ReadHandleResult
mempty = ReadHandleResult
ReadNoData

-- | Turns a 'ReadHandleResult' into a 'Stderr'.
readHandleResultToStderr :: ReadHandleResult -> Stderr
readHandleResultToStderr :: ReadHandleResult -> Stderr
readHandleResultToStderr ReadHandleResult
ReadNoData = List UnlinedText -> Stderr
MkStderr (List UnlinedText -> Stderr) -> List UnlinedText -> Stderr
forall a b. (a -> b) -> a -> b
$ Text -> List UnlinedText
ShrunText.fromText Text
"<No data>"
readHandleResultToStderr (ReadErr List UnlinedText
errs) = List UnlinedText -> Stderr
MkStderr List UnlinedText
errs
readHandleResultToStderr (ReadSuccess List UnlinedText
errs) = List UnlinedText -> Stderr
MkStderr List UnlinedText
errs

-- | Attempts to read from the handle.
readHandle ::
  ( HasCallStack,
    MonadCatch m,
    MonadHandleReader m
  ) =>
  Int ->
  Handle ->
  m ReadHandleResult
readHandle :: forall (m :: Type -> Type).
(HasCallStack, MonadCatch m, MonadHandleReader m) =>
Int -> Handle -> m ReadHandleResult
readHandle Int
blockSize Handle
handle = do
  -- The "nothingIfReady" check and reading step both need to go in the try as
  -- the former can also throw.
  m ReadHandleResult -> m (Either SomeException ReadHandleResult)
forall (m :: Type -> Type) a.
(HasCallStack, MonadCatch m) =>
m a -> m (Either SomeException a)
tryAny m ReadHandleResult
readHandle' m (Either SomeException ReadHandleResult)
-> (Either SomeException ReadHandleResult -> ReadHandleResult)
-> m ReadHandleResult
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Left SomeException
ex -> List UnlinedText -> ReadHandleResult
ReadErr (List UnlinedText -> ReadHandleResult)
-> List UnlinedText -> ReadHandleResult
forall a b. (a -> b) -> a -> b
$ Text -> List UnlinedText
ShrunText.fromText (Text -> List UnlinedText) -> Text -> List UnlinedText
forall a b. (a -> b) -> a -> b
$ Text
"HandleException: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeException -> Text
forall e. Exception e => e -> Text
displayExceptiont SomeException
ex
    Right ReadHandleResult
x -> ReadHandleResult
x
  where
    readHandle' :: m ReadHandleResult
readHandle' =
      m (Maybe Text)
nothingIfReady m (Maybe Text)
-> (Maybe Text -> m ReadHandleResult) -> m ReadHandleResult
forall a b. m a -> (a -> m b) -> m b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just Text
err -> ReadHandleResult -> m ReadHandleResult
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (ReadHandleResult -> m ReadHandleResult)
-> ReadHandleResult -> m ReadHandleResult
forall a b. (a -> b) -> a -> b
$ List UnlinedText -> ReadHandleResult
ReadErr (List UnlinedText -> ReadHandleResult)
-> List UnlinedText -> ReadHandleResult
forall a b. (a -> b) -> a -> b
$ Text -> List UnlinedText
ShrunText.fromText Text
err
        Maybe Text
Nothing ->
          -- NOTE: [Blocking / Streaming output]
          --
          -- hGetNonBlocking is suboptimal because we might take
          -- multiple lines of output, hence log them on a single line, which
          -- is quite ugly. Something like hGetLine would be ideal, but try
          -- as we might we cannot get this to stream properly (logs are
          -- buffered until the process finishes). Thus we have settled on
          -- a workaround: Use the following non blocking call which streams
          -- properly, and manually split the lines ourselves. The block size
          -- should be large enough that we are not likely to cut off a line
          -- prematurely, but obviously this is best-effort.
          Handle -> Int -> m ByteString
forall (m :: Type -> Type).
(MonadHandleReader m, HasCallStack) =>
Handle -> Int -> m ByteString
hGetNonBlocking Handle
handle Int
blockSize m ByteString
-> (ByteString -> ReadHandleResult) -> m ReadHandleResult
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
            ByteString
"" -> ReadHandleResult
ReadNoData
            ByteString
bs -> List UnlinedText -> ReadHandleResult
ReadSuccess (Text -> List UnlinedText
ShrunText.fromText (Text -> List UnlinedText) -> Text -> List UnlinedText
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
decodeUtf8Lenient ByteString
bs)

    nothingIfReady :: m (Maybe Text)
nothingIfReady = do
      -- NOTE: This somewhat torturous logic exists for a reason. We want to
      -- check several conditions before attempting to read from our handle,
      -- but we have to do this in a specific order as some of these boolean
      -- functions will throw exceptions under some circumstances, which we
      -- would like to avoid.
      --
      -- Note that this description comes from experience and reading the
      -- GHC source, so it may not be completely accurate.

      -- hIsClosed does not explicitly throw exceptions so it can be first.
      Bool
isClosed <- Handle -> m Bool
forall (m :: Type -> Type).
(MonadHandleReader m, HasCallStack) =>
Handle -> m Bool
hIsClosed Handle
handle
      if Bool
isClosed
        then Maybe Text -> m (Maybe Text)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe Text -> m (Maybe Text)) -> Maybe Text -> m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Handle closed"
        else do
          -- hIsReadable _does_ throw an exception if the the handle is closed or
          -- "semi-closed". Thus it should go after the hIsClosed check
          -- (GHC explicitly does not export an hSemiClosed).
          Bool
isReadable <- Handle -> m Bool
forall (m :: Type -> Type).
(MonadHandleReader m, HasCallStack) =>
Handle -> m Bool
hIsReadable Handle
handle
          if Bool -> Bool
not Bool
isReadable
            then Maybe Text -> m (Maybe Text)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (Maybe Text -> m (Maybe Text)) -> Maybe Text -> m (Maybe Text)
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"Handle is not readable"
            else Maybe Text -> m (Maybe Text)
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe Text
forall a. Maybe a
Nothing

-- NOTE: [EOF / blocking error] We would like to check hIsEOF (definitely
-- causes errors at the end) and probably hReady as well, but these both
-- block and I have not found a way to invoke them while also streaming
-- the process output (blocks until everything gets dumped at the end).