{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module OpenTelemetry.Processor.Simple
  ( SimpleProcessorConfig(..)
  , simpleProcessor
  ) where

import Control.Exception
import Control.Concurrent.Async
import Control.Concurrent.Chan.Unagi
import Control.Monad
import Data.IORef
import OpenTelemetry.Processor
import OpenTelemetry.Trace.Core (ImmutableSpan, spanTracer, tracerName)
import qualified OpenTelemetry.Exporter as Exporter
import qualified Data.HashMap.Strict as HashMap

newtype SimpleProcessorConfig = SimpleProcessorConfig
  { SimpleProcessorConfig -> Exporter
exporter :: Exporter.Exporter
  -- ^ The exporter where the spans are pushed.
  }

-- | This is an implementation of SpanProcessor which passes finished spans 
-- and passes the export-friendly span data representation to the configured SpanExporter, 
-- as soon as they are finished.
--
-- @since 0.0.1.0
simpleProcessor :: SimpleProcessorConfig -> IO Processor
simpleProcessor :: SimpleProcessorConfig -> IO Processor
simpleProcessor SimpleProcessorConfig{Exporter
exporter :: Exporter
exporter :: SimpleProcessorConfig -> Exporter
..} = do
  (InChan (IORef ImmutableSpan)
inChan :: InChan (IORef ImmutableSpan), OutChan (IORef ImmutableSpan)
outChan :: OutChan (IORef ImmutableSpan)) <- IO (InChan (IORef ImmutableSpan), OutChan (IORef ImmutableSpan))
forall a. IO (InChan a, OutChan a)
newChan
  Async Any
exportWorker <- IO Any -> IO (Async Any)
forall a. IO a -> IO (Async a)
async (IO Any -> IO (Async Any)) -> IO Any -> IO (Async Any)
forall a b. (a -> b) -> a -> b
$ IO ExportResult -> IO Any
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO ExportResult -> IO Any) -> IO ExportResult -> IO Any
forall a b. (a -> b) -> a -> b
$ do
    -- TODO, masking vs bracket here, not sure what's the right choice
    IORef ImmutableSpan
spanRef <- OutChan (IORef ImmutableSpan)
-> (IO (IORef ImmutableSpan) -> IO ()) -> IO (IORef ImmutableSpan)
forall a. OutChan a -> (IO a -> IO ()) -> IO a
readChanOnException OutChan (IORef ImmutableSpan)
outChan (IO (IORef ImmutableSpan) -> (IORef ImmutableSpan -> IO ()) -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= InChan (IORef ImmutableSpan) -> IORef ImmutableSpan -> IO ()
forall a. InChan a -> a -> IO ()
writeChan InChan (IORef ImmutableSpan)
inChan)
    ImmutableSpan
span_ <- IORef ImmutableSpan -> IO ImmutableSpan
forall a. IORef a -> IO a
readIORef IORef ImmutableSpan
spanRef
    IO ExportResult -> IO ExportResult
