{-# LANGUAGE ScopedTypeVariables #-}
module Tracing.DataDog (
publishDataDog,
DataDogSpan(..)
) where
import Tracing.Core (Span(..), SpanId(..), OpName(..), TraceId(..), SpanContext(..),
SpanRelation(..), SpanTag(..))
import Control.Monad.Trans (liftIO, MonadIO)
import Control.Monad (void)
import Data.Monoid ((<>), mempty)
import Data.Aeson
import Data.Maybe (fromMaybe)
import Data.Int (Int64)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lex.Integral as BS
import qualified Data.HashMap.Strict as HM
import Network.HTTP.Client
publishDataDog :: MonadIO m =>
String
-> Manager
-> [Span]
-> m (Maybe (Response T.Text))
publishDataDog _ _ [] = pure Nothing
publishDataDog destination manager spans =
liftIO . fmap (Just . fmap decode) $ httpLbs zipkinReq manager
where
decode = T.decodeUtf8 . LBS.toStrict
req = parseRequest_ destination
body = RequestBodyLBS . encode $ DataDogSpan <$> spans
zipkinReq = req { method = "POST", requestBody = body, requestHeaders = [("content-type", "application/json")]}
newtype DataDogSpan = DataDogSpan Span
instance ToJSON DataDogSpan where
toJSON (DataDogSpan span) = object $ [
"trace_id" .= (unTrace . traceId $ context span),
"span_id" .= (unSpan . spanId $ context span),
"name" .= unOp (operationName span),
"resource" .= unOp (operationName span),
"start" .= (floor . toNanos $ timestamp span :: Int64),
"type" .= ("web"::T.Text),
"duration" .= (toNanos $ duration span),
"service" .= (serviceName span),
"meta" .= (unTag <$> tags span)
] <>
parentId (relations span)
where
toNanos = (*) 1000000000
unOp (OpName n) = n
unSpan (SpanId sid) = sid
unTrace (TraceId tid) = tid
parentId :: [SpanRelation] -> [(T.Text, Value)]
parentId (ChildOf ctx:_) = ["parent_id" .= (unSpan $ spanId ctx)]
parentId (FollowsFrom ctx:_) = ["parent_id" .= (unSpan $ spanId ctx)]
parentId _ = []
padLeft 0 txt = txt
padLeft n txt
| T.length txt < n = padLeft n ("0"<>txt)
| otherwise = txt
unTag (TagString a) = toJSON a
unTag (TagBool a) = toJSON a
unTag (TagInt a) = toJSON a
unTag (TagDouble a) = toJSON a