{-# LANGUAGE DeriveGeneric #-}
{-|
Module      : Instana.SDK.Internal.SpanStack
Description : Keeps the current spans of a thread.
-}
module Instana.SDK.Internal.SpanStack
  ( SpanStack
  , empty
  , entry
  , isEmpty
  , isSuppressed
  , mapEntry
  , mapTop
  , peek
  , pop
  , popWhenMatches
  , push
  , pushSuppress
  , readTraceId
  , readW3cTraceContext
  , suppress
  ) where

import           GHC.Generics

import           Instana.SDK.Internal.Id              (Id)
import           Instana.SDK.Internal.Util            ((|>))
import           Instana.SDK.Internal.W3CTraceContext (W3CTraceContext)
import           Instana.SDK.Span.EntrySpan           (EntrySpan)
import qualified Instana.SDK.Span.EntrySpan           as EntrySpan
import           Instana.SDK.Span.ExitSpan            (ExitSpan)
import qualified Instana.SDK.Span.ExitSpan            as ExitSpan
import           Instana.SDK.Span.Span                (Span (..), SpanKind (..))


-- Implementation Note
-- ===================
--
-- This implementation currently heavily relies on the assumption that the
-- monitored application does not employ context switches in a thread (like
-- doing actual async IO, for example). Since Haskell's standard vehicle for
-- concurrency (Control.Concurrent#forkIO and friends) uses green threads (and
-- not OS level threads) doing multiple things in one thread at the same time is
-- not very common, in fact, I haven't seen it in the wild yet.
--
-- Under this assumptions there can be at most two current spans per thread, an
-- entry and an exit. A new exit can only be started once the IO action related
-- to the last exit has completed. The same holds for any entry span. Thus, the
-- spans in one thread do not form a tree (as async contexts and their spans do
-- in Node.js for example) but only a stack with maximal depth 2, like this:
-- * no current span, currently not tracing
-- * an active entry span but not exit
-- * a non-active entry and an active exit


{-|The stack of currently open spans in one thread.
-}
data SpanStack =
    -- |Indicates that we are currently not processing any request.
    None
    -- |Indicates that we are currently processing a request that had
    -- X-INSTANA-L=0 set and that should not record any spans.
  | Suppressed W3CTraceContext
    -- |Indicates that we are currently processing an entry.
  | EntryOnly EntrySpan
    -- |Indicates that currently an exit is in progress.
  | EntryAndExit EntrySpan ExitSpan
  deriving (SpanStack -> SpanStack -> Bool
(SpanStack -> SpanStack -> Bool)
-> (SpanStack -> SpanStack -> Bool) -> Eq SpanStack
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SpanStack -> SpanStack -> Bool
$c/= :: SpanStack -> SpanStack -> Bool
== :: SpanStack -> SpanStack -> Bool
$c== :: SpanStack -> SpanStack -> Bool
Eq, (forall x. SpanStack -> Rep SpanStack x)
-> (forall x. Rep SpanStack x -> SpanStack) -> Generic SpanStack
forall x. Rep SpanStack x -> SpanStack
forall x. SpanStack -> Rep SpanStack x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SpanStack x -> SpanStack
$cfrom :: forall x. SpanStack -> Rep SpanStack x
Generic, Int -> SpanStack -> ShowS
[SpanStack] -> ShowS
SpanStack -> String
(Int -> SpanStack -> ShowS)
-> (SpanStack -> String)
-> ([SpanStack] -> ShowS)
-> Show SpanStack
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SpanStack] -> ShowS
$cshowList :: [SpanStack] -> ShowS
show :: SpanStack -> String
$cshow :: SpanStack -> String
showsPrec :: Int -> SpanStack -> ShowS
$cshowsPrec :: Int -> SpanStack -> ShowS
Show)


{-|Creates an empty span stack.
-}
empty :: SpanStack
empty :: SpanStack
empty =
  SpanStack
None


{-|Initializes a span stack with one entry span.
-}
entry :: EntrySpan -> SpanStack
entry :: EntrySpan -> SpanStack
entry entrySpan :: EntrySpan
entrySpan =
  SpanStack
empty
    SpanStack -> (SpanStack -> SpanStack) -> SpanStack
forall a b. a -> (a -> b) -> b
|> Span -> SpanStack -> SpanStack
push (EntrySpan -> Span
Entry EntrySpan
entrySpan)


