{-# LANGUAGE TupleSections #-}

module OpenTracing.Jaeger.Thrift
    ( toThriftSpan
    , toThriftTags
    , toThriftProcess
    , toThriftBatch
    )
where

import           Data.ByteString.Lazy       (toStrict)
import           Control.Lens
import           Data.Bool                  (bool)
import           Data.Foldable
import           Data.Int                   (Int64)
import           Data.Text                  (Text)
import           Data.Text.Lazy.Builder     (toLazyText)
import           Data.Text.Lazy.Builder.Int (decimal)
import           Data.Text.Lens
import           Data.Vector                (Vector)
import qualified Data.Vector                as Vector
import           Data.Vector.Lens           (vector)
import           GHC.Stack                  (prettyCallStack)
import           Jaeger.Types
    ( Batch (..)
    , Log (..)
    , Process (..)
    , Span (..)
    , SpanRef (..)
    , Tag (..)
    )
import qualified Jaeger.Types               as Thrift
import           OpenTracing.Log
import           OpenTracing.Span
import           OpenTracing.Tags
import           OpenTracing.Time
import           OpenTracing.Types          (TraceID (..))


toThriftSpan :: FinishedSpan -> Thrift.Span
toThriftSpan :: FinishedSpan -> Span
toThriftSpan FinishedSpan
s = Thrift.Span
    { span_traceIdLow :: Int64
span_traceIdLow    = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall a. HasSpanFields a => Lens' a SpanContext
spanContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to SpanContext -> Int64
traceIdLo') FinishedSpan
s
    , span_traceIdHigh :: Int64
span_traceIdHigh   = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall a. HasSpanFields a => Lens' a SpanContext
spanContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to SpanContext -> Int64
traceIdHi') FinishedSpan
s
    , span_spanId :: Int64
span_spanId        = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall a. HasSpanFields a => Lens' a SpanContext
spanContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to SpanContext -> Int64
ctxSpanID') FinishedSpan
s
    , span_parentSpanId :: Int64
span_parentSpanId  = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int64
0 (SpanContext -> Int64
ctxSpanID' forall b c a. (b -> c) -> (a -> b) -> a -> c
. Reference -> SpanContext
refCtx) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *). Foldable t => t Reference -> Maybe Reference
findParent
                         forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall s a. HasRefs s a => Lens' s a
spanRefs FinishedSpan
s
    , span_operationName :: Text
span_operationName = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. HasSpanFields a => Lens' a Text
spanOperation FinishedSpan
s
    , span_references :: Maybe (Vector SpanRef)
span_references    = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ( forall s a. HasRefs s a => Lens' s a
spanRefs
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (forall a b. (a -> b) -> [a] -> [b]
map Reference -> SpanRef
toThriftSpanRef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList)
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Iso [a] [b] (Vector a) (Vector b)
vector
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t b. AReview t b -> Getter b t
re forall a b. Prism (Maybe a) (Maybe b) a b
_Just
                                )
                                FinishedSpan
s
    , span_flags :: Int32
span_flags         = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ( forall a. HasSpanFields a => Lens' a SpanContext
spanContext
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' SpanContext Sampled
ctxSampled
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t b. AReview t b -> Getter b t
re Iso' Bool Sampled
_IsSampled
                                forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (forall a. a -> a -> Bool -> a
bool Int32
0 Int32
1)
                                )
                                FinishedSpan
s
    , span_startTime :: Int64
span_startTime     = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall a. HasSpanFields a => Lens' a UTCTime
spanStart forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a b. (AsMicros a, Integral b) => a -> b
micros) FinishedSpan
s
    , span_duration :: Int64
span_duration      = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' FinishedSpan NominalDiffTime
spanDuration forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a b. (AsMicros a, Integral b) => a -> b
micros) FinishedSpan
s
    , span_tags :: Maybe (Vector Tag)
span_tags          = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall a. HasSpanFields a => Lens' a Tags
spanTags forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Tags -> Vector Tag
toThriftTags forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t b. AReview t b -> Getter b t
re forall a b. Prism (Maybe a) (Maybe b) a b
_Just) FinishedSpan
s
    , span_logs :: Maybe (Vector Log)
