module Hydra.LoggingSpec where

import Hydra.Prelude
import Test.Hydra.Prelude

import Control.Exception (IOException)
import Data.Aeson (object, (.=))
import Data.Text.IO qualified as Text.IO
import Hydra.Logging (defaultLogBuffering, defaultQueueSize, traceWith, withTracerOutputTo)
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])
 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 ()