{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE NamedFieldPuns    #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes        #-}
{-# LANGUAGE RecordWildCards   #-}
{-# LANGUAGE StrictData        #-}
{-# LANGUAGE TemplateHaskell   #-}

module OpenTracing.Zipkin.V2.HttpReporter
    ( ZipkinOptions
    , zipkinOptions
    , zoManager
    , zoLocalEndpoint
    , zoEndpoint
    , zoLogfmt
    , zoErrorLog

    , defaultZipkinEndpoint
    , defaultZipkinAddr

    , Zipkin
    , newZipkin
    , closeZipkin
    , withZipkin

    , zipkinHttpReporter

    , Endpoint(..)

    , newManager
    , defaultManagerSettings
    )
where

import           Control.Lens                hiding (Context)
import           Control.Monad               (unless)
import           Control.Monad.Catch
import           Control.Monad.IO.Class
import           Data.Aeson                  hiding (Error)
import           Data.Aeson.Encoding
import qualified Data.ByteString.Base64.Lazy as B64
import           Data.ByteString.Builder
import           Data.Map.Lens               (toMapOf)
import           Data.Maybe                  (catMaybes)
import           Data.Monoid
import           Data.Text.Lazy.Encoding     (decodeUtf8)
import           Data.Text.Strict.Lens       (packed, utf8)
import           Network.HTTP.Client
import           Network.HTTP.Types
import           OpenTracing.Log
import           OpenTracing.Reporting
import           OpenTracing.Span
import           OpenTracing.Tags
import           OpenTracing.Time
import           OpenTracing.Types
import           OpenTracing.Zipkin.Types

newtype Zipkin = Zipkin { Zipkin -> BatchEnv
fromZipkin :: BatchEnv }

data ZipkinOptions = ZipkinOptions
    { ZipkinOptions -> Manager
_zoManager       :: Manager
    , ZipkinOptions -> Endpoint
_zoLocalEndpoint :: Endpoint
    , ZipkinOptions -> String
_zoEndpoint      :: String
    , ZipkinOptions
-> forall (t :: * -> *). Foldable t => t LogField -> Builder
_zoLogfmt        :: forall t. Foldable t => t LogField -> Builder -- == LogFieldsFormatter
    , ZipkinOptions -> Builder -> IO ()
_zoErrorLog      :: Builder -> IO ()
    }

makeLenses ''ZipkinOptions

zipkinOptions :: Manager -> Endpoint -> ZipkinOptions
zipkinOptions :: Manager -> Endpoint -> ZipkinOptions
zipkinOptions Manager
mgr Endpoint
loc = ZipkinOptions :: Manager
-> Endpoint
-> String
-> (forall (t :: * -> *). Foldable t => t LogField -> Builder)
-> (Builder -> IO ())
-> ZipkinOptions
ZipkinOptions
    { _zoManager :: Manager
_zoManager       = Manager
mgr
    , _zoLocalEndpoint :: Endpoint
_zoLocalEndpoint = Endpoint
loc
    , _zoEndpoint :: String
_zoEndpoint      = String
defaultZipkinEndpoint
    , _zoLogfmt :: forall (t :: * -> *). Foldable t => t LogField -> Builder
_zoLogfmt        = forall (t :: * -> *). Foldable t => t LogField -> Builder
jsonMap
    , _zoErrorLog :: Builder -> IO ()
_zoErrorLog      = Builder -> IO ()
defaultErrorLog
    }

defaultZipkinEndpoint :: String
defaultZipkinEndpoint :: String
defaultZipkinEndpoint = String
"http://"
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Getting String (Addr 'HTTP) String -> Addr 'HTTP -> String
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting String (Addr 'HTTP) String
forall (a :: Protocol). Lens' (Addr a) String
addrHostName Addr 'HTTP
addr
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
":"
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Port -> String
forall a. Show a => a -> String
show (Getting Port (Addr 'HTTP) Port -> Addr 'HTTP -> Port
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Port (Addr 'HTTP) Port
forall (a :: Protocol). Lens' (Addr a) Port
addrPort Addr 'HTTP
addr)
    String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"/api/v2/spans"
  where
    addr :: Addr 'HTTP
addr = Addr 'HTTP
defaultZipkinAddr

newZipkin :: ZipkinOptions -> IO Zipkin
newZipkin :: ZipkinOptions -> IO Zipkin
newZipkin opts :: ZipkinOptions
opts@ZipkinOptions{_zoEndpoint :: ZipkinOptions -> String
_zoEndpoint=String
endpoint, _zoErrorLog :: ZipkinOptions -> Builder -> IO ()
_zoErrorLog=Builder -> IO ()
errlog} = do
    Request
rq <- IO Request
mkReq
    (BatchEnv -> Zipkin) -> IO BatchEnv -> IO Zipkin
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BatchEnv -> Zipkin
Zipkin
        (IO BatchEnv -> IO Zipkin)
-> (([FinishedSpan] -> IO ()) -> IO BatchEnv)
-> ([FinishedSpan] -> IO ())
-> IO Zipkin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BatchOptions -> IO BatchEnv
newBatchEnv
        (BatchOptions -> IO BatchEnv)
-> (([FinishedSpan] -> IO ()) -> BatchOptions)
-> ([FinishedSpan] -> IO ())
-> IO BatchEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ASetter
  BatchOptions BatchOptions (Builder -> IO ()) (Builder -> IO ())
-> (Builder -> IO ()) -> BatchOptions -> BatchOptions
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  BatchOptions BatchOptions (Builder -> IO ()) (Builder -> IO ())
Lens' BatchOptions (Builder -> IO ())
boptErrorLog Builder -> IO ()
errlog (BatchOptions -> BatchOptions)
-> (([FinishedSpan] -> IO ()) -> BatchOptions)
-> ([FinishedSpan] -> IO ())
-> BatchOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FinishedSpan] -> IO ()) -> BatchOptions
batchOptions
        (([FinishedSpan] -> IO ()) -> IO Zipkin)
-> ([FinishedSpan] -> IO ()) -> IO Zipkin
forall a b. (a -> b) -> a -> b
$ ZipkinOptions -> Request -> [FinishedSpan] -> IO ()
reporter ZipkinOptions
opts Request
rq
  where
    mkReq :: IO Request
mkReq = do
        Request
rq <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
endpoint
        Request -> IO Request
forall (m :: * -> *) a. Monad m => a -> m a
return Request
rq { requestHeaders :: RequestHeaders
requestHeaders = [(HeaderName
hContentType, ByteString
"application/json")] }

closeZipkin :: Zipkin -> IO ()
closeZipkin :: Zipkin -> IO ()
closeZipkin = BatchEnv -> IO ()
closeBatchEnv (BatchEnv -> IO ()) -> (Zipkin -> BatchEnv) -> Zipkin -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Zipkin -> BatchEnv
fromZipkin

withZipkin
    :: ( MonadIO   m
       , MonadMask m
       )
    => ZipkinOptions
    -> (Zipkin -> m a)
    -> m a
withZipkin :: ZipkinOptions -> (Zipkin -> m a) -> m a
withZipkin ZipkinOptions
opts = m Zipkin -> (Zipkin -> m ()) -> (Zipkin -> m a) -> m a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (IO Zipkin -> m Zipkin
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Zipkin -> m Zipkin) -> IO Zipkin -> m Zipkin
forall a b. (a -> b) -> a -> b
$ ZipkinOptions -> IO Zipkin
newZipkin ZipkinOptions
opts) (IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> (Zipkin -> IO ()) -> Zipkin -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Zipkin -> IO ()
closeZipkin)


zipkinHttpReporter :: MonadIO m => Zipkin -> FinishedSpan -> m ()
zipkinHttpReporter :: Zipkin -> FinishedSpan -> m ()
zipkinHttpReporter = BatchEnv -> FinishedSpan -> m ()
forall (m :: * -> *). MonadIO m => BatchEnv -> FinishedSpan -> m ()
batchReporter (BatchEnv -> FinishedSpan -> m ())
-> (Zipkin -> BatchEnv) -> Zipkin -> FinishedSpan -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Zipkin -> BatchEnv
fromZipkin

reporter :: ZipkinOptions -> Request -> [FinishedSpan] -> IO ()
reporter :: ZipkinOptions -> Request -> [FinishedSpan] -> IO ()
reporter ZipkinOptions{String
Manager
Endpoint
Builder -> IO ()
forall (t :: * -> *). Foldable t => t LogField -> Builder
_zoErrorLog :: Builder -> IO ()
_zoLogfmt :: forall (t :: * -> *). Foldable t => t LogField -> Builder
_zoEndpoint :: String
_zoLocalEndpoint :: Endpoint
_zoManager :: Manager
_zoErrorLog :: ZipkinOptions -> Builder -> IO ()
_zoLogfmt :: ZipkinOptions
-> forall (t :: * -> *). Foldable t => t LogField -> Builder
_zoEndpoint :: ZipkinOptions -> String
_zoLocalEndpoint :: ZipkinOptions -> Endpoint
_zoManager :: ZipkinOptions -> Manager
..} Request
rq [FinishedSpan]
spans = do
    Status
rs <- Response ByteString -> Status
forall body. Response body -> Status
responseStatus (Response ByteString -> Status)
-> IO (Response ByteString) -> IO Status
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response ByteString)
httpLbs Request
rq { requestBody :: RequestBody
requestBody = RequestBody
body } Manager
_zoManager
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Status -> Bool
statusIsSuccessful Status
rs) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
        Builder -> IO ()
_zoErrorLog (Builder -> IO ()) -> Builder -> IO ()
forall a b. (a -> b) -> a -> b
$ ShortByteString -> Builder
shortByteString ShortByteString
"Error from Zipkin server: "
                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec (Status -> Int
statusCode Status
rs)
                    Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char8 Char
'\n'
  where
    body :: RequestBody
body = ByteString -> RequestBody
RequestBodyLBS
         (ByteString -> RequestBody)
-> ([FinishedSpan] -> ByteString) -> [FinishedSpan] -> RequestBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Encoding' Value -> ByteString
forall a. Encoding' a -> ByteString
encodingToLazyByteString
         (Encoding' Value -> ByteString)
-> ([FinishedSpan] -> Encoding' Value)
-> [FinishedSpan]
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FinishedSpan -> Encoding' Value)
-> [FinishedSpan] -> Encoding' Value
forall a. (a -> Encoding' Value) -> [a] -> Encoding' Value
list (Endpoint
-> (forall (t :: * -> *). Foldable t => t LogField -> Builder)
-> FinishedSpan
-> Encoding' Value
spanE Endpoint
_zoLocalEndpoint forall (t :: * -> *). Foldable t => t LogField -> Builder
_zoLogfmt)
         ([FinishedSpan] -> RequestBody) -> [FinishedSpan] -> RequestBody
forall a b. (a -> b) -> a -> b
$ [FinishedSpan]
spans


spanE :: Endpoint -> LogFieldsFormatter -> FinishedSpan -> Encoding
spanE :: Endpoint
-> (forall (t :: * -> *). Foldable t => t LogField -> Builder)
-> FinishedSpan
-> Encoding' Value
spanE Endpoint
loc forall (t :: * -> *). Foldable t => t LogField -> Builder
logfmt FinishedSpan
s = Series -> Encoding' Value
pairs (Series -> Encoding' Value) -> Series -> Encoding' Value
forall a b. (a -> b) -> a -> b
$
       Text -> Encoding' Value -> Series
pair Text
"name"           (Getting (Encoding' Value) FinishedSpan (Encoding' Value)
-> FinishedSpan -> Encoding' Value
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Text -> Const (Encoding' Value) Text)
-> FinishedSpan -> Const (Encoding' Value) FinishedSpan
forall a. HasSpanFields a => Lens' a Text
spanOperation ((Text -> Const (Encoding' Value) Text)
 -> FinishedSpan -> Const (Encoding' Value) FinishedSpan)
-> ((Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
    -> Text -> Const (Encoding' Value) Text)
-> Getting (Encoding' Value) FinishedSpan (Encoding' Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Encoding' Value)
-> (Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
-> Text
-> Const (Encoding' Value) Text
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Text -> Encoding' Value
forall a. Text -> Encoding' a
text) FinishedSpan
s)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text -> Encoding' Value -> Series
pair Text
"id"             (Getting (Encoding' Value) FinishedSpan (Encoding' Value)
-> FinishedSpan -> Encoding' Value
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((SpanContext -> Const (Encoding' Value) SpanContext)
-> FinishedSpan -> Const (Encoding' Value) FinishedSpan
forall a. HasSpanFields a => Lens' a SpanContext
spanContext ((SpanContext -> Const (Encoding' Value) SpanContext)
 -> FinishedSpan -> Const (Encoding' Value) FinishedSpan)
-> ((Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
    -> SpanContext -> Const (Encoding' Value) SpanContext)
-> Getting (Encoding' Value) FinishedSpan (Encoding' Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpanContext -> Word64)
-> Optic' (->) (Const (Encoding' Value)) SpanContext Word64
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to SpanContext -> Word64
ctxSpanID  Optic' (->) (Const (Encoding' Value)) SpanContext Word64
-> ((Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
    -> Word64 -> Const (Encoding' Value) Word64)
-> (Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
-> SpanContext
-> Const (Encoding' Value) SpanContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (Encoding' Value) Text)
-> Word64 -> Const (Encoding' Value) Word64
forall a. AsHex a => Getter a Text
hexText ((Text -> Const (Encoding' Value) Text)
 -> Word64 -> Const (Encoding' Value) Word64)
-> ((Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
    -> Text -> Const (Encoding' Value) Text)
-> (Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
-> Word64
-> Const (Encoding' Value) Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Encoding' Value)
-> (Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
-> Text
-> Const (Encoding' Value) Text
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Text -> Encoding' Value
forall a. Text -> Encoding' a
text) FinishedSpan
s)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text -> Encoding' Value -> Series
pair Text
"traceId"        (Getting (Encoding' Value) FinishedSpan (Encoding' Value)
-> FinishedSpan -> Encoding' Value
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((SpanContext -> Const (Encoding' Value) SpanContext)
-> FinishedSpan -> Const (Encoding' Value) FinishedSpan
forall a. HasSpanFields a => Lens' a SpanContext
spanContext ((SpanContext -> Const (Encoding' Value) SpanContext)
 -> FinishedSpan -> Const (Encoding' Value) FinishedSpan)
-> ((Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
    -> SpanContext -> Const (Encoding' Value) SpanContext)
-> Getting (Encoding' Value) FinishedSpan (Encoding' Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpanContext -> TraceID)
-> Optic' (->) (Const (Encoding' Value)) SpanContext TraceID
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to SpanContext -> TraceID
ctxTraceID Optic' (->) (Const (Encoding' Value)) SpanContext TraceID
-> ((Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
    -> TraceID -> Const (Encoding' Value) TraceID)
-> (Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
-> SpanContext
-> Const (Encoding' Value) SpanContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const (Encoding' Value) Text)
-> TraceID -> Const (Encoding' Value) TraceID
forall a. AsHex a => Getter a Text
hexText ((Text -> Const (Encoding' Value) Text)
 -> TraceID -> Const (Encoding' Value) TraceID)
-> ((Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
    -> Text -> Const (Encoding' Value) Text)
-> (Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
-> TraceID
-> Const (Encoding' Value) TraceID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Encoding' Value)
-> (Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
-> Text
-> Const (Encoding' Value) Text
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Text -> Encoding' Value
forall a. Text -> Encoding' a
text) FinishedSpan
s)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Series -> (Word64 -> Series) -> Maybe Word64 -> Series
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Series
forall a. Monoid a => a
mempty
            (Text -> Encoding' Value -> Series
pair Text
"parentId" (Encoding' Value -> Series)
-> (Word64 -> Encoding' Value) -> Word64 -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Encoding' Value
forall a. Text -> Encoding' a
text (Text -> Encoding' Value)
-> (Word64 -> Text) -> Word64 -> Encoding' Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting Text Word64 Text -> Word64 -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Text Word64 Text
forall a. AsHex a => Getter a Text
hexText)
            (Getting (Maybe Word64) FinishedSpan (Maybe Word64)
-> FinishedSpan -> Maybe Word64
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((SpanContext -> Const (Maybe Word64) SpanContext)
-> FinishedSpan -> Const (Maybe Word64) FinishedSpan
forall a. HasSpanFields a => Lens' a SpanContext
spanContext ((SpanContext -> Const (Maybe Word64) SpanContext)
 -> FinishedSpan -> Const (Maybe Word64) FinishedSpan)
-> ((Maybe Word64 -> Const (Maybe Word64) (Maybe Word64))
    -> SpanContext -> Const (Maybe Word64) SpanContext)
-> Getting (Maybe Word64) FinishedSpan (Maybe Word64)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpanContext -> Maybe Word64)
-> (Maybe Word64 -> Const (Maybe Word64) (Maybe Word64))
-> SpanContext
-> Const (Maybe Word64) SpanContext
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to SpanContext -> Maybe Word64
ctxParentSpanID) FinishedSpan
s)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Series -> (TagVal -> Series) -> Maybe TagVal -> Series
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Series
forall a. Monoid a => a
mempty
            (Text -> Encoding' Value -> Series
pair Text
"kind" (Encoding' Value -> Series)
-> (TagVal -> Encoding' Value) -> TagVal -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagVal -> Encoding' Value
forall a. ToJSON a => a -> Encoding' Value
toEncoding)
            (Getting (Maybe TagVal) FinishedSpan (Maybe TagVal)
-> FinishedSpan -> Maybe TagVal
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Tags -> Const (Maybe TagVal) Tags)
-> FinishedSpan -> Const (Maybe TagVal) FinishedSpan
forall a. HasSpanFields a => Lens' a Tags
spanTags ((Tags -> Const (Maybe TagVal) Tags)
 -> FinishedSpan -> Const (Maybe TagVal) FinishedSpan)
-> ((Maybe TagVal -> Const (Maybe TagVal) (Maybe TagVal))
    -> Tags -> Const (Maybe TagVal) Tags)
-> Getting (Maybe TagVal) FinishedSpan (Maybe TagVal)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tags -> Maybe TagVal)
-> (Maybe TagVal -> Const (Maybe TagVal) (Maybe TagVal))
-> Tags
-> Const (Maybe TagVal) Tags
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (Text -> Tags -> Maybe TagVal
getTag Text
forall a. (Eq a, IsString a) => a
SpanKindKey)) FinishedSpan
s)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text -> Encoding' Value -> Series
pair Text
"timestamp"      (Getting (Encoding' Value) FinishedSpan (Encoding' Value)
-> FinishedSpan -> Encoding' Value
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((UTCTime -> Const (Encoding' Value) UTCTime)
-> FinishedSpan -> Const (Encoding' Value) FinishedSpan
forall a. HasSpanFields a => Lens' a UTCTime
spanStart ((UTCTime -> Const (Encoding' Value) UTCTime)
 -> FinishedSpan -> Const (Encoding' Value) FinishedSpan)
-> ((Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
    -> UTCTime -> Const (Encoding' Value) UTCTime)
-> Getting (Encoding' Value) FinishedSpan (Encoding' Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTCTime -> Encoding' Value)
-> (Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
-> UTCTime
-> Const (Encoding' Value) UTCTime
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to UTCTime -> Encoding' Value
forall a. AsMicros a => a -> Encoding' Value
microsE) FinishedSpan
s)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text -> Encoding' Value -> Series
pair Text
"duration"       (Getting (Encoding' Value) FinishedSpan (Encoding' Value)
-> FinishedSpan -> Encoding' Value
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((NominalDiffTime -> Const (Encoding' Value) NominalDiffTime)
-> FinishedSpan -> Const (Encoding' Value) FinishedSpan
Lens' FinishedSpan NominalDiffTime
spanDuration ((NominalDiffTime -> Const (Encoding' Value) NominalDiffTime)
 -> FinishedSpan -> Const (Encoding' Value) FinishedSpan)
-> ((Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
    -> NominalDiffTime -> Const (Encoding' Value) NominalDiffTime)
-> Getting (Encoding' Value) FinishedSpan (Encoding' Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NominalDiffTime -> Encoding' Value)
-> (Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
-> NominalDiffTime
-> Const (Encoding' Value) NominalDiffTime
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to NominalDiffTime -> Encoding' Value
forall a. AsMicros a => a -> Encoding' Value
microsE) FinishedSpan
s)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text -> Encoding' Value -> Series
pair Text
"debug"          (Bool -> Encoding' Value
bool Bool
False)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text -> Encoding' Value -> Series
pair Text
"localEndpoint"  (Endpoint -> Encoding' Value
forall a. ToJSON a => a -> Encoding' Value
toEncoding Endpoint
loc)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Series
-> (Encoding' Value -> Series) -> Maybe (Encoding' Value) -> Series
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Series
forall a. Monoid a => a
mempty
             (Text -> Encoding' Value -> Series
pair Text
"remoteEndpoint")
             (Getting
  (Maybe (Encoding' Value)) FinishedSpan (Maybe (Encoding' Value))
-> FinishedSpan -> Maybe (Encoding' Value)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Tags -> Const (Maybe (Encoding' Value)) Tags)
-> FinishedSpan -> Const (Maybe (Encoding' Value)) FinishedSpan
forall a. HasSpanFields a => Lens' a Tags
spanTags ((Tags -> Const (Maybe (Encoding' Value)) Tags)
 -> FinishedSpan -> Const (Maybe (Encoding' Value)) FinishedSpan)
-> ((Maybe (Encoding' Value)
     -> Const (Maybe (Encoding' Value)) (Maybe (Encoding' Value)))
    -> Tags -> Const (Maybe (Encoding' Value)) Tags)
-> Getting
     (Maybe (Encoding' Value)) FinishedSpan (Maybe (Encoding' Value))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tags -> Maybe (Encoding' Value))
-> (Maybe (Encoding' Value)
    -> Const (Maybe (Encoding' Value)) (Maybe (Encoding' Value)))
-> Tags
-> Const (Maybe (Encoding' Value)) Tags
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Tags -> Maybe (Encoding' Value)
remoteEndpoint) FinishedSpan
s)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text -> Encoding' Value -> Series
pair Text
"annotations"    ((LogRecord -> Encoding' Value) -> [LogRecord] -> Encoding' Value
forall a. (a -> Encoding' Value) -> [a] -> Encoding' Value
list ((forall (t :: * -> *). Foldable t => t LogField -> Builder)
-> LogRecord -> Encoding' Value
logRecE forall (t :: * -> *). Foldable t => t LogField -> Builder
logfmt) ([LogRecord] -> Encoding' Value) -> [LogRecord] -> Encoding' Value
forall a b. (a -> b) -> a -> b
$ Getting [LogRecord] FinishedSpan [LogRecord]
-> FinishedSpan -> [LogRecord]
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting [LogRecord] FinishedSpan [LogRecord]
forall a. HasSpanFields a => Lens' a [LogRecord]
spanLogs FinishedSpan
s)
    -- Zipkin V2 requires tag values to be strings
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text -> Encoding' Value -> Series
pair Text
"tags"           (Map Text Text -> Encoding' Value
forall a. ToJSON a => a -> Encoding' Value
toEncoding (Map Text Text -> Encoding' Value)
-> (FinishedSpan -> Map Text Text)
-> FinishedSpan
-> Encoding' Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IndexedGetting Text (Map Text Text) FinishedSpan Text
-> FinishedSpan -> Map Text Text
forall i a s. IndexedGetting i (Map i a) s a -> s -> Map i a
toMapOf ((Tags -> Const (Map Text Text) Tags)
-> FinishedSpan -> Const (Map Text Text) FinishedSpan
forall a. HasSpanFields a => Lens' a Tags
spanTags ((Tags -> Const (Map Text Text) Tags)
 -> FinishedSpan -> Const (Map Text Text) FinishedSpan)
-> (Indexed Text Text (Const (Map Text Text) Text)
    -> Tags -> Const (Map Text Text) Tags)
-> IndexedGetting Text (Map Text Text) FinishedSpan Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tags -> HashMap Text TagVal)
-> Optic' (->) (Const (Map Text Text)) Tags (HashMap Text TagVal)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Tags -> HashMap Text TagVal
fromTags Optic' (->) (Const (Map Text Text)) Tags (HashMap Text TagVal)
-> (Indexed Text Text (Const (Map Text Text) Text)
    -> HashMap Text TagVal
    -> Const (Map Text Text) (HashMap Text TagVal))
-> Indexed Text Text (Const (Map Text Text) Text)
-> Tags
-> Const (Map Text Text) Tags
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Indexed Text TagVal (Const (Map Text Text) TagVal)
-> HashMap Text TagVal
-> Const (Map Text Text) (HashMap Text TagVal)
forall i (f :: * -> *) a.
FoldableWithIndex i f =>
IndexedFold i (f a) a
ifolded (Indexed Text TagVal (Const (Map Text Text) TagVal)
 -> HashMap Text TagVal
 -> Const (Map Text Text) (HashMap Text TagVal))
-> (Indexed Text Text (Const (Map Text Text) Text)
    -> Indexed Text TagVal (Const (Map Text Text) TagVal))
-> Indexed Text Text (Const (Map Text Text) Text)
-> HashMap Text TagVal
-> Const (Map Text Text) (HashMap Text TagVal)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TagVal -> Text)
-> Indexed Text Text (Const (Map Text Text) Text)
-> Indexed Text TagVal (Const (Map Text Text) TagVal)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to TagVal -> Text
tagToText) (FinishedSpan -> Encoding' Value)
-> FinishedSpan -> Encoding' Value
forall a b. (a -> b) -> a -> b
$ FinishedSpan
s)
    -- nb. references are lost, perhaps we should stick them into annotations?
  where tagToText :: TagVal -> Text
tagToText = \ case
          BoolT Bool
b   -> Getting Text Bool Text -> Bool -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Bool -> String) -> Optic' (->) (Const Text) Bool String
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Bool -> String
forall a. Show a => a -> String
show Optic' (->) (Const Text) Bool String
-> ((Text -> Const Text Text) -> String -> Const Text String)
-> Getting Text Bool Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text) -> String -> Const Text String
Iso' String Text
packed) Bool
b
          StringT Text
t -> Text
t
          IntT Int64
i    -> Getting Text Int64 Text -> Int64 -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Int64 -> String) -> Optic' (->) (Const Text) Int64 String
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Int64 -> String
forall a. Show a => a -> String
show Optic' (->) (Const Text) Int64 String
-> ((Text -> Const Text Text) -> String -> Const Text String)
-> Getting Text Int64 Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text) -> String -> Const Text String
Iso' String Text
packed) Int64
i
          DoubleT Double
d -> Getting Text Double Text -> Double -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Double -> String) -> Optic' (->) (Const Text) Double String
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Double -> String
forall a. Show a => a -> String
show Optic' (->) (Const Text) Double String
-> ((Text -> Const Text Text) -> String -> Const Text String)
-> Getting Text Double Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text) -> String -> Const Text String
Iso' String Text
packed) Double
d
          BinaryT ByteString
b -> Getting Text ByteString Text -> ByteString -> Text
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((ByteString -> ByteString)
-> Optic' (->) (Const Text) ByteString ByteString
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ByteString -> ByteString
B64.encode Optic' (->) (Const Text) ByteString ByteString
-> Getting Text ByteString Text -> Getting Text ByteString Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Const Text ByteString)
-> ByteString -> Const Text ByteString
forall lazy strict. Strict lazy strict => Iso' lazy strict
strict ((ByteString -> Const Text ByteString)
 -> ByteString -> Const Text ByteString)
-> ((Text -> Const Text Text)
    -> ByteString -> Const Text ByteString)
-> Getting Text ByteString Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text) -> ByteString -> Const Text ByteString
Prism' ByteString Text
utf8) ByteString
b

remoteEndpoint :: Tags -> Maybe Encoding
remoteEndpoint :: Tags -> Maybe (Encoding' Value)
remoteEndpoint Tags
ts = case [Series]
fields of
    [] -> Maybe (Encoding' Value)
forall a. Maybe a
Nothing
    [Series]
xs -> Encoding' Value -> Maybe (Encoding' Value)
forall a. a -> Maybe a
Just (Encoding' Value -> Maybe (Encoding' Value))
-> (Series -> Encoding' Value) -> Series -> Maybe (Encoding' Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Series -> Encoding' Value
pairs (Series -> Maybe (Encoding' Value))
-> Series -> Maybe (Encoding' Value)
forall a b. (a -> b) -> a -> b
$ [Series] -> Series
forall a. Monoid a => [a] -> a
mconcat [Series]
xs
  where
    fields :: [Series]
fields = [Maybe Series] -> [Series]
forall a. [Maybe a] -> [a]
catMaybes
        [ Text -> Encoding' Value -> Series
pair Text
forall a. (Eq a, IsString a) => a
PeerServiceKey (Encoding' Value -> Series)
-> (TagVal -> Encoding' Value) -> TagVal -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagVal -> Encoding' Value
forall a. ToJSON a => a -> Encoding' Value
toEncoding (TagVal -> Series) -> Maybe TagVal -> Maybe Series
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Tags -> Maybe TagVal
getTag Text
forall a. (Eq a, IsString a) => a
PeerServiceKey Tags
ts
        , Text -> Encoding' Value -> Series
pair Text
forall a. (Eq a, IsString a) => a
PeerIPv4Key    (Encoding' Value -> Series)
-> (TagVal -> Encoding' Value) -> TagVal -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagVal -> Encoding' Value
forall a. ToJSON a => a -> Encoding' Value
toEncoding (TagVal -> Series) -> Maybe TagVal -> Maybe Series
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Tags -> Maybe TagVal
getTag Text
forall a. (Eq a, IsString a) => a
PeerIPv4Key    Tags
ts
        , Text -> Encoding' Value -> Series
pair Text
forall a. (Eq a, IsString a) => a
PeerIPv6Key    (Encoding' Value -> Series)
-> (TagVal -> Encoding' Value) -> TagVal -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagVal -> Encoding' Value
forall a. ToJSON a => a -> Encoding' Value
toEncoding (TagVal -> Series) -> Maybe TagVal -> Maybe Series
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Tags -> Maybe TagVal
getTag Text
forall a. (Eq a, IsString a) => a
PeerIPv6Key    Tags
ts
        , Text -> Encoding' Value -> Series
pair Text
forall a. (Eq a, IsString a) => a
PeerPortKey    (Encoding' Value -> Series)
-> (TagVal -> Encoding' Value) -> TagVal -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagVal -> Encoding' Value
forall a. ToJSON a => a -> Encoding' Value
toEncoding (TagVal -> Series) -> Maybe TagVal -> Maybe Series
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Tags -> Maybe TagVal
getTag Text
forall a. (Eq a, IsString a) => a
PeerPortKey    Tags
ts
        ]

logRecE :: LogFieldsFormatter -> LogRecord -> Encoding
logRecE :: (forall (t :: * -> *). Foldable t => t LogField -> Builder)
-> LogRecord -> Encoding' Value
logRecE forall (t :: * -> *). Foldable t => t LogField -> Builder
logfmt LogRecord
r = Series -> Encoding' Value
pairs (Series -> Encoding' Value) -> Series -> Encoding' Value
forall a b. (a -> b) -> a -> b
$
       Text -> Encoding' Value -> Series
pair Text
"timestamp" (Getting (Encoding' Value) LogRecord (Encoding' Value)
-> LogRecord -> Encoding' Value
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((UTCTime -> Const (Encoding' Value) UTCTime)
-> LogRecord -> Const (Encoding' Value) LogRecord
Lens' LogRecord UTCTime
logTime ((UTCTime -> Const (Encoding' Value) UTCTime)
 -> LogRecord -> Const (Encoding' Value) LogRecord)
-> ((Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
    -> UTCTime -> Const (Encoding' Value) UTCTime)
-> Getting (Encoding' Value) LogRecord (Encoding' Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTCTime -> Encoding' Value)
-> (Encoding' Value -> Const (Encoding' Value) (Encoding' Value))
-> UTCTime
-> Const (Encoding' Value) UTCTime
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to UTCTime -> Encoding' Value
forall a. AsMicros a => a -> Encoding' Value
microsE) LogRecord
r)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text -> Encoding' Value -> Series
pair Text
"value"     (Text -> Encoding' Value
forall a. Text -> Encoding' a
lazyText (Text -> Encoding' Value)
-> (NonEmpty LogField -> Text)
-> NonEmpty LogField
-> Encoding' Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 (ByteString -> Text)
-> (NonEmpty LogField -> ByteString) -> NonEmpty LogField -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString (Builder -> ByteString)
-> (NonEmpty LogField -> Builder)
-> NonEmpty LogField
-> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty LogField -> Builder
forall (t :: * -> *). Foldable t => t LogField -> Builder
logfmt (NonEmpty LogField -> Encoding' Value)
-> NonEmpty LogField -> Encoding' Value
forall a b. (a -> b) -> a -> b
$ Getting (NonEmpty LogField) LogRecord (NonEmpty LogField)
-> LogRecord -> NonEmpty LogField
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting (NonEmpty LogField) LogRecord (NonEmpty LogField)
Lens' LogRecord (NonEmpty LogField)
logFields LogRecord
r)

microsE :: AsMicros a => a -> Encoding
microsE :: a -> Encoding' Value
microsE = Word64 -> Encoding' Value
word64 (Word64 -> Encoding' Value)
-> (a -> Word64) -> a -> Encoding' Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Word64
forall a b. (AsMicros a, Integral b) => a -> b
micros