{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Monad.Trace.Class (
Span(..), spanIsSampled, spanIsDebug,
Context(..),
TraceID(..), decodeTraceID, encodeTraceID,
SpanID(..), decodeSpanID, encodeSpanID,
Reference(..),
MonadTrace(..),
Builder(..), Name, builder,
rootSpan, rootSpanWith, childSpan, childSpanWith,
SamplingDecision(..),
SamplingPolicy, alwaysSampled, neverSampled, sampledWithProbability, sampledWhen, debugEnabled,
Key, Value, tagDoubleValue, tagInt64Value, tagTextValue, logValue, logValueAt
) where
import Control.Monad.Trace.Internal
import Control.Monad.Except (ExceptT(..))
import Control.Monad.Identity (Identity(..))
import Control.Monad.Reader (ReaderT(..))
import qualified Control.Monad.RWS.Lazy as RWS.Lazy
import qualified Control.Monad.RWS.Strict as RWS.Strict
import qualified Control.Monad.State.Lazy as State.Lazy
import qualified Control.Monad.State.Strict as State.Strict
import Control.Monad.Trans.Class (MonadTrans, lift)
import qualified Control.Monad.Writer.Lazy as Writer.Lazy
import qualified Control.Monad.Writer.Strict as Writer.Strict
import qualified Data.Aeson as JSON
import Data.ByteString (ByteString)
import Data.Int (Int64)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock.POSIX (POSIXTime)
import System.Random (randomRIO)
class Monad m => MonadTrace m where
trace :: Builder -> m a -> m a
activeSpan :: m (Maybe Span)
default activeSpan :: (MonadTrace n, MonadTrans t, m ~ t n) => m (Maybe Span)
activeSpan = n (Maybe Span) -> t n (Maybe Span)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift n (Maybe Span)
forall (m :: * -> *). MonadTrace m => m (Maybe Span)
activeSpan
addSpanEntry :: Key -> Value -> m ()
default addSpanEntry :: (MonadTrace n, MonadTrans t, m ~ t n) => Key -> Value -> m ()
addSpanEntry Text
key = n () -> m ()
n () -> t n ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (n () -> m ()) -> (Value -> n ()) -> Value -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value -> n ()
forall (m :: * -> *). MonadTrace m => Text -> Value -> m ()
addSpanEntry Text
key
instance MonadTrace m => MonadTrace (ExceptT e m) where
trace :: forall a. Builder -> ExceptT e m a -> ExceptT e m a
trace Builder
name (ExceptT m (Either e a)
actn) = m (Either e a) -> ExceptT e m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e a) -> ExceptT e m a)
-> m (Either e a) -> ExceptT e m a
forall a b. (a -> b) -> a -> b
$ Builder -> m (Either e a) -> m (Either e a)
forall a. Builder -> m a -> m a
forall (m :: * -> *) a. MonadTrace m => Builder -> m a -> m a
trace Builder
name m (Either e a)
actn
instance MonadTrace m => MonadTrace (ReaderT r m) where
trace :: forall a. Builder -> ReaderT r m a -> ReaderT r m a
trace Builder
name (ReaderT r -> m a
actn) = (r -> m a) -> ReaderT r m a
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((r -> m a) -> ReaderT r m a) -> (r -> m a) -> ReaderT r m a
forall a b. (a -> b) -> a -> b
$ \r
r -> Builder -> m a -> m a
forall a. Builder -> m a -> m a
forall (m :: * -> *) a. MonadTrace m => Builder -> m a -> m a
trace Builder
name (r -> m a
actn r
r)
instance (MonadTrace m, Monoid w) => MonadTrace (RWS.Lazy.RWST r w s m) where
trace :: forall a. Builder -> RWST r w s m a -> RWST r w s m a
trace Builder
name (RWS.Lazy.RWST r -> s -> m (a, s, w)
actn) = (r -> s -> m (a, s, w)) -> RWST r w s m a
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWS.Lazy.RWST ((r -> s -> m (a, s, w)) -> RWST r w s m a)
-> (r -> s -> m (a, s, w)) -> RWST r w s m a
forall a b. (a -> b) -> a -> b
$ \r
r s
s -> Builder -> m (a, s, w) -> m (a, s, w)
forall a. Builder -> m a -> m a
forall (m :: * -> *) a. MonadTrace m => Builder -> m a -> m a
trace Builder
name (r -> s -> m (a, s, w)
actn r
r s
s)
instance (MonadTrace m, Monoid w) => MonadTrace (RWS.Strict.RWST r w s m) where
trace :: forall a. Builder -> RWST r w s m a -> RWST r w s m a
trace Builder
name (RWS.Strict.RWST r -> s -> m (a, s, w)
actn) = (r -> s -> m (a, s, w)) -> RWST r w s m a
forall r w s (m :: * -> *) a.
(r -> s -> m (a, s, w)) -> RWST r w s m a
RWS.Strict.RWST ((r -> s -> m (a, s, w)) -> RWST r w s m a)
-> (r -> s -> m (a, s, w)) -> RWST r w s m a
forall a b. (a -> b) -> a -> b
$ \r
r s
s -> Builder -> m (a, s, w) -> m (a, s, w)
forall a. Builder -> m a -> m a
forall (m :: * -> *) a. MonadTrace m => Builder -> m a -> m a
trace Builder
name (r -> s -> m (a, s, w)
actn r
r s
s)
instance MonadTrace m => MonadTrace (State.Lazy.StateT s m) where
trace :: forall a. Builder -> StateT s m a -> StateT s m a
trace Builder
name (State.Lazy.StateT s -> m (a, s)
actn) = (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
State.Lazy.StateT ((s -> m (a, s)) -> StateT s m a)
-> (s -> m (a, s)) -> StateT s m a
forall a b. (a -> b) -> a -> b
$ \s
s -> Builder -> m (a, s) -> m (a, s)
forall a. Builder -> m a -> m a
forall (m :: * -> *) a. MonadTrace m => Builder -> m a -> m a
trace Builder
name (s -> m (a, s)
actn s
s)
instance MonadTrace m => MonadTrace (State.Strict.StateT s m) where
trace :: forall a. Builder -> StateT s m a -> StateT s m a
trace Builder
name (State.Strict.StateT s -> m (a, s)
actn) = (s -> m (a, s)) -> StateT s m a
forall s (m :: * -> *) a. (s -> m (a, s)) -> StateT s m a
State.Strict.StateT ((s -> m (a, s)) -> StateT s m a)
-> (s -> m (a, s)) -> StateT s m a
forall a b. (a -> b) -> a -> b
$ \s
s -> Builder -> m (a, s) -> m (a, s)
forall a. Builder -> m a -> m a
forall (m :: * -> *) a. MonadTrace m => Builder -> m a -> m a
trace Builder
name (s -> m (a, s)
actn s
s)
instance (MonadTrace m, Monoid w) => MonadTrace (Writer.Lazy.WriterT w m) where
trace :: forall a. Builder -> WriterT w m a -> WriterT w m a
trace Builder
name (Writer.Lazy.WriterT m (a, w)
actn) = m (a, w) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Writer.Lazy.WriterT (m (a, w) -> WriterT w m a) -> m (a, w) -> WriterT w m a
forall a b. (a -> b) -> a -> b
$ Builder -> m (a, w) -> m (a, w)
forall a. Builder -> m a -> m a
forall (m :: * -> *) a. MonadTrace m => Builder -> m a -> m a
trace Builder
name m (a, w)
actn
instance (MonadTrace m, Monoid w) => MonadTrace (Writer.Strict.WriterT w m) where
trace :: forall a. Builder -> WriterT w m a -> WriterT w m a
trace Builder
name (Writer.Strict.WriterT m (a, w)
actn) = m (a, w) -> WriterT w m a
forall w (m :: * -> *) a. m (a, w) -> WriterT w m a
Writer.Strict.WriterT (m (a, w) -> WriterT w m a) -> m (a, w) -> WriterT w m a
forall a b. (a -> b) -> a -> b
$ Builder -> m (a, w) -> m (a, w)
forall a. Builder -> m a -> m a
forall (m :: * -> *) a. MonadTrace m => Builder -> m a -> m a
trace Builder
name m (a, w)
actn
instance MonadTrace Identity where
trace :: forall a. Builder -> Identity a -> Identity a
trace Builder
_ = Identity a -> Identity a
forall a. a -> a
id
activeSpan :: Identity (Maybe Span)
activeSpan = Maybe Span -> Identity (Maybe Span)
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Span
forall a. Maybe a
Nothing
addSpanEntry :: Text -> Value -> Identity ()
addSpanEntry Text
_ Value
_ = () -> Identity ()
forall a. a -> Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
data Builder = Builder
{ Builder -> Text
builderName :: !Name
, Builder -> Maybe TraceID
builderTraceID :: !(Maybe TraceID)
, Builder -> Maybe SpanID
builderSpanID :: !(Maybe SpanID)
, Builder -> Set Reference
builderReferences :: !(Set Reference)
, Builder -> Map Text Value
builderTags :: !(Map Key JSON.Value)
, Builder -> Map Text ByteString
builderBaggages :: !(Map Key ByteString)
, Builder -> Maybe SamplingPolicy
builderSamplingPolicy :: !(Maybe SamplingPolicy)
}
builder :: Name -> Builder
builder :: Text -> Builder
builder Text
name = Text
-> Maybe TraceID
-> Maybe SpanID
-> Set Reference
-> Map Text Value
-> Map Text ByteString
-> Maybe SamplingPolicy
-> Builder
Builder Text
name Maybe TraceID
forall a. Maybe a
Nothing Maybe SpanID
forall a. Maybe a
Nothing Set Reference
forall a. Set a
Set.empty Map Text Value
forall k a. Map k a
Map.empty Map Text ByteString
forall k a. Map k a
Map.empty Maybe SamplingPolicy
forall a. Maybe a
Nothing
instance IsString Builder where
fromString :: String -> Builder
fromString = Text -> Builder
builder (Text -> Builder) -> (String -> Text) -> String -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
type SamplingPolicy = IO SamplingDecision
alwaysSampled :: SamplingPolicy
alwaysSampled :: SamplingPolicy
alwaysSampled = SamplingDecision -> SamplingPolicy
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SamplingDecision
Always
neverSampled :: SamplingPolicy
neverSampled :: SamplingPolicy
neverSampled = SamplingDecision -> SamplingPolicy
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SamplingDecision
Never
debugEnabled :: SamplingPolicy
debugEnabled :: SamplingPolicy
debugEnabled = SamplingDecision -> SamplingPolicy
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure SamplingDecision
Debug
sampledWhen :: Bool -> SamplingPolicy
sampledWhen :: Bool -> SamplingPolicy
sampledWhen Bool
b = SamplingDecision -> SamplingPolicy
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SamplingDecision -> SamplingPolicy)
-> SamplingDecision -> SamplingPolicy
forall a b. (a -> b) -> a -> b
$ if Bool
b then SamplingDecision
Always else SamplingDecision
Never
sampledWithProbability :: Double -> SamplingPolicy
sampledWithProbability :: Double -> SamplingPolicy
sampledWithProbability Double
r = (Double, Double) -> IO Double
forall a (m :: * -> *). (Random a, MonadIO m) => (a, a) -> m a
randomRIO (Double
0, Double
1) IO Double -> (Double -> SamplingPolicy) -> SamplingPolicy
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Bool -> SamplingPolicy
sampledWhen (Bool -> SamplingPolicy)
-> (Double -> Bool) -> Double -> SamplingPolicy
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
r)
rootSpanWith :: MonadTrace m => (Builder -> Builder) -> SamplingPolicy -> Name -> m a -> m a
rootSpanWith :: forall (m :: * -> *) a.
MonadTrace m =>
(Builder -> Builder) -> SamplingPolicy -> Text -> m a -> m a
rootSpanWith Builder -> Builder
f SamplingPolicy
policy Text
name = Builder -> m a -> m a
forall a. Builder -> m a -> m a
forall (m :: * -> *) a. MonadTrace m => Builder -> m a -> m a
trace (Builder -> m a -> m a) -> Builder -> m a -> m a
forall a b. (a -> b) -> a -> b
$ (Builder -> Builder
f (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Builder
builder Text
name) { builderSamplingPolicy = Just policy }
rootSpan :: MonadTrace m => SamplingPolicy -> Name -> m a -> m a
rootSpan :: forall (m :: * -> *) a.
MonadTrace m =>
SamplingPolicy -> Text -> m a -> m a
rootSpan = (Builder -> Builder) -> SamplingPolicy -> Text -> m a -> m a
forall (m :: * -> *) a.
MonadTrace m =>
(Builder -> Builder) -> SamplingPolicy -> Text -> m a -> m a
rootSpanWith Builder -> Builder
forall a. a -> a
id
childSpanWith :: MonadTrace m => (Builder -> Builder) -> Name -> m a -> m a
childSpanWith :: forall (m :: * -> *) a.
MonadTrace m =>
(Builder -> Builder) -> Text -> m a -> m a
childSpanWith Builder -> Builder
f Text
name m a
actn = m (Maybe Span)
forall (m :: * -> *). MonadTrace m => m (Maybe Span)
activeSpan m (Maybe Span) -> (Maybe Span -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Span
Nothing -> m a
actn
Just Span
spn -> do
let
ctx :: Context
ctx = Span -> Context
spanContext Span
spn
bldr :: Builder
bldr = Builder -> Builder
f (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Builder
builder Text
name
bldr' :: Builder
bldr' = Builder
bldr
{ builderTraceID = Just $ contextTraceID ctx
, builderReferences = Set.insert (ChildOf $ contextSpanID ctx) (builderReferences bldr) }
Builder -> m a -> m a
forall a. Builder -> m a -> m a
forall (m :: * -> *) a. MonadTrace m => Builder -> m a -> m a
trace Builder
bldr' m a
actn
childSpan :: MonadTrace m => Name -> m a -> m a
childSpan :: forall (m :: * -> *) a. MonadTrace m => Text -> m a -> m a
childSpan = (Builder -> Builder) -> Text -> m a -> m a
forall (m :: * -> *) a.
MonadTrace m =>
(Builder -> Builder) -> Text -> m a -> m a
childSpanWith Builder -> Builder
forall a. a -> a
id
tagDoubleValue :: Double -> Value
tagDoubleValue :: Double -> Value
tagDoubleValue = Value -> Value
TagValue (Value -> Value) -> (Double -> Value) -> Double -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON
tagInt64Value :: Integral a => a -> Value
tagInt64Value :: forall a. Integral a => a -> Value
tagInt64Value = Value -> Value
TagValue (Value -> Value) -> (a -> Value) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. ToJSON a => a -> Value
JSON.toJSON @Int64) (Int64 -> Value) -> (a -> Int64) -> a -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral
tagTextValue :: Text -> Value
tagTextValue :: Text -> Value
tagTextValue = Value -> Value
TagValue (Value -> Value) -> (Text -> Value) -> Text -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON
logValue :: JSON.ToJSON a => a -> Value
logValue :: forall a. ToJSON a => a -> Value
logValue a
v = Value -> Maybe POSIXTime -> Value
LogValue (a -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON a
v) Maybe POSIXTime
forall a. Maybe a
Nothing
logValueAt :: JSON.ToJSON a => POSIXTime -> a -> Value
logValueAt :: forall a. ToJSON a => POSIXTime -> a -> Value
logValueAt POSIXTime
t a
v = Value -> Maybe POSIXTime -> Value
LogValue (a -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON a
v) (POSIXTime -> Maybe POSIXTime
forall a. a -> Maybe a
Just POSIXTime
t)