span_logs          = forall a. a -> Maybe a
Just
                         forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Vector a
Vector.fromList
                         forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' (\LogRecord
r [Log]
acc -> LogRecord -> Log
toThriftLog LogRecord
r forall a. a -> [a] -> [a]
: [Log]
acc) []
                         forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. HasSpanFields a => Lens' a [LogRecord]
spanLogs FinishedSpan
s
    }

toThriftSpanRef :: Reference -> Thrift.SpanRef
toThriftSpanRef :: Reference -> SpanRef
toThriftSpanRef Reference
ref = Thrift.SpanRef
    { spanRef_refType :: SpanRefType
spanRef_refType     = Reference -> SpanRefType
toThriftRefType Reference
ref
    , spanRef_traceIdLow :: Int64
spanRef_traceIdLow  = SpanContext -> Int64
traceIdLo' (Reference -> SpanContext
refCtx Reference
ref)
    , spanRef_traceIdHigh :: Int64
spanRef_traceIdHigh = SpanContext -> Int64
traceIdHi' (Reference -> SpanContext
refCtx Reference
ref)
    , spanRef_spanId :: Int64
spanRef_spanId      = SpanContext -> Int64
ctxSpanID' (Reference -> SpanContext
refCtx Reference
ref)
    }

toThriftRefType :: Reference -> Thrift.SpanRefType
toThriftRefType :: Reference -> SpanRefType
toThriftRefType (ChildOf     SpanContext
_) = SpanRefType
Thrift.CHILD_OF
toThriftRefType (FollowsFrom SpanContext
_) = SpanRefType
Thrift.FOLLOWS_FROM

toThriftTags :: Tags -> Vector Thrift.Tag
toThriftTags :: Tags -> Vector Tag
toThriftTags = forall i (f :: * -> *) m a.
(FoldableWithIndex i f, Monoid m) =>
(i -> a -> m) -> f a -> m
ifoldMap (\Text
k TagVal
v -> forall a. a -> Vector a
Vector.singleton (Text -> TagVal -> Tag
toThriftTag Text
k TagVal
v)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tags -> HashMap Text TagVal
fromTags

toThriftTag :: Text -> TagVal -> Thrift.Tag
-- acc. to https://github.com/opentracing/specification/blob/8d634bc7e3e73050f6ac1006858cddac8d9e0abe/semantic_conventions.yaml
-- "http.status_code" is supposed to be integer-valued. Jaeger, however, drops
-- the value (nb. _not_ the tag key) unless it is a string.
toThriftTag :: Text -> TagVal -> Tag
toThriftTag Text
HttpStatusCodeKey (IntT Int64
v) = Thrift.Tag
    { tag_key :: Text
tag_key     = forall a. (Eq a, IsString a) => a
HttpStatusCodeKey
    , tag_vType :: TagType
tag_vType   = TagType
Thrift.STRING
    , tag_vStr :: Maybe Text
tag_vStr    = forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall lazy strict. Strict lazy strict => Iso' lazy strict
strict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
toLazyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Integral a => a -> Builder
decimal forall a b. (a -> b) -> a -> b
$ Int64
v
    , tag_vDouble :: Maybe Double
tag_vDouble = forall a. Maybe a
Nothing
    , tag_vBool :: Maybe Bool
tag_vBool   = forall a. Maybe a
Nothing
    , tag_vLong :: Maybe Int64
tag_vLong   = forall a. Maybe a
Nothing
    , tag_vBinary :: Maybe ByteString
tag_vBinary = forall a. Maybe a
Nothing
    }
toThriftTag Text
k TagVal
v =
  Thrift.Tag
  {
    tag_key :: Text
tag_key = Text
k
  , tag_vType :: TagType
tag_vType = case TagVal
v of
      BoolT   Bool
_ -> TagType
Thrift.BOOL
      StringT Text
_ -> TagType
Thrift.STRING
      IntT    Int64
_ -> TagType
Thrift.LONG
      DoubleT Double
_ -> TagType
Thrift.DOUBLE
      BinaryT ByteString
_ -> TagType
Thrift.BINARY
  , tag_vStr :: Maybe Text
tag_vStr = case TagVal
v of
      StringT Text
x -> forall a. a -> Maybe a
Just Text
x
      TagVal
_ -> forall a. Maybe a
Nothing
  , tag_vDouble :: Maybe Double
tag_vDouble = case TagVal
v of
      DoubleT Double
x -> forall a. a -> Maybe a
Just Double
x
      TagVal
_ -> forall a. Maybe a
Nothing
  , tag_vBool :: Maybe Bool
tag_vBool = case TagVal
v of
      BoolT Bool
x -> forall a. a -> Maybe a
Just Bool
x
      TagVal
_ -> forall a. Maybe a
Nothing
  , tag_vLong :: Maybe Int64
tag_vLong = case TagVal
v of
      IntT Int64
x -> forall a. a -> Maybe a
Just Int64
x
      TagVal
_ -> forall a. Maybe a
Nothing
  , tag_vBinary :: Maybe ByteString
tag_vBinary = case TagVal
v of
      BinaryT ByteString
x -> forall a. a -> Maybe a
Just (ByteString -> ByteString
toStrict ByteString
x)
      TagVal
_ -> forall a. Maybe a
Nothing
  }

toThriftLog :: LogRecord -> Thrift.Log
toThriftLog :: LogRecord -> Log
toThriftLog LogRecord
r = Thrift.Log
    { log_timestamp :: Int64
log_timestamp = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' LogRecord UTCTime
logTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a b. (AsMicros a, Integral b) => a -> b
micros) LogRecord
r
    , log_fields :: Vector Tag
log_fields    = forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ( forall a. a -> Vector a
Vector.singleton
                              forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> TagVal -> Tag
toThriftTag
                              forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogField -> (Text, TagVal)
asTag
                              )
                    forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' LogRecord (NonEmpty LogField)
logFields LogRecord
r
    }
  where
    asTag :: LogField -> (Text, TagVal)
