{-# 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
  , suppress
  ) where

import           GHC.Generics

import           Instana.SDK.Internal.Id    (Id)
import           Instana.SDK.Internal.Util  ((|>))
import           Instana.SDK.Span.EntrySpan (EntrySpan)
import qualified Instana.SDK.Span.EntrySpan as EntrySpan
import           Instana.SDK.Span.ExitSpan  (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
    -- |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 an span stack with a suppressed marker.
-}
suppress :: SpanStack
suppress :: SpanStack
suppress =
  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 t :: SpanStack
t =
  SpanStack
t SpanStack -> SpanStack -> Bool
forall a. Eq a => a -> a -> Bool
== SpanStack
Suppressed


{-|Pushes a span onto the stack. Invalid calls are ignored (like pushing an
exit onto an empty span 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
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.
-}
pushSuppress :: SpanStack -> SpanStack
pushSuppress :: SpanStack -> SpanStack
pushSuppress None =
  SpanStack
Suppressed
pushSuppress Suppressed =
  SpanStack
Suppressed
-- 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 =
  (SpanStack
Suppressed, 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


{-|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 =
  SpanStack
Suppressed
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 =
  SpanStack
Suppressed
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