{-|Creates a span stack with a suppressed marker.
-}
suppress :: W3CTraceContext -> SpanStack
suppress :: W3CTraceContext -> SpanStack
suppress =
  W3CTraceContext -> SpanStack
Suppressed


{-|Checks if the span stack is empty.
-}
isEmpty :: SpanStack -> Bool
isEmpty :: SpanStack -> Bool
isEmpty t :: SpanStack
t =
  SpanStack
t SpanStack -> SpanStack -> Bool
forall a. Eq a => a -> a -> Bool
== SpanStack
None


{-|Checks if tracing is currently suppressed.
-}
isSuppressed :: SpanStack -> Bool
isSuppressed :: SpanStack -> Bool
isSuppressed stack :: SpanStack
stack =
  case SpanStack
stack of
    Suppressed _ -> Bool
True
    _            -> Bool
False


{-|Pushes a span onto the stack. Invalid calls are ignored (like pushing an
exit onto an empty stack or an entry span onto an already existing entry span.
-}
push :: Span -> SpanStack -> SpanStack
push :: Span -> SpanStack -> SpanStack
push (Entry entrySpan :: EntrySpan
entrySpan) None =
  EntrySpan -> SpanStack
EntryOnly EntrySpan
entrySpan
-- a new incoming entry can lift the suppression, an exit can't
push (Entry entrySpan :: EntrySpan
entrySpan) (Suppressed _) =
  EntrySpan -> SpanStack
EntryOnly EntrySpan
entrySpan
-- pushing an exit child onto an entry parent is valid
push (Exit exitSpan :: ExitSpan
exitSpan) (EntryOnly entrySpan :: EntrySpan
entrySpan) =
  EntrySpan -> ExitSpan -> SpanStack
EntryAndExit EntrySpan
entrySpan ExitSpan
exitSpan
-- ignore invalid calls/invalid state
push _ current :: SpanStack
current =
  SpanStack
current


{-|Pushes a suppressed marker onto the stack. This is only valid if the span
stack is currently empty, otherwise the span stack is returned unmodified.

When pushing the suppressed marker, the w3c trace context for the request in
progress must still be provided.
-}
pushSuppress :: W3CTraceContext -> SpanStack -> SpanStack
pushSuppress :: W3CTraceContext -> SpanStack -> SpanStack
pushSuppress w3cTraceContext :: W3CTraceContext
w3cTraceContext None =
  W3CTraceContext -> SpanStack
Suppressed W3CTraceContext
w3cTraceContext
pushSuppress w3cTraceContext :: W3CTraceContext
w3cTraceContext (Suppressed _) =
  -- this effectively overwrites/discards the previous W3C trace context
  W3CTraceContext -> SpanStack
Suppressed W3CTraceContext
w3cTraceContext
-- ignore invalid calls/invalid state
pushSuppress _ current :: SpanStack
current =
  SpanStack
current


{-|Pops the top element, returns a tuple of the top element and the remaining
stack after poppint the top element.
-}
pop :: SpanStack -> (SpanStack, Maybe Span)
pop :: SpanStack -> (SpanStack, Maybe Span)
pop None =
  (SpanStack
None, Maybe Span
forall a. Maybe a
Nothing)
pop (Suppressed _) =
  (SpanStack
None, Maybe Span
forall a. Maybe a
Nothing)
pop (EntryOnly entrySpan :: EntrySpan
entrySpan) =
  (SpanStack
None, Span -> Maybe Span
forall a. a -> Maybe a
Just (Span -> Maybe Span) -> Span -> Maybe Span
forall a b. (a -> b) -> a -> b
$ EntrySpan -> Span
Entry EntrySpan
entrySpan)
pop (EntryAndExit entrySpan :: EntrySpan
entrySpan exitSpan :: ExitSpan
exitSpan) =
  (EntrySpan -> SpanStack
EntryOnly EntrySpan
entrySpan, Span -> Maybe Span
forall a. a -> Maybe a
Just (Span -> Maybe Span) -> Span -> Maybe Span
forall a b. (a -> b) -> a -> b
$ ExitSpan -> Span
Exit ExitSpan
exitSpan)


{-|Pops the top element, but only if the top element is of the expected kind.
If so, a tuple of the top element and the remaining stack after popping the top
element is returned. If not, Nothing and an unmodified stack is returned. The
last part of the 3-tuple is an error message that is only provided if there is
a mismatch between the expected span kind and the actual span kind on the top of
the stack.
-}
popWhenMatches :: SpanKind -> SpanStack -> (SpanStack, Maybe Span, Maybe String)
popWhenMatches :: SpanKind -> SpanStack -> (SpanStack, Maybe Span, Maybe String)
popWhenMatches _ None =
  (SpanStack
None, Maybe Span
forall a. Maybe a
Nothing, Maybe String
forall a. Maybe a
Nothing)
popWhenMatches EntryKind (Suppressed _) =
  -- This effectively unsuppresses - we started an entry that was suppressed and
  -- now we are asked to complete this very entry, so the suppression is lifted
  -- and we are back to a pristine state, ready to start the next entry when the
  -- next request comes in.
  (SpanStack
None, Maybe Span
forall a. Maybe a
Nothing, Maybe String
forall a. Maybe a
Nothing)
popWhenMatches _ (Suppressed w3cTraceContext :: W3CTraceContext
w3cTraceContext)  =
  (W3CTraceContext -> SpanStack
Suppressed W3CTraceContext
w3cTraceContext, Maybe Span
forall a. Maybe a
Nothing, Maybe String
forall a. Maybe a
Nothing)
popWhenMatches expectedKind :: SpanKind
expectedKind stack :: SpanStack
stack =
  case (SpanKind
expectedKind, SpanStack -> Maybe Span
peek SpanStack
stack) of
    (EntryKind, Just (Entry _)) ->
      (SpanStack
st, Maybe Span
sp, Maybe String
forall a. Maybe a
Nothing)
      where
        (st :: SpanStack
st, sp :: Maybe Span
sp) = SpanStack -> (SpanStack, Maybe Span)
pop SpanStack
stack
    (ExitKind, Just (Exit _)) ->
      (SpanStack
st, Maybe Span
sp, Maybe String
forall a. Maybe a
Nothing)
      where
        (st :: SpanStack
st, sp :: Maybe Span
sp) = SpanStack -> (SpanStack, Maybe Span)
pop SpanStack
stack
    (_, actualTopElement :: Maybe Span
actualTopElement) ->
      ( SpanStack
stack
      , Maybe Span
forall a. Maybe a
Nothing
      , String -> Maybe String
forall a. a -> Maybe a
Just (String -> Maybe String) -> String -> Maybe String
forall a b. (a -> b) -> a -> b
$ "Cannot pop \"" String -> ShowS
forall a. [a] -> [a] -> [a]
++ (SpanKind -> String
forall a. Show a => a -> String
show SpanKind
expectedKind) String -> ShowS
forall a. [a] -> [a] -> [a]
++
        " from span stack. Current top element: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Maybe Span -> String
forall a. Show a => a -> String
show Maybe Span
actualTopElement
      )


{-|Returns the top element without modifying the stack.
-}
peek :: SpanStack -> Maybe Span
peek :: SpanStack -> Maybe Span
peek None =
  Maybe Span
forall a. Maybe a
Nothing
peek (Suppressed _) =
  Maybe Span
forall a. Maybe a
Nothing
peek (EntryOnly entrySpan :: EntrySpan
entrySpan) =
  Span -> Maybe Span
forall a. a -> Maybe a
Just (Span -> Maybe Span) -> Span -> Maybe Span
forall a b. (a -> b) -> a -> b
$ EntrySpan -> Span
Entry EntrySpan
entrySpan
peek (EntryAndExit _ exitSpan :: ExitSpan
exitSpan) =
  Span -> Maybe Span
forall a. a -> Maybe a
Just (Span -> Maybe Span) -> Span -> Maybe Span
forall a b. (a -> b) -> a -> b
$ ExitSpan -> Span
Exit ExitSpan
exitSpan


{-|Reads the trace ID from the entry span of the stack, if any.
-}
readTraceId :: SpanStack -> Maybe Id
readTraceId :: SpanStack -> Maybe Id
readTraceId None =
  Maybe Id
forall a. Maybe a
Nothing
readTraceId (Suppressed _) =
  Maybe Id
forall a. Maybe a
Nothing
readTraceId (EntryOnly entrySpan :: EntrySpan
entrySpan) =
  Id -> Maybe Id
forall a. a -> Maybe a
Just (Id -> Maybe Id) -> Id -> Maybe Id
forall a b. (a -> b) -> a -> b
$ EntrySpan -> Id
EntrySpan.traceId EntrySpan
entrySpan
readTraceId (EntryAndExit entrySpan :: EntrySpan
entrySpan _) =
  Id -> Maybe Id
forall a. a -> Maybe a
Just (Id -> Maybe Id) -> Id -> Maybe Id
forall a b. (a -> b) -> a -> b
$ EntrySpan -> Id
EntrySpan.traceId EntrySpan
entrySpan


{-|Reads the W3C trace context from the current span or suppression marker,
if any.
-}
readW3cTraceContext :: SpanStack -> Maybe W3CTraceContext
readW3cTraceContext :: SpanStack -> Maybe W3CTraceContext
readW3cTraceContext None =
  Maybe W3CTraceContext
forall a. Maybe a
Nothing
readW3cTraceContext (Suppressed w3cTraceContext :: W3CTraceContext
w3cTraceContext) =
  W3CTraceContext -> Maybe W3CTraceContext
forall a. a -> Maybe a
Just W3CTraceContext
w3cTraceContext
readW3cTraceContext (EntryOnly entrySpan :: EntrySpan
entrySpan) =
  EntrySpan -> Maybe W3CTraceContext
EntrySpan.w3cTraceContext EntrySpan
entrySpan
readW3cTraceContext (EntryAndExit _ exitSpan :: ExitSpan
exitSpan) =
  W3CTraceContext -> Maybe W3CTraceContext
forall a. a -> Maybe a
Just (W3CTraceContext -> Maybe W3CTraceContext)
-> W3CTraceContext -> Maybe W3CTraceContext
forall a b. (a -> b) -> a -> b
$ ExitSpan -> W3CTraceContext
ExitSpan.w3cTraceContext ExitSpan
exitSpan


{-|Modifies the top element in place by applying the given function to it. This
is a no op if the span stack is empty.
-}
mapTop :: (Span -> Span) -> SpanStack -> SpanStack
mapTop :: (Span -> Span) -> SpanStack -> SpanStack
mapTop _ None =
  SpanStack
None
mapTop _ (Suppressed w3cTraceContext :: W3CTraceContext
w3cTraceContext) =
  W3CTraceContext -> SpanStack
Suppressed W3CTraceContext
w3cTraceContext
mapTop fn :: Span -> Span
fn stack :: SpanStack
stack =
  let
    (remainder :: SpanStack
remainder, Just oldTop :: Span
oldTop) = SpanStack -> (SpanStack, Maybe Span)
pop SpanStack
stack
    newTop :: Span
newTop = Span -> Span
fn Span
oldTop
  in
  Span -> SpanStack -> SpanStack
push Span
newTop SpanStack
remainder


{-|Modifies the entry span in place by applying the given function to it. This
is a no op if the span stack is empty. This function will never modify the exit
span.
-}
mapEntry :: (Span -> Span) -> SpanStack -> SpanStack
mapEntry :: (Span -> Span) -> SpanStack -> SpanStack
mapEntry _ None =
  SpanStack
None
mapEntry _ (Suppressed w3cTraceContext :: W3CTraceContext
w3cTraceContext) =
  W3CTraceContext -> SpanStack
Suppressed W3CTraceContext
w3cTraceContext
mapEntry fn :: Span -> Span
fn (EntryOnly entrySpan :: EntrySpan
entrySpan) =
  (Span -> Span) -> SpanStack -> SpanStack
mapTop Span -> Span
fn (EntrySpan -> SpanStack
EntryOnly EntrySpan
entrySpan)
mapEntry fn :: Span -> Span
fn (EntryAndExit oldEntrySpan :: EntrySpan
oldEntrySpan oldExitSpan :: ExitSpan
oldExitSpan) =
  let
    (Entry newEntrySpan :: EntrySpan
newEntrySpan) = Span -> Span
fn (EntrySpan -> Span
Entry EntrySpan
oldEntrySpan)
  in
  EntrySpan -> ExitSpan -> SpanStack
EntryAndExit EntrySpan
newEntrySpan ExitSpan
oldExitSpan