{-# 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
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
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