Trace.hs

{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Copyright: © 2018-2020 IOHK
-- License: Apache-2.0
--
-- Provides functions for setting up and capturing logging so that expectations
-- about logging can be asserted in test scenarios.

module Test.Utils.Trace
     ( withLogging
     , withLogging'
     , captureLogging
     , captureLogging'
     , traceSpec
     ) where

import Prelude


import Cardano.BM.Trace
    ( traceInTVarIO )
import Control.Monad.IO.Unlift
    ( MonadIO (..), MonadUnliftIO (..) )
import Control.Tracer
    ( Tracer, natTracer )
import Data.Text.Class
    ( ToText (..) )
import Say
    ( say )
import Test.Hspec
    ( HasCallStack, Spec, SpecWith, around )
import UnliftIO.Exception
    ( onException )
import UnliftIO.STM
    ( newTVarIO, readTVarIO )

-- | Run an action with a logging 'Trace' object, and a function to get all
-- messages that have been traced.
withLogging :: MonadUnliftIO m => ((Tracer m msg, m [msg]) -> m a) -> m a
withLogging = withLogging'

-- | Same as 'withLogging', but with a different Tracer monad.
withLogging' :: forall m mtr msg a. (MonadUnliftIO m, MonadIO mtr) => ((Tracer mtr msg, m [msg]) -> m a) -> m a
withLogging' action = do
    tvar <- newTVarIO []
    let getMsgs = reverse <$> readTVarIO tvar
    action (natTracer liftIO (traceInTVarIO tvar), getMsgs)

-- | Run an action with a 'Trace', returning captured log messages along with
-- the result of the action.
captureLogging :: MonadUnliftIO m => (Tracer m msg -> m a) -> m ([msg], a)
captureLogging = captureLogging'

-- | Same as 'captureLogging', but with a different Tracer monad.
captureLogging' :: forall m mtr msg a. (MonadUnliftIO m, MonadIO mtr) => (Tracer mtr msg -> m a) -> m ([msg], a)
captureLogging' action = withLogging' @m @mtr $ \(tr, getMsgs) -> do
    res <- action tr
    msgs <- getMsgs
    pure (msgs, res)

-- | Provides a Tracer to the spec, which is silent, unless something goes
-- wrong. In that case, it dumps all the traces it has collected to stdout.
traceSpec :: (HasCallStack, ToText msg) => SpecWith (Tracer IO msg) -> Spec
traceSpec = around $ \spec -> withLogging $ \(tr, getMsgs) -> do
    let dumpLogs = getMsgs >>= mapM_ (say . toText)
        rule s = say ("--- Failed spec logs " <> s <> " ---")
        explain a = rule "BEGIN" *> a <* rule "END"
    spec tr `onException` explain dumpLogs