{-# 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
  , mapTop
  , peek
  , pop
  , popWhenMatches
  , push
  , pushSuppress
  , suppress
  ) where

import           GHC.Generics

import           Instana.SDK.Internal.Util  ((|>))
import           Instana.SDK.Span.EntrySpan (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 (Eq, Generic, Show)


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


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


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


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


{-|Checks if tracing is currently suppressed.
-}
isSuppressed :: SpanStack -> Bool
isSuppressed t =
  t == 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 (Entry entrySpan) None =
  EntryOnly entrySpan
-- a new incoming entry can lift the suppression, an exit can't
push (Entry entrySpan) Suppressed =
  EntryOnly entrySpan
push (Exit exitSpan) (EntryOnly entrySpan) =
  EntryAndExit entrySpan exitSpan
-- ignore invalid calls/invalid state
push _ current =
  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 None =
  Suppressed
pushSuppress Suppressed =
  Suppressed
-- ignore invalid calls/invalid state
pushSuppress current =
  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 None =
  (None, Nothing)
pop Suppressed =
  (None, Nothing)
pop (EntryOnly entrySpan) =
  (None, Just $ Entry entrySpan)
pop (EntryAndExit entrySpan exitSpan) =
  (EntryOnly entrySpan, Just $ Exit 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 _ None =
  (None, Nothing, 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.
  (None, Nothing, Nothing)
popWhenMatches _ Suppressed =
  (Suppressed, Nothing, Nothing)
popWhenMatches expectedKind stack =
  case (expectedKind, peek stack) of
    (EntryKind, Just (Entry _)) ->
      (st, sp, Nothing)
      where
        (st, sp) = pop stack
    (ExitKind, Just (Exit _)) ->
      (st, sp, Nothing)
      where
        (st, sp) = pop stack
    (_, actualTopElement) ->
      ( stack
      , Nothing
      , Just $ "Cannot pop \"" ++ (show expectedKind) ++
        " from span stack. Current top element: " ++ show actualTopElement
      )


{-|Returns the top element without modifying the stack.
-}
peek :: SpanStack -> Maybe Span
peek None =
  Nothing
peek Suppressed =
  Nothing
peek (EntryOnly entrySpan) =
  Just $ Entry entrySpan
peek (EntryAndExit _ exitSpan) =
  Just $ Exit 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 _ None =
  None
mapTop _ Suppressed =
  Suppressed
mapTop fn stack =
  let
    (remainder, Just oldTop) = pop stack
    newTop = fn oldTop
  in
  push newTop remainder