module Hydra.LoggingSpec where

import Hydra.Prelude
import Test.Hydra.Prelude

import Control.Exception (AsyncException (StackOverflow), IOException, throw)
import Control.Tracer.JSON (defaultLogBuffering, defaultQueueSize, traceWith, withTracerOutputTo)
import Data.Aeson (object, (.=))
import Data.Text.IO qualified as Text.IO
import System.FilePath ((</>))
import System.IO (hClose)
import System.Process (createPipe)

spec :: Spec
spec :: Spec
spec = do
  [Char] -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"dumps logs to the given handle in JSON" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$ do
    -- Write to a file handle instead of capturing the process-global stdout:
    -- capturing swaps the stdout file descriptor under every concurrently
    -- running test and raced the tracer's own shutdown flush.
    [Char] -> ([Char] -> IO ()) -> IO ()
forall (m :: * -> *) r.
(MonadIO m, MonadMask m) =>
[Char] -> ([Char] -> m r) -> m r
withTempDir [Char]
"logging-spec" (([Char] -> IO ()) -> IO ()) -> ([Char] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \[Char]
dir -> do
      let logFile :: [Char]
logFile = [Char]
dir [Char] -> [Char] -> [Char]
</> [Char]
"log.jsonl"
      [Char] -> IOMode -> (Handle -> IO ()) -> IO ()
forall a. [Char] -> IOMode -> (Handle -> IO a) -> IO a
withFile [Char]
logFile IOMode
WriteMode ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
        BufferMode -> Handle -> Text -> (Tracer IO Value -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadIO m, MonadFork m, MonadTime m, ToJSON msg) =>
BufferMode -> Handle -> Text -> (Tracer m msg -> IO a) -> IO a
withTracerOutputTo BufferMode
LineBuffering Handle
h Text
"test" ((Tracer IO Value -> IO ()) -> IO ())
-> (Tracer IO Value -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO Value
tracer ->
          Tracer IO Value -> Value -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO Value
tracer ([Pair] -> Value
object [Key
"foo" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int
42 :: Int)])
      ByteString
captured <- [Char] -> IO ByteString
forall (m :: * -> *). MonadIO m => [Char] -> m ByteString
readFileBS [Char]
logFile
      Text -> [Char]
forall a. ToString a => a -> [Char]
toString (forall a b. ConvertUtf8 a b => b -> a
decodeUtf8 @Text ByteString
captured) [Char] -> [Char] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Char]
"{\"foo\":42}"

  -- A pipe is what a log reader actually gets, and unlike a file it cannot be
  -- satisfied after the fact by the flush on tracer shutdown.
  [Char] -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"flushes entries without waiting for the buffer to fill" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    ((Handle, Handle) -> IO ()) -> IO ()
forall a. ((Handle, Handle) -> IO a) -> IO a
withPipe (((Handle, Handle) -> IO ()) -> IO ())
-> ((Handle, Handle) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Handle
readEnd, Handle
writeEnd) ->
      BufferMode -> Handle -> Text -> (Tracer IO Value -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadIO m, MonadFork m, MonadTime m, ToJSON msg) =>
BufferMode -> Handle -> Text -> (Tracer m msg -> IO a) -> IO a
withTracerOutputTo BufferMode
defaultLogBuffering Handle
writeEnd Text
"test" ((Tracer IO Value -> IO ()) -> IO ())
-> (Tracer IO Value -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO Value
tracer -> do
        Tracer IO Value -> Value -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO Value
tracer ([Pair] -> Value
object [Key
"foo" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= (Int
42 :: Int)])
        -- The writer thread is asynchronous, so this blocks until it has both
        -- written and flushed the entry.
        Text
line <- NominalDiffTime -> IO Text -> IO Text
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO Text -> IO Text) -> IO Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Handle -> IO Text
Text.IO.hGetLine Handle
readEnd
        Text -> [Char]
