riemann (empty) → 0.1.0.0
raw patch · 8 files changed
+696/−0 lines, 8 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, cereal, containers, data-default, directory, doctest, either, errors, filepath, lens, network, protobuf, riemann, test-framework, test-framework-hunit, test-framework-quickcheck2, text, time, transformers
Files
- LICENSE +21/−0
- Setup.hs +2/−0
- riemann.cabal +79/−0
- src/Network/Monitoring/Riemann.hs +150/−0
- src/Network/Monitoring/Riemann/Types.hs +404/−0
- test/Doctest.hs +20/−0
- test/Property.hs +10/−0
- test/Unit.hs +10/−0
+ LICENSE view
@@ -0,0 +1,21 @@+Copyright (c) 2013 Joseph Abrahamson, Reify Health LLC+ 2015 Trevis Elser++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ riemann.cabal view
@@ -0,0 +1,79 @@+name: riemann+version: 0.1.0.0+synopsis: A Riemann client for Haskell+description: Very simple event sending to a Riemann server.+homepage: https://github.com/telser/riemann-hs+license: MIT+license-file: LICENSE+author: Joseph Abrahamson, Trevis Elser+maintainer: trevis@clickscape.com+copyright: 2013 Joseph Abrahamson, 2015 Trevis Elser+category: Network+build-type: Simple+cabal-version: >=1.10+++source-repository head+ type: git+ location: https://github.com/telser/riemann-hs/++library+ hs-source-dirs: src+ exposed-modules:+ Network.Monitoring.Riemann+ Network.Monitoring.Riemann.Types+ other-modules:+ build-depends:+ base >= 4.8.0 && < 5.0,+ network >= 2.4.0.0,+ text >= 0.11.2.3,+ containers >= 0.4.2.0,+ protobuf >= 0.2,+ either,+ lens,+ time,+ errors,+ data-default,+ transformers,+ cereal+ default-language: Haskell2010++test-suite doctest+ type: exitcode-stdio-1.0+ ghc-options: -threaded+ hs-source-dirs: test+ main-is: Doctest.hs+ build-depends:+ base,+ directory,+ either,+ doctest,+ filepath+ default-language: Haskell2010++test-suite property+ type: exitcode-stdio-1.0+ ghc-options: -threaded+ hs-source-dirs: test+ main-is: Property.hs+ build-depends:+ base,+ either,+ QuickCheck >= 2.5.1.0,+ test-framework,+ test-framework-quickcheck2,+ riemann+ default-language: Haskell2010++test-suite unit+ type: exitcode-stdio-1.0+ ghc-options: -threaded+ hs-source-dirs: test+ main-is: Unit.hs+ build-depends:+ base,+ HUnit,+ test-framework,+ test-framework-hunit,+ riemann+ default-language: Haskell2010
+ src/Network/Monitoring/Riemann.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Monitoring.Riemann (+ module Network.Monitoring.Riemann.Types,+ module Data.Int,+ Client, makeClient,+ sendEvent, sendEvent'+ {-, sendEvent'-}+ ) where++import Network.Monitoring.Riemann.Types++import Data.Int+import Data.Default+import Data.Time.Clock.POSIX+import Data.ProtocolBuffers+import Data.Serialize.Put++import Control.Applicative+import qualified Control.Monad as CM+import qualified Control.Monad.IO.Class as CMIC+import qualified Control.Error as Error+import Control.Monad.Trans.Either+import Control.Lens+import qualified Control.Exception as Except++import Network.Socket hiding (send, sendTo, recv, recvFrom)+import Network.Socket.ByteString++{-%++In brief, a Riemann client has two operating conditions: (a) as a+decoration of *real* code or (b) as a component of self-reflecting+system component. In 95% of cases the client will be used for (a), so+that's the easiest way to use the client.++An (a)-style Riemann client should allow for liberal *decoration* of+code with monitoring keys. These decorations should trivially reduce+to nops if there is no connection to a Riemann server and they should+silently ignore all server errors. The (a)-style Riemann decorations+should never slow real code and thus must either be very, very fast or+asynchronous.++As a tradeoff, we can never be sure that *all* (a)-style decorations+fire and are observed by a Riemann server. Neither the client or the+server can take note of or be affected by packet failure.++A (b)-style Riemann client should allow for smart load balancing. It+should be able to guarantee connectivity to the Riemann server and+failover along with the server should Riemann ever die or become+partitioned. (To this end, there's some need for pools of Riemann+servers, but this may be non-critical.) Riemann (b)-style interactions+also include querying the Riemann server --- so we'll need a query+combinator language.++-}++{-%++API Design+----------++Basic events ought to be generated very easily. Sane defaults ought to+be built-in---we shouldn't be specifying the host in every decorated+call, we shouldn't have any concept of the current time when we+decorate an action. To this end the Monoid instances for `Event`s,+`State`s, `Msg`s, and `Query`s are designed to either grow or be+overridden to the right (using lots of `Last` newtypes over maybes and+inner `(<>)` applications).++The Client also should be defaulted at as high a level as possible.++e.g.++```+withClient :: Client -> IO a -> IO a+withDefaultEvent :: Event -> IO a -> IO a+withEventTiming :: IO a -> IO a+withHostname :: Text -> IO a -> IO a+```++-}++{-%++Implementation+--------------++There are roughly two independent factors for library design. First,+we can use UDP or TCP---Riemann size limits UDP datagrams, but the+limit is high (16 mb by default), so there's theoretically a corner+case there but it's a fair bet that we won't hit it---and secondly we+can deliver them in the main thread or asynchronously via a concurrent+process.++There's a tradeoff here between throughput and assurance. Asynch+UDP+has the highest throughput, while Synch+TCP has the greatest+assurance. We'll optimize for (a)-type decoration via Asynch+UDP.++Can we do the same and optimize (b)-type calls as Synch+TCP? Probably.++-}++{-%++Syntax+------++riemann $ ev "<service>" <metric> & tags <>~ "foo"++-}++data Client = UDP (Maybe (Socket, AddrInfo))+ deriving (Show, Eq)++type Hostname = String+type Port = Int++-- | Attempts to bind a UDP client at the passed 'Hostname' and+-- 'Port'. Failures are silently ignored---failure in monitoring+-- should not cause an application failure...+makeClient :: Hostname -> Port -> IO Client+makeClient hn po = UDP . Error.rightMay <$> sock+ where sock :: IO (Either Except.SomeException (Socket, AddrInfo))+ sock =+ Except.try $ do addrs <- getAddrInfo+ (Just $ defaultHints {+ addrFlags = [AI_NUMERICSERV] })+ (Just hn)+ (Just $ show po)+ case addrs of+ [] -> fail "No accessible addresses"+ (addy:_) -> do+ s <- socket (addrFamily addy)+ Datagram+ (addrProtocol addy)+ return (s, addy)++-- | Attempts to forward an event to a client. Fails silently.+sendEvent :: CMIC.MonadIO m => Client -> Event -> m ()+sendEvent c = CMIC.liftIO . CM.void . Error.runExceptT . sendEvent' c++-- | Attempts to forward an event to a client. If it fails, it'll+-- return an 'IOException' in the 'Either'.+sendEvent' :: Client -> Event -> Error.ExceptT Except.IOException IO ()+sendEvent' (UDP Nothing) _ = return ()+sendEvent' (UDP (Just (s, addy))) e = Error.tryIO $ do+ now <- fmap round getPOSIXTime+ let msg = def & events .~ [e & time ?~ now]+ CM.void $ sendTo s (runPut $ encodeMessage msg) (addrAddress addy)
+ src/Network/Monitoring/Riemann/Types.hs view
@@ -0,0 +1,404 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}++module Network.Monitoring.Riemann.Types (+ HasState (..),+ AMetric (..),+ HasQuery (..),+ State, Event, Query, Msg,+ ev,+ once, attributes,+ MsgState, msgState, states, events+ ) where++import Data.ProtocolBuffers++import GHC.Generics hiding (to, from)+import qualified GHC.Generics as G++import Data.Int+import Data.Monoid+import Data.Maybe+import Data.Time.Clock+import Data.Default+import Data.List+import Data.Text (Text)+import qualified Data.Text as T+import Data.Map (Map)+import qualified Data.Map as M++import Control.Lens+import Control.Monad+import Control.Arrow+import Control.Applicative++-- $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 (Signed 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 (Signed 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 (Signed 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".+--+-- >>> get state $ ev "service" (0 :: (Signed Int64))+-- Just "ok"+--+-- >>> get service $ ev "service" (0 :: (Signed Int64))+-- Just "service"+--+-- >>> get metric $ ev "service" (0 :: (Signed Int64)) :: Maybe (Signed Int64)+-- Just 0+--+-- >>> get 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
+ test/Doctest.hs view
@@ -0,0 +1,20 @@+import Control.Applicative+import Control.Monad+import Data.List+import System.Directory+import System.FilePath+import Test.DocTest++main = getSources >>= doctest++getSources :: IO [FilePath]+getSources = filter (isSuffixOf ".hs") <$> go "src"+ where+ go dir = do+ (dirs, files) <- getFilesAndDirectories dir+ (files ++) . concat <$> mapM go dirs++getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath])+getFilesAndDirectories dir = do+ c <- map (dir </>) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir+ (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c
+ test/Property.hs view
@@ -0,0 +1,10 @@+import Test.Framework (defaultMain, testGroup)+import Test.QuickCheck+import Test.Framework.Providers.QuickCheck2 (testProperty)++main :: IO ()+main = defaultMain [+ testGroup "(default)" [+ testProperty "isGood" (\a -> a == (a `asTypeOf` True))+ ]+ ]
+ test/Unit.hs view
@@ -0,0 +1,10 @@+import Test.Framework (defaultMain, testGroup)+import Test.HUnit+import Test.Framework.Providers.HUnit (testCase)++main :: IO ()+main = defaultMain [+ testGroup "(default)" [+ testCase "isGood" (True @=? True)+ ]+ ]