Permalink
Find file
Fetching contributors…
Cannot retrieve contributors at this time
404 lines (342 sloc) 12.2 KB
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeOperators #-}
module Network.Monitoring.Riemann.Types (
HasState (..),
AMetric (..),
HasQuery (..),
State, Event, Query, Msg,
ev,
once, attributes,
MsgState(..), msgState, states, events,
Hostname, Port
) where
import Control.Arrow
import Control.Lens
import Control.Monad
import Data.Default
import Data.Int
import Data.List
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.ProtocolBuffers
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics hiding (from, to)
import qualified GHC.Generics as G
-- $class
-- | 'HasState' types (e.g. 'Event' and 'State') have information
-- representing the state of a 'service' on a 'host' at a given
-- 'time'. These shared types give rise to restrictedly polymorphic
-- lenses.
class HasState a where
time :: Lens' a (Maybe Int64)
-- ^ The time of the event, in unix epoch seconds
state :: Lens' a (Maybe Text)
-- ^ Any string less than 255 bytes, e.g. "ok", "warning",
-- "critical"
service :: Lens' a (Maybe Text)
-- ^ e.g. "API port 8000 reqs/sec"
host :: Lens' a (Maybe Text)
-- ^ A hostname, e.g. "api1", "foo.com"
description :: Lens' a (Maybe Text)
-- ^ Freeform text
tags :: Lens' a [Text]
-- ^ Freeform list of strings, e.g. ["rate", "fooproduct",
-- "transient"]
ttl :: Lens' a (Maybe Float)
-- ^ A floating-point time, in seconds, that this event is
-- considered valid for. Expired states may be removed from the
-- index.
-- | 'HasQuery' types contain a Riemann query inside them
-- somewhere. This class provides 'query' as a polymorphic lens toward
-- that query.
class HasQuery a where
query :: Lens' a (Maybe Text)
-- $generics
class GMonoid f where
gmempty :: f a
gmappend :: f a -> f a -> f a
instance GMonoid U1 where
gmempty = U1
gmappend U1 U1 = U1
instance (GMonoid a, GMonoid b) => GMonoid (a :*: b) where
gmempty = gmempty :*: gmempty
gmappend (a :*: x) (b :*: y) = gmappend a b :*: gmappend x y
instance Monoid a => GMonoid (K1 i a) where
gmempty = K1 mempty
gmappend (K1 x) (K1 y) = K1 $ mappend x y
instance GMonoid a => GMonoid (M1 i c a) where
gmempty = M1 gmempty
gmappend (M1 x) (M1 y) = M1 $ gmappend x y
defMappend :: (Generic a, GMonoid (Rep a)) => a -> a -> a
defMappend x y = G.to $ G.from x `gmappend` G.from y
-- $types
-- | 'State' is an object within Riemann's index, a result from a
-- 'Query'.
data State = State {
_stateTime :: Optional 1 (Value Int64),
_stateState :: Optional 2 (Value Text),
_stateService :: Optional 3 (Value Text),
_stateHost :: Optional 4 (Value Text),
_stateDescription :: Optional 5 (Value Text),
_stateOnce :: Optional 6 (Value Bool),
_stateTags :: Repeated 7 (Value Text),
_stateTtl :: Optional 8 (Value Float)
} deriving (Eq, Generic)
-- | 'Event' is a description of an application-level event, emitted
-- to Riemann for indexing.
data Event = Event {
_eventTime :: Optional 1 (Value Int64),
_eventState :: Optional 2 (Value Text),
_eventService :: Optional 3 (Value Text),
_eventHost :: Optional 4 (Value Text),
_eventDescription :: Optional 5 (Value Text),
_eventTags :: Repeated 7 (Value Text),
_eventTtl :: Optional 8 (Value Float),
_eventAttributes :: Repeated 9 (Message Attribute),
_eventMetricSInt :: Optional 13 (Value (Signed Int64)),
_eventMetricD :: Optional 14 (Value Double),
_eventMetricF :: Optional 15 (Value Float)
} deriving (Eq, Generic)
-- | 'Query' is a question to be made of the Riemann index.
data Query = Query { _queryQuery :: Optional 1 (Value Text) }
deriving (Eq, Generic)
-- | 'Msg' is a wrapper for sending/receiving multiple 'State's,
-- 'Event's, or a single 'Query'.
data Msg = Msg {
_msgOk :: Optional 2 (Value Bool),
_msgError :: Optional 3 (Value Text),
_msgStates :: Repeated 4 (Message State),
_msgQuery :: Optional 5 (Message Query),
_msgEvents :: Repeated 6 (Message Event)
} deriving (Eq, Generic)
-- | 'Attribute' is a key/value pair.
data Attribute = Attribute {
_attributeKey :: Required 1 (Value Text),
_attributeValue :: Optional 2 (Value Text)
} deriving (Eq, Show, Generic)
-- $state
instance Encode State
instance Decode State
$(makeLenses ''State)
instance HasState State where
time = stateTime . field
state = stateState . field
service = stateService . field
host = stateHost . field
description = stateDescription . field
tags = stateTags . field
ttl = stateTtl . field
once :: Lens' State (Maybe Bool)
once = stateOnce . field
instance Show State where
show s = "State { " ++ intercalate ", " innards ++ " }"
where innards = catMaybes [
showM "time" time,
showM "state" state,
showM "service" service,
showM "host" host,
showM "description" description,
showL "tags" tags,
showM "ttl" ttl,
showM "once" once
]
showM name l = (\x -> name ++ " = " ++ x) . show <$> s ^. l
showL name l = let lst = s ^. l
in if null lst then Nothing else Just $ name ++ " = " ++ show lst
instance Default State where
def = State {
_stateTime = putField Nothing,
_stateState = putField Nothing,
_stateService = putField Nothing,
_stateHost = putField Nothing,
_stateDescription = putField Nothing,
_stateTags = putField [],
_stateTtl = putField Nothing,
_stateOnce = putField Nothing
}
instance Monoid State where
mempty = def
mappend = defMappend
-- $attribute
instance Encode Attribute
instance Decode Attribute
$(makeLenses ''Attribute)
akey :: Lens' Attribute Text
akey = attributeKey . field
aval :: Lens' Attribute (Maybe Text)
aval = attributeValue . field
apair :: Iso' Attribute (Text, Maybe Text)
apair = iso (view akey &&& view aval)
(\(k, v) -> Attribute (putField k) (putField v))
-- $event
instance Encode Event
instance Decode Event
$(makeLenses ''Event)
instance HasState Event where
time = eventTime . field
state = eventState . field
service = eventService . field
host = eventHost . field
description = eventDescription . field
tags = eventTags . field
ttl = eventTtl . field
-- | The class of types which can be interpreted as metrics for an
-- 'Event'.
class AMetric a where
metric :: Lens' Event (Maybe a)
instance AMetric Int where
metric = eventMetricSInt . field . mapping (iso fromIntegral fromIntegral)
instance AMetric Integer where
metric = eventMetricSInt . field . mapping (iso fromIntegral fromIntegral)
instance AMetric (Signed Int64) where
metric = eventMetricSInt . field
instance AMetric Double where metric = eventMetricD . field
instance AMetric Float where metric = eventMetricF . field
attributes :: Lens' Event (Map Text Text)
attributes = eventAttributes
. field
. mapping apair
-- This isn't really an iso, it throws away `(_, Nothing)`s
-- but I'm okay with that since these just represent
-- "empty" attributes.
. iso (mapMaybe sequen) (map $ over _2 Just)
. iso M.fromList M.toList
where sequen :: Applicative f => (a, f b) -> f (a, b)
sequen (a, fb) = (a,) <$> fb
instance Show Event where
show s = "Event { " ++ intercalate ", " innards ++ " }"
where innards = catMaybes [
showM "time" time,
showM "state" state,
showM "service" service,
showM "host" host,
showM "description" description,
showL "tags" tags,
showM "ttl" ttl,
showMap "attributes" attributes,
showM "metric_sint" (metric :: Lens' Event (Maybe Int)),
showM "metric_f" (metric :: Lens' Event (Maybe Float)),
showM "metric_d" (metric :: Lens' Event (Maybe Double))
]
showM name l = (\x -> name ++ " = " ++ x) . show <$> s ^. l
showMap name l = let mp = s ^. l
in if M.null mp then Nothing
else Just . (\x -> name ++ " = " ++ show x) $ mp
showL name l = let lst = s ^. l
in if null lst then Nothing
else Just $ name ++ " = " ++ show lst
instance Default Event where
def = Event {
_eventTime = putField Nothing,
_eventState = putField Nothing,
_eventService = putField Nothing,
_eventHost = putField Nothing,
_eventDescription = putField Nothing,
_eventTags = putField [],
_eventTtl = putField Nothing,
_eventAttributes = putField [],
_eventMetricSInt = putField Nothing,
_eventMetricD = putField Nothing,
_eventMetricF = putField Nothing
}
instance Monoid Event where
mempty = def
mappend = defMappend
-- Nicer constructors
-- | Create a simple 'Event' with state "ok".
--
-- >>> view state $ ev "service" (0 :: (Signed Int64))
-- Just "ok"
--
-- >>> view service $ ev "service" (0 :: (Signed Int64))
-- Just "service"
--
-- >>> view metric $ ev "service" (0 :: (Signed Int64)) :: Maybe (Signed Int64)
-- Just (Signed 0)
--
-- >>> view tags $ ev "service" (0 :: (Signed Int64))
-- []
ev :: AMetric a => String -> a -> Event
ev serv met =
def
& state ?~ "ok"
& service ?~ T.pack serv
& metric ?~ met
-- $query
instance Encode Query
instance Decode Query
$(makeLenses ''Query)
instance HasQuery Query where
query = queryQuery . field
instance Default Query where
def = Query { _queryQuery = putField Nothing }
instance Monoid Query where
mempty = def
mappend = defMappend
instance Show Query where
show s = "Query { " ++ intercalate ", " innards ++ " }"
where innards = catMaybes [
showM "query" query
]
showM name l = (\x -> name ++ " = " ++ x) . show <$> s ^. l
-- $msg
data MsgState = Ok | Error Text | Unknown
instance Encode Msg
instance Decode Msg
$(makeLenses ''Msg)
msgState :: Lens' Msg MsgState
msgState = iso dup fst
. alongside (msgOk . field) (msgError . field)
. iso toMsgState fromMsgState
where dup x = (x, x)
toMsgState (_, Just err) = Error err
toMsgState (Just True , Nothing ) = Ok
toMsgState (Just False, Nothing ) = Error "<no msg>"
toMsgState (Nothing , Nothing ) = Unknown
fromMsgState Ok = (Just True, Nothing)
fromMsgState (Error err) = (Just False, Just err)
fromMsgState Unknown = (Nothing, Nothing)
states :: Lens' Msg [State]
states = msgStates . field
events :: Lens' Msg [Event]
events = msgEvents . field
instance Show Msg where
show s = "Msg { " ++ intercalate ", " innards ++ " }"
where innards = catMaybes [
showMsgState,
showL "states" states,
showL "events" events,
showM "query" query
]
showM name l = (\x -> name ++ " = " ++ x) . show <$> s ^. l
showL name l = let lst = s ^. l
in if null lst then Nothing else Just $ name ++ " = " ++ show lst
showMsgState = ("msgState = " ++) <$> case s ^. msgState of
Ok -> Just "Ok"
Error err -> Just $ "Error " ++ show err
Unknown -> Nothing
instance HasQuery Msg where
query = msgQuery . field
. mapping (iso (getField . _queryQuery) (Query . putField))
. iso join return
instance Default Msg where
def = Msg {
_msgOk = putField Nothing,
_msgError = putField Nothing,
_msgStates = putField [],
_msgQuery = putField Nothing,
_msgEvents = putField []
}
instance Monoid Msg where
mempty = def
mappend = defMappend
type Hostname = String
type Port = Int