{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
module Datadog.Client (
Agent(..)
, AgentT
, DDText
, HasAlpha
, MetaKey(..)
, MetaValue(..)
, ServiceName(..)
, Span(..)
, SpanId(..)
, SpanName(..)
, Tag
, Trace(..)
, TraceId(..)
, newServantAgent
) where
import Control.Monad (unless, void)
import Control.Monad.Except (ExceptT, MonadError, MonadIO,
liftEither, liftIO)
import Data.Char (isAlpha, isAsciiLower, isDigit)
import Data.FFunctor (FFunctor, ffmap)
import Data.Int (Int64)
import qualified Data.List.NonEmpty as NEL
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Arbitrary ()
import Data.Text.Prettyprint.Doc (viaShow)
import Data.Time (NominalDiffTime, UTCTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import Data.Typeable (Proxy (..), Typeable, typeOf)
import Data.Word (Word64)
import Refined hiding (NonEmpty)
import qualified Refined
import Servant.Client (ClientEnv, ClientM, ServantError,
client, runClientM)
import qualified Datadog.Agent as API
newtype Agent m = Agent
{ putTraces :: NEL.NonEmpty Trace -> m ()
}
type AgentT m = Agent (ExceptT ServantError m)
instance FFunctor Agent where
ffmap nt (Agent p1) = Agent (nt . p1)
newServantAgent :: (MonadIO m, MonadError ServantError m) => ClientEnv -> Agent m
newServantAgent env = ffmap (liftClientM env) (Agent traces)
type DDText = Refined.NonEmpty && (SizeLessThan 101)
newtype SpanId = SpanId (Refined NonZero Word64) deriving (Eq, Show)
newtype TraceId = TraceId (Refined NonZero Word64) deriving (Eq, Show)
newtype ServiceName = ServiceName (Refined (DDText && Tag) Text) deriving (Eq, Show)
data Trace = Trace
{ tService :: ServiceName
, tId :: TraceId
, tSpans :: (Refined (Refined.NonEmpty) (Map SpanId Span))
} deriving (Eq, Show)
newtype SpanName = SpanName (Refined (DDText && HasAlpha) Text) deriving (Eq, Show)
newtype MetaKey = MetaKey (Refined (DDText && Tag) Text) deriving (Eq, Ord, Show)
newtype MetaValue = MetaValue (Refined DDText Text) deriving (Eq, Show)
data Span = Span
{ sName :: SpanName
, sParentId :: Maybe SpanId
, sStart :: UTCTime
, sDuration :: NominalDiffTime
, sMeta :: Maybe (Map MetaKey MetaValue)
} deriving (Eq, Show)
traces :: NEL.NonEmpty Trace -> ClientM ()
traces (NEL.toList -> ts) = void . raw $ toAPI <$> ts
where
raw = client (Proxy @ API.Traces3)
toAPI :: Trace -> API.Trace
toAPI (trace@(Trace _ _ (M.toList . unrefine -> spans))) =
API.Trace $ (mkSpan trace) <$> spans
mkSpan :: Trace -> (SpanId, Span) -> API.Span
mkSpan (Trace (ServiceName (unrefine -> serviceName))
(TraceId (unrefine -> traceId))
_)
((SpanId (unrefine -> spanId)),
(Span (SpanName (unrefine -> spanName))
parent
start
duration
meta)) =
API.Span serviceName
spanName
"time"
traceId
spanId
((\(SpanId (unrefine -> p)) -> p) <$> parent)
(timeToNanos start)
(nominalToNanos duration)
Nothing
((\m -> (M.map unValue) . (M.mapKeys unKey) $ m) <$> meta)
Nothing
Nothing
unKey (MetaKey (unrefine -> k)) = k
unValue (MetaValue (unrefine -> v)) = v
timeToNanos :: UTCTime -> Int64
timeToNanos time = nominalToNanos $ utcTimeToPOSIXSeconds time
nominalToNanos :: NominalDiffTime -> Int64
nominalToNanos time =
let (nanos, _) = properFraction (1000000000 * time)
in nanos
data Tag
instance Predicate Tag Text where
validate p txt = validate' p (T.all isValidChar) txt
where
isValidChar c = case c of
':' -> True
'.' -> True
'/' -> True
'-' -> True
c' -> isAsciiLower c' || isDigit c'
data HasAlpha
instance Predicate HasAlpha Text where
validate p txt = validate' p (T.any isAlpha) txt
validate' :: (Typeable t, Monad m, Show a) => t -> (a -> Bool) -> a -> RefineT m ()
validate' t p a =
unless (p a) $
throwRefineOtherException (typeOf t) ("failed predicate: " <> (viaShow a))
liftClientM :: (MonadIO m, MonadError ServantError m)
=> ClientEnv
-> ClientM a
-> m a
liftClientM env ca = liftEither =<< (liftIO $ runClientM ca env)