{-# 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.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
    { _zoManager :: Manager
_zoManager       = Manager
mgr
    , _zoLocalEndpoint :: Endpoint
_zoLocalEndpoint = Endpoint
loc
    , _zoEndpoint :: String
_zoEndpoint      = String
defaultZipkinEndpoint
    , _zoLogfmt :: forall (t :: * -> *). Foldable t => t LogField -> Builder
_zoLogfmt        = t LogField -> Builder
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) (f :: * -> *).
Functor f =>
(String -> f String) -> Addr a -> f (Addr a)
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) (f :: * -> *).
Functor f =>
(Port -> f Port) -> Addr a -> f (Addr a)
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 a b. (a -> b) -> IO a -> IO b
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 a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Request
rq { method = "POST", requestHeaders = [(hContentType, "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 :: forall (m :: * -> *) a.
(MonadIO m, MonadMask m) =>
ZipkinOptions -> (Zipkin -> m a) -> m a
withZipkin ZipkinOptions
opts = m Zipkin -> (Zipkin -> m ()) -> (Zipkin -> m a) -> m a
forall (m :: * -> *) a c b.
(HasCallStack, MonadMask m) =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (IO Zipkin -> m Zipkin
forall a. IO a -> m a
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 a. IO a -> m a
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 :: forall (m :: * -> *). MonadIO m => 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
_zoManager :: ZipkinOptions -> Manager
_zoLocalEndpoint :: ZipkinOptions -> Endpoint
_zoEndpoint :: ZipkinOptions -> String
_zoLogfmt :: ZipkinOptions
-> forall (t :: * -> *). Foldable t => t LogField -> Builder
_zoErrorLog :: ZipkinOptions -> Builder -> IO ()
_zoManager :: Manager
_zoLocalEndpoint :: Endpoint
_zoEndpoint :: String
_zoLogfmt :: forall (t :: * -> *). Foldable t => t LogField -> Builder
_zoErrorLog :: Builder -> IO ()
..} 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 = 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 -> ByteString
forall a. Encoding' a -> ByteString
encodingToLazyByteString
         (Encoding -> ByteString)
-> ([FinishedSpan] -> Encoding) -> [FinishedSpan] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FinishedSpan -> Encoding) -> [FinishedSpan] -> Encoding
forall a. (a -> Encoding) -> [a] -> Encoding
list (Endpoint
-> (forall (t :: * -> *). Foldable t => t LogField -> Builder)
-> FinishedSpan
-> Encoding
spanE Endpoint
_zoLocalEndpoint t LogField -> Builder
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
spanE Endpoint
loc forall (t :: * -> *). Foldable t => t LogField -> Builder
logfmt FinishedSpan
s = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$
       Key -> Encoding -> Series
pair Key
"name"           (Getting Encoding FinishedSpan Encoding -> FinishedSpan -> Encoding
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Text -> Const Encoding Text)
-> FinishedSpan -> Const Encoding FinishedSpan
forall a. HasSpanFields a => Lens' a Text
Lens' FinishedSpan Text
spanOperation ((Text -> Const Encoding Text)
 -> FinishedSpan -> Const Encoding FinishedSpan)
-> ((Encoding -> Const Encoding Encoding)
    -> Text -> Const Encoding Text)
-> Getting Encoding FinishedSpan Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Encoding)
-> (Encoding -> Const Encoding Encoding)
-> Text
-> Const Encoding Text
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Text -> Encoding
forall a. Text -> Encoding' a
text) FinishedSpan
s)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key -> Encoding -> Series
pair Key
"id"             (Getting Encoding FinishedSpan Encoding -> FinishedSpan -> Encoding
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((SpanContext -> Const Encoding SpanContext)
-> FinishedSpan -> Const Encoding FinishedSpan
forall a. HasSpanFields a => Lens' a SpanContext
Lens' FinishedSpan SpanContext
spanContext ((SpanContext -> Const Encoding SpanContext)
 -> FinishedSpan -> Const Encoding FinishedSpan)
-> ((Encoding -> Const Encoding Encoding)
    -> SpanContext -> Const Encoding SpanContext)
-> Getting Encoding FinishedSpan Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpanContext -> Word64)
-> (Word64 -> Const Encoding Word64)
-> SpanContext
-> Const Encoding SpanContext
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to SpanContext -> Word64
ctxSpanID  ((Word64 -> Const Encoding Word64)
 -> SpanContext -> Const Encoding SpanContext)
-> ((Encoding -> Const Encoding Encoding)
    -> Word64 -> Const Encoding Word64)
-> (Encoding -> Const Encoding Encoding)
-> SpanContext
-> Const Encoding SpanContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Encoding Text) -> Word64 -> Const Encoding Word64
forall a. AsHex a => Getter a Text
Getter Word64 Text
hexText ((Text -> Const Encoding Text) -> Word64 -> Const Encoding Word64)
-> ((Encoding -> Const Encoding Encoding)
    -> Text -> Const Encoding Text)
