{-# LANGUAGE CPP #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module Monitor.Tracing.Zipkin (
Settings(..), defaultSettings,
Endpoint(..), defaultEndpoint,
Zipkin,
new, run, publish, with,
B3(..), b3ToHeaders, b3FromHeaders, b3ToHeaderValue, b3FromHeaderValue, b3FromSpan,
clientSpan, clientSpanWith, serverSpan, serverSpanWith, producerSpanWith, consumerSpanWith,
tag, addTag, addInheritedTag, addConsumerKind, addProducerKind,
annotate, annotateAt,
addEndpoint
) where
import Control.Monad.Trace
import Control.Monad.Trace.Class
import Control.Concurrent (forkIO, threadDelay)
import Control.Concurrent.STM (atomically, tryReadTChan)
import Control.Monad (forever, guard, void, when)
import Control.Monad.Fix (fix)
import Control.Monad.IO.Class (MonadIO, liftIO)
import qualified Data.Aeson as JSON
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.CaseInsensitive (CI)
import Data.Time.Clock (NominalDiffTime)
import Data.Foldable (toList)
import Data.Int (Int64)
import Data.IORef (modifyIORef, newIORef, readIORef)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, fromMaybe, listToMaybe, maybeToList)
import Data.Monoid (Endo(..))
#if !MIN_VERSION_base(4, 11, 0)
import Data.Semigroup ((<>))
#endif
import Data.Set (Set)
import qualified Data.Set as Set
import Data.String (IsString(..))
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Data.Time.Clock.POSIX (POSIXTime)
import Network.HTTP.Client (Manager, Request)
import qualified Network.HTTP.Client as HTTP
import Network.Socket (HostName, PortNumber)
import UnliftIO (MonadUnliftIO)
import UnliftIO.Exception (finally)
data Settings = Settings
{ Settings -> Maybe HostName
settingsHostname :: !(Maybe HostName)
, Settings -> Maybe PortNumber
settingsPort :: !(Maybe PortNumber)
, Settings -> Maybe Endpoint
settingsEndpoint :: !(Maybe Endpoint)
, Settings -> Maybe Manager
settingsManager :: !(Maybe Manager)
, Settings -> Maybe NominalDiffTime
settingsPublishPeriod :: !(Maybe NominalDiffTime)
}
defaultSettings :: Settings
defaultSettings :: Settings
defaultSettings = Maybe HostName
-> Maybe PortNumber
-> Maybe Endpoint
-> Maybe Manager
-> Maybe NominalDiffTime
-> Settings
Settings Maybe HostName
forall a. Maybe a
Nothing Maybe PortNumber
forall a. Maybe a
Nothing Maybe Endpoint
forall a. Maybe a
Nothing Maybe Manager
forall a. Maybe a
Nothing Maybe NominalDiffTime
forall a. Maybe a
Nothing
instance IsString Settings where
fromString :: HostName -> Settings
fromString HostName
s = Settings
defaultSettings { settingsHostname = Just s }
data Zipkin = Zipkin
{ Zipkin -> Manager
zipkinManager :: !Manager
, Zipkin -> Request
zipkinRequest :: !Request
, Zipkin -> Tracer
zipkinTracer :: !Tracer
, Zipkin -> Maybe Endpoint
zipkinEndpoint :: !(Maybe Endpoint)
}
flushSpans :: Maybe Endpoint -> Tracer -> Request -> Manager -> IO ()
flushSpans :: Maybe Endpoint -> Tracer -> Request -> Manager -> IO ()
flushSpans Maybe Endpoint
ept Tracer
tracer Request
req Manager
mgr = do
IORef [ZipkinSpan]
ref <- [ZipkinSpan] -> IO (IORef [ZipkinSpan])
forall a. a -> IO (IORef a)
newIORef []
(IO () -> IO ()) -> IO ()
forall a. (a -> a) -> a
fix ((IO () -> IO ()) -> IO ()) -> (IO () -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \IO ()
loop -> STM (Maybe Sample) -> IO (Maybe Sample)
forall a. STM a -> IO a
atomically (TChan Sample -> STM (Maybe Sample)
forall a. TChan a -> STM (Maybe a)
tryReadTChan (TChan Sample -> STM (Maybe Sample))
-> TChan Sample -> STM (Maybe Sample)
forall a b. (a -> b) -> a -> b
$ Tracer -> TChan Sample
spanSamples Tracer
tracer) IO (Maybe Sample) -> (Maybe Sample -> IO ()) -> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Sample
Nothing -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just Sample
sample -> IORef [ZipkinSpan] -> ([ZipkinSpan] -> [ZipkinSpan]) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef IORef [ZipkinSpan]
ref (Maybe Endpoint -> Sample -> ZipkinSpan
ZipkinSpan Maybe Endpoint
ept Sample
sampleZipkinSpan -> [ZipkinSpan] -> [ZipkinSpan]
forall a. a -> [a] -> [a]
:) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
loop
[ZipkinSpan]
spns <- IORef [ZipkinSpan] -> IO [ZipkinSpan]
forall a. IORef a -> IO a
readIORef IORef [ZipkinSpan]
ref
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [ZipkinSpan] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ZipkinSpan]
spns) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
let req' :: Request
req' = Request
req { HTTP.requestBody = HTTP.RequestBodyLBS $ JSON.encode spns }
IO (Response ByteString) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Response ByteString) -> IO ())
-> IO (Response ByteString) -> IO ()
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
HTTP.httpLbs Request
req' Manager
mgr
new :: MonadIO m => Settings -> m Zipkin
new :: forall (m :: * -> *). MonadIO m => Settings -> m Zipkin
new (Settings Maybe HostName
mbHostname Maybe PortNumber
mbPort Maybe Endpoint
mbEpt Maybe Manager
mbMgr Maybe NominalDiffTime
mbPrd) = 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
$ do
Manager
mgr <- IO Manager
-> (Manager -> IO Manager) -> Maybe Manager -> IO Manager
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ManagerSettings -> IO Manager
HTTP.newManager ManagerSettings
HTTP.defaultManagerSettings) Manager -> IO Manager
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Manager
mbMgr
Tracer
tracer <- IO Tracer
forall (m :: * -> *). MonadIO m => m Tracer
newTracer
let
req :: Request
req = Request
HTTP.defaultRequest
{ HTTP.method = "POST"
, HTTP.host = BS.pack (fromMaybe "localhost" mbHostname)
, HTTP.path = "/api/v2/spans"
, HTTP.port = maybe 9411 fromIntegral mbPort
, HTTP.requestHeaders = [("content-type", "application/json")]
}
IO (Maybe ThreadId) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Maybe ThreadId) -> IO ()) -> IO (Maybe ThreadId) -> IO ()
forall a b. (a -> b) -> a -> b
$ let prd :: NominalDiffTime
prd = NominalDiffTime -> Maybe NominalDiffTime -> NominalDiffTime
forall a. a -> Maybe a -> a
fromMaybe NominalDiffTime
0 Maybe NominalDiffTime
mbPrd in if NominalDiffTime
prd NominalDiffTime -> NominalDiffTime -> Bool
forall a. Ord a => a -> a -> Bool
<= NominalDiffTime
0
then Maybe ThreadId -> IO (Maybe ThreadId)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe ThreadId
forall a. Maybe a
Nothing
else (ThreadId -> Maybe ThreadId) -> IO ThreadId -> IO (Maybe ThreadId)
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ThreadId -> Maybe ThreadId
forall a. a -> Maybe a
Just (IO ThreadId -> IO (Maybe ThreadId))
-> IO ThreadId -> IO (Maybe ThreadId)
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Int -> IO ()
threadDelay (NominalDiffTime -> Int
forall a. Integral a => NominalDiffTime -> a
microSeconds NominalDiffTime
prd)
Maybe Endpoint -> Tracer -> Request -> Manager -> IO ()
flushSpans Maybe Endpoint
mbEpt Tracer
tracer Request
req Manager
mgr
Zipkin -> IO Zipkin
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Zipkin -> IO Zipkin) -> Zipkin -> IO Zipkin
forall a b. (a -> b) -> a -> b
$ Manager -> Request -> Tracer -> Maybe Endpoint -> Zipkin
Zipkin Manager
mgr Request
req Tracer
tracer Maybe Endpoint
mbEpt
run :: TraceT m a -> Zipkin -> m a
run :: forall (m :: * -> *) a. TraceT m a -> Zipkin -> m a
run TraceT m a
actn Zipkin
zipkin = TraceT m a -> Tracer -> m a
forall (m :: * -> *) a. TraceT m a -> Tracer -> m a
runTraceT TraceT m a
actn (Zipkin -> Tracer
zipkinTracer Zipkin
zipkin)
publish :: MonadIO m => Zipkin -> m ()
publish :: forall (m :: * -> *). MonadIO m => Zipkin -> m ()
publish Zipkin
z =
IO () -> m ()
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe Endpoint -> Tracer -> Request -> Manager -> IO ()
flushSpans (Zipkin -> Maybe Endpoint
zipkinEndpoint Zipkin
z) (Zipkin -> Tracer
zipkinTracer Zipkin
z) (Zipkin -> Request
zipkinRequest Zipkin
z) (Zipkin -> Manager
zipkinManager Zipkin
z)
with :: MonadUnliftIO m => Settings -> (Zipkin -> m a) -> m a
with :: forall (m :: * -> *) a.
MonadUnliftIO m =>
Settings -> (Zipkin -> m a) -> m a
with Settings
settings Zipkin -> m a
f = do
Zipkin
zipkin <- Settings -> m Zipkin
forall (m :: * -> *). MonadIO m => Settings -> m Zipkin
new Settings
settings
Zipkin -> m a
f Zipkin
zipkin m a -> m () -> m a
forall (m :: * -> *) a b. MonadUnliftIO m => m a -> m b -> m a
`finally` Zipkin -> m ()
forall (m :: * -> *). MonadIO m => Zipkin -> m ()
publish Zipkin
zipkin
tag :: MonadTrace m => Text -> Text -> m ()
tag :: forall (m :: * -> *). MonadTrace m => Text -> Text -> m ()
tag Text
key Text
val = Text -> Value -> m ()
forall (m :: * -> *). MonadTrace m => Text -> Value -> m ()
addSpanEntry (Text
publicKeyPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
key) (Text -> Value
tagTextValue Text
val)
addTag :: Text -> Text -> Builder -> Builder
addTag :: Text -> Text -> Builder -> Builder
addTag Text
key Text
val Builder
bldr =
Builder
bldr { builderTags = Map.insert (publicKeyPrefix <> key) (JSON.toJSON val) (builderTags bldr) }
addConsumerKind :: Builder -> Builder
addConsumerKind :: Builder -> Builder
addConsumerKind = Text -> Text -> Builder -> Builder
addTag Text
kindKey Text
consumerKindValue
addProducerKind :: Builder -> Builder
addProducerKind :: Builder -> Builder
addProducerKind = Text -> Text -> Builder -> Builder
addTag Text
kindKey Text
producerKindValue
addInheritedTag :: Text -> Text -> Builder -> Builder
addInheritedTag :: Text -> Text -> Builder -> Builder
addInheritedTag Text
key Text
val Builder
bldr =
let bgs :: Map Text ByteString
bgs = Builder -> Map Text ByteString
builderBaggages Builder
bldr
in Builder
bldr { builderBaggages = Map.insert key (T.encodeUtf8 val) bgs }
annotate :: MonadTrace m => Text -> m ()
annotate :: forall (m :: * -> *). MonadTrace m => Text -> m ()
annotate Text
val = Text -> Value -> m ()
forall (m :: * -> *). MonadTrace m => Text -> Value -> m ()
addSpanEntry Text
"" (Text -> Value
forall a. ToJSON a => a -> Value
logValue Text
val)
annotateAt :: MonadTrace m => POSIXTime -> Text -> m ()
annotateAt :: forall (m :: * -> *).
MonadTrace m =>
NominalDiffTime -> Text -> m ()
annotateAt NominalDiffTime
time Text
val = Text -> Value -> m ()
forall (m :: * -> *). MonadTrace m => Text -> Value -> m ()
addSpanEntry Text
"" (NominalDiffTime -> Text -> Value
forall a. ToJSON a => NominalDiffTime -> a -> Value
logValueAt NominalDiffTime
time Text
val)
data B3 = B3
{ B3 -> TraceID
b3TraceID :: !TraceID
, B3 -> SpanID
b3SpanID :: !SpanID
, B3 -> Bool
b3IsSampled :: !Bool
, B3 -> Bool
b3IsDebug :: !Bool
, B3 -> Maybe SpanID
b3ParentSpanID :: !(Maybe SpanID)
} deriving (B3 -> B3 -> Bool
(B3 -> B3 -> Bool) -> (B3 -> B3 -> Bool) -> Eq B3
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: B3 -> B3 -> Bool
== :: B3 -> B3 -> Bool
$c/= :: B3 -> B3 -> Bool
/= :: B3 -> B3 -> Bool
Eq, Eq B3
Eq B3 =>
(B3 -> B3 -> Ordering)
-> (B3 -> B3 -> Bool)
-> (B3 -> B3 -> Bool)
-> (B3 -> B3 -> Bool)
-> (B3 -> B3 -> Bool)
-> (B3 -> B3 -> B3)
-> (B3 -> B3 -> B3)
-> Ord B3
B3 -> B3 -> Bool
B3 -> B3 -> Ordering
B3 -> B3 -> B3
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: B3 -> B3 -> Ordering
compare :: B3 -> B3 -> Ordering
$c< :: B3 -> B3 -> Bool
< :: B3 -> B3 -> Bool
$c<= :: B3 -> B3 -> Bool
<= :: B3 -> B3 -> Bool
$c> :: B3 -> B3 -> Bool
> :: B3 -> B3 -> Bool
$c>= :: B3 -> B3 -> Bool
>= :: B3 -> B3 -> Bool
$cmax :: B3 -> B3 -> B3
max :: B3 -> B3 -> B3
$cmin :: B3 -> B3 -> B3
min :: B3 -> B3 -> B3
Ord, Int -> B3 -> ShowS
[B3] -> ShowS
B3 -> HostName
(Int -> B3 -> ShowS)
-> (B3 -> HostName) -> ([B3] -> ShowS) -> Show B3
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> B3 -> ShowS
showsPrec :: Int -> B3 -> ShowS
$cshow :: B3 -> HostName
show :: B3 -> HostName
$cshowList :: [B3] -> ShowS
showList :: [B3] -> ShowS
Show)
traceIDHeader, spanIDHeader, parentSpanIDHeader, sampledHeader, debugHeader :: CI ByteString
= CI ByteString
"X-B3-TraceId"
= CI ByteString
"X-B3-SpanId"
= CI ByteString
"X-B3-ParentSpanId"
= CI ByteString
"X-B3-Sampled"
= CI ByteString
"X-B3-Flags"
b3ToHeaders :: B3 -> Map (CI ByteString) ByteString
(B3 TraceID
traceID SpanID
spanID Bool
isSampled Bool
isDebug Maybe SpanID
mbParentID) =
let
defaultKVs :: [(CI ByteString, Text)]
defaultKVs = [(CI ByteString
traceIDHeader, TraceID -> Text
encodeZipkinTraceID TraceID
traceID), (CI ByteString
spanIDHeader, SpanID -> Text
encodeSpanID SpanID
spanID)]
parentKVs :: [(CI ByteString, Text)]
parentKVs = (CI ByteString
parentSpanIDHeader,) (Text -> (CI ByteString, Text))
-> (SpanID -> Text) -> SpanID -> (CI ByteString, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanID -> Text
encodeSpanID (SpanID -> (CI ByteString, Text))
-> [SpanID] -> [(CI ByteString, Text)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SpanID -> [SpanID]
forall a. Maybe a -> [a]
maybeToList Maybe SpanID
mbParentID
sampledKVs :: [(CI ByteString, Text)]
sampledKVs = case (Bool
isSampled, Bool
isDebug) of
(Bool
_, Bool
True) -> [(CI ByteString
debugHeader, Text
"1")]
(Bool
True, Bool
_) -> [(CI ByteString
sampledHeader, Text
"1")]
(Bool
False, Bool
_) -> [(CI ByteString
sampledHeader, Text
"0")]
in (Text -> ByteString)
-> Map (CI ByteString) Text -> Map (CI ByteString) ByteString
forall a b.
(a -> b) -> Map (CI ByteString) a -> Map (CI ByteString) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
T.encodeUtf8 (Map (CI ByteString) Text -> Map (CI ByteString) ByteString)
-> Map (CI ByteString) Text -> Map (CI ByteString) ByteString
forall a b. (a -> b) -> a -> b
$ [(CI ByteString, Text)] -> Map (CI ByteString) Text
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CI ByteString, Text)] -> Map (CI ByteString) Text)
-> [(CI ByteString, Text)] -> Map (CI ByteString) Text
forall a b. (a -> b) -> a -> b
$ [(CI ByteString, Text)]
defaultKVs [(CI ByteString, Text)]
-> [(CI ByteString, Text)] -> [(CI ByteString, Text)]
forall a. [a] -> [a] -> [a]
++ [(CI ByteString, Text)]
parentKVs [(CI ByteString, Text)]
-> [(CI ByteString, Text)] -> [(CI ByteString, Text)]
forall a. [a] -> [a] -> [a]
++ [(CI ByteString, Text)]
sampledKVs
b3FromHeaders :: Map (CI ByteString) ByteString -> Maybe B3
Map (CI ByteString) ByteString
hdrs = do
let
find :: CI ByteString -> Maybe Text
find CI ByteString
key = ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> Maybe ByteString -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CI ByteString -> Map (CI ByteString) ByteString -> Maybe ByteString
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CI ByteString
key Map (CI ByteString) ByteString
hdrs
findBool :: Bool -> CI ByteString -> Maybe Bool
findBool Bool
def CI ByteString
key = case CI ByteString -> Maybe Text
find CI ByteString
key of
Maybe Text
Nothing -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
def
Just Text
"1" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
Just Text
"0" -> Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
Maybe Text
_ -> Maybe Bool
forall a. Maybe a
Nothing
Bool
dbg <- Bool -> CI ByteString -> Maybe Bool
findBool Bool
False CI ByteString
debugHeader
Bool
sampled <- Bool -> CI ByteString -> Maybe Bool
findBool Bool
dbg CI ByteString
sampledHeader
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool
sampled Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
False Bool -> Bool -> Bool
&& Bool
dbg)
TraceID -> SpanID -> Bool -> Bool -> Maybe SpanID -> B3
B3
(TraceID -> SpanID -> Bool -> Bool -> Maybe SpanID -> B3)
-> Maybe TraceID
-> Maybe (SpanID -> Bool -> Bool -> Maybe SpanID -> B3)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (CI ByteString -> Maybe Text
find CI ByteString
traceIDHeader Maybe Text -> (Text -> Maybe TraceID) -> Maybe TraceID
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe TraceID
decodeZipkinTraceID)
Maybe (SpanID -> Bool -> Bool -> Maybe SpanID -> B3)
-> Maybe SpanID -> Maybe (Bool -> Bool -> Maybe SpanID -> B3)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (CI ByteString -> Maybe Text
find CI ByteString
spanIDHeader Maybe Text -> (Text -> Maybe SpanID) -> Maybe SpanID
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe SpanID
decodeSpanID)
Maybe (Bool -> Bool -> Maybe SpanID -> B3)
-> Maybe Bool -> Maybe (Bool -> Maybe SpanID -> B3)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Maybe Bool
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
sampled
Maybe (Bool -> Maybe SpanID -> B3)
-> Maybe Bool -> Maybe (Maybe SpanID -> B3)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> Maybe Bool
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
dbg
Maybe (Maybe SpanID -> B3) -> Maybe (Maybe SpanID) -> Maybe B3
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Maybe SpanID)
-> (Text -> Maybe (Maybe SpanID))
-> Maybe Text
-> Maybe (Maybe SpanID)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe SpanID -> Maybe (Maybe SpanID)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe SpanID
forall a. Maybe a
Nothing) (Maybe SpanID -> Maybe (Maybe SpanID)
forall a. a -> Maybe a
Just (Maybe SpanID -> Maybe (Maybe SpanID))
-> (Text -> Maybe SpanID) -> Text -> Maybe (Maybe SpanID)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe SpanID
decodeSpanID) (CI ByteString -> Maybe Text
find CI ByteString
parentSpanIDHeader)
b3ToHeaderValue :: B3 -> ByteString
(B3 TraceID
traceID SpanID
spanID Bool
isSampled Bool
isDebug Maybe SpanID
mbParentID) =
let
state :: Text
state = case (Bool
isSampled, Bool
isDebug) of
(Bool
_ , Bool
True) -> Text
"d"
(Bool
True, Bool
_) -> Text
"1"
(Bool
False, Bool
_) -> Text
"0"
required :: [Text]
required = [TraceID -> Text
encodeZipkinTraceID TraceID
traceID, SpanID -> Text
encodeSpanID SpanID
spanID, Text
state]
optional :: [Text]
optional = SpanID -> Text
encodeSpanID (SpanID -> Text) -> [SpanID] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SpanID -> [SpanID]
forall a. Maybe a -> [a]
maybeToList Maybe SpanID
mbParentID
in ByteString -> [ByteString] -> ByteString
BS.intercalate ByteString
"-" ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Text -> ByteString) -> [Text] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> ByteString
T.encodeUtf8 ([Text] -> [ByteString]) -> [Text] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ [Text]
required [Text] -> [Text] -> [Text]
forall a. [a] -> [a] -> [a]
++ [Text]
optional
shortTraceIDPrefix :: Text
shortTraceIDPrefix :: Text
shortTraceIDPrefix = Text
"0000000000000000"
decodeZipkinTraceID :: Text -> Maybe TraceID
decodeZipkinTraceID :: Text -> Maybe TraceID
decodeZipkinTraceID Text
txt =
let normalized :: Text
normalized = if Text -> Int
T.length Text
txt Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
16 then Text
shortTraceIDPrefix Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
txt else Text
txt
in Text -> Maybe TraceID
decodeTraceID Text
normalized
encodeZipkinTraceID :: TraceID -> Text
encodeZipkinTraceID :: TraceID -> Text
encodeZipkinTraceID TraceID
traceID =
let txt :: Text
txt = TraceID -> Text
encodeTraceID TraceID
traceID
in Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
txt (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
shortTraceIDPrefix Text
txt
b3FromHeaderValue :: ByteString -> Maybe B3
ByteString
bs = case HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"-" (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 ByteString
bs of
(Text
traceIDstr:Text
spanIDstr:[Text]
strs) -> do
TraceID
traceID <- Text -> Maybe TraceID
decodeZipkinTraceID Text
traceIDstr
SpanID
spanID <- Text -> Maybe SpanID
decodeSpanID Text
spanIDstr
let buildB3 :: Bool -> Bool -> Maybe SpanID -> B3
buildB3 = TraceID -> SpanID -> Bool -> Bool -> Maybe SpanID -> B3
B3 TraceID
traceID SpanID
spanID
case [Text]
strs of
[] -> B3 -> Maybe B3
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (B3 -> Maybe B3) -> B3 -> Maybe B3
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Maybe SpanID -> B3
buildB3 Bool
False Bool
False Maybe SpanID
forall a. Maybe a
Nothing
(Text
state:[Text]
strs') -> do
Maybe SpanID -> B3
buildB3' <- case Text
state of
Text
"0" -> (Maybe SpanID -> B3) -> Maybe (Maybe SpanID -> B3)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe SpanID -> B3) -> Maybe (Maybe SpanID -> B3))
-> (Maybe SpanID -> B3) -> Maybe (Maybe SpanID -> B3)
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Maybe SpanID -> B3
buildB3 Bool
False Bool
False
Text
"1" -> (Maybe SpanID -> B3) -> Maybe (Maybe SpanID -> B3)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe SpanID -> B3) -> Maybe (Maybe SpanID -> B3))
-> (Maybe SpanID -> B3) -> Maybe (Maybe SpanID -> B3)
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Maybe SpanID -> B3
buildB3 Bool
True Bool
False
Text
"d" -> (Maybe SpanID -> B3) -> Maybe (Maybe SpanID -> B3)
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((Maybe SpanID -> B3) -> Maybe (Maybe SpanID -> B3))
-> (Maybe SpanID -> B3) -> Maybe (Maybe SpanID -> B3)
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Maybe SpanID -> B3
buildB3 Bool
True Bool
True
Text
_ -> Maybe (Maybe SpanID -> B3)
forall a. Maybe a
Nothing
case [Text]
strs' of
[] -> B3 -> Maybe B3
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (B3 -> Maybe B3) -> B3 -> Maybe B3
forall a b. (a -> b) -> a -> b
$ Maybe SpanID -> B3
buildB3' Maybe SpanID
forall a. Maybe a
Nothing
[Text
str] -> Maybe SpanID -> B3
buildB3' (Maybe SpanID -> B3) -> (SpanID -> Maybe SpanID) -> SpanID -> B3
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanID -> Maybe SpanID
forall a. a -> Maybe a
Just (SpanID -> B3) -> Maybe SpanID -> Maybe B3
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Maybe SpanID
decodeSpanID Text
str
[Text]
_ -> Maybe B3
forall a. Maybe a
Nothing
[Text]
_ -> Maybe B3
forall a. Maybe a
Nothing
b3FromSpan :: Span -> B3
b3FromSpan :: Span -> B3
b3FromSpan Span
s =
let
ctx :: Context
ctx = Span -> Context
spanContext Span
s
refs :: Set Reference
refs = Span -> Set Reference
spanReferences Span
s
in TraceID -> SpanID -> Bool -> Bool -> Maybe SpanID -> B3
B3 (Context -> TraceID
contextTraceID Context
ctx) (Context -> SpanID
contextSpanID Context
ctx) (Span -> Bool
spanIsSampled Span
s) (Span -> Bool
spanIsDebug Span
s) (Set Reference -> Maybe SpanID
parentID Set Reference
refs)
insertTag :: JSON.ToJSON a => Key -> a -> Endo Builder
insertTag :: forall a. ToJSON a => Text -> a -> Endo Builder
insertTag Text
key a
val =
(Builder -> Builder) -> Endo Builder
forall a. (a -> a) -> Endo a
Endo ((Builder -> Builder) -> Endo Builder)
-> (Builder -> Builder) -> Endo Builder
forall a b. (a -> b) -> a -> b
$ \Builder
bldr -> Builder
bldr { builderTags = Map.insert key (JSON.toJSON val) (builderTags bldr) }
importB3 :: B3 -> Endo Builder
importB3 :: B3 -> Endo Builder
importB3 B3
b3 =
let
policy :: SamplingPolicy
policy = if B3 -> Bool
b3IsDebug B3
b3
then SamplingPolicy
debugEnabled
else Bool -> SamplingPolicy
sampledWhen (Bool -> SamplingPolicy) -> Bool -> SamplingPolicy
forall a b. (a -> b) -> a -> b
$ B3 -> Bool
b3IsSampled B3
b3
in (Builder -> Builder) -> Endo Builder
forall a. (a -> a) -> Endo a
Endo ((Builder -> Builder) -> Endo Builder)
-> (Builder -> Builder) -> Endo Builder
forall a b. (a -> b) -> a -> b
$ \Builder
bldr -> Builder
bldr
{ builderTraceID = Just (b3TraceID b3)
, builderSamplingPolicy = Just policy }
publicKeyPrefix :: Text
publicKeyPrefix :: Text
publicKeyPrefix = Text
"Z."
endpointKey :: Key
endpointKey :: Text
endpointKey = Text
"z.e"
kindKey :: Key
kindKey :: Text
kindKey = Text
"z.k"
consumerKindValue :: Text
consumerKindValue :: Text
consumerKindValue = Text
"CONSUMER"
producerKindValue :: Text
producerKindValue :: Text
producerKindValue = Text
"PRODUCER"
outgoingSpan :: MonadTrace m => Text -> Endo Builder -> Name -> (Maybe B3 -> m a) -> m a
outgoingSpan :: forall (m :: * -> *) a.
MonadTrace m =>
Text -> Endo Builder -> Text -> (Maybe B3 -> m a) -> m a
outgoingSpan Text
kind Endo Builder
endo Text
name Maybe B3 -> m a
f = (Builder -> Builder) -> Text -> m a -> m a
forall (m :: * -> *) a.
MonadTrace m =>
(Builder -> Builder) -> Text -> m a -> m a
childSpanWith (Endo Builder -> Builder -> Builder
forall a. Endo a -> a -> a
appEndo Endo Builder
endo') Text
name m a
actn where
endo' :: Endo Builder
endo' = Text -> Text -> Endo Builder
forall a. ToJSON a => Text -> a -> Endo Builder
insertTag Text
kindKey Text
kind Endo Builder -> Endo Builder -> Endo Builder
forall a. Semigroup a => a -> a -> a
<> Endo Builder
endo
actn :: m a
actn = m (Maybe Span)
forall (m :: * -> *). MonadTrace m => m (Maybe Span)
activeSpan m (Maybe Span) -> (Maybe Span -> m a) -> m a
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Span
Nothing -> Maybe B3 -> m a
f Maybe B3
forall a. Maybe a
Nothing
Just Span
spn -> Maybe B3 -> m a
f (Maybe B3 -> m a) -> Maybe B3 -> m a
forall a b. (a -> b) -> a -> b
$ B3 -> Maybe B3
forall a. a -> Maybe a
Just (B3 -> Maybe B3) -> B3 -> Maybe B3
forall a b. (a -> b) -> a -> b
$ Span -> B3
b3FromSpan Span
spn
clientSpan :: MonadTrace m => Name -> (Maybe B3 -> m a) -> m a
clientSpan :: forall (m :: * -> *) a.
MonadTrace m =>
Text -> (Maybe B3 -> m a) -> m a
clientSpan = (Builder -> Builder) -> Text -> (Maybe B3 -> m a) -> m a
forall (m :: * -> *) a.
MonadTrace m =>
(Builder -> Builder) -> Text -> (Maybe B3 -> m a) -> m a
clientSpanWith Builder -> Builder
forall a. a -> a
id
clientSpanWith :: MonadTrace m => (Builder -> Builder) -> Name -> (Maybe B3 -> m a) -> m a
clientSpanWith :: forall (m :: * -> *) a.
MonadTrace m =>
(Builder -> Builder) -> Text -> (Maybe B3 -> m a) -> m a
clientSpanWith Builder -> Builder
f = Text -> Endo Builder -> Text -> (Maybe B3 -> m a) -> m a
forall (m :: * -> *) a.
MonadTrace m =>
Text -> Endo Builder -> Text -> (Maybe B3 -> m a) -> m a
outgoingSpan Text
"CLIENT" ((Builder -> Builder) -> Endo Builder
forall a. (a -> a) -> Endo a
Endo Builder -> Builder
f)
producerSpanWith :: MonadTrace m => (Builder -> Builder) -> Name -> (Maybe B3 -> m a) -> m a
producerSpanWith :: forall (m :: * -> *) a.
MonadTrace m =>
(Builder -> Builder) -> Text -> (Maybe B3 -> m a) -> m a
producerSpanWith Builder -> Builder
f = Text -> Endo Builder -> Text -> (Maybe B3 -> m a) -> m a
forall (m :: * -> *) a.
MonadTrace m =>
Text -> Endo Builder -> Text -> (Maybe B3 -> m a) -> m a
outgoingSpan Text
producerKindValue ((Builder -> Builder) -> Endo Builder
forall a. (a -> a) -> Endo a
Endo Builder -> Builder
f)
incomingSpan :: MonadTrace m => Text -> B3 -> Endo Builder -> m a -> m a
incomingSpan :: forall (m :: * -> *) a.
MonadTrace m =>
Text -> B3 -> Endo Builder -> m a -> m a
incomingSpan Text
kind B3
b3 Endo Builder
endo m a
actn =
let bldr :: Builder
bldr = Endo Builder -> Builder -> Builder
forall a. Endo a -> a -> a
appEndo (Text -> Text -> Endo Builder
forall a. ToJSON a => Text -> a -> Endo Builder
insertTag Text
kindKey Text
kind Endo Builder -> Endo Builder -> Endo Builder
forall a. Semigroup a => a -> a -> a
<> B3 -> Endo Builder
importB3 B3
b3 Endo Builder -> Endo Builder -> Endo Builder
forall a. Semigroup a => a -> a -> a
<> Endo Builder
endo) (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Text -> Builder
builder Text
""
in Builder -> m a -> m a
forall a. Builder -> m a -> m a
forall (m :: * -> *) a. MonadTrace m => Builder -> m a -> m a
trace Builder
bldr m a
actn
serverSpan :: MonadTrace m => B3 -> m a -> m a
serverSpan :: forall (m :: * -> *) a. MonadTrace m => B3 -> m a -> m a
serverSpan = (Builder -> Builder) -> B3 -> m a -> m a
forall (m :: * -> *) a.
MonadTrace m =>
(Builder -> Builder) -> B3 -> m a -> m a
serverSpanWith Builder -> Builder
forall a. a -> a
id
serverSpanWith :: MonadTrace m => (Builder -> Builder) -> B3 -> m a -> m a
serverSpanWith :: forall (m :: * -> *) a.
MonadTrace m =>
(Builder -> Builder) -> B3 -> m a -> m a
serverSpanWith Builder -> Builder
f B3
b3 =
let endo :: Endo Builder
endo = (Builder -> Builder) -> Endo Builder
forall a. (a -> a) -> Endo a
Endo ((Builder -> Builder) -> Endo Builder)
-> (Builder -> Builder) -> Endo Builder
forall a b. (a -> b) -> a -> b
$ \Builder
bldr -> Builder -> Builder
f (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Builder
bldr { builderSpanID = Just (b3SpanID b3) }
in Text -> B3 -> Endo Builder -> m a -> m a
forall (m :: * -> *) a.
MonadTrace m =>
Text -> B3 -> Endo Builder -> m a -> m a
incomingSpan Text
"SERVER" B3
b3 Endo Builder
endo
consumerSpanWith :: MonadTrace m => (Builder -> Builder) -> B3 -> m a -> m a
consumerSpanWith :: forall (m :: * -> *) a.
MonadTrace m =>
(Builder -> Builder) -> B3 -> m a -> m a
consumerSpanWith Builder -> Builder
f B3
b3 =
let endo :: Endo Builder
endo = (Builder -> Builder) -> Endo Builder
forall a. (a -> a) -> Endo a
Endo ((Builder -> Builder) -> Endo Builder)
-> (Builder -> Builder) -> Endo Builder
forall a b. (a -> b) -> a -> b
$ \Builder
bldr -> Builder -> Builder
f (Builder -> Builder) -> Builder -> Builder
forall a b. (a -> b) -> a -> b
$ Builder
bldr { builderReferences = Set.singleton (ChildOf $ b3SpanID b3) }
in Text -> B3 -> Endo Builder -> m a -> m a
forall (m :: * -> *) a.
MonadTrace m =>
Text -> B3 -> Endo Builder -> m a -> m a
incomingSpan Text
consumerKindValue B3
b3 Endo Builder
endo
data Endpoint = Endpoint
{ Endpoint -> Maybe Text
endpointService :: !(Maybe Text)
, Endpoint -> Maybe Int
endpointPort :: !(Maybe Int)
, Endpoint -> Maybe Text
endpointIPv4 :: !(Maybe Text)
, Endpoint -> Maybe Text
endpointIPv6 :: !(Maybe Text)
} deriving (Endpoint -> Endpoint -> Bool
(Endpoint -> Endpoint -> Bool)
-> (Endpoint -> Endpoint -> Bool) -> Eq Endpoint
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Endpoint -> Endpoint -> Bool
== :: Endpoint -> Endpoint -> Bool
$c/= :: Endpoint -> Endpoint -> Bool
/= :: Endpoint -> Endpoint -> Bool
Eq, Eq Endpoint
Eq Endpoint =>
(Endpoint -> Endpoint -> Ordering)
-> (Endpoint -> Endpoint -> Bool)
-> (Endpoint -> Endpoint -> Bool)
-> (Endpoint -> Endpoint -> Bool)
-> (Endpoint -> Endpoint -> Bool)
-> (Endpoint -> Endpoint -> Endpoint)
-> (Endpoint -> Endpoint -> Endpoint)
-> Ord Endpoint
Endpoint -> Endpoint -> Bool
Endpoint -> Endpoint -> Ordering
Endpoint -> Endpoint -> Endpoint
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Endpoint -> Endpoint -> Ordering
compare :: Endpoint -> Endpoint -> Ordering
$c< :: Endpoint -> Endpoint -> Bool
< :: Endpoint -> Endpoint -> Bool
$c<= :: Endpoint -> Endpoint -> Bool
<= :: Endpoint -> Endpoint -> Bool
$c> :: Endpoint -> Endpoint -> Bool
> :: Endpoint -> Endpoint -> Bool
$c>= :: Endpoint -> Endpoint -> Bool
>= :: Endpoint -> Endpoint -> Bool
$cmax :: Endpoint -> Endpoint -> Endpoint
max :: Endpoint -> Endpoint -> Endpoint
$cmin :: Endpoint -> Endpoint -> Endpoint
min :: Endpoint -> Endpoint -> Endpoint
Ord, Int -> Endpoint -> ShowS
[Endpoint] -> ShowS
Endpoint -> HostName
(Int -> Endpoint -> ShowS)
-> (Endpoint -> HostName) -> ([Endpoint] -> ShowS) -> Show Endpoint
forall a.
(Int -> a -> ShowS) -> (a -> HostName) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Endpoint -> ShowS
showsPrec :: Int -> Endpoint -> ShowS
$cshow :: Endpoint -> HostName
show :: Endpoint -> HostName
$cshowList :: [Endpoint] -> ShowS
showList :: [Endpoint] -> ShowS
Show)
defaultEndpoint :: Endpoint
defaultEndpoint :: Endpoint
defaultEndpoint = Maybe Text -> Maybe Int -> Maybe Text -> Maybe Text -> Endpoint
Endpoint Maybe Text
forall a. Maybe a
Nothing Maybe Int
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing Maybe Text
forall a. Maybe a
Nothing
addEndpoint :: Endpoint -> Builder -> Builder
addEndpoint :: Endpoint -> Builder -> Builder
addEndpoint = Endo Builder -> Builder -> Builder
forall a. Endo a -> a -> a
appEndo (Endo Builder -> Builder -> Builder)
-> (Endpoint -> Endo Builder) -> Endpoint -> Builder -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Endpoint -> Endo Builder
forall a. ToJSON a => Text -> a -> Endo Builder
insertTag Text
endpointKey
instance IsString Endpoint where
fromString :: HostName -> Endpoint
fromString HostName
s = Endpoint
defaultEndpoint { endpointService = Just (T.pack s) }
instance JSON.ToJSON Endpoint where
toJSON :: Endpoint -> Value
toJSON (Endpoint Maybe Text
mbSvc Maybe Int
mbPort Maybe Text
mbIPv4 Maybe Text
mbIPv6) = [Pair] -> Value
JSON.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
[ (Key
"serviceName" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..=) (Text -> Pair) -> Maybe Text -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mbSvc
, (Key
"port" Key -> Int -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..=) (Int -> Pair) -> Maybe Int -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Int
mbPort
, (Key
"ipv4" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..=) (Text -> Pair) -> Maybe Text -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mbIPv4
, (Key
"ipv6" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..=) (Text -> Pair) -> Maybe Text -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mbIPv6 ]
parentID :: Set Reference -> Maybe SpanID
parentID :: Set Reference -> Maybe SpanID
parentID = [SpanID] -> Maybe SpanID
forall a. [a] -> Maybe a
listToMaybe ([SpanID] -> Maybe SpanID)
-> (Set Reference -> [SpanID]) -> Set Reference -> Maybe SpanID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe SpanID] -> [SpanID]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe SpanID] -> [SpanID])
-> (Set Reference -> [Maybe SpanID]) -> Set Reference -> [SpanID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Reference -> Maybe SpanID) -> [Reference] -> [Maybe SpanID]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Reference -> Maybe SpanID
go ([Reference] -> [Maybe SpanID])
-> (Set Reference -> [Reference])
-> Set Reference
-> [Maybe SpanID]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Reference -> [Reference]
forall a. Set a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList where
go :: Reference -> Maybe SpanID
go (ChildOf SpanID
d) = SpanID -> Maybe SpanID
forall a. a -> Maybe a
Just SpanID
d
go Reference
_ = Maybe SpanID
forall a. Maybe a
Nothing
data ZipkinAnnotation = ZipkinAnnotation !POSIXTime !JSON.Value
instance JSON.ToJSON ZipkinAnnotation where
toJSON :: ZipkinAnnotation -> Value
toJSON (ZipkinAnnotation NominalDiffTime
t Value
v) = [Pair] -> Value
JSON.object
[ Key
"timestamp" Key -> Int64 -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= forall a. Integral a => NominalDiffTime -> a
microSeconds @Int64 NominalDiffTime
t
, Key
"value" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= Value
v ]
data ZipkinSpan = ZipkinSpan !(Maybe Endpoint) !Sample
publicTags :: Tags -> Map Text JSON.Value
publicTags :: Map Text Value -> Map Text Value
publicTags = [(Text, Value)] -> Map Text Value
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Text, Value)] -> Map Text Value)
-> (Map Text Value -> [(Text, Value)])
-> Map Text Value
-> Map Text Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Text, Value)] -> [(Text, Value)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Text, Value)] -> [(Text, Value)])
-> (Map Text Value -> [Maybe (Text, Value)])
-> Map Text Value
-> [(Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Text, Value) -> Maybe (Text, Value))
-> [(Text, Value)] -> [Maybe (Text, Value)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Value) -> Maybe (Text, Value)
forall {b}. (Text, b) -> Maybe (Text, b)
go ([(Text, Value)] -> [Maybe (Text, Value)])
-> (Map Text Value -> [(Text, Value)])
-> Map Text Value
-> [Maybe (Text, Value)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text Value -> [(Text, Value)]
forall k a. Map k a -> [(k, a)]
Map.assocs where
go :: (Text, b) -> Maybe (Text, b)
go (Text
k, b
v) = case Text -> Text -> Maybe Text
T.stripPrefix Text
publicKeyPrefix Text
k of
Maybe Text
Nothing -> Maybe (Text, b)
forall a. Maybe a
Nothing
Just Text
k' -> (Text, b) -> Maybe (Text, b)
forall a. a -> Maybe a
Just (Text
k', b
v)
instance JSON.ToJSON ZipkinSpan where
toJSON :: ZipkinSpan -> Value
toJSON (ZipkinSpan Maybe Endpoint
mbEpt (Sample Span
spn Map Text Value
tags Logs
logs NominalDiffTime
start NominalDiffTime
duration)) =
let
ctx :: Context
ctx = Span -> Context
spanContext Span
spn
requiredKVs :: [Pair]
requiredKVs =
[ Key
"traceId" Key -> TraceID -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= Context -> TraceID
contextTraceID Context
ctx
, Key
"name" Key -> Text -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= Span -> Text
spanName Span
spn
, Key
"id" Key -> SpanID -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= Context -> SpanID
contextSpanID Context
ctx
, Key
"timestamp" Key -> Int64 -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= forall a. Integral a => NominalDiffTime -> a
microSeconds @Int64 NominalDiffTime
start
, Key
"duration" Key -> Int64 -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= forall a. Integral a => NominalDiffTime -> a
microSeconds @Int64 NominalDiffTime
duration
, Key
"debug" Key -> Bool -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= Span -> Bool
spanIsDebug Span
spn
, Key
"tags" Key -> Map Text Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= (Map Text Value -> Map Text Value
publicTags Map Text Value
tags Map Text Value -> Map Text Value -> Map Text Value
forall a. Semigroup a => a -> a -> a
<> (Text -> Value
forall a. ToJSON a => a -> Value
JSON.toJSON (Text -> Value) -> (ByteString -> Text) -> ByteString -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
T.decodeUtf8 (ByteString -> Value) -> Map Text ByteString -> Map Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> Map Text ByteString
contextBaggages Context
ctx))
, Key
"annotations" Key -> [ZipkinAnnotation] -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..= ((NominalDiffTime, Text, Value) -> ZipkinAnnotation)
-> Logs -> [ZipkinAnnotation]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(NominalDiffTime
t, Text
_, Value
v) -> NominalDiffTime -> Value -> ZipkinAnnotation
ZipkinAnnotation NominalDiffTime
t Value
v) Logs
logs ]
optionalKVs :: [Pair]
optionalKVs = [Maybe Pair] -> [Pair]
forall a. [Maybe a] -> [a]
catMaybes
[ (Key
"parentId" Key -> SpanID -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..=) (SpanID -> Pair) -> Maybe SpanID -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Set Reference -> Maybe SpanID
parentID (Span -> Set Reference
spanReferences Span
spn)
, (Key
"localEndpoint" Key -> Endpoint -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..=) (Endpoint -> Pair) -> Maybe Endpoint -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Endpoint
mbEpt
, (Key
"remoteEndpoint" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..=) (Value -> Pair) -> Maybe Value -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Map Text Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
endpointKey Map Text Value
tags
, (Key
"kind" Key -> Value -> Pair
forall v. ToJSON v => Key -> v -> Pair
forall e kv v. (KeyValue e kv, ToJSON v) => Key -> v -> kv
JSON..=) (Value -> Pair) -> Maybe Value -> Maybe Pair
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Map Text Value -> Maybe Value
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
kindKey Map Text Value
tags ]
in [Pair] -> Value
JSON.object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [Pair]
requiredKVs [Pair] -> [Pair] -> [Pair]
forall a. [a] -> [a] -> [a]
++ [Pair]
optionalKVs
microSeconds :: Integral a => NominalDiffTime -> a
microSeconds :: forall a. Integral a => NominalDiffTime -> a
microSeconds = NominalDiffTime -> a
forall a. Integral a => NominalDiffTime -> a
forall a b. (RealFrac a, Integral b) => a -> b
round (NominalDiffTime -> a)
-> (NominalDiffTime -> NominalDiffTime) -> NominalDiffTime -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
1000000)