{-# 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.Lazy.Char8 as LBSC8
import qualified Data.ByteString.Lex.Integral as BS
import Network.HTTP.Client
import Network.HTTP.Types.Header (Header)
import Data.Aeson.Types (ToJSON(toJSON))
import qualified Data.Map as Map


-- | Publish 'Span' in the <https://docs.datadoghq.com/api/?lang=bash#send-traces DataDog format> . No call is made
-- on an empty span list
publishDataDog :: MonadIO m =>
    String -- ^ The address of the backend server
    -> Manager
    -> [Header]
    -> [Span] -- ^ The traced spans to send to a DataDog backend
    -> m (Maybe (Response T.Text))
publishDataDog :: String
-> Manager -> [Header] -> [Span] -> m (Maybe (Response Text))
publishDataDog String
_ Manager
_ [Header]
_ [] = Maybe (Response Text) -> m (Maybe (Response Text))
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Response Text)
forall a. Maybe a
Nothing
publishDataDog String
destination Manager
manager [Header]
additionalHeaders [Span]
spans =
    IO (Maybe (Response Text)) -> m (Maybe (Response Text))
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe (Response Text)) -> m (Maybe (Response Text)))
-> (IO (Response ByteString) -> IO (Maybe (Response Text)))
-> IO (Response ByteString)
-> m (Maybe (Response Text))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Response ByteString -> Maybe (Response Text))
-> IO (Response ByteString) -> IO (Maybe (Response Text))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Response Text -> Maybe (Response Text)
forall a. a -> Maybe a
Just (Response Text -> Maybe (Response Text))
-> (Response ByteString -> Response Text)
-> Response ByteString
-> Maybe (Response Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Text) -> Response ByteString -> Response Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decode) (IO (Response ByteString) -> m (Maybe (Response Text)))
-> IO (Response ByteString) -> m (Maybe (Response Text))
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
httpLbs Request
ddReq Manager
manager
    where
        decode :: ByteString -> Text
decode = ByteString -> Text
T.decodeUtf8 (ByteString -> Text)
-> (ByteString -> ByteString) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict
        req :: Request
req = String -> Request
parseRequest_ String
destination
        body :: RequestBody
body = ByteString -> RequestBody
RequestBodyLBS (ByteString -> RequestBody)
-> ([DataDogSpan] -> ByteString) -> [DataDogSpan] -> RequestBody
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [DataDogSpan] -> ByteString
forall a. ToJSON a => a -> ByteString
encode ([DataDogSpan] -> RequestBody) -> [DataDogSpan] -> RequestBody
forall a b. (a -> b) -> a -> b
$ Span -> DataDogSpan
DataDogSpan (Span -> DataDogSpan) -> [Span] -> [DataDogSpan]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Span]
spans
        ddReq :: Request
ddReq = Request
req { method :: ByteString
method = ByteString
"POST",
                      requestBody :: RequestBody
requestBody = RequestBody
body,
                      requestHeaders :: [Header]
requestHeaders = [(HeaderName
"content-type", ByteString
"application/json")] [Header] -> [Header] -> [Header]
forall a. Semigroup a => a -> a -> a
<> [Header]
additionalHeaders
                    }

newtype DataDogSpan = DataDogSpan Span
instance ToJSON DataDogSpan where
    toJSON :: DataDogSpan -> Value