-> (Encoding -> Const Encoding Encoding)
-> Word64
-> Const Encoding Word64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Encoding)
-> (Encoding -> Const Encoding Encoding)
-> Text
-> Const Encoding Text
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Text -> Encoding
forall a. Text -> Encoding' a
text) FinishedSpan
s)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key -> Encoding -> Series
pair Key
"traceId"        (Getting Encoding FinishedSpan Encoding -> FinishedSpan -> Encoding
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((SpanContext -> Const Encoding SpanContext)
-> FinishedSpan -> Const Encoding FinishedSpan
forall a. HasSpanFields a => Lens' a SpanContext
Lens' FinishedSpan SpanContext
spanContext ((SpanContext -> Const Encoding SpanContext)
 -> FinishedSpan -> Const Encoding FinishedSpan)
-> ((Encoding -> Const Encoding Encoding)
    -> SpanContext -> Const Encoding SpanContext)
-> Getting Encoding FinishedSpan Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SpanContext -> TraceID)
-> (TraceID -> Const Encoding TraceID)
-> SpanContext
-> Const Encoding SpanContext
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to SpanContext -> TraceID
ctxTraceID ((TraceID -> Const Encoding TraceID)
 -> SpanContext -> Const Encoding SpanContext)
-> ((Encoding -> Const Encoding Encoding)
    -> TraceID -> Const Encoding TraceID)
-> (Encoding -> Const Encoding Encoding)
-> SpanContext
-> Const Encoding SpanContext
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Encoding Text) -> TraceID -> Const Encoding TraceID
forall a. AsHex a => Getter a Text
Getter TraceID Text
hexText ((Text -> Const Encoding Text)
 -> TraceID -> Const Encoding TraceID)
-> ((Encoding -> Const Encoding Encoding)
    -> Text -> Const Encoding Text)
