diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/riemann.cabal b/riemann.cabal new file mode 100644 --- /dev/null +++ b/riemann.cabal @@ -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 diff --git a/src/Network/Monitoring/Riemann.hs b/src/Network/Monitoring/Riemann.hs new file mode 100644 --- /dev/null +++ b/src/Network/Monitoring/Riemann.hs @@ -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 "" & 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) diff --git a/src/Network/Monitoring/Riemann/Types.hs b/src/Network/Monitoring/Riemann/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Monitoring/Riemann/Types.hs @@ -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 "" + 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 diff --git a/test/Doctest.hs b/test/Doctest.hs new file mode 100644 --- /dev/null +++ b/test/Doctest.hs @@ -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 diff --git a/test/Property.hs b/test/Property.hs new file mode 100644 --- /dev/null +++ b/test/Property.hs @@ -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)) + ] + ] diff --git a/test/Unit.hs b/test/Unit.hs new file mode 100644 --- /dev/null +++ b/test/Unit.hs @@ -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) + ] + ]