{-# 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
, 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 = forall (t :: * -> *). Foldable t => t LogField -> Builder
jsonMap
, _zoErrorLog :: Builder -> IO ()
_zoErrorLog = Builder -> IO ()
defaultErrorLog
}
defaultZipkinEndpoint :: String
defaultZipkinEndpoint :: String
defaultZipkinEndpoint = String
"http://"
forall a. Semigroup a => a -> a -> a
<> forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (a :: Protocol). Lens' (Addr a) String
addrHostName Addr 'HTTP
addr
forall a. Semigroup a => a -> a -> a
<> String
":"
forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall (a :: Protocol). Lens' (Addr a) Port
addrPort Addr 'HTTP
addr)
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
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap BatchEnv -> Zipkin
Zipkin
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BatchOptions -> IO BatchEnv
newBatchEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' BatchOptions (Builder -> IO ())
boptErrorLog Builder -> IO ()
errlog forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([FinishedSpan] -> IO ()) -> BatchOptions
batchOptions
forall a b. (a -> b) -> a -> b
$ ZipkinOptions -> Request -> [FinishedSpan] -> IO ()
reporter ZipkinOptions
opts Request
rq
where
mkReq :: IO Request
mkReq = do
Request
rq <- forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
endpoint
forall (m :: * -> *) a. Monad m => a -> m a
return Request
rq { method :: Method
method = Method
"POST", requestHeaders :: RequestHeaders
requestHeaders = [(HeaderName
hContentType, Method
"application/json")] }
closeZipkin :: Zipkin -> IO ()
closeZipkin :: Zipkin -> IO ()
closeZipkin = BatchEnv -> IO ()
closeBatchEnv 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 = forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ZipkinOptions -> IO Zipkin
newZipkin ZipkinOptions
opts) (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO 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 = forall (m :: * -> *). MonadIO m => BatchEnv -> FinishedSpan -> m ()
batchReporter 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 <- forall body. Response body -> Status
responseStatus 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Status -> Bool
statusIsSuccessful Status
rs) forall a b. (a -> b) -> a -> b
$
Builder -> IO ()
_zoErrorLog forall a b. (a -> b) -> a -> b
$ ShortByteString -> Builder
shortByteString ShortByteString
"Error from Zipkin server: "
forall a. Semigroup a => a -> a -> a
<> Int -> Builder
intDec (Status -> Int
statusCode Status
rs)
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
char8 Char
'\n'
where
body :: RequestBody
body = ByteString -> RequestBody
RequestBodyLBS
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Encoding' a -> ByteString
encodingToLazyByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Encoding) -> [a] -> Encoding
list (Endpoint
-> (forall (t :: * -> *). Foldable t => t LogField -> Builder)
-> FinishedSpan
-> Encoding
spanE Endpoint
_zoLocalEndpoint forall (t :: * -> *). Foldable t => t LogField -> Builder
_zoLogfmt)
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 forall a b. (a -> b) -> a -> b
$
Key -> Encoding -> Series
pair Key
"name" (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall a. HasSpanFields a => Lens' a Text
spanOperation 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. Text -> Encoding' a
text) FinishedSpan
s)
forall a. Semigroup a => a -> a -> a
<> Key -> Encoding -> Series
pair Key
"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 -> Word64
ctxSpanID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. AsHex a => Getter a Text
hexText 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. Text -> Encoding' a
text) FinishedSpan
s)
forall a. Semigroup a => a -> a -> a
<> Key -> Encoding -> Series
pair Key
"traceId" (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 -> TraceID
ctxTraceID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. AsHex a => Getter a Text
hexText 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. Text -> Encoding' a
text) FinishedSpan
s)
forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty
(Key -> Encoding -> Series
pair Key
"parentId" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Text -> Encoding' a
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. AsHex a => Getter a Text
hexText)
(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 Word64
ctxParentSpanID) FinishedSpan
s)
forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty
(Key -> Encoding -> Series
pair Key
"kind" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Encoding
toEncoding)
(forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall a. HasSpanFields a => Lens' a Tags
spanTags forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to (Text -> Tags -> Maybe TagVal
getTag forall a. (Eq a, IsString a) => a
SpanKindKey)) FinishedSpan
s)
forall a. Semigroup a => a -> a -> a
<> Key -> Encoding -> Series
pair Key
"timestamp" (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. AsMicros a => a -> Encoding
microsE) FinishedSpan
s)
forall a. Semigroup a => a -> a -> a
<> Key -> Encoding -> Series
pair Key
"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. AsMicros a => a -> Encoding
microsE) FinishedSpan
s)
forall a. Semigroup a => a -> a -> a
<> Key -> Encoding -> Series
pair Key
"debug" (Bool -> Encoding
bool Bool
False)
forall a. Semigroup a => a -> a -> a
<> Key -> Encoding -> Series
pair Key
"localEndpoint" (forall a. ToJSON a => a -> Encoding
toEncoding Endpoint
loc)
forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty
(Key -> Encoding -> Series
pair Key
"remoteEndpoint")
(forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (forall a. HasSpanFields a => Lens' a Tags
spanTags forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Tags -> Maybe Encoding
remoteEndpoint) FinishedSpan
s)
forall a. Semigroup a => a -> a -> a
<> Key -> Encoding -> Series
pair Key
"annotations" (forall a. (a -> Encoding) -> [a] -> Encoding
list ((forall (t :: * -> *). Foldable t => t LogField -> Builder)
-> LogRecord -> Encoding
logRecE forall (t :: * -> *). Foldable t => t LogField -> Builder
logfmt) forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a. HasSpanFields a => Lens' a [LogRecord]
spanLogs FinishedSpan
s)
forall a. Semigroup a => a -> a -> a
<> Key -> Encoding -> Series
pair Key
"tags" (forall a. ToJSON a => a -> Encoding
toEncoding forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i a s. IndexedGetting i (Map i a) s a -> s -> Map i a
toMapOf (forall a. HasSpanFields a => Lens' a Tags
spanTags forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to Tags -> HashMap Text TagVal
fromTags forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i (f :: * -> *) a.
FoldableWithIndex i f =>
IndexedFold i (f a) a
ifolded 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 TagVal -> Text
tagToText) forall a b. (a -> b) -> a -> b
$ FinishedSpan
s)
where tagToText :: TagVal -> Text
tagToText = \ case
BoolT Bool
b -> 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 forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' String Text
packed) Bool
b
StringT Text
t -> Text
t
IntT Int64
i -> 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 forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' String Text
packed) Int64
i
DoubleT Double
d -> 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 forall a. Show a => a -> String
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. Iso' String Text
packed) Double
d
BinaryT ByteString
b -> 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 ByteString -> ByteString
B64.encode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall lazy strict. Strict lazy strict => Iso' lazy strict
strict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prism' Method Text
utf8) ByteString
b
remoteEndpoint :: Tags -> Maybe Encoding
remoteEndpoint :: Tags -> Maybe Encoding
remoteEndpoint Tags
ts = case [Series]
fields of
[] -> forall a. Maybe a
Nothing
[Series]
xs -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Series -> Encoding
pairs forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat [Series]
xs
where
fields :: [Series]
fields = forall a. [Maybe a] -> [a]
catMaybes
[ Key -> Encoding -> Series
pair forall a. (Eq a, IsString a) => a
PeerServiceKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Encoding
toEncoding forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Tags -> Maybe TagVal
getTag forall a. (Eq a, IsString a) => a
PeerServiceKey Tags
ts
, Key -> Encoding -> Series
pair forall a. (Eq a, IsString a) => a
PeerIPv4Key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Encoding
toEncoding forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Tags -> Maybe TagVal
getTag forall a. (Eq a, IsString a) => a
PeerIPv4Key Tags
ts
, Key -> Encoding -> Series
pair forall a. (Eq a, IsString a) => a
PeerIPv6Key forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Encoding
toEncoding forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Tags -> Maybe TagVal
getTag forall a. (Eq a, IsString a) => a
PeerIPv6Key Tags
ts
, Key -> Encoding -> Series
pair forall a. (Eq a, IsString a) => a
PeerPortKey forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> Encoding
toEncoding forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Tags -> Maybe TagVal
getTag 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 forall a b. (a -> b) -> a -> b
$
Key -> Encoding -> Series
pair Key
"timestamp" (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' LogRecord UTCTime
logTime forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> Optic' p f s a
to forall a. AsMicros a => a -> Encoding
microsE) LogRecord
r)
forall a. Semigroup a => a -> a -> a
<> Key -> Encoding -> Series
pair Key
"value" (forall a. Text -> Encoding' a
lazyText forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *). Foldable t => t LogField -> Builder
logfmt forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' LogRecord (NonEmpty LogField)
logFields LogRecord
r)
microsE :: AsMicros a => a -> Encoding
microsE :: forall a. AsMicros a => a -> Encoding
microsE = Word64 -> Encoding
word64 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (AsMicros a, Integral b) => a -> b
micros