-> (Encoding -> Const Encoding Encoding)
-> TraceID
-> Const Encoding TraceID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Encoding)
-> (Encoding -> Const Encoding Encoding)
-> Text
-> Const Encoding Text
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Text -> Encoding
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
            (Key -> Encoding -> Series
pair Key
"parentId" (Encoding -> Series) -> (Word64 -> Encoding) -> Word64 -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Encoding
forall a. Text -> Encoding' a
text (Text -> Encoding) -> (Word64 -> Text) -> Word64 -> Encoding
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
Getter Word64 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
Lens' FinishedSpan 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
            (Key -> Encoding -> Series
pair Key
"kind" (Encoding -> Series) -> (TagVal -> Encoding) -> TagVal -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagVal -> Encoding
forall a. ToJSON a => a -> Encoding
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
Lens' FinishedSpan 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
<> Key -> Encoding -> Series
pair Key
"timestamp"      (Getting Encoding FinishedSpan Encoding -> FinishedSpan -> Encoding
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((UTCTime -> Const Encoding UTCTime)
-> FinishedSpan -> Const Encoding FinishedSpan
forall a. HasSpanFields a => Lens' a UTCTime
Lens' FinishedSpan UTCTime
spanStart ((UTCTime -> Const Encoding UTCTime)
 -> FinishedSpan -> Const Encoding FinishedSpan)
-> ((Encoding -> Const Encoding Encoding)
    -> UTCTime -> Const Encoding UTCTime)
-> Getting Encoding FinishedSpan Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTCTime -> Encoding)
-> (Encoding -> Const Encoding Encoding)
-> UTCTime
-> Const Encoding UTCTime
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to UTCTime -> Encoding
forall a. AsMicros a => a -> Encoding
microsE) FinishedSpan
s)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key -> Encoding -> Series
pair Key
"duration"       (Getting Encoding FinishedSpan Encoding -> FinishedSpan -> Encoding
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((NominalDiffTime -> Const Encoding NominalDiffTime)
-> FinishedSpan -> Const Encoding FinishedSpan
Lens' FinishedSpan NominalDiffTime
spanDuration ((NominalDiffTime -> Const Encoding NominalDiffTime)
 -> FinishedSpan -> Const Encoding FinishedSpan)
-> ((Encoding -> Const Encoding Encoding)
    -> NominalDiffTime -> Const Encoding NominalDiffTime)
-> Getting Encoding FinishedSpan Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NominalDiffTime -> Encoding)
-> (Encoding -> Const Encoding Encoding)
-> NominalDiffTime
-> Const Encoding NominalDiffTime
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to NominalDiffTime -> Encoding
forall a. AsMicros a => a -> Encoding
microsE) FinishedSpan
s)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key -> Encoding -> Series
pair Key
"debug"          (Bool -> Encoding
bool Bool
False)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key -> Encoding -> Series
pair Key
"localEndpoint"  (Endpoint -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding Endpoint
loc)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Series -> (Encoding -> Series) -> Maybe Encoding -> Series
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Series
forall a. Monoid a => a
mempty
             (Key -> Encoding -> Series
pair Key
"remoteEndpoint")
             (Getting (Maybe Encoding) FinishedSpan (Maybe Encoding)
-> FinishedSpan -> Maybe Encoding
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Tags -> Const (Maybe Encoding) Tags)
-> FinishedSpan -> Const (Maybe Encoding) FinishedSpan
forall a. HasSpanFields a => Lens' a Tags
Lens' FinishedSpan Tags
spanTags ((Tags -> Const (Maybe Encoding) Tags)
 -> FinishedSpan -> Const (Maybe Encoding) FinishedSpan)
-> ((Maybe Encoding -> Const (Maybe Encoding) (Maybe Encoding))
    -> Tags -> Const (Maybe Encoding) Tags)
-> Getting (Maybe Encoding) FinishedSpan (Maybe Encoding)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tags -> Maybe Encoding)
-> (Maybe Encoding -> Const (Maybe Encoding) (Maybe Encoding))
-> Tags
-> Const (Maybe Encoding) Tags
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Tags -> Maybe Encoding
remoteEndpoint) FinishedSpan
s)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key -> Encoding -> Series
pair Key
"annotations"    ((LogRecord -> Encoding) -> [LogRecord] -> Encoding
forall a. (a -> Encoding) -> [a] -> Encoding
list ((forall (t :: * -> *). Foldable t => t LogField -> Builder)
-> LogRecord -> Encoding
logRecE t LogField -> Builder
forall (t :: * -> *). Foldable t => t LogField -> Builder
logfmt) ([LogRecord] -> Encoding) -> [LogRecord] -> Encoding
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]
Lens' FinishedSpan [LogRecord]
spanLogs FinishedSpan
s)
    -- Zipkin V2 requires tag values to be strings
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key -> Encoding -> Series
pair Key
"tags"           (Map Text Text -> Encoding
forall a. ToJSON a => a -> Encoding
toEncoding (Map Text Text -> Encoding)
-> (FinishedSpan -> Map Text Text) -> FinishedSpan -> Encoding
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
Lens' FinishedSpan 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)
-> (HashMap Text TagVal
    -> Const (Map Text Text) (HashMap Text TagVal))
-> Tags
-> Const (Map Text Text) Tags
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Tags -> HashMap Text TagVal
fromTags ((HashMap Text TagVal
  -> Const (Map Text Text) (HashMap Text TagVal))
 -> Tags -> Const (Map Text Text) Tags)
-> (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
IndexedFold Text (HashMap Text TagVal) TagVal
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) -> FinishedSpan -> Encoding
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)
-> (String -> Const Text String) -> Bool -> Const Text Bool
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 ((String -> Const Text String) -> Bool -> Const Text Bool)
-> ((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)
-> (String -> Const Text String) -> Int64 -> Const Text Int64
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 ((String -> Const Text String) -> Int64 -> Const Text Int64)
-> ((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)
-> (String -> Const Text String) -> Double -> Const Text Double
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 ((String -> Const Text String) -> Double -> Const Text Double)
-> ((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)
-> (ByteString -> Const Text ByteString)
-> ByteString
-> Const Text ByteString
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to ByteString -> ByteString
B64.encode ((ByteString -> Const Text ByteString)
 -> ByteString -> Const Text ByteString)
-> Getting Text ByteString Text -> Getting Text ByteString Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Method -> Const Text Method)
-> ByteString -> Const Text ByteString
forall lazy strict. Strict lazy strict => Iso' lazy strict
Iso' ByteString Method
strict ((Method -> Const Text Method)
 -> ByteString -> Const Text ByteString)
-> ((Text -> Const Text Text) -> Method -> Const Text Method)
-> Getting Text ByteString Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> Const Text Text) -> Method -> Const Text Method
Prism' Method Text
utf8) ByteString
b

