{-|
Module: OpenTracing.Standard

Standard implementations of `OpenTracing.Tracer` fields.
-}

{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns        #-}
{-# LANGUAGE OverloadedStrings     #-}
{-# LANGUAGE RecordWildCards       #-}
{-# LANGUAGE StrictData            #-}
{-# LANGUAGE TemplateHaskell       #-}

module OpenTracing.Standard
    ( StdEnv
    , newStdEnv
    , envTraceID128bit
    , envSampler

    , stdTracer
    , stdReporter
    )
where

import Control.Concurrent (MVar, newMVar, withMVar)
import Control.Lens                 hiding (Context, (.=))
import Control.Monad.Reader
import Data.Monoid
import Data.Word
import OpenTracing.Reporting.Stdio (stdoutReporter)
import OpenTracing.Sampling         (Sampler (runSampler))
import OpenTracing.Span
import OpenTracing.Types
import Prelude                      hiding (putStrLn)
import System.Random.MWC

-- | A standard environment for generating trace and span IDs.
data StdEnv = StdEnv
    { StdEnv -> MVar GenIO
envPRNGRef        :: MVar GenIO
    , StdEnv -> Sampler
_envSampler       :: Sampler
    , StdEnv -> Bool
_envTraceID128bit :: Bool
    }

newStdEnv :: MonadIO m => Sampler -> m StdEnv
newStdEnv :: forall (m :: * -> *). MonadIO m => Sampler -> m StdEnv
newStdEnv Sampler
samp = do
    Gen RealWorld
prng <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO GenIO
createSystemRandom
    MVar (Gen RealWorld)
prngRef <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (MVar a)
newMVar Gen RealWorld
prng
    forall (m :: * -> *) a. Monad m => a -> m a
return StdEnv { envPRNGRef :: MVar GenIO
envPRNGRef = MVar (Gen RealWorld)
prngRef, _envSampler :: Sampler
_envSampler = Sampler
samp, _envTraceID128bit :: Bool
_envTraceID128bit = Bool
True }

makeLenses ''StdEnv

-- | A standard implementation of `OpenTracing.Tracer.tracerStart`.
stdTracer :: MonadIO m => StdEnv -> SpanOpts -> m Span
stdTracer :: forall (m :: * -> *). MonadIO m => StdEnv -> SpanOpts -> m Span
stdTracer StdEnv
r = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT StdEnv
r forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(MonadIO m, MonadReader StdEnv m) =>
SpanOpts -> m Span
start

-- | A implementation of `OpenTracing.Tracer.tracerReport` that logs spans to stdout.
stdReporter :: MonadIO m => FinishedSpan -> m ()
stdReporter :: forall (m :: * -> *). MonadIO m => FinishedSpan -> m ()
stdReporter = forall (m :: * -> *). MonadIO m => FinishedSpan -> m ()
stdoutReporter

--------------------------------------------------------------------------------
-- Internal

start :: (MonadIO m, MonadReader StdEnv m) => SpanOpts -> m Span
start :: forall (m :: * -> *).
(MonadIO m, MonadReader StdEnv m) =>
SpanOpts -> m Span
start SpanOpts
so = do
    SpanContext
ctx <- do
        Maybe Reference
p <- forall (t :: * -> *). Foldable t => t Reference -> Maybe Reference
findParent forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SpanRefs -> IO [Reference]
freezeRefs (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SpanOpts SpanRefs
spanOptRefs SpanOpts
so))
        case Maybe Reference
p of
            Maybe Reference
Nothing -> forall (m :: * -> *).
(MonadIO m, MonadReader StdEnv m) =>
SpanOpts -> m SpanContext
freshContext SpanOpts
so
            Just Reference
p' -> forall (m :: * -> *).
(MonadIO m, MonadReader StdEnv m) =>
SpanContext -> m SpanContext
fromParent   (Reference -> SpanContext
refCtx Reference
p')
    forall (m :: * -> *) (t :: * -> *).
(MonadIO m, Foldable t) =>
SpanContext -> Text -> SpanRefs -> t Tag -> m Span
newSpan SpanContext
ctx
            (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SpanOpts Text
spanOptOperation SpanOpts
so)
            (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SpanOpts SpanRefs
spanOptRefs SpanOpts
so)
            (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SpanOpts [Tag]
spanOptTags SpanOpts
so)

newTraceID :: (MonadIO m, MonadReader StdEnv m) => m TraceID
newTraceID :: forall (m :: * -> *).
(MonadIO m, MonadReader StdEnv m) =>
m TraceID
newTraceID = do
    StdEnv{Bool
MVar GenIO
Sampler
_envTraceID128bit :: Bool
_envSampler :: Sampler
envPRNGRef :: MVar GenIO
_envTraceID128bit :: StdEnv -> Bool
_envSampler :: StdEnv -> Sampler
envPRNGRef :: StdEnv -> MVar GenIO
..} <- forall r (m :: * -> *). MonadReader r m => m r
ask
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar GenIO
envPRNGRef forall a b. (a -> b) -> a -> b
$ \Gen RealWorld
prng -> do
      Maybe Word64
hi <- if Bool
_envTraceID128bit then
                forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
Gen (PrimState m) -> m a
uniform Gen RealWorld
prng)
            else
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      Word64
lo <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
Gen (PrimState m) -> m a
uniform Gen RealWorld
prng
      forall (m :: * -> *) a. Monad m => a -> m a
return TraceID { traceIdHi :: Maybe Word64
traceIdHi = Maybe Word64
hi, traceIdLo :: Word64
traceIdLo = Word64
lo }

newSpanID :: (MonadIO m, MonadReader StdEnv m) => m Word64
newSpanID :: forall (m :: * -> *). (MonadIO m, MonadReader StdEnv m) => m Word64
newSpanID = do
  MVar (Gen RealWorld)
prngRef <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks StdEnv -> MVar GenIO
envPRNGRef
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar (Gen RealWorld)
prngRef forall a b. (a -> b) -> a -> b
$ \Gen RealWorld
prng -> do
    forall a (m :: * -> *).
(Variate a, PrimMonad m) =>
Gen (PrimState m) -> m a
uniform Gen RealWorld
prng

freshContext
    :: ( MonadIO            m
       , MonadReader StdEnv m
       )
    => SpanOpts
    -> m SpanContext
freshContext :: forall (m :: * -> *).
(MonadIO m, MonadReader StdEnv m) =>
SpanOpts -> m SpanContext
freshContext SpanOpts
so = do
    TraceID
trid <- forall (m :: * -> *).
(MonadIO m, MonadReader StdEnv m) =>
m TraceID
newTraceID
    Word64
spid <- forall (m :: * -> *). (MonadIO m, MonadReader StdEnv m) => m Word64
newSpanID
    Sampler
smpl <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' StdEnv Sampler
envSampler

    Sampled
sampled' <- case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SpanOpts (Maybe Sampled)
spanOptSampled SpanOpts
so of
        Maybe Sampled
Nothing -> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Iso' Bool Sampled
_IsSampled
               forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sampler
-> forall (m :: * -> *). MonadIO m => TraceID -> Text -> m Bool
runSampler Sampler
smpl TraceID
trid (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SpanOpts Text
spanOptOperation SpanOpts
so)
        Just Sampled
s  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Sampled
s

    forall (m :: * -> *) a. Monad m => a -> m a
return SpanContext
        { ctxTraceID :: TraceID
ctxTraceID      = TraceID
trid
        , ctxSpanID :: Word64
ctxSpanID       = Word64
spid
        , ctxParentSpanID :: Maybe Word64
ctxParentSpanID = forall a. Maybe a
Nothing
        , _ctxSampled :: Sampled
_ctxSampled     = Sampled
sampled'
        , _ctxBaggage :: HashMap Text Text
_ctxBaggage     = forall a. Monoid a => a
mempty
        }

fromParent
    :: ( MonadIO            m
       , MonadReader StdEnv m
       )
    => SpanContext
    -> m SpanContext
fromParent :: forall (m :: * -> *).
(MonadIO m, MonadReader StdEnv m) =>
SpanContext -> m SpanContext
fromParent SpanContext
p = do
    Word64
spid <- forall (m :: * -> *). (MonadIO m, MonadReader StdEnv m) => m Word64
newSpanID
    forall (m :: * -> *) a. Monad m => a -> m a
return SpanContext
        { ctxTraceID :: TraceID
ctxTraceID      = SpanContext -> TraceID
ctxTraceID SpanContext
p
        , ctxSpanID :: Word64
ctxSpanID       = Word64
spid
        , ctxParentSpanID :: Maybe Word64
ctxParentSpanID = forall a. a -> Maybe a
Just (SpanContext -> Word64
ctxSpanID SpanContext
p)
        , _ctxSampled :: Sampled
_ctxSampled     = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SpanContext Sampled
ctxSampled SpanContext
p
        , _ctxBaggage :: HashMap Text Text
_ctxBaggage     = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' SpanContext (HashMap Text Text)
ctxBaggage SpanContext
p
        }