toJSON (DataDogSpan Span
span) = [Pair] -> Value
object ([Pair] -> Value) -> [Pair] -> Value
forall a b. (a -> b) -> a -> b
$ [
        Key
"trace_id"  Key -> Int64 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (TraceId -> Int64
unTrace (TraceId -> Int64)
-> (SpanContext -> TraceId) -> SpanContext -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanContext -> TraceId
traceId (SpanContext -> Int64) -> SpanContext -> Int64
forall a b. (a -> b) -> a -> b
$ Span -> SpanContext
context Span
span),
        Key
"span_id" Key -> Int64 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (SpanId -> Int64
unSpan (SpanId -> Int64)
-> (SpanContext -> SpanId) -> SpanContext -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SpanContext -> SpanId
spanId (SpanContext -> Int64) -> SpanContext -> Int64
forall a b. (a -> b) -> a -> b
$ Span -> SpanContext
context Span
span),
        Key
"name" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.=  OpName -> Text
unOp (Span -> OpName
operationName Span
span),
        Key
"resource" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= OpName -> Text
unOp (Span -> OpName
operationName Span
span),
        Key
"start" Key -> Int64 -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (POSIXTime -> Int64
forall a b. (RealFrac a, Integral b) => a -> b
floor (POSIXTime -> Int64)
-> (POSIXTime -> POSIXTime) -> POSIXTime -> Int64
forall b c a. (b -> c) -> (a -> b) -> a -> c
. POSIXTime -> POSIXTime
toNanos (POSIXTime -> Int64) -> POSIXTime -> Int64
forall a b. (a -> b) -> a -> b
$ Span -> POSIXTime
timestamp Span
span :: Int64),
        Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"web"::T.Text),
        Key
"duration" Key -> POSIXTime -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (POSIXTime -> POSIXTime
toNanos (POSIXTime -> POSIXTime) -> POSIXTime -> POSIXTime
forall a b. (a -> b) -> a -> b
$ Span -> POSIXTime
duration Span
span),
        Key
"service" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Span -> Text
serviceName Span
span),
        Key
"meta" Key -> Map Text Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (SpanTag -> Value
unTag (SpanTag -> Value) -> Map Text SpanTag -> Map Text Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Span -> Map Text SpanTag
tags Span
span)
        ] [Pair] -> [Pair] -> [Pair]
forall a. Semigroup a => a -> a -> a
<>
        [SpanRelation] -> [Pair]
forall a. KeyValue a => [SpanRelation] -> [a]
parentId (Span -> [SpanRelation]
relations Span
span)
        where
            toNanos :: POSIXTime -> POSIXTime
toNanos = POSIXTime -> POSIXTime -> POSIXTime
forall a. Num a => a -> a -> a
(*) POSIXTime
1000000000
            unOp :: OpName -> Text
unOp (OpName Text
n) = Text
n
            unSpan :: SpanId -> Int64
unSpan (SpanId Int64
sid) = Int64
sid
            unTrace :: TraceId -> Int64
unTrace (TraceId Int64
tid) = Int64
tid
            parentId :: [SpanRelation] -> [a]
parentId (ChildOf SpanContext
ctx:[SpanRelation]
_) = [Key
"parent_id" Key -> Int64 -> a
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (SpanId -> Int64
unSpan (SpanId -> Int64) -> SpanId -> Int64
forall a b. (a -> b) -> a -> b
$ SpanContext -> SpanId
spanId SpanContext
ctx)]
            parentId (FollowsFrom SpanContext
ctx:[SpanRelation]
_) = [Key
"parent_id" Key -> Int64 -> a
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (SpanId -> Int64
unSpan (SpanId -> Int64) -> SpanId -> Int64
forall a b. (a -> b) -> a -> b
$ SpanContext -> SpanId
spanId SpanContext
ctx)]
            parentId [SpanRelation]
_ = []
            padLeft :: Int -> Text -> Text
padLeft Int
0 Text
txt = Text
txt
            padLeft Int
n Text
txt
                | Text -> Int
T.length Text
txt Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n = Int -> Text -> Text
padLeft Int
n (Text
"0"Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>Text
txt)
                | Bool
otherwise = Text
txt
            unTag :: SpanTag -> Value
unTag (TagString Text
a) = Text -> Value
forall a. ToJSON a => a -> Value
toJSON Text
a
            unTag (TagBool Bool
a) = Bool -> Value
forall a. ToJSON a => a -> Value
toJSON Bool
a
            unTag (TagInt Int64
a) = Int64 -> Value
forall a. ToJSON a => a -> Value
toJSON Int64
a
            unTag (TagDouble Double
a) = Double -> Value
forall a. ToJSON a => a -> Value
toJSON Double
a