forall a. ToString a => a -> [Char]
toString Text
line [Char] -> [Char] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Char]
"{\"foo\":42}"

  [Char] -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"keeps logging after the reader of its output has gone away" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    ((Handle, Handle) -> IO ()) -> IO ()
forall a. ((Handle, Handle) -> IO a) -> IO a
withPipe (((Handle, Handle) -> IO ()) -> IO ())
-> ((Handle, Handle) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Handle
readEnd, Handle
writeEnd) ->
      BufferMode -> Handle -> Text -> (Tracer IO Value -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadIO m, MonadFork m, MonadTime m, ToJSON msg) =>
BufferMode -> Handle -> Text -> (Tracer m msg -> IO a) -> IO a
withTracerOutputTo BufferMode
defaultLogBuffering Handle
writeEnd Text
"test" ((Tracer IO Value -> IO ()) -> IO ())
-> (Tracer IO Value -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO Value
tracer -> do
        Handle -> IO ()
hClose Handle
readEnd
        -- Writing to a pipe nobody reads raises an IOException, as GHC ignores
        -- SIGPIPE. The writer has to survive that: were it to die, the queue
        -- would fill and every subsequent 'traceWith' would block forever.
        NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
defaultQueueSize :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i ->
            Tracer IO Value -> Value -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO Value
tracer ([Pair] -> Value
object [Key
"foo" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
i])

  -- A 'ToJSON' reachable from a traced type can be
  -- partial: the node traces client inputs, and a side-loaded snapshot's
  -- accumulator hash is a lazy thunk that calls 'error' above the trusted
  -- setup's capacity. The encode runs here, on the writer thread, not at the
  -- 'traceWith' call site -- and this thread is unlinked, so its death is
  -- invisible until the queue fills and the whole process wedges.
  [Char] -> IO () -> SpecWith (Arg (IO ()))
forall a.
(HasCallStack, Example a) =>
[Char] -> a -> SpecWith (Arg a)
it [Char]
"keeps logging when a message's ToJSON throws" (IO () -> SpecWith (Arg (IO ())))
-> IO () -> SpecWith (Arg (IO ()))
forall a b. (a -> b) -> a -> b
$
    ((Handle, Handle) -> IO ()) -> IO ()
forall a. ((Handle, Handle) -> IO a) -> IO a
withPipe (((Handle, Handle) -> IO ()) -> IO ())
-> ((Handle, Handle) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Handle
readEnd, Handle
writeEnd) ->
      BufferMode
-> Handle -> Text -> (Tracer IO Loggable -> IO ()) -> IO ()
forall (m :: * -> *) msg a.
(MonadIO m, MonadFork m, MonadTime m, ToJSON msg) =>
BufferMode -> Handle -> Text -> (Tracer m msg -> IO a) -> IO a
withTracerOutputTo BufferMode
defaultLogBuffering Handle
writeEnd Text
"test" ((Tracer IO Loggable -> IO ()) -> IO ())
-> (Tracer IO Loggable -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Tracer IO Loggable
tracer -> do
        [Loggable] -> (Loggable -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Loggable
Unencodable, Loggable
Overflowing, Loggable
Undescribable] ((Loggable -> IO ()) -> IO ()) -> (Loggable -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Loggable
poison -> do
          Tracer IO Loggable -> Loggable -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO Loggable
tracer Loggable
poison
          -- Loudly, not silently: the offending entry is replaced by a
          -- diagnostic one rather than dropped.
          Text
line <- NominalDiffTime -> IO Text -> IO Text
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO Text -> IO Text) -> IO Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Handle -> IO Text
Text.IO.hGetLine Handle
readEnd
          Text -> [Char]
forall a. ToString a => a -> [Char]
toString Text
line [Char] -> [Char] -> IO ()
forall a. (HasCallStack, Show a, Eq a) => [a] -> [a] -> IO ()
`shouldContain` [Char]
"UnencodableLogEntry"
        -- And the writer is still draining, so nothing blocks.
        NominalDiffTime -> IO () -> IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTimer m, MonadThrow m) =>
NominalDiffTime -> m a -> m a
failAfter NominalDiffTime
5 (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
          [Int] -> (Int -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Int
1 .. Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
defaultQueueSize :: Int] ((Int -> IO ()) -> IO ()) -> (Int -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Int
i -> do
            Tracer IO Loggable -> Loggable -> IO ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer IO Loggable
tracer (Int -> Loggable
Encodable Int
i)
            IO Text -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Text -> IO ()) -> IO Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> IO Text
Text.IO.hGetLine Handle
readEnd
 where
  withPipe :: ((Handle, Handle) -> IO a) -> IO a
  withPipe :: forall a. ((Handle, Handle) -> IO a) -> IO a
withPipe = IO (Handle, Handle)
-> ((Handle, Handle) -> IO ())
-> ((Handle, Handle) -> IO a)
-> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
forall (m :: * -> *) a b c.
MonadThrow m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket IO (Handle, Handle)
createPipe (((Handle, Handle) -> IO ()) -> ((Handle, Handle) -> IO a) -> IO a)
-> ((Handle, Handle) -> IO ())
-> ((Handle, Handle) -> IO a)
-> IO a
forall a b. (a -> b) -> a -> b
$ \(Handle
readEnd, Handle
writeEnd) ->
    [Handle] -> (Handle -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Handle
readEnd, Handle
writeEnd] ((Handle -> IO ()) -> IO ()) -> (Handle -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Handle
h ->
      Handle -> IO ()
hClose Handle
h IO () -> (IOException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` \(IOException
_ :: IOException) -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

-- | A traced message whose 'ToJSON' is partial, standing in for the node's real
-- ones (an 'Input' carrying a snapshot whose accumulator cannot be committed
-- to).
data Loggable = Unencodable | Overflowing | Undescribable | Encodable Int

instance ToJSON Loggable where
  toJSON :: Loggable -> Value
toJSON = \case
    Loggable
Unencodable -> Text -> Value
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"ToJSON Loggable: deliberately partial"
    -- 'StackOverflow' is an 'AsyncException' but nobody cancelled us: it comes
    -- out of the encoding work itself, so it has to be survived like any other
    -- synchronous failure rather than rethrown.
    Loggable
Overflowing -> AsyncException -> Value
forall a e. Exception e => e -> a
throw AsyncException
StackOverflow
    -- Fails twice: encoding the entry throws, and describing /that/ exception
    -- for the diagnostic entry throws as well. The writer has to survive both.
    Loggable
Undescribable -> Undescribed -> Value
forall a e. Exception e => e -> a
throw Undescribed
Undescribed
    Encodable Int
i -> [Pair] -> Value
object [Key
"foo" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
.= Int
i]

-- | An exception that cannot be rendered, so the diagnostic entry substituted
-- for it cannot be encoded either. 'unencodable' reaches this through
-- 'SomeException''s own 'displayException', which delegates to the wrapped
-- exception's.
data Undescribed = Undescribed
  deriving stock (Int -> Undescribed -> [Char] -> [Char]
[Undescribed] -> [Char] -> [Char]
Undescribed -> [Char]
(Int -> Undescribed -> [Char] -> [Char])
-> (Undescribed -> [Char])
-> ([Undescribed] -> [Char] -> [Char])
-> Show Undescribed
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> Undescribed -> [Char] -> [Char]
showsPrec :: Int -> Undescribed -> [Char] -> [Char]
$cshow :: Undescribed -> [Char]
show :: Undescribed -> [Char]
$cshowList :: [Undescribed] -> [Char] -> [Char]
showList :: [Undescribed] -> [Char] -> [Char]
Show)

instance Exception Undescribed where
  displayException :: Undescribed -> [Char]
displayException Undescribed
_ = Text -> [Char]
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"displayException Undescribed: deliberately partial"