asTag LogField
f = (LogField -> Text
logFieldLabel LogField
f,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> TagVal
StringT forall a b. (a -> b) -> a -> b
$ case LogField
f of
        LogField Text
_ a
v -> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall t. IsText t => Iso' String t
packed (forall a. Show a => a -> String
show a
v)
        Event      Text
v -> Text
v
        Message    Text
v -> Text
v
        Stack      CallStack
v -> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall t. IsText t => Iso' String t
packed (CallStack -> String
prettyCallStack CallStack
v)
        ErrKind    Text
v -> Text
v
        ErrObj     e
v -> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall t. IsText t => Iso' String t
packed (forall a. Show a => a -> String
show e
v)

toThriftProcess :: Text -> Tags -> Thrift.Process
toThriftProcess :: Text -> Tags -> Process
toThriftProcess Text
srv Tags
tags = Thrift.Process
    { process_serviceName :: Text
process_serviceName = Text
srv
    , process_tags :: Maybe (Vector Tag)
process_tags        = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Tags -> Vector Tag
toThriftTags Tags
tags
    }

toThriftBatch :: Thrift.Process -> Vector FinishedSpan -> Thrift.Batch
toThriftBatch :: Process -> Vector FinishedSpan -> Batch
toThriftBatch Process
tproc Vector FinishedSpan
spans = Thrift.Batch
    { batch_process :: Process
batch_process = Process
tproc
    , batch_spans :: Vector Span
batch_spans   = FinishedSpan -> Span
toThriftSpan forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Vector FinishedSpan
spans
    , batch_seqNo :: Maybe Int64
batch_seqNo   = forall a. Maybe a
Nothing
    , batch_stats :: Maybe ClientStats
batch_stats   = forall a. Maybe a
Nothing
    }

traceIdLo' :: SpanContext -> Int64
traceIdLo' :: SpanContext -> Int64
traceIdLo' = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceID -> Word64
traceIdLo forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanContext -> TraceID
ctxTraceID

traceIdHi' :: SpanContext -> Int64
traceIdHi' :: SpanContext -> Int64
traceIdHi' = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int64
0 forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. TraceID -> Maybe Word64
traceIdHi forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanContext -> TraceID
ctxTraceID

ctxSpanID' :: SpanContext -> Int64
ctxSpanID' :: SpanContext -> Int64
ctxSpanID' = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanContext -> Word64
ctxSpanID