forall a. IO a -> IO a
mask_ (Exporter
exporter Exporter
-> HashMap InstrumentationLibrary (Vector ImmutableSpan)
-> IO ExportResult
`Exporter.exporterExport` InstrumentationLibrary
-> Vector ImmutableSpan
-> HashMap InstrumentationLibrary (Vector ImmutableSpan)
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton (Tracer -> InstrumentationLibrary
tracerName (Tracer -> InstrumentationLibrary)
-> Tracer -> InstrumentationLibrary
forall a b. (a -> b) -> a -> b
$ ImmutableSpan -> Tracer
spanTracer ImmutableSpan
span_) (ImmutableSpan -> Vector ImmutableSpan
forall (f :: * -> *) a. Applicative f => a -> f a
pure ImmutableSpan
span_))

  Processor -> IO Processor
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Processor -> IO Processor) -> Processor -> IO Processor
forall a b. (a -> b) -> a -> b
$ Processor :: (IORef ImmutableSpan -> Context -> IO ())
-> (IORef ImmutableSpan -> IO ())
-> IO (Async ShutdownResult)
-> IO ()
-> Processor
Processor
    { processorOnStart :: IORef ImmutableSpan -> Context -> IO ()
processorOnStart = \IORef ImmutableSpan
_ Context
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , processorOnEnd :: IORef ImmutableSpan -> IO ()
processorOnEnd = InChan (IORef ImmutableSpan) -> IORef ImmutableSpan -> IO ()
forall a. InChan a -> a -> IO ()
writeChan InChan (IORef ImmutableSpan)
inChan 
    , processorShutdown :: IO (Async ShutdownResult)
processorShutdown = IO ShutdownResult -> IO (Async ShutdownResult)
forall a. IO a -> IO (Async a)
async (IO ShutdownResult -> IO (Async ShutdownResult))
-> IO ShutdownResult -> IO (Async ShutdownResult)
forall a b. (a -> b) -> a -> b
$ ((forall a. IO a -> IO a) -> IO ShutdownResult)
-> IO ShutdownResult
forall b. ((forall a. IO a -> IO a) -> IO b) -> IO b
mask (((forall a. IO a -> IO a) -> IO ShutdownResult)
 -> IO ShutdownResult)
-> ((forall a. IO a -> IO a) -> IO ShutdownResult)
-> IO ShutdownResult
forall a b. (a -> b) -> a -> b
$ \forall a. IO a -> IO a
restore -> do
        Async Any -> IO ()
forall a. Async a -> IO ()
cancel Async Any
exportWorker
        -- TODO handle timeouts
        IO () -> IO ()
forall a. IO a -> IO a
restore (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          -- TODO, not convinced we should shut down processor here
          OutChan (IORef ImmutableSpan) -> IO ()
shutdownProcessor OutChan (IORef ImmutableSpan)
outChan IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Exporter -> IO ()
Exporter.exporterShutdown Exporter
exporter
        ShutdownResult -> IO ShutdownResult
forall (f :: * -> *) a. Applicative f => a -> f a
pure ShutdownResult
ShutdownSuccess
    , processorForceFlush :: IO ()
processorForceFlush = () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    }

  where
    shutdownProcessor :: OutChan (IORef ImmutableSpan) -> IO ()
    shutdownProcessor :: OutChan (IORef ImmutableSpan) -> IO ()
shutdownProcessor OutChan (IORef ImmutableSpan)
outChan = do
      (Element IO (Maybe (IORef ImmutableSpan))
m, IO (IORef ImmutableSpan)
_) <- OutChan (IORef ImmutableSpan)
-> IO (Element (IORef ImmutableSpan), IO (IORef ImmutableSpan))
forall a. OutChan a -> IO (Element a, IO a)
tryReadChan OutChan (IORef ImmutableSpan)
outChan
      Maybe (IORef ImmutableSpan)
mSpan <- IO (Maybe (IORef ImmutableSpan))
m
      case Maybe (IORef ImmutableSpan)
mSpan of 
        Maybe (IORef ImmutableSpan)
Nothing -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just IORef ImmutableSpan
spanRef -> do
          ImmutableSpan
span_ <- IORef ImmutableSpan -> IO ImmutableSpan
forall a. IORef a -> IO a
readIORef IORef ImmutableSpan
spanRef
          ExportResult
_ <- Exporter
exporter Exporter
-> HashMap InstrumentationLibrary (Vector ImmutableSpan)
-> IO ExportResult
`Exporter.exporterExport` InstrumentationLibrary
-> Vector ImmutableSpan
-> HashMap InstrumentationLibrary (Vector ImmutableSpan)
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton (Tracer -> InstrumentationLibrary
tracerName (Tracer -> InstrumentationLibrary)
-> Tracer -> InstrumentationLibrary
forall a b. (a -> b) -> a -> b
$ ImmutableSpan -> Tracer
spanTracer ImmutableSpan
span_) (ImmutableSpan -> Vector ImmutableSpan
forall (f :: * -> *) a. Applicative f => a -> f a
pure ImmutableSpan
span_)
          OutChan (IORef ImmutableSpan) -> IO ()
shutdownProcessor OutChan (IORef ImmutableSpan)
outChan