{-|
Module: OpenTracing.Tracer

This module provides mid and high level tracing functions.
-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes     #-}
{-# LANGUAGE StrictData     #-}

module OpenTracing.Tracer
    ( Tracer(..)
    , HasTracer(..)
    , runTracer

    , traced
    , traced_
    , startSpan
    , finishSpan
    )
where

import Control.Exception.Safe
import Control.Lens
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Reader
import Data.List.NonEmpty     (NonEmpty (..))
import Data.Time.Clock        (getCurrentTime)
import OpenTracing.Log
import OpenTracing.Span
import OpenTracing.Tags
import Prelude                hiding (span)

-- | A `Tracer` is a set of effectful actions that define the mid-level interface
-- to an [OpenTracing tracer](https://github.com/opentracing/specification/blob/master/specification.md#tracer)
--
-- Appliction code should generally construct a `Tracer` once and then use other
-- higher-level functions such as `traced`, `startSpan`, `finishedSpan`.
--
-- @since 0.1.0.0
data Tracer = Tracer
    { Tracer -> forall (m :: * -> *). MonadIO m => SpanOpts -> m Span
tracerStart  :: forall m. MonadIO m => SpanOpts     -> m Span
      -- ^ Start recording a new span with the given options. This is
      -- a mid-level operation that will handle start timing and random span ID
      -- generation.
      --
      -- Application code should supply this field with `stdTracer`.
    , Tracer -> forall (m :: * -> *). MonadIO m => FinishedSpan -> m ()
tracerReport :: forall m. MonadIO m => FinishedSpan -> m ()
    -- ^ Report a finished span. What reporting means for each application will
    -- depend on where this data is going. There are multiple backends that define
    -- reporters for Google Cloudtrace, Zipkin, and Jaeger, for example.
    }

-- | Typeclass for application environments that contain a `Tracer`.
--
-- @since 0.1.0.0
class HasTracer a where
    tracer :: Getting r a Tracer

instance HasTracer Tracer where
    tracer :: Getting r Tracer Tracer
tracer = Getting r Tracer Tracer
forall a. a -> a
id

runTracer :: HasTracer r => r -> ReaderT r m a -> m a
runTracer :: r -> ReaderT r m a -> m a
runTracer = (ReaderT r m a -> r -> m a) -> r -> ReaderT r m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT r m a -> r -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT

-- | Trace a computation as a span. This is a high-level operation that will handle
-- all aspects of the trace, including timing and reporting. If the traced computation
-- throws an excpetion, `traced` will clean up and add logs before rethrowing the
-- exception
--
-- @
--         traced tracer (spanOpts "hello" mempty          ) $ \parent ->
--         traced tracer (spanOpts "world" (childOf parent)) $ \child ->
--            liftIO $ do
--                putStrLn "doing some work..."
--                addLogRecord child (Message "doing some work")
--                threadDelay 500000
-- @
--
-- @since 0.1.0.0
traced
    :: ( HasTracer t
       , MonadMask m
       , MonadIO   m
       )
    => t -- ^ A tracer environment
    -> SpanOpts -- ^ The options to use when creating the span. Options include:
    --
    --   * Operation name
    --
    --   * Tags
    --
    --   * Relations to other spans
    -> (ActiveSpan -> m a) -- ^ the computation to trace. The argument is the
    -- span that is created. It can be used to:
    --
    --   * Add logs
    --
    --   * Add child spans
    -> m (Traced a)
traced :: t -> SpanOpts -> (ActiveSpan -> m a) -> m (Traced a)
traced t
t SpanOpts
opt ActiveSpan -> m a
f = do
    ActiveSpan
span <- t -> SpanOpts -> m ActiveSpan
forall t (m :: * -> *).
(HasTracer t, MonadIO m) =>
t -> SpanOpts -> m ActiveSpan
startSpan t
t SpanOpts
opt
    -- /Note/: as per 'withException', we will be reporting any exception incl.
    -- async ones. Exceptions thrown by 'finishSpan'' will be ignored, and the
    -- one from 'f' will be rethrown. Observe that 'withException' does _not_
    -- run the error handler under `uninterruptibleMask', unlike 'bracket'. This
    -- is a good thing, as we might be doing blocking I/O.
    a
ret  <- m a -> (SomeException -> m ()) -> m a
forall (m :: * -> *) e a b.
(MonadMask m, Exception e) =>
m a -> (e -> m b) -> m a
withException (ActiveSpan -> m a
f ActiveSpan
span) (ActiveSpan -> SomeException -> m ActiveSpan
forall (m :: * -> *).
MonadIO m =>
ActiveSpan -> SomeException -> m ActiveSpan
onErr ActiveSpan
span (SomeException -> m ActiveSpan)
-> (ActiveSpan -> m ()) -> SomeException -> m ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> m FinishedSpan -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m FinishedSpan -> m ())
-> (ActiveSpan -> m FinishedSpan) -> ActiveSpan -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. t -> ActiveSpan -> m FinishedSpan
forall t (m :: * -> *).
(HasTracer t, MonadIO m) =>
t -> ActiveSpan -> m FinishedSpan
finishSpan t
t)
    FinishedSpan
fin  <- t -> ActiveSpan -> m FinishedSpan
forall t (m :: * -> *).
(HasTracer t, MonadIO m) =>
t -> ActiveSpan -> m FinishedSpan
finishSpan t
t ActiveSpan
span
    Traced a -> m (Traced a)
forall (m :: * -> *) a. Monad m => a -> m a
return Traced :: forall a. a -> FinishedSpan -> Traced a
Traced { tracedResult :: a
tracedResult = a
ret, tracedSpan :: FinishedSpan
tracedSpan = FinishedSpan
fin }
  where
    onErr :: MonadIO m => ActiveSpan -> SomeException -> m ActiveSpan
    onErr :: ActiveSpan -> SomeException -> m ActiveSpan
onErr ActiveSpan
span SomeException
e = IO ActiveSpan -> m ActiveSpan
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ActiveSpan -> m ActiveSpan) -> IO ActiveSpan -> m ActiveSpan
forall a b. (a -> b) -> a -> b
$ do
        UTCTime
now <- IO UTCTime
getCurrentTime
        ActiveSpan -> (Span -> Span) -> IO ()
forall (m :: * -> *).
MonadIO m =>
ActiveSpan -> (Span -> Span) -> m ()
modifyActiveSpan ActiveSpan
span ((Span -> Span) -> IO ()) -> (Span -> Span) -> IO ()
forall a b. (a -> b) -> a -> b
$
              ASetter Span Span Tags Tags -> (Tags -> Tags) -> Span -> Span
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Span Span Tags Tags
forall a. HasSpanFields a => Lens' a Tags
spanTags (Tag -> Tags -> Tags
setTag (Bool -> Tag
Error Bool
True))
            (Span -> Span) -> (Span -> Span) -> Span -> Span
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter Span Span [LogRecord] [LogRecord]
-> ([LogRecord] -> [LogRecord]) -> Span -> Span
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter Span Span [LogRecord] [LogRecord]
forall a. HasSpanFields a => Lens' a [LogRecord]
spanLogs (UTCTime -> NonEmpty LogField -> LogRecord
LogRecord UTCTime
now (SomeException -> LogField
forall e. Exception e => e -> LogField
ErrObj SomeException
e LogField -> [LogField] -> NonEmpty LogField
forall a. a -> [a] -> NonEmpty a
:| []) LogRecord -> [LogRecord] -> [LogRecord]
forall a. a -> [a] -> [a]
:)
        ActiveSpan -> IO ActiveSpan
forall (f :: * -> *) a. Applicative f => a -> f a
pure ActiveSpan
span

-- | Variant of `traced` that doesn't return the wrapped value.
--
-- @since 0.1.0.0
traced_
    :: ( HasTracer t
       , MonadMask m
       , MonadIO   m
       )
    => t
    -> SpanOpts
    -> (ActiveSpan -> m a)
    -> m a
traced_ :: t -> SpanOpts -> (ActiveSpan -> m a) -> m a
traced_ t
t SpanOpts
opt ActiveSpan -> m a
f = Traced a -> a
forall a. Traced a -> a
tracedResult (Traced a -> a) -> m (Traced a) -> m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> SpanOpts -> (ActiveSpan -> m a) -> m (Traced a)
forall t (m :: * -> *) a.
(HasTracer t, MonadMask m, MonadIO m) =>
t -> SpanOpts -> (ActiveSpan -> m a) -> m (Traced a)
traced t
t SpanOpts
opt ActiveSpan -> m a
f

-- | Start recording a span
--
-- @since 0.1.0.0
startSpan :: (HasTracer t, MonadIO m) => t -> SpanOpts -> m ActiveSpan
startSpan :: t -> SpanOpts -> m ActiveSpan
startSpan t
t SpanOpts
opt = do
    let Tracer{forall (m :: * -> *). MonadIO m => SpanOpts -> m Span
tracerStart :: forall (m :: * -> *). MonadIO m => SpanOpts -> m Span
tracerStart :: Tracer -> forall (m :: * -> *). MonadIO m => SpanOpts -> m Span
tracerStart} = Getting Tracer t Tracer -> t -> Tracer
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Tracer t Tracer
forall a r. HasTracer a => Getting r a Tracer
tracer t
t
    SpanOpts -> m Span
forall (m :: * -> *). MonadIO m => SpanOpts -> m Span
tracerStart SpanOpts
opt m Span -> (Span -> m ActiveSpan) -> m ActiveSpan
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO ActiveSpan -> m ActiveSpan
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ActiveSpan -> m ActiveSpan)
-> (Span -> IO ActiveSpan) -> Span -> m ActiveSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Span -> IO ActiveSpan
forall (m :: * -> *). MonadIO m => Span -> m ActiveSpan
mkActive

-- | Finish recording a span
--
-- @since 0.1.0.0
finishSpan :: (HasTracer t, MonadIO m) => t -> ActiveSpan -> m FinishedSpan
finishSpan :: t -> ActiveSpan -> m FinishedSpan
finishSpan t
t ActiveSpan
a = do
    let Tracer{forall (m :: * -> *). MonadIO m => FinishedSpan -> m ()
tracerReport :: forall (m :: * -> *). MonadIO m => FinishedSpan -> m ()
tracerReport :: Tracer -> forall (m :: * -> *). MonadIO m => FinishedSpan -> m ()
tracerReport} = Getting Tracer t Tracer -> t -> Tracer
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Tracer t Tracer
forall a r. HasTracer a => Getting r a Tracer
tracer t
t
    FinishedSpan
span <- IO Span -> m Span
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (ActiveSpan -> IO Span
forall (m :: * -> *). MonadIO m => ActiveSpan -> m Span
readActiveSpan ActiveSpan
a) m Span -> (Span -> m FinishedSpan) -> m FinishedSpan
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Span -> m FinishedSpan
forall (m :: * -> *). MonadIO m => Span -> m FinishedSpan
spanFinish
    case Getting Sampled FinishedSpan Sampled -> FinishedSpan -> Sampled
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Sampled FinishedSpan Sampled
forall a. HasSampled a => Lens' a Sampled
sampled FinishedSpan
span of
        Sampled
Sampled    -> FinishedSpan -> m ()
forall (m :: * -> *). MonadIO m => FinishedSpan -> m ()
tracerReport FinishedSpan
span
        Sampled
NotSampled -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- TODO: record metric
    FinishedSpan -> m FinishedSpan
forall (m :: * -> *) a. Monad m => a -> m a
return FinishedSpan
span