{-|
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 :: forall r. Getting r Tracer Tracer
tracer = forall a. a -> a
id

runTracer :: HasTracer r => r -> ReaderT r m a -> m a
runTracer :: forall r (m :: * -> *) a. HasTracer r => r -> ReaderT r m a -> m a
runTracer = forall a b c. (a -> b -> c) -> b -> a -> c
flip 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 :: 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 = do
    ActiveSpan
span <- 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  <- forall (m :: * -> *) e a b.
(MonadMask m, Exception e) =>
m a -> (e -> m b) -> m a
withException (ActiveSpan -> m a
f ActiveSpan
span) (forall (m :: * -> *).
MonadIO m =>
ActiveSpan -> SomeException -> m ActiveSpan
onErr ActiveSpan
span forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> forall (f :: * -> *) a. Functor f => f a -> f ()
void forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t (m :: * -> *).
(HasTracer t, MonadIO m) =>
t -> ActiveSpan -> m FinishedSpan
finishSpan t
t)
    FinishedSpan
fin  <- forall t (m :: * -> *).
(HasTracer t, MonadIO m) =>
t -> ActiveSpan -> m FinishedSpan
finishSpan t
t ActiveSpan
span
    forall (m :: * -> *) a. Monad m => a -> m a
return Traced { tracedResult :: a
tracedResult = a
ret, tracedSpan :: FinishedSpan
tracedSpan = FinishedSpan
fin }
  where
    onErr :: MonadIO m => ActiveSpan -> SomeException -> m ActiveSpan
    onErr :: forall (m :: * -> *).
MonadIO m =>
ActiveSpan -> SomeException -> m ActiveSpan
onErr ActiveSpan
span SomeException
e = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        UTCTime
now <- IO UTCTime
getCurrentTime
        forall (m :: * -> *).
MonadIO m =>
ActiveSpan -> (Span -> Span) -> m ()
modifyActiveSpan ActiveSpan
span forall a b. (a -> b) -> a -> b
$
              forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall a. HasSpanFields a => Lens' a Tags
spanTags (Tag -> Tags -> Tags
setTag (Bool -> Tag
Error Bool
True))
            forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over forall a. HasSpanFields a => Lens' a [LogRecord]
spanLogs (UTCTime -> NonEmpty LogField -> LogRecord
LogRecord UTCTime
now (forall e. Exception e => e -> LogField
ErrObj SomeException
e forall a. a -> [a] -> NonEmpty a
:| []) forall a. a -> [a] -> [a]
:)
        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_ :: forall t (m :: * -> *) a.
(HasTracer t, MonadMask m, MonadIO m) =>
t -> SpanOpts -> (ActiveSpan -> m a) -> m a
traced_ t
t SpanOpts
opt ActiveSpan -> m a
f = forall a. Traced a -> a
tracedResult forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 :: forall t (m :: * -> *).
(HasTracer t, MonadIO m) =>
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} = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a r. HasTracer a => Getting r a Tracer
tracer t
t
    forall (m :: * -> *). MonadIO m => SpanOpts -> m Span
tracerStart SpanOpts
opt forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 :: forall t (m :: * -> *).
(HasTracer t, MonadIO m) =>
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} = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a r. HasTracer a => Getting r a Tracer
tracer t
t
    FinishedSpan
span <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *). MonadIO m => ActiveSpan -> m Span
readActiveSpan ActiveSpan
a) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). MonadIO m => Span -> m FinishedSpan
spanFinish
    case forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. HasSampled a => Lens' a Sampled
sampled FinishedSpan
span of
        Sampled
Sampled    -> forall (m :: * -> *). MonadIO m => FinishedSpan -> m ()
tracerReport FinishedSpan
span
        Sampled
NotSampled -> forall (m :: * -> *) a. Monad m => a -> m a
return () -- TODO: record metric
    forall (m :: * -> *) a. Monad m => a -> m a
return FinishedSpan
span