{-|
Module: OpenTracing.Span

Data types and functions for manipulating [spans](https://github.com/opentracing/specification/blob/master/specification.md#span)
-}
{-# LANGUAGE FlexibleContexts       #-}
{-# LANGUAGE FlexibleInstances      #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase             #-}
{-# LANGUAGE MultiParamTypeClasses  #-}
{-# LANGUAGE NamedFieldPuns         #-}
{-# LANGUAGE OverloadedStrings      #-}
{-# LANGUAGE RecordWildCards        #-}
{-# LANGUAGE StrictData             #-}
{-# LANGUAGE TemplateHaskell        #-}
{-# LANGUAGE TupleSections          #-}

module OpenTracing.Span
    ( SpanContext(..)
    , ctxSampled
    , ctxBaggage

    , Span
    , newSpan

    , HasSpanFields

    , ActiveSpan
    , mkActive
    , modifyActiveSpan
    , readActiveSpan
    , addTag
    , addLogRecord
    , addLogRecord'
    , setBaggageItem
    , getBaggageItem

    , FinishedSpan
    , spanFinish

    , spanContext
    , spanOperation
    , spanStart
    , spanTags
    , spanRefs
    , spanLogs
    , spanDuration

    , SpanOpts
    , spanOpts
    , spanOptOperation
    , spanOptRefs
    , spanOptTags
    , spanOptSampled

    , Reference(..)
    , findParent

    , SpanRefs
    , refActiveParents
    , refPredecessors
    , refPropagated
    , childOf
    , followsFrom
    , freezeRefs

    , Sampled(..)
    , _IsSampled
    , sampled

    , Traced(..)
    )
where

import Control.Applicative
import Control.Lens           hiding (op, pre, (.=))
import Control.Monad.IO.Class
import Data.Aeson             (ToJSON (..), object, (.=))
import Data.Aeson.Encoding    (int, pairs)
import Data.Bool              (bool)
import Data.Foldable
import Data.HashMap.Strict    (HashMap, insert)
import Data.IORef
import Data.List.NonEmpty     (NonEmpty (..))
import Data.Semigroup
import Data.Text              (Text)
import Data.Time.Clock
import Data.Word
import OpenTracing.Log
import OpenTracing.Tags
import OpenTracing.Types
import Prelude                hiding (span)

-- | A `SpanContext` is the data that uniquely identifies a span
-- and the context in which it occurs. Spans occur in traces, which form
-- complete pictures of a computation, potentially across multiple machines.
--
-- @since 0.1.0.0
data SpanContext = SpanContext
    { SpanContext -> TraceID
ctxTraceID      :: TraceID
    -- ^ A trace identifier. Trace ids are globally unique
    , SpanContext -> Word64
ctxSpanID       :: Word64
    -- ^ A span identifier. Span identifiers are unique to their trace.
    , SpanContext -> Maybe Word64
ctxParentSpanID :: Maybe Word64
    -- ^ Spans without a parent are known as "root spans"
    , SpanContext -> Sampled
_ctxSampled     :: Sampled
    -- ^ Whether or not this span is going to be reported.
    , SpanContext -> HashMap Text Text
_ctxBaggage     :: HashMap Text Text
    -- ^ Baggage is arbitrary key:value pairs that cross process boundaries.
    }

instance ToJSON SpanContext where
    toEncoding :: SpanContext -> Encoding
toEncoding SpanContext{Maybe Word64
Word64
HashMap Text Text
TraceID
Sampled
_ctxBaggage :: HashMap Text Text
_ctxSampled :: Sampled
ctxParentSpanID :: Maybe Word64
ctxSpanID :: Word64
ctxTraceID :: TraceID
_ctxBaggage :: SpanContext -> HashMap Text Text
_ctxSampled :: SpanContext -> Sampled
ctxParentSpanID :: SpanContext -> Maybe Word64
ctxSpanID :: SpanContext -> Word64
ctxTraceID :: SpanContext -> TraceID
..} = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$
           Text
"trace_id" Text -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Getting Text TraceID Text -> TraceID -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text TraceID Text
forall a. AsHex a => Getter a Text
hexText TraceID
ctxTraceID
        Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
"span_id"  Text -> Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Getting Text Word64 Text -> Word64 -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Word64 Text
forall a. AsHex a => Getter a Text
hexText Word64
ctxSpanID
        Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
"sampled"  Text -> Sampled -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Sampled
_ctxSampled
        Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
"baggage"  Text -> HashMap Text Text -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= HashMap Text Text
_ctxBaggage

    toJSON :: SpanContext -> Value
toJSON SpanContext{Maybe Word64
Word64
HashMap Text Text
TraceID
Sampled
_ctxBaggage :: HashMap Text Text
_ctxSampled :: Sampled
ctxParentSpanID :: Maybe Word64
ctxSpanID :: Word64
ctxTraceID :: TraceID
_ctxBaggage :: SpanContext -> HashMap Text Text
_ctxSampled :: SpanContext -> Sampled
ctxParentSpanID :: SpanContext -> Maybe Word64
ctxSpanID :: SpanContext -> Word64
ctxTraceID :: SpanContext -> TraceID
..} = [Pair] -> Value
object
        [ Text
"trace_id" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Getting Text TraceID Text -> TraceID -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text TraceID Text
forall a. AsHex a => Getter a Text
hexText TraceID
ctxTraceID
        , Text
"span_id"  Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Getting Text Word64 Text -> Word64 -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Word64 Text
forall a. AsHex a => Getter a Text
hexText Word64
ctxSpanID
        , Text
"sampled"  Text -> Sampled -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Sampled
_ctxSampled
        , Text
"baggage"  Text -> HashMap Text Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= HashMap Text Text
_ctxBaggage
        ]

-- | A wrapper for a value that was produced by a traced computation.
--
-- @since 0.1.0.0
data Traced a = Traced
    { Traced a -> a
tracedResult :: a
    -- ^ The raw value produced
    , Traced a -> FinishedSpan
tracedSpan   :: ~FinishedSpan
    -- ^ The resulting span that was created
    }

-- | A datatype indicating whether a recorded span was sampled, i.e. whether or not
-- it will be reported. Traces are often sampled in high volume environments to keep
-- the amount of data generated manageable.
--
-- @since 0.1.0.0
data Sampled = NotSampled | Sampled
    deriving (Sampled -> Sampled -> Bool
(Sampled -> Sampled -> Bool)
-> (Sampled -> Sampled -> Bool) -> Eq Sampled
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Sampled -> Sampled -> Bool
$c/= :: Sampled -> Sampled -> Bool
== :: Sampled -> Sampled -> Bool
$c== :: Sampled -> Sampled -> Bool
Eq, Int -> Sampled -> ShowS
[Sampled] -> ShowS
Sampled -> String
(Int -> Sampled -> ShowS)
-> (Sampled -> String) -> ([Sampled] -> ShowS) -> Show Sampled
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Sampled] -> ShowS
$cshowList :: [Sampled] -> ShowS
show :: Sampled -> String
$cshow :: Sampled -> String
showsPrec :: Int -> Sampled -> ShowS
$cshowsPrec :: Int -> Sampled -> ShowS
Show, ReadPrec [Sampled]
ReadPrec Sampled
Int -> ReadS Sampled
ReadS [Sampled]
(Int -> ReadS Sampled)
-> ReadS [Sampled]
-> ReadPrec Sampled
-> ReadPrec [Sampled]
-> Read Sampled
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Sampled]
$creadListPrec :: ReadPrec [Sampled]
readPrec :: ReadPrec Sampled
$creadPrec :: ReadPrec Sampled
readList :: ReadS [Sampled]
$creadList :: ReadS [Sampled]
readsPrec :: Int -> ReadS Sampled
$creadsPrec :: Int -> ReadS Sampled
Read, Sampled
Sampled -> Sampled -> Bounded Sampled
forall a. a -> a -> Bounded a
maxBound :: Sampled
$cmaxBound :: Sampled
minBound :: Sampled
$cminBound :: Sampled
Bounded, Int -> Sampled
Sampled -> Int
Sampled -> [Sampled]
Sampled -> Sampled
Sampled -> Sampled -> [Sampled]
Sampled -> Sampled -> Sampled -> [Sampled]
(Sampled -> Sampled)
-> (Sampled -> Sampled)
-> (Int -> Sampled)
-> (Sampled -> Int)
-> (Sampled -> [Sampled])
-> (Sampled -> Sampled -> [Sampled])
-> (Sampled -> Sampled -> [Sampled])
-> (Sampled -> Sampled -> Sampled -> [Sampled])
-> Enum Sampled
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: Sampled -> Sampled -> Sampled -> [Sampled]
$cenumFromThenTo :: Sampled -> Sampled -> Sampled -> [Sampled]
enumFromTo :: Sampled -> Sampled -> [Sampled]
$cenumFromTo :: Sampled -> Sampled -> [Sampled]
enumFromThen :: Sampled -> Sampled -> [Sampled]
$cenumFromThen :: Sampled -> Sampled -> [Sampled]
enumFrom :: Sampled -> [Sampled]
$cenumFrom :: Sampled -> [Sampled]
fromEnum :: Sampled -> Int
$cfromEnum :: Sampled -> Int
toEnum :: Int -> Sampled
$ctoEnum :: Int -> Sampled
pred :: Sampled -> Sampled
$cpred :: Sampled -> Sampled
succ :: Sampled -> Sampled
$csucc :: Sampled -> Sampled
Enum)

instance ToJSON Sampled where
    toJSON :: Sampled -> Value
toJSON     = Int -> Value
forall a. ToJSON a => a -> Value
toJSON (Int -> Value) -> (Sampled -> Int) -> Sampled -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sampled -> Int
forall a. Enum a => a -> Int
fromEnum
    toEncoding :: Sampled -> Encoding
toEncoding = Int -> Encoding
int (Int -> Encoding) -> (Sampled -> Int) -> Sampled -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sampled -> Int
forall a. Enum a => a -> Int
fromEnum

_IsSampled :: Iso' Bool Sampled
_IsSampled :: p Sampled (f Sampled) -> p Bool (f Bool)
_IsSampled = (Bool -> Sampled)
-> (Sampled -> Bool) -> Iso Bool Bool Sampled Sampled
forall s a b t. (s -> a) -> (b -> t) -> Iso s t a b
iso (Sampled -> Sampled -> Bool -> Sampled
forall a. a -> a -> Bool -> a
bool Sampled
NotSampled Sampled
Sampled) ((Sampled -> Bool) -> Iso Bool Bool Sampled Sampled)
-> (Sampled -> Bool) -> Iso Bool Bool Sampled Sampled
forall a b. (a -> b) -> a -> b
$ \case
    Sampled
Sampled    -> Bool
True
    Sampled
NotSampled -> Bool
False

-- | A reference from one span to another. Spans can be related in two ways:
--
--   * `ChildOf` indicates that the parent span is dependent on the child span in order
--      to produce its own result.
--
--   * `FollowsFrom` indicates that there is no dependence relation, perhaps the
--      parent span spawned an asynchronous task.
--
-- More info in the [OpenTracing spec](https://github.com/opentracing/specification/blob/master/specification.md#references-between-spans)
--
-- @since 0.1.0.0
data Reference
    = ChildOf     { Reference -> SpanContext
refCtx :: SpanContext }
    | FollowsFrom { refCtx :: SpanContext }

findParent :: Foldable t => t Reference -> Maybe Reference
findParent :: t Reference -> Maybe Reference
findParent = (Maybe Reference -> Reference -> Maybe Reference)
-> Maybe Reference -> t Reference -> Maybe Reference
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Maybe Reference -> Reference -> Maybe Reference
go Maybe Reference
forall a. Maybe a
Nothing
  where
    go :: Maybe Reference -> Reference -> Maybe Reference
go Maybe Reference
Nothing  Reference
y = Reference -> Maybe Reference
forall a. a -> Maybe a
Just Reference
y
    go (Just Reference
x) Reference
y = Reference -> Maybe Reference
forall a. a -> Maybe a
Just (Reference -> Maybe Reference) -> Reference -> Maybe Reference
forall a b. (a -> b) -> a -> b
$ case Reference -> Reference -> Ordering
prec Reference
x Reference
y of { Ordering
LT -> Reference
y; Ordering
_ -> Reference
x }

    prec :: Reference -> Reference -> Ordering
prec (ChildOf     SpanContext
_) (FollowsFrom SpanContext
_) = Ordering
GT
    prec (FollowsFrom SpanContext
_) (ChildOf     SpanContext
_) = Ordering
LT
    prec Reference
_               Reference
_               = Ordering
EQ

-- | The different references that a span can hold to other spans.
--
-- @since 0.1.0.0
data SpanRefs = SpanRefs
    { SpanRefs -> [ActiveSpan]
_refActiveParents :: [ActiveSpan  ]
    -- ^ Parent span references. `ActiveSpans` are still in progress (parent spans by
    -- definition depend on their children to complete)
    , SpanRefs -> [FinishedSpan]
_refPredecessors  :: [FinishedSpan]
    -- ^ Spans that this span `FollowsFrom`
    , SpanRefs -> [Reference]
_refPropagated    :: [Reference   ]
    -- ^ References that are propagated across process boundaries. Can be either parents
    -- or predecessors.
    }

instance Semigroup SpanRefs where
    (SpanRefs [ActiveSpan]
par [FinishedSpan]
pre [Reference]
pro) <> :: SpanRefs -> SpanRefs -> SpanRefs
<> (SpanRefs [ActiveSpan]
par' [FinishedSpan]
pre' [Reference]
pro') = SpanRefs :: [ActiveSpan] -> [FinishedSpan] -> [Reference] -> SpanRefs
SpanRefs
        { _refActiveParents :: [ActiveSpan]
_refActiveParents = [ActiveSpan]
par [ActiveSpan] -> [ActiveSpan] -> [ActiveSpan]
forall a. Semigroup a => a -> a -> a
<> [ActiveSpan]
par'
        , _refPredecessors :: [FinishedSpan]
_refPredecessors  = [FinishedSpan]
pre [FinishedSpan] -> [FinishedSpan] -> [FinishedSpan]
forall a. Semigroup a => a -> a -> a
<> [FinishedSpan]
pre'
        , _refPropagated :: [Reference]
_refPropagated    = [Reference]
pro [Reference] -> [Reference] -> [Reference]
forall a. Semigroup a => a -> a -> a
<> [Reference]
pro'
        }

instance Monoid SpanRefs where
    mempty :: SpanRefs
mempty  = [ActiveSpan] -> [FinishedSpan] -> [Reference] -> SpanRefs
SpanRefs [ActiveSpan]
forall a. Monoid a => a
mempty [FinishedSpan]
forall a. Monoid a => a
mempty [Reference]
forall a. Monoid a => a
mempty
    mappend :: SpanRefs -> SpanRefs -> SpanRefs
mappend = SpanRefs -> SpanRefs -> SpanRefs
forall a. Semigroup a => a -> a -> a
(<>)

-- | Create a `SpanRefs` containing the single refrence to a parent span.
--
-- @since 0.1.0.0
childOf :: ActiveSpan -> SpanRefs
childOf :: ActiveSpan -> SpanRefs
childOf ActiveSpan
a = SpanRefs
forall a. Monoid a => a
mempty { _refActiveParents :: [ActiveSpan]
_refActiveParents = [ActiveSpan
a] }

-- | Create a `SpanRefs` containing the single refrence to a predecessor span.
--
-- @since 0.1.0.0
followsFrom :: FinishedSpan -> SpanRefs
followsFrom :: FinishedSpan -> SpanRefs
followsFrom FinishedSpan
a = SpanRefs
forall a. Monoid a => a
mempty { _refPredecessors :: [FinishedSpan]
_refPredecessors = [FinishedSpan
a] }

-- | Convert `SpanRefs` (which may include the mutable `ActiveSpan`s) into
-- an immutable list of `Reference`s
--
-- @since 0.1.0.0
freezeRefs :: SpanRefs -> IO [Reference]
freezeRefs :: SpanRefs -> IO [Reference]
freezeRefs SpanRefs{[FinishedSpan]
[ActiveSpan]
[Reference]
_refPropagated :: [Reference]
_refPredecessors :: [FinishedSpan]
_refActiveParents :: [ActiveSpan]
_refPropagated :: SpanRefs -> [Reference]
_refPredecessors :: SpanRefs -> [FinishedSpan]
_refActiveParents :: SpanRefs -> [ActiveSpan]
..} = do
    [Reference]
a <- (ActiveSpan -> IO Reference) -> [ActiveSpan] -> IO [Reference]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Span -> Reference) -> IO Span -> IO Reference
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SpanContext -> Reference
ChildOf (SpanContext -> Reference)
-> (Span -> SpanContext) -> Span -> Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Span -> SpanContext
_sContext) (IO Span -> IO Reference)
-> (ActiveSpan -> IO Span) -> ActiveSpan -> IO Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActiveSpan -> IO Span
forall (m :: * -> *). MonadIO m => ActiveSpan -> m Span
readActiveSpan) [ActiveSpan]
_refActiveParents
    let b :: [Reference]
b = (FinishedSpan -> Reference) -> [FinishedSpan] -> [Reference]
forall a b. (a -> b) -> [a] -> [b]
map (SpanContext -> Reference
FollowsFrom (SpanContext -> Reference)
-> (FinishedSpan -> SpanContext) -> FinishedSpan -> Reference
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FinishedSpan -> SpanContext
_fContext) [FinishedSpan]
_refPredecessors
    [Reference] -> IO [Reference]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Reference] -> IO [Reference]) -> [Reference] -> IO [Reference]
forall a b. (a -> b) -> a -> b
$ [Reference]
a [Reference] -> [Reference] -> [Reference]
forall a. Semigroup a => a -> a -> a
<> [Reference]
b [Reference] -> [Reference] -> [Reference]
forall a. Semigroup a => a -> a -> a
<> [Reference]
_refPropagated

-- | `SpanOpts` is the metadata information about a span needed in order to start
-- measuring a span. This is the information that application code will provide in
-- order to indicate what a span is doing and how it related to other spans. More info
-- in the [OpenTracing spec](https://github.com/opentracing/specification/blob/master/specification.md#start-a-new-span)
--
-- @since 0.1.0.0
data SpanOpts = SpanOpts
    { SpanOpts -> Text
_spanOptOperation :: Text
    -- ^ The span operation, a human-readable string which concisely represents the
    -- work done by the Span
    , SpanOpts -> SpanRefs
_spanOptRefs      :: SpanRefs
    -- ^ Zero or more references to related spans. Zero references indicates that
    -- a span is a root span and should be given a new trace ID.
    , SpanOpts -> [Tag]
_spanOptTags      :: [Tag]
    -- ^ Tags describing the work done by the span in more detail than the operation
    -- provides.
    , SpanOpts -> Maybe Sampled
_spanOptSampled   :: Maybe Sampled
    -- ^ Force 'Span' to be sampled (or not).
    -- 'Nothing' denotes leave decision to 'Sampler' (the default)
    }

-- | Create a new `SpanOpts` with the minimal amount of required information.
--
-- @since 0.1.0.0
spanOpts :: Text -> SpanRefs -> SpanOpts
spanOpts :: Text -> SpanRefs -> SpanOpts
spanOpts Text
op SpanRefs
refs = SpanOpts :: Text -> SpanRefs -> [Tag] -> Maybe Sampled -> SpanOpts
SpanOpts
    { _spanOptOperation :: Text
_spanOptOperation = Text
op
    , _spanOptRefs :: SpanRefs
_spanOptRefs      = SpanRefs
refs
    , _spanOptTags :: [Tag]
_spanOptTags      = [Tag]
forall a. Monoid a => a
mempty
    , _spanOptSampled :: Maybe Sampled
_spanOptSampled   = Maybe Sampled
forall a. Maybe a
Nothing
    }

-- | `Span` is a span that has been started (but not finished). See the [OpenTracing spec](https://github.com/opentracing/specification/blob/master/specification.md#span) for
-- more info
--
-- @since 0.1.0.0
data Span = Span
    { Span -> SpanContext
_sContext   :: SpanContext
    -- ^ The context in which a span occurs
    , Span -> Text
_sOperation :: Text
    -- ^ The operation that describes a span (see `SpanOpts` for more info)
    , Span -> UTCTime
_sStart     :: UTCTime
    -- ^ The time that the span started
    , Span -> Tags
_sTags      :: Tags
    -- ^ Tags describing the span in more detail than the operation.
    , Span -> SpanRefs
_sRefs      :: SpanRefs
    -- ^ References the span holds to other spans
    , Span -> [LogRecord]
_sLogs      :: [LogRecord]
    -- ^ Structured data the describe events over the lifetime of the span
    }

-- | Create a new `Span` with the provided info. The created `Span` will have a start
-- time equal to the system time when `newSpan` is called.
--
-- @since 0.1.0.0
newSpan
    :: ( MonadIO  m
       , Foldable t
       )
    => SpanContext
    -> Text
    -> SpanRefs
    -> t Tag
    -> m Span
newSpan :: SpanContext -> Text -> SpanRefs -> t Tag -> m Span
newSpan SpanContext
ctx Text
op SpanRefs
refs t Tag
ts = do
    UTCTime
t <- IO UTCTime -> m UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
    Span -> m Span
forall (f :: * -> *) a. Applicative f => a -> f a
pure Span :: SpanContext
-> Text -> UTCTime -> Tags -> SpanRefs -> [LogRecord] -> Span
Span
        { _sContext :: SpanContext
_sContext   = SpanContext
ctx
        , _sOperation :: Text
_sOperation = Text
op
        , _sStart :: UTCTime
_sStart     = UTCTime
t
        , _sTags :: Tags
_sTags      = (Tag -> Tags) -> t Tag -> Tags
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Tag -> Tags -> Tags
`setTag` Tags
forall a. Monoid a => a
mempty) t Tag
ts
        , _sRefs :: SpanRefs
_sRefs      = SpanRefs
refs
        , _sLogs :: [LogRecord]
_sLogs      = [LogRecord]
forall a. Monoid a => a
mempty
        }

-- | A mutable `Span` that is currently being recorded.
--
-- @since 0.1.0.0
newtype ActiveSpan = ActiveSpan { ActiveSpan -> IORef Span
fromActiveSpan :: IORef Span }

-- | @since 0.1.0.0
mkActive :: MonadIO m => Span -> m ActiveSpan
mkActive :: Span -> m ActiveSpan
mkActive = (IORef Span -> ActiveSpan) -> m (IORef Span) -> m ActiveSpan
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IORef Span -> ActiveSpan
ActiveSpan (m (IORef Span) -> m ActiveSpan)
-> (Span -> m (IORef Span)) -> Span -> m ActiveSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (IORef Span) -> m (IORef Span)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef Span) -> m (IORef Span))
-> (Span -> IO (IORef Span)) -> Span -> m (IORef Span)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Span -> IO (IORef Span)
forall a. a -> IO (IORef a)
newIORef

-- | @since 0.1.0.0
modifyActiveSpan :: MonadIO m => ActiveSpan -> (Span -> Span) -> m ()
modifyActiveSpan :: ActiveSpan -> (Span -> Span) -> m ()
modifyActiveSpan ActiveSpan{IORef Span
fromActiveSpan :: IORef Span
fromActiveSpan :: ActiveSpan -> IORef Span
fromActiveSpan} Span -> Span
f =
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ IORef Span -> (Span -> (Span, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' IORef Span
fromActiveSpan ((,()) (Span -> (Span, ())) -> (Span -> Span) -> Span -> (Span, ())
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Span -> Span
f)

-- | @since 0.1.0.0
readActiveSpan :: MonadIO m => ActiveSpan -> m Span
readActiveSpan :: ActiveSpan -> m Span
readActiveSpan = IO Span -> m Span
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Span -> m Span)
-> (ActiveSpan -> IO Span) -> ActiveSpan -> m Span
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef Span -> IO Span
forall a. IORef a -> IO a
readIORef (IORef Span -> IO Span)
-> (ActiveSpan -> IORef Span) -> ActiveSpan -> IO Span
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActiveSpan -> IORef Span
fromActiveSpan

-- | A span that has finished executing.
--
-- @since 0.1.0.0
data FinishedSpan = FinishedSpan
    { FinishedSpan -> SpanContext
_fContext   :: SpanContext
    , FinishedSpan -> Text
_fOperation :: Text
    , FinishedSpan -> UTCTime
_fStart     :: UTCTime
    , FinishedSpan -> NominalDiffTime
_fDuration  :: NominalDiffTime
    , FinishedSpan -> Tags
_fTags      :: Tags
    , FinishedSpan -> [Reference]
_fRefs      :: [Reference]
    , FinishedSpan -> [LogRecord]
_fLogs      :: [LogRecord]
    }

-- | Convert an unfinished `Span` into a `FinishedSpan`
--
-- @since 0.1.0.0
spanFinish :: MonadIO m => Span -> m FinishedSpan
spanFinish :: Span -> m FinishedSpan
spanFinish Span
s = do
    (UTCTime
t,[Reference]
refs) <- IO (UTCTime, [Reference]) -> m (UTCTime, [Reference])
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (UTCTime, [Reference]) -> m (UTCTime, [Reference]))
-> IO (UTCTime, [Reference]) -> m (UTCTime, [Reference])
forall a b. (a -> b) -> a -> b
$ (UTCTime -> [Reference] -> (UTCTime, [Reference]))
-> IO UTCTime -> IO [Reference] -> IO (UTCTime, [Reference])
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) IO UTCTime
getCurrentTime (SpanRefs -> IO [Reference]
freezeRefs (Span -> SpanRefs
_sRefs Span
s))
    FinishedSpan -> m FinishedSpan
forall (f :: * -> *) a. Applicative f => a -> f a
pure FinishedSpan :: SpanContext
-> Text
-> UTCTime
-> NominalDiffTime
-> Tags
-> [Reference]
-> [LogRecord]
-> FinishedSpan
FinishedSpan
        { _fContext :: SpanContext
_fContext   = Span -> SpanContext
_sContext Span
s
        , _fOperation :: Text
_fOperation = Span -> Text
_sOperation Span
s
        , _fStart :: UTCTime
_fStart     = Span -> UTCTime
_sStart Span
s
        , _fDuration :: NominalDiffTime
_fDuration  = UTCTime -> UTCTime -> NominalDiffTime
diffUTCTime UTCTime
t (Span -> UTCTime
_sStart Span
s)
        , _fTags :: Tags
_fTags      = Span -> Tags
_sTags Span
s
        , _fRefs :: [Reference]
_fRefs      = [Reference]
refs
        , _fLogs :: [LogRecord]
_fLogs      = Span -> [LogRecord]
_sLogs Span
s
        }

makeLenses ''SpanContext
makeLenses ''SpanOpts
makeLenses ''Span
makeLenses ''FinishedSpan
makeLenses ''SpanRefs

class HasSpanFields a where
    spanContext   :: Lens' a SpanContext
    spanOperation :: Lens' a Text
    spanStart     :: Lens' a UTCTime
    spanTags      :: Lens' a Tags
    spanLogs      :: Lens' a [LogRecord]

instance HasSpanFields Span where
    spanContext :: (SpanContext -> f SpanContext) -> Span -> f Span
spanContext   = (SpanContext -> f SpanContext) -> Span -> f Span
Lens' Span SpanContext
sContext
    spanOperation :: (Text -> f Text) -> Span -> f Span
spanOperation = (Text -> f Text) -> Span -> f Span
Lens' Span Text
sOperation
    spanStart :: (UTCTime -> f UTCTime) -> Span -> f Span
spanStart     = (UTCTime -> f UTCTime) -> Span -> f Span
Lens' Span UTCTime
sStart
    spanTags :: (Tags -> f Tags) -> Span -> f Span
spanTags      = (Tags -> f Tags) -> Span -> f Span
Lens' Span Tags
sTags
    spanLogs :: ([LogRecord] -> f [LogRecord]) -> Span -> f Span
spanLogs      = ([LogRecord] -> f [LogRecord]) -> Span -> f Span
Lens' Span [LogRecord]
sLogs

instance HasSpanFields FinishedSpan where
    spanContext :: (SpanContext -> f SpanContext) -> FinishedSpan -> f FinishedSpan
spanContext   = (SpanContext -> f SpanContext) -> FinishedSpan -> f FinishedSpan
Lens' FinishedSpan SpanContext
fContext
    spanOperation :: (Text -> f Text) -> FinishedSpan -> f FinishedSpan
spanOperation = (Text -> f Text) -> FinishedSpan -> f FinishedSpan
Lens' FinishedSpan Text
fOperation
    spanStart :: (UTCTime -> f UTCTime) -> FinishedSpan -> f FinishedSpan
spanStart     = (UTCTime -> f UTCTime) -> FinishedSpan -> f FinishedSpan
Lens' FinishedSpan UTCTime
fStart
    spanTags :: (Tags -> f Tags) -> FinishedSpan -> f FinishedSpan
spanTags      = (Tags -> f Tags) -> FinishedSpan -> f FinishedSpan
Lens' FinishedSpan Tags
fTags
    spanLogs :: ([LogRecord] -> f [LogRecord]) -> FinishedSpan -> f FinishedSpan
spanLogs      = ([LogRecord] -> f [LogRecord]) -> FinishedSpan -> f FinishedSpan
Lens' FinishedSpan [LogRecord]
fLogs

class HasSampled a where
    sampled :: Lens' a Sampled

instance HasSampled Sampled where
    sampled :: (Sampled -> f Sampled) -> Sampled -> f Sampled
sampled = (Sampled -> f Sampled) -> Sampled -> f Sampled
forall a. a -> a
id

instance HasSampled SpanContext where
    sampled :: (Sampled -> f Sampled) -> SpanContext -> f SpanContext
sampled = (Sampled -> f Sampled) -> SpanContext -> f SpanContext
Lens' SpanContext Sampled
ctxSampled

instance HasSampled Span where
    sampled :: (Sampled -> f Sampled) -> Span -> f Span
sampled = (SpanContext -> f SpanContext) -> Span -> f Span
forall a. HasSpanFields a => Lens' a SpanContext
spanContext ((SpanContext -> f SpanContext) -> Span -> f Span)
-> ((Sampled -> f Sampled) -> SpanContext -> f SpanContext)
-> (Sampled -> f Sampled)
-> Span
-> f Span
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sampled -> f Sampled) -> SpanContext -> f SpanContext
forall a. HasSampled a => Lens' a Sampled
sampled

instance HasSampled FinishedSpan where
    sampled :: (Sampled -> f Sampled) -> FinishedSpan -> f FinishedSpan
sampled = (SpanContext -> f SpanContext) -> FinishedSpan -> f FinishedSpan
forall a. HasSpanFields a => Lens' a SpanContext
spanContext ((SpanContext -> f SpanContext) -> FinishedSpan -> f FinishedSpan)
-> ((Sampled -> f Sampled) -> SpanContext -> f SpanContext)
-> (Sampled -> f Sampled)
-> FinishedSpan
-> f FinishedSpan
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Sampled -> f Sampled) -> SpanContext -> f SpanContext
forall a. HasSampled a => Lens' a Sampled
sampled


class HasRefs s a | s -> a where
    spanRefs :: Lens' s a

instance HasRefs Span SpanRefs where
    spanRefs :: (SpanRefs -> f SpanRefs) -> Span -> f Span
spanRefs = (SpanRefs -> f SpanRefs) -> Span -> f Span
Lens' Span SpanRefs
sRefs

instance HasRefs FinishedSpan [Reference] where
    spanRefs :: ([Reference] -> f [Reference]) -> FinishedSpan -> f FinishedSpan
spanRefs = ([Reference] -> f [Reference]) -> FinishedSpan -> f FinishedSpan
Lens' FinishedSpan [Reference]
fRefs


spanDuration :: Lens' FinishedSpan NominalDiffTime
spanDuration :: (NominalDiffTime -> f NominalDiffTime)
-> FinishedSpan -> f FinishedSpan
spanDuration = (NominalDiffTime -> f NominalDiffTime)
-> FinishedSpan -> f FinishedSpan
Lens' FinishedSpan NominalDiffTime
fDuration

addTag :: MonadIO m => ActiveSpan -> Tag -> m ()
addTag :: ActiveSpan -> Tag -> m ()
addTag ActiveSpan
s Tag
t = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    ActiveSpan -> (Span -> Span) -> IO ()
forall (m :: * -> *).
MonadIO m =>
ActiveSpan -> (Span -> Span) -> m ()
modifyActiveSpan ActiveSpan
s ((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 Tag
t)

-- | Log structured data to an `ActiveSpan`. More info in the [OpenTracing spec](https://github.com/opentracing/specification/blob/master/specification.md#log-structured-data)
--
-- @since 0.1.0.0
addLogRecord :: MonadIO m => ActiveSpan -> LogField -> m ()
addLogRecord :: ActiveSpan -> LogField -> m ()
addLogRecord ActiveSpan
s LogField
f = ActiveSpan -> LogField -> [LogField] -> m ()
forall (m :: * -> *).
MonadIO m =>
ActiveSpan -> LogField -> [LogField] -> m ()
addLogRecord' ActiveSpan
s LogField
f []

addLogRecord' :: MonadIO m => ActiveSpan -> LogField -> [LogField] -> m ()
addLogRecord' :: ActiveSpan -> LogField -> [LogField] -> m ()
addLogRecord' ActiveSpan
s LogField
f [LogField]
fs = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    UTCTime
t <- IO UTCTime
getCurrentTime
    ActiveSpan -> (Span -> Span) -> IO ()
forall (m :: * -> *).
MonadIO m =>
ActiveSpan -> (Span -> Span) -> m ()
modifyActiveSpan ActiveSpan
s ((Span -> Span) -> IO ()) -> (Span -> Span) -> IO ()
forall a b. (a -> b) -> a -> b
$
        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
t (LogField
f LogField -> [LogField] -> NonEmpty LogField
forall a. a -> [a] -> NonEmpty a
:| [LogField]
fs)LogRecord -> [LogRecord] -> [LogRecord]
forall a. a -> [a] -> [a]
:)

setBaggageItem :: MonadIO m => ActiveSpan -> Text -> Text -> m ()
setBaggageItem :: ActiveSpan -> Text -> Text -> m ()
setBaggageItem ActiveSpan
s Text
k Text
v = ActiveSpan -> (Span -> Span) -> m ()
forall (m :: * -> *).
MonadIO m =>
ActiveSpan -> (Span -> Span) -> m ()
modifyActiveSpan ActiveSpan
s ((Span -> Span) -> m ()) -> (Span -> Span) -> m ()
forall a b. (a -> b) -> a -> b
$
  ASetter Span Span (HashMap Text Text) (HashMap Text Text)
-> (HashMap Text Text -> HashMap Text Text) -> Span -> Span
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((SpanContext -> Identity SpanContext) -> Span -> Identity Span
forall a. HasSpanFields a => Lens' a SpanContext
spanContext ((SpanContext -> Identity SpanContext) -> Span -> Identity Span)
-> ((HashMap Text Text -> Identity (HashMap Text Text))
    -> SpanContext -> Identity SpanContext)
-> ASetter Span Span (HashMap Text Text) (HashMap Text Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashMap Text Text -> Identity (HashMap Text Text))
-> SpanContext -> Identity SpanContext
Lens' SpanContext (HashMap Text Text)
ctxBaggage) (Text -> Text -> HashMap Text Text -> HashMap Text Text
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
insert Text
k Text
v)

getBaggageItem :: MonadIO m => ActiveSpan -> Text -> m (Maybe Text)
getBaggageItem :: ActiveSpan -> Text -> m (Maybe Text)
getBaggageItem ActiveSpan
s Text
k = Getting (Maybe Text) Span (Maybe Text) -> Span -> Maybe Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((SpanContext -> Const (Maybe Text) SpanContext)
-> Span -> Const (Maybe Text) Span
forall a. HasSpanFields a => Lens' a SpanContext
spanContext ((SpanContext -> Const (Maybe Text) SpanContext)
 -> Span -> Const (Maybe Text) Span)
-> ((Maybe Text -> Const (Maybe Text) (Maybe Text))
    -> SpanContext -> Const (Maybe Text) SpanContext)
-> Getting (Maybe Text) Span (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HashMap Text Text -> Const (Maybe Text) (HashMap Text Text))
-> SpanContext -> Const (Maybe Text) SpanContext
Lens' SpanContext (HashMap Text Text)
ctxBaggage ((HashMap Text Text -> Const (Maybe Text) (HashMap Text Text))
 -> SpanContext -> Const (Maybe Text) SpanContext)
-> ((Maybe Text -> Const (Maybe Text) (Maybe Text))
    -> HashMap Text Text -> Const (Maybe Text) (HashMap Text Text))
-> (Maybe Text -> Const (Maybe Text) (Maybe Text))
-> SpanContext
-> Const (Maybe Text) SpanContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Index (HashMap Text Text)
-> Lens' (HashMap Text Text) (Maybe (IxValue (HashMap Text Text)))
forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Text
Index (HashMap Text Text)
k) (Span -> Maybe Text) -> m Span -> m (Maybe Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ActiveSpan -> m Span
forall (m :: * -> *). MonadIO m => ActiveSpan -> m Span
readActiveSpan ActiveSpan
s