{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE TupleSections     #-}
{-# LANGUAGE ViewPatterns      #-}

{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}

module OpenTracing.Zipkin.V1.Thrift
    ( toThriftSpan

    , thriftEncodeSpan
    , thriftEncodeSpans
    )
where

import           Control.Lens
import           Data.Bifunctor
import           Data.Bits
import           Data.ByteString.Builder
import           Data.ByteString          (ByteString)
import qualified Data.ByteString.Lazy     as Lazy
import           Data.ByteString.Lens
import           Data.Foldable            (foldl', toList)
import qualified Data.HashMap.Strict      as HashMap
import           Data.Int
import qualified Data.IP                  as IP
import           Data.List.NonEmpty       (NonEmpty (..))
import           Data.Text.Encoding       (decodeUtf8, encodeUtf8)
import qualified Data.Vector              as Vector
import           OpenTracing.Log
import           OpenTracing.Span
import           OpenTracing.Tags
import           OpenTracing.Time
import           OpenTracing.Types
import           OpenTracing.Zipkin.Types (Endpoint (..))
import qualified Pinch
import           Zipkincore.Types
    ( Annotation (..)
    , BinaryAnnotation (..)
    , Span (..)
    , endpoint_ipv4
    , endpoint_ipv6
    , endpoint_port
    , endpoint_service_name
    )
import qualified Zipkincore.Types         as Thrift


toThriftSpan
    :: Endpoint
    -> LogFieldsFormatter
    -> FinishedSpan
    -> Thrift.Span
toThriftSpan :: Endpoint -> LogFieldsFormatter -> FinishedSpan -> Span
toThriftSpan (Endpoint -> Endpoint
toThriftEndpoint -> Endpoint
loc) LogFieldsFormatter
logfmt FinishedSpan
s = Thrift.Span
    { span_trace_id :: Int64
span_trace_id           = 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_trace_id_high :: Maybe Int64
span_trace_id_high      = 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 -> Maybe Int64
traceIdHi') FinishedSpan
s
    , span_name :: Text
span_name               = 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_id :: Int64
span_id                 = 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_parent_id :: Maybe Int64
span_parent_id          = 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 -> Maybe Int64
ctxParentSpanID') FinishedSpan
s
    , span_annotations :: Vector Annotation
span_annotations        = Vector Annotation
annotations
    , span_binary_annotations :: Vector BinaryAnnotation
span_binary_annotations = Vector BinaryAnnotation
binaryAnnotations
    , span_debug :: Maybe Bool
span_debug              = forall a. Maybe a
Nothing
    , span_timestamp :: Maybe Int64
span_timestamp          = forall a. a -> Maybe a
Just Int64
tstart
    , span_duration :: Maybe 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 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
    }
  where
    tstart :: Int64
tstart = 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

    (Vector Annotation
annotations, Vector BinaryAnnotation
binaryAnnotations)
        = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap forall a. [a] -> Vector a
Vector.fromList forall a. [a] -> Vector a
Vector.fromList
        forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (forall a. Semigroup a => a -> a -> a
<> [LogRecord] -> [Annotation]
annFromLogs (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. HasSpanFields a => Lens' a [LogRecord]
spanLogs FinishedSpan
s))
        forall a b. (a -> b) -> a -> b
$ Tags -> ([Annotation], [BinaryAnnotation])
annFromTags (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. HasSpanFields a => Lens' a Tags
spanTags FinishedSpan
s)

    annFromTags :: Tags -> ([Thrift.Annotation], [Thrift.BinaryAnnotation])
    annFromTags :: Tags -> ([Annotation], [BinaryAnnotation])
annFromTags = forall {a}. ([a], [BinaryAnnotation]) -> ([a], [BinaryAnnotation])
perhapsLocal forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {p :: * -> * -> *}.
Bifunctor p =>
p [Annotation] [BinaryAnnotation]
-> Tag -> p [Annotation] [BinaryAnnotation]
go ([],[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. HashMap k v -> [(k, v)]
HashMap.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tags -> HashMap Text TagVal
fromTags
      where
        go :: p [Annotation] [BinaryAnnotation]
-> Tag -> p [Annotation] [BinaryAnnotation]
go p [Annotation] [BinaryAnnotation]
acc (SpanKind SpanKinds
sk) =
            let ann :: Annotation
ann = Thrift.Annotation
                    { annotation_timestamp :: Int64
annotation_timestamp = Int64
tstart
                    , annotation_host :: Maybe Endpoint
annotation_host      = forall a. a -> Maybe a
Just Endpoint
loc
                    , annotation_value :: Text
annotation_value     = case SpanKinds
sk of
                          SpanKinds
RPCClient -> Text
Thrift.cLIENT_SEND
                          SpanKinds
RPCServer -> Text
Thrift.sERVER_RECV
                          SpanKinds
Producer  -> Text
Thrift.mESSAGE_SEND
                          SpanKinds
Consumer  -> Text
Thrift.mESSAGE_RECV
                    }
             in forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Annotation
annforall a. a -> [a] -> [a]
:) p [Annotation] [BinaryAnnotation]
acc

        go p [Annotation] [BinaryAnnotation]
acc (Text
k,TagVal
v) =
            let (AnnotationType
anntyp, ByteString
annval) = TagVal -> (AnnotationType, ByteString)
toThriftTag TagVal
v
                ann :: BinaryAnnotation
ann              = Thrift.BinaryAnnotation
                    { binaryAnnotation_key :: Text
binaryAnnotation_key             = Text
k
                    , binaryAnnotation_value :: ByteString
binaryAnnotation_value           = ByteString
annval
                    , binaryAnnotation_annotation_type :: AnnotationType
binaryAnnotation_annotation_type = AnnotationType
anntyp
                    , binaryAnnotation_host :: Maybe Endpoint
binaryAnnotation_host            = forall a. a -> Maybe a
Just Endpoint
loc
                    }
             in forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (BinaryAnnotation
annforall a. a -> [a] -> [a]
:) p [Annotation] [BinaryAnnotation]
acc

        -- if we don't have a 'SpanKind', we're supposed to tell Zipkin about us
        -- via a 'BinaryAnnotation'
        perhapsLocal :: ([a], [BinaryAnnotation]) -> ([a], [BinaryAnnotation])
perhapsLocal ([],[BinaryAnnotation]
bs) = ([],) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. a -> [a] -> [a]
:[BinaryAnnotation]
bs) forall a b. (a -> b) -> a -> b
$ Thrift.BinaryAnnotation
            { binaryAnnotation_key :: Text
binaryAnnotation_key             = Text
Thrift.lOCAL_COMPONENT
            , binaryAnnotation_value :: ByteString
binaryAnnotation_value           = Text -> ByteString
encodeUtf8 forall a b. (a -> b) -> a -> b
$ Endpoint -> Text
endpoint_service_name Endpoint
loc
            , binaryAnnotation_annotation_type :: AnnotationType
binaryAnnotation_annotation_type = AnnotationType
Thrift.STRING
            , binaryAnnotation_host :: Maybe Endpoint
binaryAnnotation_host            = forall a. a -> Maybe a
Just Endpoint
loc
            }
        perhapsLocal ([a], [BinaryAnnotation])
xs = ([a], [BinaryAnnotation])
xs

    annFromLogs :: [LogRecord] -> [Thrift.Annotation]
    annFromLogs :: [LogRecord] -> [Annotation]
annFromLogs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' [Annotation] -> LogRecord -> [Annotation]
go []
      where
        go :: [Annotation] -> LogRecord -> [Annotation]
go [Annotation]
acc (LogRecord UTCTime
t NonEmpty LogField
fs) = Thrift.Annotation
            { annotation_timestamp :: Int64
annotation_timestamp = forall a b. (AsMicros a, Integral b) => a -> b
micros UTCTime
t
            , annotation_host :: Maybe Endpoint
annotation_host      = forall a. a -> Maybe a
Just Endpoint
loc
            , annotation_value :: Text
annotation_value     = case NonEmpty LogField
fs of
                  (Event Text
x :| []) -> Text
x -- proper zipkin annotation
                  NonEmpty LogField
fields          -> ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
Lazy.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString forall a b. (a -> b) -> a -> b
$ LogFieldsFormatter
logfmt NonEmpty LogField
fields
            }
            forall a. a -> [a] -> [a]
: [Annotation]
acc

thriftEncodeSpan :: Thrift.Span -> ByteString
thriftEncodeSpan :: Span -> ByteString
thriftEncodeSpan = forall a. Pinchable a => Protocol -> a -> ByteString
Pinch.encode Protocol
Pinch.binaryProtocol

thriftEncodeSpans :: Traversable t => t Thrift.Span -> ByteString
thriftEncodeSpans :: forall (t :: * -> *). Traversable t => t Span -> ByteString
thriftEncodeSpans
     = forall a. Pinchable a => Protocol -> a -> ByteString
Pinch.encode Protocol
Pinch.binaryProtocol
     forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> [a]
toList

toThriftTag :: TagVal -> (Thrift.AnnotationType, ByteString)
toThriftTag :: TagVal -> (AnnotationType, ByteString)
toThriftTag (BoolT   Bool
v) = (AnnotationType
Thrift.BOOL, if Bool
v then ByteString
"1" else ByteString
"0")
toThriftTag (StringT Text
v) = (AnnotationType
Thrift.STRING, forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Text -> ByteString
encodeUtf8) Text
v)
toThriftTag (IntT    Int64
v) = (AnnotationType
Thrift.I64, ByteString -> ByteString
Lazy.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int64 -> Builder
int64BE forall a b. (a -> b) -> a -> b
$ Int64
v)
toThriftTag (DoubleT Double
v) = (AnnotationType
Thrift.DOUBLE, ByteString -> ByteString
Lazy.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Double -> Builder
doubleBE forall a b. (a -> b) -> a -> b
$ Double
v)
toThriftTag (BinaryT ByteString
v) = (AnnotationType
Thrift.BYTES, ByteString -> ByteString
Lazy.toStrict ByteString
v)

toThriftEndpoint :: Endpoint -> Thrift.Endpoint
toThriftEndpoint :: Endpoint -> Endpoint
toThriftEndpoint Endpoint{Maybe IPv6
Maybe Port
Text
IPv4
serviceName :: Endpoint -> Text
ipv4 :: Endpoint -> IPv4
ipv6 :: Endpoint -> Maybe IPv6
port :: Endpoint -> Maybe Port
port :: Maybe Port
ipv6 :: Maybe IPv6
ipv4 :: IPv4
serviceName :: Text
..} = Thrift.Endpoint
    { endpoint_ipv4 :: Int32
endpoint_ipv4         = IPv4 -> Int32
packIPv4 forall a b. (a -> b) -> a -> b
$ IPv4 -> IPv4
fromIPv4 IPv4
ipv4
    , endpoint_port :: Int16
endpoint_port         = forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int16
0 (forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. Port -> Word16
fromPort) Maybe Port
port
    , endpoint_service_name :: Text
endpoint_service_name = Text
serviceName
    , endpoint_ipv6 :: Maybe ByteString
endpoint_ipv6         = IPv6 -> ByteString
packIPv6 forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv6 -> IPv6
fromIPv6 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe IPv6
ipv6
    }
  where
    packIPv4 :: IP.IPv4 -> Int32
    packIPv4 :: IPv4 -> Int32
packIPv4 IPv4
ip =
        let [Int
a,Int
b,Int
c,Int
d] = IPv4 -> [Int]
IP.fromIPv4 IPv4
ip
         in forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Int
a forall a. Bits a => a -> Int -> a
`shiftL` Int
24 forall a. Bits a => a -> a -> a
.|. Int
b forall a. Bits a => a -> Int -> a
`shiftL` Int
16 forall a. Bits a => a -> a -> a
.|. Int
c forall a. Bits a => a -> Int -> a
`shiftL` Int
8 forall a. Bits a => a -> a -> a
.|. Int
d

    packIPv6 :: IP.IPv6 -> ByteString
    packIPv6 :: IPv6 -> ByteString
packIPv6 = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall t. IsByteString t => Iso' [Word8] t
packedBytes forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. IPv6 -> [Int]
IP.fromIPv6b


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 -> Maybe Int64
traceIdHi' :: SpanContext -> Maybe Int64
traceIdHi' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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

ctxParentSpanID' :: SpanContext -> Maybe Int64
ctxParentSpanID' :: SpanContext -> Maybe Int64
ctxParentSpanID' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (Integral a, Num b) => a -> b
fromIntegral forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanContext -> Maybe Word64
ctxParentSpanID