remoteEndpoint :: Tags -> Maybe Encoding
remoteEndpoint :: Tags -> Maybe Encoding
remoteEndpoint Tags
ts = case [Series]
fields of
    [] -> Maybe Encoding
forall a. Maybe a
Nothing
    [Series]
xs -> Encoding -> Maybe Encoding
forall a. a -> Maybe a
Just (Encoding -> Maybe Encoding)
-> (Series -> Encoding) -> Series -> Maybe Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Series -> Encoding
pairs (Series -> Maybe Encoding) -> Series -> Maybe Encoding
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
        [ Key -> Encoding -> Series
pair Key
forall a. (Eq a, IsString a) => a
PeerServiceKey (Encoding -> Series) -> (TagVal -> Encoding) -> TagVal -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagVal -> Encoding
forall a. ToJSON a => a -> Encoding
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
        , Key -> Encoding -> Series
pair Key
forall a. (Eq a, IsString a) => a
PeerIPv4Key    (Encoding -> Series) -> (TagVal -> Encoding) -> TagVal -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagVal -> Encoding
forall a. ToJSON a => a -> Encoding
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
        , Key -> Encoding -> Series
pair Key
forall a. (Eq a, IsString a) => a
PeerIPv6Key    (Encoding -> Series) -> (TagVal -> Encoding) -> TagVal -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagVal -> Encoding
forall a. ToJSON a => a -> Encoding
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
        , Key -> Encoding -> Series
pair Key
forall a. (Eq a, IsString a) => a
PeerPortKey    (Encoding -> Series) -> (TagVal -> Encoding) -> TagVal -> Series
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TagVal -> Encoding
forall a. ToJSON a => a -> Encoding
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
logRecE forall (t :: * -> *). Foldable t => t LogField -> Builder
logfmt LogRecord
r = Series -> Encoding
pairs (Series -> Encoding) -> Series -> Encoding
forall a b. (a -> b) -> a -> b
$
       Key -> Encoding -> Series
pair Key
"timestamp" (Getting Encoding LogRecord Encoding -> LogRecord -> Encoding
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((UTCTime -> Const Encoding UTCTime)
-> LogRecord -> Const Encoding LogRecord
Lens' LogRecord UTCTime
logTime ((UTCTime -> Const Encoding UTCTime)
 -> LogRecord -> Const Encoding LogRecord)
-> ((Encoding -> Const Encoding Encoding)
    -> UTCTime -> Const Encoding UTCTime)
-> Getting Encoding LogRecord Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (UTCTime -> Encoding)
-> (Encoding -> Const Encoding Encoding)
-> UTCTime
-> Const Encoding UTCTime
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to UTCTime -> Encoding
forall a. AsMicros a => a -> Encoding
microsE) LogRecord
r)
    Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Key -> Encoding -> Series
pair Key
"value"     (Text -> Encoding
forall a. Text -> Encoding' a
lazyText (Text -> Encoding)
-> (NonEmpty LogField -> Text) -> NonEmpty LogField -> Encoding
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) -> NonEmpty LogField -> Encoding
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 :: forall a. AsMicros a => a -> Encoding
microsE = Word64 -> Encoding
word64 (Word64 -> Encoding) -> (a -> Word64) -> a -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Word64
forall b. Integral b => a -> b
forall a b. (AsMicros a, Integral b) => a -> b
micros