riemann 0.1.0.2 → 0.1.1.0
raw patch · 8 files changed
+374/−155 lines, 8 filesdep +bytestringdep +directorydep +doctestdep −eitherdep ~basedep ~errorsdep ~transformersnew-component:exe:riemann-clientnew-uploaderPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: bytestring, directory, doctest, filepath, http-client, mtl, wreq
Dependencies removed: either
Dependency ranges changed: base, errors, transformers
API changes (from Hackage documentation)
- Network.Monitoring.Riemann: instance GHC.Classes.Eq Network.Monitoring.Riemann.Client
- Network.Monitoring.Riemann: instance GHC.Show.Show Network.Monitoring.Riemann.Client
- Network.Monitoring.Riemann: makeClient :: Hostname -> Port -> IO Client
- Network.Monitoring.Riemann: sendEvent' :: Client -> Event -> EitherT IOException IO ()
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Constructor Network.Monitoring.Riemann.Types.C1_0Attribute
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Constructor Network.Monitoring.Riemann.Types.C1_0Event
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Constructor Network.Monitoring.Riemann.Types.C1_0Msg
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Constructor Network.Monitoring.Riemann.Types.C1_0Query
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Constructor Network.Monitoring.Riemann.Types.C1_0State
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Datatype Network.Monitoring.Riemann.Types.D1Attribute
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Datatype Network.Monitoring.Riemann.Types.D1Event
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Datatype Network.Monitoring.Riemann.Types.D1Msg
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Datatype Network.Monitoring.Riemann.Types.D1Query
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Datatype Network.Monitoring.Riemann.Types.D1State
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_0Attribute
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_0Event
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_0Msg
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_0Query
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_0State
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_10Event
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_1Attribute
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_1Event
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_1Msg
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_1State
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_2Event
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_2Msg
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_2State
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_3Event
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_3Msg
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_3State
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_4Event
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_4Msg
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_4State
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_5Event
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_5State
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_6Event
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_6State
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_7Event
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_7State
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_8Event
- Network.Monitoring.Riemann.Types: instance GHC.Generics.Selector Network.Monitoring.Riemann.Types.S1_0_9Event
+ Network.Monitoring.Riemann: TCP :: Hostname -> Port -> IORef TCPState -> Client
+ Network.Monitoring.Riemann: UDP :: Hostname -> Port -> Either IOException (Socket, AddrInfo) -> Client
+ Network.Monitoring.Riemann: [riemannHost] :: Client -> Hostname
+ Network.Monitoring.Riemann: [riemannPort] :: Client -> Port
+ Network.Monitoring.Riemann: [tcpClient] :: Client -> IORef TCPState
+ Network.Monitoring.Riemann: [udpClient] :: Client -> Either IOException (Socket, AddrInfo)
+ Network.Monitoring.Riemann: closeClient :: Client -> IO ()
+ Network.Monitoring.Riemann: isError :: (MonadIO m) => Client -> m Bool
+ Network.Monitoring.Riemann: makeTCPClient :: Hostname -> Port -> IO Client
+ Network.Monitoring.Riemann: makeUDPClient :: Hostname -> Port -> IO Client
+ Network.Monitoring.Riemann: sendEventT :: Client -> Event -> ExceptT IOException IO Client
+ Network.Monitoring.Riemann.Types: Error :: Text -> MsgState
+ Network.Monitoring.Riemann.Types: Ok :: MsgState
+ Network.Monitoring.Riemann.Types: Unknown :: MsgState
+ Network.Monitoring.Riemann.Types: type Hostname = String
+ Network.Monitoring.Riemann.Types: type Port = Int
- Network.Monitoring.Riemann.Types: time :: HasState a => Lens' a (Maybe (Signed Int64))
+ Network.Monitoring.Riemann.Types: time :: HasState a => Lens' a (Maybe Int64)
Files
- LICENSE +0/−1
- riemann.cabal +66/−55
- src/Network/Monitoring/Riemann.hs +87/−31
- src/Network/Monitoring/Riemann/TCP.hs +100/−0
- src/Network/Monitoring/Riemann/Types.hs +53/−54
- src/riemann.hs +43/−0
- test/Doctest.hs +20/−0
- test/Property.hs +5/−14
LICENSE view
@@ -1,5 +1,4 @@ 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
riemann.cabal view
@@ -1,21 +1,16 @@ name: riemann-version: 0.1.0.2+version: 0.1.1.0 synopsis: A Riemann client for Haskell-description: Very simple event sending to a Riemann server.-homepage: https://github.com/telser/riemann-hs+description: A Riemann client for Haskell+homepage: https://github.com/tel/riemann-hs license: MIT license-file: LICENSE-author: Joseph Abrahamson, Trevis Elser-maintainer: trevis@clickscape.com-copyright: 2013 Joseph Abrahamson, 2015 Trevis Elser+author: Joseph Abrahamson+maintainer: me@jspha.com+copyright: 2013 Joseph Abrahamson category: Network build-type: Simple-cabal-version: >=1.10---source-repository head- type: git- location: https://github.com/telser/riemann-hs/+cabal-version: >=1.20 library hs-source-dirs: src@@ -23,51 +18,70 @@ Network.Monitoring.Riemann Network.Monitoring.Riemann.Types other-modules:+ Network.Monitoring.Riemann.TCP 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- , transformers >= 0.4.3.0 && < 0.5- , either- , errors < 2.0- , lens- , time- , data-default- , cereal+ base >= 4.5 && < 5,+ network >= 2.4.0.0,+ text >= 0.11.2.3,+ containers >= 0.4.2.0,+ protobuf >= 0.2,+ bytestring >= 0.10,+ lens,+ time,+ errors,+ data-default,+ mtl,+ 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--- , transformers >= 0.4.3.0 && < 0.5--- , either--- , errors < 2.0--- , directory--- , either--- , doctest--- , filepath--- default-language: Haskell2010+executable riemann-client+ main-is: riemann.hs+ hs-source-dirs: src+ ghc-options: -threaded+ build-depends:+ base,+ riemann,+ network >= 2.4.0.0,+ text >= 0.11.2.3,+ containers >= 0.4.2.0,+ protobuf >= 0.2,+ wreq,+ http-client, + bytestring,+ lens,+ time,+ errors,+ data-default,+ mtl,+ transformers,+ cereal+ default-language: Haskell2010+ ghc-options: -Wall -fwarn-tabs +test-suite doctest+ type: exitcode-stdio-1.0+ ghc-options: -threaded+ hs-source-dirs: test+ main-is: Doctest.hs+ build-depends:+ base,+ directory,+ 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- , transformers >= 0.4.3.0 && < 0.5- , either- , errors < 2.0- , QuickCheck >= 2.5.1.0- , test-framework- , test-framework-quickcheck2- , riemann+ base,+ QuickCheck >= 2.5.1.0,+ test-framework,+ test-framework-quickcheck2,+ riemann default-language: Haskell2010 test-suite unit@@ -76,12 +90,9 @@ hs-source-dirs: test main-is: Unit.hs build-depends:- base- , transformers >= 0.4.3.0 && < 0.5- , either- , errors < 2.0- , HUnit- , test-framework- , test-framework-hunit- , riemann+ base,+ HUnit,+ test-framework,+ test-framework-hunit,+ riemann default-language: Haskell2010
src/Network/Monitoring/Riemann.hs view
@@ -1,30 +1,31 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-} module Network.Monitoring.Riemann ( module Network.Monitoring.Riemann.Types, module Data.Int,- Client, makeClient,- sendEvent, sendEvent'- {-, sendEvent'-}- ) where+ Client(..), makeUDPClient, makeTCPClient, isError,+ closeClient,+ sendEventT, sendEvent ) where +import Network.Monitoring.Riemann.TCP import Network.Monitoring.Riemann.Types import Data.Default import Data.Int+import Data.IORef (IORef, atomicModifyIORef',+ newIORef, readIORef,+ writeIORef) import Data.ProtocolBuffers import Data.Serialize.Put-import Data.Time.Clock import Data.Time.Clock.POSIX -import Control.Applicative-import qualified Control.Error as Error+import Control.Error import Control.Exception import Control.Lens-import qualified Control.Monad as CM-import qualified Control.Monad.IO.Class as CMIC-import Control.Monad.Trans.Either-import qualified Control.Monad.Trans.Except as Except+import Control.Monad+import Control.Monad.Trans import Network.Socket hiding (recv, recvFrom, send, sendTo)@@ -113,18 +114,30 @@ -} -data Client = UDP (Maybe (Socket, AddrInfo))- deriving (Show, Eq)+data Client = UDP { riemannHost :: Hostname+ , riemannPort :: Port+ , udpClient :: Either IOException (Socket, AddrInfo)+ }+ | TCP { riemannHost :: Hostname+ , riemannPort :: Port+ , tcpClient :: IORef TCPState+ -- ^ TCP connection's state is maintained into a mutable reference in order to allow+ -- not mutating the @Client@ structure+ } -type Hostname = String-type Port = Int+-- |Checks whether or not a given @Client@ is in an error state.+isError :: (MonadIO m) => Client -> m Bool+isError (UDP _ _ (Left _)) = return True+isError (UDP _ _ (Right _ )) = return False+isError (TCP _ _ r) = isTCPError <$> liftIO (readIORef r) + -- | 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 SomeException (Socket, AddrInfo))+makeUDPClient :: Hostname -> Port -> IO Client+makeUDPClient hn po = UDP hn po <$> sock+ where sock :: IO (Either IOException (Socket, AddrInfo)) sock = try $ do addrs <- getAddrInfo (Just $ defaultHints {@@ -134,21 +147,64 @@ case addrs of [] -> fail "No accessible addresses" (addy:_) -> do- s <- socket (addrFamily addy)- Datagram- (addrProtocol addy)+ s <- socket AF_INET+ Datagram+ defaultProtocol return (s, addy) +-- | Attempts to connect to given riemann server+-- Returns an initialised TCP client that can later be used to send events to given riemann host/port.+-- TCP Clients always try to reconnect to server when an event is sent and connection is either closed+-- or in error.+makeTCPClient :: Hostname -> Port -> IO Client+makeTCPClient hn po = do+ ref <- newIORef CnxClosed+ cnx <- tcpConnect hn po CnxClosed+ writeIORef ref cnx+ return $ TCP hn po ref+++closeClient :: Client -> IO ()+closeClient (UDP _ _ cnx) = either (const $ return ()) (close . fst) cnx+closeClient (TCP _ _ r ) = do+ tcp <- readIORef r+ case tcp of+ CnxOpen (s,_) -> close s+ _ -> return ()+ atomicModifyIORef' r (const $ (CnxClosed, ()))++ -- | Attempts to forward an event to a client. Fails silently.-sendEvent :: CMIC.MonadIO m => Client -> Event -> m ()-sendEvent c = CMIC.liftIO . CM.void . runEitherT . sendEvent' c+sendEvent :: MonadIO m => Client -> Event -> m ()+sendEvent c = liftIO . void . runExceptT . sendEventT c -- | Attempts to forward an event to a client. If it fails, it'll--- return an 'IOException' in the 'Either'.-sendEvent' :: Client -> Event -> EitherT IOException IO ()-sendEvent' (UDP Nothing) _ = return ()-sendEvent' (UDP (Just (s, addy))) e = Error.tryIO $ do- current <- getCurrentTime- let now = round (utcTimeToPOSIXSeconds current)+-- return an 'IOException' in the 'ExceptT', otherwise it returns the passed @Client@, possibly+-- modified to cope for changes in state.+sendEventT :: Client -> Event -> ExceptT IOException IO Client+sendEventT client@(UDP _ _ _) event = sendUDPEvent client event+sendEventT client@(TCP _ _ _ ) event = sendTCPEvent client event++sendTCPEvent :: (MonadIO m) => Client -> Event -> ExceptT IOException m Client+sendTCPEvent c@(TCP h n r) event = tryIO $ do+ tcp <- readIORef r+ case tcp of+ CnxOpen (s,_) -> doSendTCPEvent r s event >> return c+ s -> do+ s' <- tcpConnect h n s+ writeIORef r s'+ case s' of+ CnxOpen (sock,_) -> doSendTCPEvent r sock event >> return c+ CnxError e -> throw e+ _ -> fail "connection is closed after retry"+sendTCPEvent _ _ = fail "trying to send TCP event through UDP client"+++sendUDPEvent :: (MonadIO m) => Client -> Event -> ExceptT IOException m Client+sendUDPEvent (UDP _ _ (Left e)) _ = throwE e+sendUDPEvent c@(UDP _ _ (Right (s, addy))) e = tryIO $ do+ now <- fmap round getPOSIXTime let msg = def & events .~ [e & time ?~ now]- CM.void $ sendTo s (runPut $ encodeMessage msg) (addrAddress addy)+ void $ sendTo s (runPut $ encodeMessage msg) (addrAddress addy)+ return c+sendUDPEvent _ _ = fail "trying to send UDP event through TCP client"
+ src/Network/Monitoring/Riemann/TCP.hs view
@@ -0,0 +1,100 @@+-- | TCP Specific connection handling for monitoring with Riemann+module Network.Monitoring.Riemann.TCP(tcpConnect, isTCPError, TCPState(..), doSendTCPEvent) where++import Network.Monitoring.Riemann.Types++import qualified Data.ByteString as BS+import Data.Default+import Data.IORef (IORef, writeIORef)+import Data.ProtocolBuffers+import Data.Serialize.Get+import Data.Serialize.Put+import Data.Time.Clock.POSIX++import Control.Exception+import Control.Lens+import Control.Monad++import Network.Socket hiding (recv, recvFrom, send,+ sendTo)+import Network.Socket.ByteString+++-- | High-level and probably too naive state of TCP connection to Riemann server.+data TCPState = CnxClosed+ -- ^Connection is known to be closed+ | CnxOpen (Socket, AddrInfo)+ -- ^Connection is expected to be usable with given socket and address+ | CnxError IOException+ -- ^Connection failed with given exception+ deriving Show++-- |Is given state in error?+isTCPError :: TCPState -> Bool+isTCPError (CnxError _) = True+isTCPError _ = False++-- | Try connecting with TCP to given host/port.+--+-- * If the passed @TCPState@ is already connected then no new connection attempt is made+-- * Otherwise, we try to connect to given host/port and update @TCPState@ accordingly+--+-- '''Note''': We never use IPv6 address resolved for given hostname.+tcpConnect :: Hostname -> Port -> TCPState -> IO TCPState+tcpConnect _ _ s@(CnxOpen _) = return s+tcpConnect hn po _ = do+ res <- try $ doConnect hn po+ return $ case res of+ Left e -> CnxError e+ Right s -> CnxOpen s++tcpv4 :: AddrInfo -> Bool+tcpv4 addr = addrSocketType addr == Stream &&+ addrFamily addr == AF_INET++doConnect :: HostName -> Port -> IO (Socket, AddrInfo)+doConnect hn po = do addrs <- getAddrInfo+ (Just $ defaultHints {+ addrFlags = [AI_NUMERICSERV] })+ (Just hn)+ (Just $ show po)+ case (filter tcpv4 addrs) of+ [] -> fail ("No accessible addresses in " ++ show addrs)+ (addy:_) -> do+ s <- socket AF_INET+ Stream+ defaultProtocol+ connect s (addrAddress addy)+ return (s, addy)+++-- | Try sending a riemann event to given @Socket@, updating given state accordingly.+doSendTCPEvent :: IORef TCPState -> Socket -> Event -> IO ()+doSendTCPEvent r s event = do+ sending <- try $ do+ now <- fmap round getPOSIXTime+ let msg = def & events .~ [event & time ?~ now]+ bytes = runPut $ encodeMessage msg+ bytesWithLen = runPut (putWord32be (fromIntegral $ BS.length bytes) >> putByteString bytes)+ void $ send s bytesWithLen+ case sending of+ Left e -> writeIORef r (CnxError e)+ Right _ -> doReceiveAck r s++-- | Re+doReceiveAck :: IORef TCPState -> Socket -> IO ()+doReceiveAck r s = do+ bs <- recv s 4096+ if BS.length bs == 0+ then close s >> writeIORef r CnxClosed+ else case decoded bs of+ Left _ -> return () -- TODO something useful, but what ? Close the socket ?+ Right msg -> do+ let st = msg ^. msgState+ case st of+ Ok -> return ()+ Error _ -> return () -- TODO something useful+ Unknown -> return ()++ where+ decoded bs = runGet decodeMessage bs :: Either String Msg
src/Network/Monitoring/Riemann/Types.hs view
@@ -1,11 +1,11 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE TypeOperators #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeOperators #-} module Network.Monitoring.Riemann.Types ( HasState (..),@@ -14,29 +14,24 @@ State, Event, Query, Msg, ev, once, attributes,- MsgState, msgState, states, events+ MsgState(..), msgState, states, events,+ Hostname, Port ) 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+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 @@ -45,7 +40,7 @@ -- 'time'. These shared types give rise to restrictedly polymorphic -- lenses. class HasState a where- time :: Lens' a (Maybe (Signed Int64))+ 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",@@ -100,7 +95,7 @@ -- | 'State' is an object within Riemann's index, a result from a -- 'Query'. data State = State {- _stateTime :: Optional 1 (Value (Signed Int64)),+ _stateTime :: Optional 1 (Value Int64), _stateState :: Optional 2 (Value Text), _stateService :: Optional 3 (Value Text), _stateHost :: Optional 4 (Value Text),@@ -113,14 +108,14 @@ -- | 'Event' is a description of an application-level event, emitted -- to Riemann for indexing. data Event = Event {- _eventTime :: Optional 1 (Value (Signed Int64)),+ _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),@@ -166,7 +161,7 @@ once = stateOnce . field instance Show State where- show s = "State { " ++ intercalate ", " innards ++ " }" + show s = "State { " ++ intercalate ", " innards ++ " }" where innards = catMaybes [ showM "time" time, showM "state" state,@@ -178,7 +173,7 @@ showM "once" once ] showM name l = (\x -> name ++ " = " ++ x) . show <$> s ^. l- showL name l = let lst = s ^. l + showL name l = let lst = s ^. l in if null lst then Nothing else Just $ name ++ " = " ++ show lst instance Default State where@@ -233,11 +228,11 @@ class AMetric a where metric :: Lens' Event (Maybe a) -instance AMetric Int where +instance AMetric Int where metric = eventMetricSInt . field . mapping (iso fromIntegral fromIntegral)-instance AMetric Integer where +instance AMetric Integer where metric = eventMetricSInt . field . mapping (iso fromIntegral fromIntegral)-instance AMetric (Signed Int64) where +instance AMetric (Signed Int64) where metric = eventMetricSInt . field instance AMetric Double where metric = eventMetricD . field@@ -256,7 +251,7 @@ sequen (a, fb) = (a,) <$> fb instance Show Event where- show s = "Event { " ++ intercalate ", " innards ++ " }" + show s = "Event { " ++ intercalate ", " innards ++ " }" where innards = catMaybes [ showM "time" time, showM "state" state,@@ -271,13 +266,13 @@ 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 + 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 + 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,@@ -301,22 +296,22 @@ -- | Create a simple 'Event' with state "ok". ----- >>> get state $ ev "service" (0 :: (Signed Int64))+-- >>> view state $ ev "service" (0 :: (Signed Int64)) -- Just "ok" ----- >>> get service $ ev "service" (0 :: (Signed Int64))+-- >>> view service $ ev "service" (0 :: (Signed Int64)) -- Just "service" ----- >>> get metric $ ev "service" (0 :: (Signed Int64)) :: Maybe (Signed Int64)--- Just 0+-- >>> view metric $ ev "service" (0 :: (Signed Int64)) :: Maybe (Signed Int64)+-- Just (Signed 0) ----- >>> get tags $ ev "service" (0 :: (Signed Int64))+-- >>> view tags $ ev "service" (0 :: (Signed Int64)) -- [] ev :: AMetric a => String -> a -> Event ev serv met =- def - & state ?~ "ok" - & service ?~ T.pack serv + def+ & state ?~ "ok"+ & service ?~ T.pack serv & metric ?~ met -- $query@@ -336,7 +331,7 @@ mappend = defMappend instance Show Query where- show s = "Query { " ++ intercalate ", " innards ++ " }" + show s = "Query { " ++ intercalate ", " innards ++ " }" where innards = catMaybes [ showM "query" query ]@@ -370,7 +365,7 @@ events = msgEvents . field instance Show Msg where- show s = "Msg { " ++ intercalate ", " innards ++ " }" + show s = "Msg { " ++ intercalate ", " innards ++ " }" where innards = catMaybes [ showMsgState, showL "states" states,@@ -378,7 +373,7 @@ showM "query" query ] showM name l = (\x -> name ++ " = " ++ x) . show <$> s ^. l- showL name l = let lst = 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"@@ -402,3 +397,7 @@ instance Monoid Msg where mempty = def mappend = defMappend+++type Hostname = String+type Port = Int
+ src/riemann.hs view
@@ -0,0 +1,43 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import Control.Concurrent+import Control.Error+import Control.Exception (catch)+import Control.Lens+import Control.Monad+import Control.Monad.IO.Class+import Data.Monoid ((<>))+import Data.Time.Clock+import Network.HTTP.Client (HttpException (..))+import Network.Monitoring.Riemann+import Network.Wreq+import System.Environment++main :: IO ()+main = do+ [rhost,rport,uriList] <- getArgs+ c <- makeTCPClient rhost (read rport)+ uris <- lines <$> readFile uriList+ forever $ checkAll c uris+++checkAll :: Client -> [ String ] -> IO ()+checkAll c uris = forM_ uris (check c) >> threadDelay (60 * 1000000)++check :: Client -> String -> IO ()+check c uri = do+ putStr $ "checking " <> uri <> " "+ st <- getCurrentTime+ ok <- (get uri >> return True) `catch` \ (_ :: HttpException) -> return False+ en <- getCurrentTime+ let event = ev ("http " <> uri) (realToFrac (diffUTCTime en st) :: Double) & state ?~ if ok then "ok" else "error"+ res <- liftIO $ runExceptT $ sendEventT c event+ -- not very useful error handling, if socket fails to connect at startup it cannot reconnects later+ either+ (\e -> putStrLn ("error connecting to riemann server: " <> show e))+ (const $ putStrLn "sent event to riemann")+ res+
+ 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
@@ -1,19 +1,10 @@ import Test.Framework (defaultMain, testGroup) import Test.QuickCheck import Test.Framework.Providers.QuickCheck2 (testProperty)-import Network.Monitoring.Riemann --- main :: IO ()--- main = defaultMain [--- testGroup "(default)" [--- testProperty "isGood" (\a -> a == (a `asTypeOf` True))--- ]--- ]- main :: IO ()-main = do- client <- makeClient "127.0.0.1" 5555- print "Client made now attempting to send event"- sendEvent client (ev "test_service" (0.0 :: Double))- print "post event send"- print $ show client+main = defaultMain [+ testGroup "(default)" [+ testProperty "isGood" (\a -> a == (a `asTypeOf` True))+ ]+ ]