{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
module Control.Monad.Trace (
Tracer, newTracer,
runTraceT, TraceT,
spanSamples, Sample(..), Tags, Logs,
pendingSpanCount,
) where
import Prelude hiding (span)
import Control.Monad.Trace.Class
import Control.Monad.Trace.Internal
import Control.Applicative ((<|>))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (ReaderT(ReaderT), ask, asks, local, runReaderT)
import Control.Monad.Reader.Class (MonadReader)
import Control.Monad.Trans.Class (MonadTrans, lift)
import qualified Data.Aeson as JSON
import Data.Foldable (for_)
import Data.List (sortOn)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Time.Clock (NominalDiffTime)
import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime)
import UnliftIO (MonadUnliftIO, withRunInIO)
import UnliftIO.Exception (finally)
import UnliftIO.STM (TChan, TVar, atomically, modifyTVar', newTChanIO, newTVarIO, readTVar, writeTChan, writeTVar)
type Tags = Map Key JSON.Value
type Logs = [(POSIXTime, Key, JSON.Value)]
data Sample = Sample
{ Sample -> Span
sampleSpan :: !Span
, Sample -> Tags
sampleTags :: !Tags
, Sample -> Logs
sampleLogs :: !Logs
, Sample -> POSIXTime
sampleStart :: !POSIXTime
, Sample -> POSIXTime
sampleDuration :: !NominalDiffTime
}
data Tracer = Tracer
{ Tracer -> TChan Sample
tracerChannel :: TChan Sample
, Tracer -> TVar Int
tracerPendingCount :: TVar Int
}
newTracer :: MonadIO m => m Tracer
newTracer :: m Tracer
newTracer = IO Tracer -> m Tracer
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Tracer -> m Tracer) -> IO Tracer -> m Tracer
forall a b. (a -> b) -> a -> b
$ TChan Sample -> TVar Int -> Tracer
Tracer (TChan Sample -> TVar Int -> Tracer)
-> IO (TChan Sample) -> IO (TVar Int -> Tracer)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (TChan Sample)
forall (m :: * -> *) a. MonadIO m => m (TChan a)
newTChanIO IO (TVar Int -> Tracer) -> IO (TVar Int) -> IO Tracer
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Int -> IO (TVar Int)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Int
0
pendingSpanCount :: Tracer -> TVar Int
pendingSpanCount :: Tracer -> TVar Int
pendingSpanCount = Tracer -> TVar Int
tracerPendingCount
spanSamples :: Tracer -> TChan Sample
spanSamples :: Tracer -> TChan Sample
spanSamples = Tracer -> TChan Sample
tracerChannel
data Scope = Scope
{ Scope -> Tracer
scopeTracer :: !Tracer
, Scope -> Maybe Span
scopeSpan :: !(Maybe Span)
, Scope -> Maybe (TVar Tags)
scopeTags :: !(Maybe (TVar Tags))
, Scope -> Maybe (TVar Logs)
scopeLogs :: !(Maybe (TVar Logs))
}
newtype TraceT m a = TraceT { TraceT m a -> ReaderT Scope m a
traceTReader :: ReaderT Scope m a }
deriving (a -> TraceT m b -> TraceT m a
(a -> b) -> TraceT m a -> TraceT m b
(forall a b. (a -> b) -> TraceT m a -> TraceT m b)
-> (forall a b. a -> TraceT m b -> TraceT m a)
-> Functor (TraceT m)
forall a b. a -> TraceT m b -> TraceT m a
forall a b. (a -> b) -> TraceT m a -> TraceT m b
forall (m :: * -> *) a b.
Functor m =>
a -> TraceT m b -> TraceT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TraceT m a -> TraceT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> TraceT m b -> TraceT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> TraceT m b -> TraceT m a
fmap :: (a -> b) -> TraceT m a -> TraceT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> TraceT m a -> TraceT m b
Functor, Functor (TraceT m)
a -> TraceT m a
Functor (TraceT m)
-> (forall a. a -> TraceT m a)
-> (forall a b. TraceT m (a -> b) -> TraceT m a -> TraceT m b)
-> (forall a b c.
(a -> b -> c) -> TraceT m a -> TraceT m b -> TraceT m c)
-> (forall a b. TraceT m a -> TraceT m b -> TraceT m b)
-> (forall a b. TraceT m a -> TraceT m b -> TraceT m a)
-> Applicative (TraceT m)
TraceT m a -> TraceT m b -> TraceT m b
TraceT m a -> TraceT m b -> TraceT m a
TraceT m (a -> b) -> TraceT m a -> TraceT m b
(a -> b -> c) -> TraceT m a -> TraceT m b -> TraceT m c
forall a. a -> TraceT m a
forall a b. TraceT m a -> TraceT m b -> TraceT m a
forall a b. TraceT m a -> TraceT m b -> TraceT m b
forall a b. TraceT m (a -> b) -> TraceT m a -> TraceT m b
forall a b c.
(a -> b -> c) -> TraceT m a -> TraceT m b -> TraceT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (TraceT m)
forall (m :: * -> *) a. Applicative m => a -> TraceT m a
forall (m :: * -> *) a b.
Applicative m =>
TraceT m a -> TraceT m b -> TraceT m a
forall (m :: * -> *) a b.
Applicative m =>
TraceT m a -> TraceT m b -> TraceT m b
forall (m :: * -> *) a b.
Applicative m =>
TraceT m (a -> b) -> TraceT m a -> TraceT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> TraceT m a -> TraceT m b -> TraceT m c
<* :: TraceT m a -> TraceT m b -> TraceT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
TraceT m a -> TraceT m b -> TraceT m a
*> :: TraceT m a -> TraceT m b -> TraceT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
TraceT m a -> TraceT m b -> TraceT m b
liftA2 :: (a -> b -> c) -> TraceT m a -> TraceT m b -> TraceT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> TraceT m a -> TraceT m b -> TraceT m c
<*> :: TraceT m (a -> b) -> TraceT m a -> TraceT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
TraceT m (a -> b) -> TraceT m a -> TraceT m b
pure :: a -> TraceT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> TraceT m a
$cp1Applicative :: forall (m :: * -> *). Applicative m => Functor (TraceT m)
Applicative, Applicative (TraceT m)
a -> TraceT m a
Applicative (TraceT m)
-> (forall a b. TraceT m a -> (a -> TraceT m b) -> TraceT m b)
-> (forall a b. TraceT m a -> TraceT m b -> TraceT m b)
-> (forall a. a -> TraceT m a)
-> Monad (TraceT m)
TraceT m a -> (a -> TraceT m b) -> TraceT m b
TraceT m a -> TraceT m b -> TraceT m b
forall a. a -> TraceT m a
forall a b. TraceT m a -> TraceT m b -> TraceT m b
forall a b. TraceT m a -> (a -> TraceT m b) -> TraceT m b
forall (m :: * -> *). Monad m => Applicative (TraceT m)
forall (m :: * -> *) a. Monad m => a -> TraceT m a
forall (m :: * -> *) a b.
Monad m =>
TraceT m a -> TraceT m b -> TraceT m b
forall (m :: * -> *) a b.
Monad m =>
TraceT m a -> (a -> TraceT m b) -> TraceT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> TraceT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> TraceT m a
>> :: TraceT m a -> TraceT m b -> TraceT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
TraceT m a -> TraceT m b -> TraceT m b
>>= :: TraceT m a -> (a -> TraceT m b) -> TraceT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
TraceT m a -> (a -> TraceT m b) -> TraceT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (TraceT m)
Monad, Monad (TraceT m)
Monad (TraceT m)
-> (forall a. IO a -> TraceT m a) -> MonadIO (TraceT m)
IO a -> TraceT m a
forall a. IO a -> TraceT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall (m :: * -> *). MonadIO m => Monad (TraceT m)
forall (m :: * -> *) a. MonadIO m => IO a -> TraceT m a
liftIO :: IO a -> TraceT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> TraceT m a
$cp1MonadIO :: forall (m :: * -> *). MonadIO m => Monad (TraceT m)
MonadIO, m a -> TraceT m a
(forall (m :: * -> *) a. Monad m => m a -> TraceT m a)
-> MonadTrans TraceT
forall (m :: * -> *) a. Monad m => m a -> TraceT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: m a -> TraceT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> TraceT m a
MonadTrans)
instance MonadReader r m => MonadReader r (TraceT m) where
ask :: TraceT m r
ask = m r -> TraceT m r
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m r
forall r (m :: * -> *). MonadReader r m => m r
ask
local :: (r -> r) -> TraceT m a -> TraceT m a
local r -> r
f (TraceT (ReaderT Scope -> m a
g)) = ReaderT Scope m a -> TraceT m a
forall (m :: * -> *) a. ReaderT Scope m a -> TraceT m a
TraceT (ReaderT Scope m a -> TraceT m a)
-> ReaderT Scope m a -> TraceT m a
forall a b. (a -> b) -> a -> b
$ (Scope -> m a) -> ReaderT Scope m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((Scope -> m a) -> ReaderT Scope m a)
-> (Scope -> m a) -> ReaderT Scope m a
forall a b. (a -> b) -> a -> b
$ \Scope
r -> (r -> r) -> m a -> m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local r -> r
f (m a -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ Scope -> m a
g Scope
r
instance MonadUnliftIO m => MonadTrace (TraceT m) where
trace :: Builder -> TraceT m a -> TraceT m a
trace Builder
bldr (TraceT ReaderT Scope m a
reader) = ReaderT Scope m a -> TraceT m a
forall (m :: * -> *) a. ReaderT Scope m a -> TraceT m a
TraceT (ReaderT Scope m a -> TraceT m a)
-> ReaderT Scope m a -> TraceT m a
forall a b. (a -> b) -> a -> b
$ do
Scope
parentScope <- ReaderT Scope m Scope
forall r (m :: * -> *). MonadReader r m => m r
ask
let
mbParentSpn :: Maybe Span
mbParentSpn = Scope -> Maybe Span
scopeSpan Scope
parentScope
mbParentCtx :: Maybe Context
mbParentCtx = Span -> Context
spanContext (Span -> Context) -> Maybe Span -> Maybe Context
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Span
mbParentSpn
mbTraceID :: Maybe TraceID
mbTraceID = Context -> TraceID
contextTraceID (Context -> TraceID) -> Maybe Context -> Maybe TraceID
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Context
mbParentCtx
SpanID
spanID <- ReaderT Scope m SpanID
-> (SpanID -> ReaderT Scope m SpanID)
-> Maybe SpanID
-> ReaderT Scope m SpanID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO SpanID -> ReaderT Scope m SpanID
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO SpanID
randomSpanID) SpanID -> ReaderT Scope m SpanID
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe SpanID -> ReaderT Scope m SpanID)
-> Maybe SpanID -> ReaderT Scope m SpanID
forall a b. (a -> b) -> a -> b
$ Builder -> Maybe SpanID
builderSpanID Builder
bldr
TraceID
traceID <- ReaderT Scope m TraceID
-> (TraceID -> ReaderT Scope m TraceID)
-> Maybe TraceID
-> ReaderT Scope m TraceID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO TraceID -> ReaderT Scope m TraceID
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO TraceID
randomTraceID) TraceID -> ReaderT Scope m TraceID
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe TraceID -> ReaderT Scope m TraceID)
-> Maybe TraceID -> ReaderT Scope m TraceID
forall a b. (a -> b) -> a -> b
$ Builder -> Maybe TraceID
builderTraceID Builder
bldr Maybe TraceID -> Maybe TraceID -> Maybe TraceID
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe TraceID
mbTraceID
SamplingDecision
sampling <- case Builder -> Maybe SamplingPolicy
builderSamplingPolicy Builder
bldr of
Just SamplingPolicy
policy -> SamplingPolicy -> ReaderT Scope m SamplingDecision
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO SamplingPolicy
policy
Maybe SamplingPolicy
Nothing -> SamplingDecision -> ReaderT Scope m SamplingDecision
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SamplingDecision -> ReaderT Scope m SamplingDecision)
-> SamplingDecision -> ReaderT Scope m SamplingDecision
forall a b. (a -> b) -> a -> b
$ SamplingDecision -> Maybe SamplingDecision -> SamplingDecision
forall a. a -> Maybe a -> a
fromMaybe SamplingDecision
Never (Span -> SamplingDecision
spanSamplingDecision (Span -> SamplingDecision) -> Maybe Span -> Maybe SamplingDecision
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Span
mbParentSpn)
let
baggages :: Map Key ByteString
baggages = Map Key ByteString
-> Maybe (Map Key ByteString) -> Map Key ByteString
forall a. a -> Maybe a -> a
fromMaybe Map Key ByteString
forall k a. Map k a
Map.empty (Maybe (Map Key ByteString) -> Map Key ByteString)
-> Maybe (Map Key ByteString) -> Map Key ByteString
forall a b. (a -> b) -> a -> b
$ Context -> Map Key ByteString
contextBaggages (Context -> Map Key ByteString)
-> Maybe Context -> Maybe (Map Key ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Context
mbParentCtx
ctx :: Context
ctx = TraceID -> SpanID -> Map Key ByteString -> Context
Context TraceID
traceID SpanID
spanID (Builder -> Map Key ByteString
builderBaggages Builder
bldr Map Key ByteString -> Map Key ByteString -> Map Key ByteString
forall k a. Ord k => Map k a -> Map k a -> Map k a
`Map.union` Map Key ByteString
baggages)
spn :: Span
spn = Key -> Context -> Set Reference -> SamplingDecision -> Span
Span (Builder -> Key
builderName Builder
bldr) Context
ctx (Builder -> Set Reference
builderReferences Builder
bldr) SamplingDecision
sampling
tracer :: Tracer
tracer = Scope -> Tracer
scopeTracer Scope
parentScope
if Span -> Bool
spanIsSampled Span
spn
then do
TVar Tags
tagsTV <- Tags -> ReaderT Scope m (TVar Tags)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO (Tags -> ReaderT Scope m (TVar Tags))
-> Tags -> ReaderT Scope m (TVar Tags)
forall a b. (a -> b) -> a -> b
$ Builder -> Tags
builderTags Builder
bldr
TVar Logs
logsTV <- Logs -> ReaderT Scope m (TVar Logs)
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO []
TVar (Maybe POSIXTime)
startTV <- Maybe POSIXTime -> ReaderT Scope m (TVar (Maybe POSIXTime))
forall (m :: * -> *) a. MonadIO m => a -> m (TVar a)
newTVarIO Maybe POSIXTime
forall a. Maybe a
Nothing
let
run :: ReaderT Scope m a
run = do
POSIXTime
start <- IO POSIXTime -> ReaderT Scope m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO POSIXTime -> ReaderT Scope m POSIXTime)
-> IO POSIXTime -> ReaderT Scope m POSIXTime
forall a b. (a -> b) -> a -> b
$ IO POSIXTime
getPOSIXTime
STM () -> ReaderT Scope m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Scope m ()) -> STM () -> ReaderT Scope m ()
forall a b. (a -> b) -> a -> b
$ do
TVar (Maybe POSIXTime) -> Maybe POSIXTime -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar (Maybe POSIXTime)
startTV (POSIXTime -> Maybe POSIXTime
forall a. a -> Maybe a
Just POSIXTime
start)
TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Tracer -> TVar Int
tracerPendingCount Tracer
tracer) (Int -> Int -> Int
forall a. Num a => a -> a -> a
+Int
1)
(Scope -> Scope) -> ReaderT Scope m a -> ReaderT Scope m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Scope -> Scope -> Scope
forall a b. a -> b -> a
const (Scope -> Scope -> Scope) -> Scope -> Scope -> Scope
forall a b. (a -> b) -> a -> b
$ Tracer
-> Maybe Span -> Maybe (TVar Tags) -> Maybe (TVar Logs) -> Scope
Scope Tracer
tracer (Span -> Maybe Span
forall a. a -> Maybe a
Just Span
spn) (TVar Tags -> Maybe (TVar Tags)
forall a. a -> Maybe a
Just TVar Tags
tagsTV) (TVar Logs -> Maybe (TVar Logs)
forall a. a -> Maybe a
Just TVar Logs
logsTV)) ReaderT Scope m a
reader
cleanup :: ReaderT Scope m ()
cleanup = do
POSIXTime
end <- IO POSIXTime -> ReaderT Scope m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO POSIXTime -> ReaderT Scope m POSIXTime)
-> IO POSIXTime -> ReaderT Scope m POSIXTime
forall a b. (a -> b) -> a -> b
$ IO POSIXTime
getPOSIXTime
STM () -> ReaderT Scope m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Scope m ()) -> STM () -> ReaderT Scope m ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe POSIXTime) -> STM (Maybe POSIXTime)
forall a. TVar a -> STM a
readTVar TVar (Maybe POSIXTime)
startTV STM (Maybe POSIXTime) -> (Maybe POSIXTime -> STM ()) -> STM ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe POSIXTime
Nothing -> () -> STM ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just POSIXTime
start -> do
TVar Int -> (Int -> Int) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (Tracer -> TVar Int
tracerPendingCount Tracer
tracer) (\Int
n -> Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
Tags
tags <- TVar Tags -> STM Tags
forall a. TVar a -> STM a
readTVar TVar Tags
tagsTV
Logs
logs <- ((POSIXTime, Key, Value) -> (POSIXTime, Key)) -> Logs -> Logs
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (\(POSIXTime
t, Key
k, Value
_) -> (POSIXTime
t, Key
k)) (Logs -> Logs) -> STM Logs -> STM Logs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Logs -> STM Logs
forall a. TVar a -> STM a
readTVar TVar Logs
logsTV
TChan Sample -> Sample -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan (Tracer -> TChan Sample
tracerChannel Tracer
tracer) (Span -> Tags -> Logs -> POSIXTime -> POSIXTime -> Sample
Sample Span
spn Tags
tags Logs
logs POSIXTime
start (POSIXTime
end POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
- POSIXTime
start))
ReaderT Scope m a
run ReaderT Scope m a -> ReaderT Scope m () -> ReaderT Scope m a
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` ReaderT Scope m ()
cleanup
else (Scope -> Scope) -> ReaderT Scope m a -> ReaderT Scope m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (Scope -> Scope -> Scope
forall a b. a -> b -> a
const (Scope -> Scope -> Scope) -> Scope -> Scope -> Scope
forall a b. (a -> b) -> a -> b
$ Tracer
-> Maybe Span -> Maybe (TVar Tags) -> Maybe (TVar Logs) -> Scope
Scope Tracer
tracer (Span -> Maybe Span
forall a. a -> Maybe a
Just Span
spn) Maybe (TVar Tags)
forall a. Maybe a
Nothing Maybe (TVar Logs)
forall a. Maybe a
Nothing) ReaderT Scope m a
reader
activeSpan :: TraceT m (Maybe Span)
activeSpan = ReaderT Scope m (Maybe Span) -> TraceT m (Maybe Span)
forall (m :: * -> *) a. ReaderT Scope m a -> TraceT m a
TraceT (ReaderT Scope m (Maybe Span) -> TraceT m (Maybe Span))
-> ReaderT Scope m (Maybe Span) -> TraceT m (Maybe Span)
forall a b. (a -> b) -> a -> b
$ (Scope -> Maybe Span) -> ReaderT Scope m (Maybe Span)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Scope -> Maybe Span
scopeSpan
addSpanEntry :: Key -> Value -> TraceT m ()
addSpanEntry Key
key (TagValue Value
val) = ReaderT Scope m () -> TraceT m ()
forall (m :: * -> *) a. ReaderT Scope m a -> TraceT m a
TraceT (ReaderT Scope m () -> TraceT m ())
-> ReaderT Scope m () -> TraceT m ()
forall a b. (a -> b) -> a -> b
$ do
Maybe (TVar Tags)
mbTV <- (Scope -> Maybe (TVar Tags)) -> ReaderT Scope m (Maybe (TVar Tags))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Scope -> Maybe (TVar Tags)
scopeTags
Maybe (TVar Tags)
-> (TVar Tags -> ReaderT Scope m ()) -> ReaderT Scope m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (TVar Tags)
mbTV ((TVar Tags -> ReaderT Scope m ()) -> ReaderT Scope m ())
-> (TVar Tags -> ReaderT Scope m ()) -> ReaderT Scope m ()
forall a b. (a -> b) -> a -> b
$ \TVar Tags
tv -> STM () -> ReaderT Scope m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Scope m ()) -> STM () -> ReaderT Scope m ()
forall a b. (a -> b) -> a -> b
$ TVar Tags -> (Tags -> Tags) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Tags
tv ((Tags -> Tags) -> STM ()) -> (Tags -> Tags) -> STM ()
forall a b. (a -> b) -> a -> b
$ Key -> Value -> Tags -> Tags
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Key
key Value
val
addSpanEntry Key
key (LogValue Value
val Maybe POSIXTime
mbTime) = ReaderT Scope m () -> TraceT m ()
forall (m :: * -> *) a. ReaderT Scope m a -> TraceT m a
TraceT (ReaderT Scope m () -> TraceT m ())
-> ReaderT Scope m () -> TraceT m ()
forall a b. (a -> b) -> a -> b
$ do
Maybe (TVar Logs)
mbTV <- (Scope -> Maybe (TVar Logs)) -> ReaderT Scope m (Maybe (TVar Logs))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Scope -> Maybe (TVar Logs)
scopeLogs
Maybe (TVar Logs)
-> (TVar Logs -> ReaderT Scope m ()) -> ReaderT Scope m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Maybe (TVar Logs)
mbTV ((TVar Logs -> ReaderT Scope m ()) -> ReaderT Scope m ())
-> (TVar Logs -> ReaderT Scope m ()) -> ReaderT Scope m ()
forall a b. (a -> b) -> a -> b
$ \TVar Logs
tv -> do
POSIXTime
time <- ReaderT Scope m POSIXTime
-> (POSIXTime -> ReaderT Scope m POSIXTime)
-> Maybe POSIXTime
-> ReaderT Scope m POSIXTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (IO POSIXTime -> ReaderT Scope m POSIXTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO POSIXTime
getPOSIXTime) POSIXTime -> ReaderT Scope m POSIXTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe POSIXTime
mbTime
STM () -> ReaderT Scope m ()
forall (m :: * -> *) a. MonadIO m => STM a -> m a
atomically (STM () -> ReaderT Scope m ()) -> STM () -> ReaderT Scope m ()
forall a b. (a -> b) -> a -> b
$ TVar Logs -> (Logs -> Logs) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' TVar Logs
tv ((POSIXTime
time, Key
key, Value
val) (POSIXTime, Key, Value) -> Logs -> Logs
forall a. a -> [a] -> [a]
:)
instance MonadUnliftIO m => MonadUnliftIO (TraceT m) where
withRunInIO :: ((forall a. TraceT m a -> IO a) -> IO b) -> TraceT m b
withRunInIO (forall a. TraceT m a -> IO a) -> IO b
inner = ReaderT Scope m b -> TraceT m b
forall (m :: * -> *) a. ReaderT Scope m a -> TraceT m a
TraceT (ReaderT Scope m b -> TraceT m b)
-> ReaderT Scope m b -> TraceT m b
forall a b. (a -> b) -> a -> b
$ ((forall a. ReaderT Scope m a -> IO a) -> IO b)
-> ReaderT Scope m b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. ReaderT Scope m a -> IO a) -> IO b)
-> ReaderT Scope m b)
-> ((forall a. ReaderT Scope m a -> IO a) -> IO b)
-> ReaderT Scope m b
forall a b. (a -> b) -> a -> b
$ \forall a. ReaderT Scope m a -> IO a
run -> (forall a. TraceT m a -> IO a) -> IO b
inner (ReaderT Scope m a -> IO a
forall a. ReaderT Scope m a -> IO a
run (ReaderT Scope m a -> IO a)
-> (TraceT m a -> ReaderT Scope m a) -> TraceT m a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceT m a -> ReaderT Scope m a
forall (m :: * -> *) a. TraceT m a -> ReaderT Scope m a
traceTReader)
runTraceT :: TraceT m a -> Tracer -> m a
runTraceT :: TraceT m a -> Tracer -> m a
runTraceT (TraceT ReaderT Scope m a
reader) Tracer
tracer = ReaderT Scope m a -> Scope -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT Scope m a
reader (Tracer
-> Maybe Span -> Maybe (TVar Tags) -> Maybe (TVar Logs) -> Scope
Scope Tracer
tracer Maybe Span
forall a. Maybe a
Nothing Maybe (TVar Tags)
forall a. Maybe a
Nothing Maybe (TVar Logs)
forall a. Maybe a
Nothing)