module Network.Datadog.StatsD (
DogStatsSettings(..),
defaultSettings,
withDogStatsD,
send,
metric,
Metric,
MetricName(..),
MetricType(..),
event,
Event,
serviceCheck,
ServiceCheck,
ServiceCheckStatus(..),
ToStatsD,
Tag,
tag,
ToMetricValue,
value,
Priority(..),
AlertType(..),
HasName(..),
HasSampleRate(..),
HasType'(..),
HasTags(..),
HasTitle(..),
HasText(..),
HasDateHappened(..),
HasHostname(..),
HasAggregationKey(..),
HasPriority(..),
HasSourceTypeName(..),
HasAlertType(..),
HasHost(..),
HasPort(..),
HasStatus(..),
HasMessage(..),
StatsClient(Dummy)
) where
import Control.Exception (bracket)
import Control.Lens
import Control.Monad.Base
import Control.Monad.Trans.Control
import Control.Reaper
import Data.BufferBuilder.Utf8
import Data.List (intersperse)
import Data.Monoid
import Data.Maybe (isNothing)
import Data.Int
import Data.Word
import qualified Data.ByteString as B
import qualified Data.Foldable as F
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time.Clock
import Data.Time.Clock.POSIX
import Data.Time.Format
import Data.Text.Encoding (encodeUtf8)
import Data.ByteString.Short hiding (empty)
import Network.Socket hiding (send, sendTo, recv, recvFrom)
import System.IO (hClose, hSetBuffering, BufferMode(LineBuffering), IOMode(WriteMode), Handle)
epochTime :: UTCTime -> Int
epochTime = round . utcTimeToPOSIXSeconds
newtype MetricName = MetricName { fromMetricName :: Text }
cleanMetricText :: Text -> Text
cleanMetricText = T.map $ \c -> case c of
':' -> '_'
'|' -> '_'
'@' -> '_'
_ -> c
escapeEventContents :: T.Text -> T.Text
escapeEventContents = T.replace "\n" "\\n"
newtype Tag = Tag { fromTag :: Utf8Builder () }
tag :: Text -> Text -> Tag
tag k v = Tag (build k >> appendChar7 ':' >> build v)
where
build = appendText . cleanMetricText
data MetricType = Gauge
| Counter
| Timer
| Histogram
| Set
class ToMetricValue a where
encodeValue :: a -> Utf8Builder ()
instance ToMetricValue Int where
encodeValue = appendDecimalSignedInt
instance ToMetricValue Double where
encodeValue = appendDecimalDouble
metric :: (ToMetricValue a) => MetricName -> MetricType -> a -> Metric
metric n t v = Metric n 1 t (encodeValue v) []
data Metric = Metric
{ metricName :: !MetricName
, metricSampleRate :: !Double
, metricType' :: !MetricType
, mValue :: !(Utf8Builder ())
, metricTags :: ![Tag]
}
makeFields ''Metric
value :: ToMetricValue a => Setter Metric Metric (Utf8Builder ()) a
value = sets $ \f m -> m { mValue = encodeValue $ f $ mValue m }
renderMetric :: Metric -> Utf8Builder ()
renderMetric (Metric n sr t v ts) = do
appendText $ cleanMetricText $ fromMetricName n
appendChar7 ':'
v
appendChar7 '|'
unit
formatRate
formatTags
where
unit = case t of
Gauge -> appendChar7 'g'
Counter -> appendChar7 'c'
Timer -> appendBS7 "ms"
Histogram -> appendChar7 'h'
Set -> appendChar7 's'
formatTags = case ts of
[] -> return ()
xs -> appendBS7 "|#" >> F.sequence_ (intersperse (appendChar7 ',') $ map fromTag xs)
formatRate = if sr == 1 then return () else appendBS7 "|@" >> appendDecimalDouble sr
data Priority = Low | Normal
data AlertType = Error | Warning | Info | Success
event :: Text -> Text -> Event
event t d = Event t d Nothing Nothing Nothing Nothing Nothing Nothing []
data Event = Event
{ eventTitle :: !Text
, eventText :: !Text
, eventDateHappened :: !(Maybe UTCTime)
, eventHostname :: !(Maybe Text)
, eventAggregationKey :: !(Maybe Text)
, eventPriority :: !(Maybe Priority)
, eventSourceTypeName :: !(Maybe Text)
, eventAlertType :: !(Maybe AlertType)
, eventTags :: ![Tag]
}
makeFields ''Event
renderEvent :: Event -> Utf8Builder ()
renderEvent e = do
appendBS7 "_e{"
encodeValue $ B.length escapedTitle
appendChar7 ','
encodeValue $ B.length escapedText
appendBS7 "}:"
unsafeAppendBS escapedTitle
appendChar7 '|'
unsafeAppendBS escapedText
happened
formatHostname
aggregation
formatPriority
sourceType
alert
formatTags
where
escapedTitle = encodeUtf8 $ escapeEventContents $ eventTitle e
escapedText = encodeUtf8 $ escapeEventContents $ eventText e
makeField c v = F.forM_ v $ \jv ->
appendChar7 '|' >> appendChar7 c >> appendChar7 ':' >> jv
cleanTextValue f = (appendText . cleanMetricText) <$> f e
happened = F.forM_ (eventDateHappened e) $ \h -> do
appendBS7 "|d:"
appendDecimalSignedInt $ epochTime h
formatHostname = makeField 'h' $ cleanTextValue eventHostname
aggregation = makeField 'k' $ cleanTextValue eventAggregationKey
formatPriority = F.forM_ (eventPriority e) $ \p -> do
appendBS7 "|p:"
appendBS7 $ case p of
Low -> "low"
Normal -> "normal"
sourceType = makeField 's' $ cleanTextValue eventSourceTypeName
alert = F.forM_ (eventAlertType e) $ \a -> do
appendBS7 "|t:"
appendBS7 $ case a of
Error -> "error"
Warning -> "warning"
Info -> "info"
Success -> "success"
formatTags = case eventTags e of
[] -> return ()
ts -> do
appendBS7 "|#"
sequence_ $ intersperse (appendChar7 ',') $ map fromTag ts
data ServiceCheckStatus = ServiceOk | ServiceWarning | ServiceCritical | ServiceUnknown
deriving (Read, Show, Eq, Ord, Enum)
data ServiceCheck = ServiceCheck
{ serviceCheckName :: !Text
, serviceCheckStatus :: !ServiceCheckStatus
, serviceCheckMessage :: !(Maybe Text)
, serviceCheckDateHappened :: !(Maybe UTCTime)
, serviceCheckHostname :: !(Maybe Text)
, serviceCheckTags :: ![Tag]
}
makeFields ''ServiceCheck
serviceCheck :: Text
-> ServiceCheckStatus
-> ServiceCheck
serviceCheck n s = ServiceCheck n s Nothing Nothing Nothing []
class ToStatsD a where
toStatsD :: a -> Utf8Builder ()
instance ToStatsD Metric where
toStatsD = renderMetric
instance ToStatsD Event where
toStatsD = renderEvent
instance ToStatsD ServiceCheck where
toStatsD check = do
appendBS7 "_sc|"
appendText $ cleanMetricText $ check ^. name
appendChar7 '|'
appendDecimalSignedInt $ fromEnum $ check ^. status
F.forM_ (check ^. message) $ \msg ->
appendBS7 "|m:" >> appendText (cleanMetricText msg)
F.forM_ (check ^. dateHappened) $ \ts -> do
appendBS7 "|d:"
appendDecimalSignedInt $ epochTime ts
F.forM_ (check ^. hostname) $ \hn ->
appendBS7 "|h:" >> appendText (cleanMetricText hn)
case check ^. tags of
[] -> return ()
ts -> do
appendBS7 "|#"
sequence_ $ intersperse (appendChar7 ',') $ map fromTag ts
data DogStatsSettings = DogStatsSettings
{ dogStatsSettingsHost :: HostName
, dogStatsSettingsPort :: Int
}
makeFields ''DogStatsSettings
defaultSettings :: DogStatsSettings
defaultSettings = DogStatsSettings "127.0.0.1" 8125
withDogStatsD :: MonadBaseControl IO m => DogStatsSettings -> (StatsClient -> m a) -> m a
withDogStatsD s f = do
let setup = do
addrInfos <- getAddrInfo (Just $ defaultHints { addrFlags = [AI_PASSIVE] })
(Just $ s ^. host)
(Just $ show $ s ^. port)
case addrInfos of
[] -> error "No address for hostname"
(serverAddr:_) -> do
sock <- socket (addrFamily serverAddr) Datagram defaultProtocol
connect sock (addrAddress serverAddr)
h <- socketToHandle sock WriteMode
hSetBuffering h LineBuffering
let builderAction work = do
F.mapM_ (B.hPut h . runUtf8Builder) work
return $ const Nothing
reaperSettings = defaultReaperSettings { reaperAction = builderAction
, reaperDelay = 1000000
, reaperCons = \item work -> Just $ maybe item (>> item) work
, reaperNull = isNothing
, reaperEmpty = Nothing
}
r <- mkReaper reaperSettings
return $ StatsClient h r
liftBaseOp (bracket setup (\c -> finalizeStatsClient c >> hClose (statsClientHandle c))) f
data StatsClient = StatsClient
{ statsClientHandle :: !Handle
, statsClientReaper :: Reaper (Maybe (Utf8Builder ())) (Utf8Builder ())
}
| Dummy
send :: (MonadBase IO m, ToStatsD v) => StatsClient -> v -> m ()
send (StatsClient _ r) v = liftBase $ reaperAdd r (toStatsD v >> appendChar7 '\n')
send Dummy _ = return ()
finalizeStatsClient :: StatsClient -> IO ()
finalizeStatsClient (StatsClient h r) = reaperStop r >>= F.mapM_ (B.hPut h . runUtf8Builder)
finalizeStatsClient Dummy = return ()