{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
module Control.Monad.Trace.Class (
MonadTrace(..),
Span(..), Context(..),
TraceID(..), encodeTraceID, decodeTraceID,
SpanID(..), encodeSpanID, decodeSpanID,
Reference(..),
rootSpan, rootSpanWith, childSpan, childSpanWith,
Builder(..), Name, builder,
Sampling, alwaysSampled, neverSampled, sampledEvery, 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)
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 = lift activeSpan
addSpanEntry :: Key -> Value -> m ()
default addSpanEntry :: (MonadTrace n, MonadTrans t, m ~ t n) => Key -> Value -> m ()
addSpanEntry key = lift . addSpanEntry key
instance (Monad m, MonadTrace m) => MonadTrace (ExceptT e m) where
trace name (ExceptT actn) = ExceptT $ trace name actn
instance (Monad m, MonadTrace m) => MonadTrace (ReaderT r m) where
trace name (ReaderT actn) = ReaderT $ \r -> trace name (actn r)
instance (Monad m, MonadTrace m, Monoid w) => MonadTrace (RWS.Lazy.RWST r w s m) where
trace name (RWS.Lazy.RWST actn) = RWS.Lazy.RWST $ \r s -> trace name (actn r s)
instance (Monad m, MonadTrace m, Monoid w) => MonadTrace (RWS.Strict.RWST r w s m) where
trace name (RWS.Strict.RWST actn) = RWS.Strict.RWST $ \r s -> trace name (actn r s)
instance (Monad m, MonadTrace m) => MonadTrace (State.Lazy.StateT s m) where
trace name (State.Lazy.StateT actn) = State.Lazy.StateT $ \s -> trace name (actn s)
instance (Monad m, MonadTrace m) => MonadTrace (State.Strict.StateT s m) where
trace name (State.Strict.StateT actn) = State.Strict.StateT $ \s -> trace name (actn s)
instance (Monad m, MonadTrace m, Monoid w) => MonadTrace (Writer.Lazy.WriterT w m) where
trace name (Writer.Lazy.WriterT actn) = Writer.Lazy.WriterT $ trace name actn
instance (Monad m, MonadTrace m, Monoid w) => MonadTrace (Writer.Strict.WriterT w m) where
trace name (Writer.Strict.WriterT actn) = Writer.Strict.WriterT $ trace name actn
instance MonadTrace Identity where
trace _ = id
activeSpan = pure Nothing
addSpanEntry _ _ = pure ()
data Builder = Builder
{ builderName :: !Name
, builderTraceID :: !(Maybe TraceID)
, builderSpanID :: !(Maybe SpanID)
, builderReferences :: !(Set Reference)
, builderTags :: !(Map Key JSON.Value)
, builderBaggages :: !(Map Key ByteString)
, builderSampling :: !(Maybe Sampling)
} deriving Show
builder :: Name -> Builder
builder name = Builder name Nothing Nothing Set.empty Map.empty Map.empty Nothing
instance IsString Builder where
fromString = builder . T.pack
alwaysSampled :: Sampling
alwaysSampled = Always
neverSampled :: Sampling
neverSampled = Never
debugEnabled :: Sampling
debugEnabled = Debug
sampledEvery :: Int -> Sampling
sampledEvery n = WithProbability (1 / fromIntegral n)
sampledWhen :: Bool -> Sampling
sampledWhen b = if b then Always else Never
rootSpanWith :: MonadTrace m => (Builder -> Builder) -> Sampling -> Name -> m a -> m a
rootSpanWith f sampling name = trace $ (f $ builder name) { builderSampling = Just sampling }
rootSpan :: MonadTrace m => Sampling -> Name -> m a -> m a
rootSpan = rootSpanWith id
childSpanWith :: MonadTrace m => (Builder -> Builder) -> Name -> m a -> m a
childSpanWith f name actn = activeSpan >>= \case
Nothing -> actn
Just spn -> do
let
ctx = spanContext spn
bldr = (f $ builder name)
bldr' = bldr
{ builderTraceID = Just $ contextTraceID ctx
, builderReferences = Set.insert (ChildOf $ contextSpanID ctx) (builderReferences bldr) }
trace bldr' actn
childSpan :: MonadTrace m => Name -> m a -> m a
childSpan = childSpanWith id
tagDoubleValue :: Double -> Value
tagDoubleValue = TagValue . JSON.toJSON
tagInt64Value :: Integral a => a -> Value
tagInt64Value = TagValue . (JSON.toJSON @Int64) . fromIntegral
tagTextValue :: Text -> Value
tagTextValue = TagValue . JSON.toJSON
logValue :: JSON.ToJSON a => a -> Value
logValue v = LogValue (JSON.toJSON v) Nothing
logValueAt :: JSON.ToJSON a => POSIXTime -> a -> Value
logValueAt t v = LogValue (JSON.toJSON v) (Just t)