hriemann 0.1.0.0 → 0.2.0.0

raw patch · 8 files changed

+115/−83 lines, 8 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• app/Main.hs +1/−5
• hriemann.cabal +5/−3
• src/Network/Monitoring/Riemann/BatchClient.hs +5/−15
• src/Network/Monitoring/Riemann/Event.hs +43/−42
• src/Network/Monitoring/Riemann/Event/Monoid.hs +50/−0
• src/Network/Monitoring/Riemann/LoggingClient.hs +3/−2
• src/Network/Monitoring/Riemann/TCP.hs +7/−14
• src/Network/Monitoring/Riemann/TCPClient.hs +1/−2

@@ -1,18 +1,14 @@ module Main where -import           Control.Concurrent import           Control.Monad                            (forM_) import           Data.Function import           Network.Monitoring.Riemann.BatchClient import           Network.Monitoring.Riemann.Client import qualified Network.Monitoring.Riemann.Event         as Event-import           Network.Monitoring.Riemann.LoggingClient-import           Network.Monitoring.Riemann.TCPClient  main :: IO () main = do---     client <- batchClient "localhost" 5555 100 100 print-    client <- bc "localhost" 5555 100 print+    client <- batchClient "localhost" 5555 100 100 print     putStrLn "doing some IO work"     event <- pure $                  Event.warn "my service"

@@ -1,5 +1,5 @@ name:                hriemann-version:             0.1.0.0+version:             0.2.0.0 synopsis:            Initial project template from stack description:         A Riemann Client for Haskell homepage:            https://github.com/shmish111/hriemann@@ -7,16 +7,18 @@ license-file:        LICENSE author:              David Smith maintainer:          shmish111@gmail.com-copyright:           2016 David Smith-category:            Web+copyright:           2017 David Smith+category:            Monitoring build-type:          Simple -- extra-source-files: cabal-version:       >=1.10  library   hs-source-dirs:      src+  ghc-options:         -Wall   exposed-modules:     Network.Monitoring.Riemann.Client                        Network.Monitoring.Riemann.Event+                       Network.Monitoring.Riemann.Event.Monoid                        Network.Monitoring.Riemann.TCP                        Network.Monitoring.Riemann.LoggingClient                        Network.Monitoring.Riemann.TCPClient

@@ -5,7 +5,6 @@ import           Control.Concurrent.KazuraQueue import           Data.Sequence                          as Seq import           Network.Monitoring.Riemann.Client-import           Network.Monitoring.Riemann.Event       as Event import qualified Network.Monitoring.Riemann.Proto.Event as PE import           Network.Monitoring.Riemann.TCP         as TCP import           Network.Socket@@ -46,19 +45,10 @@           connection <- TCP.tcpConnection hostname port           (inChan, outChan) <- Unagi.newChan           q <- newQueue-          forkIO $ overflowConsumer outChan q bufferSize overflow-          forkIO $ riemannConsumer batchSize q connection+          _ <- forkIO $ overflowConsumer outChan q bufferSize overflow+          _ <- forkIO $ riemannConsumer batchSize q connection           return $ BatchClient inChan -bc :: HostName -> Port -> Int -> (PE.Event -> IO ()) -> IO BatchClientNoBuffer-bc hostname port batchSize overflow-    | batchSize <= 0 = error "Batch Size must be positive"-    | otherwise = do-          connection <- TCP.tcpConnection hostname port-          q <- newQueue-          forkIO $ riemannConsumer batchSize q connection-          return $ BatchClientNoBuffer q- overflowConsumer :: Unagi.OutChan LogCommand                  -> Queue LogCommand                  -> Int@@ -79,7 +69,7 @@                     else do                         writeQueue q cmd                         loop-            Stop s -> do+            Stop _ -> do                 putStrLn "stopping log consumer"                 writeQueue q cmd @@ -103,8 +93,8 @@     loop = do         cmds <- drainAll q batchSize         let (events', stops') = Seq.partition (\cmd -> case cmd of-                                                   Event event -> True-                                                   Stop s      -> False)+                                                   Event _ -> True+                                                   Stop _  -> False)                                               cmds             events = fmap (\(Event e) -> e) events'             stops = fmap (\(Stop s) -> s) stops'

@@ -7,30 +7,30 @@ Events are built by composing helper functions that set Riemann fields and applying to one of the Event constructors:  @-  Event.ok "my service"-& Event.description "my description"-& Event.metric (length [ "some data" ])-& Event.ttl 20-& Event.tags ["tag1", "tag2"]+  E.ok "my service"+& E.description "my description"+& E.metric (length [ "some data" ])+& E.ttl 20+& E.tags ["tag1", "tag2"] @ -With this design you are encouraged to create an event with one of 'Event.ok', 'Event.warn' or 'Event.failure'.+With this design you are encouraged to create an event with one of 'E.ok', 'E.warn' or 'E.failure'.  This has been done because we found that it is best to avoid services like @my.service.success@ and @my.service.error@ (that's what the Riemann state field is for). -You can use your own states using @Event.info & Event.state "trace"@ however this is discouraged as it doesn't show up nicely in riemann-dash.+You can use your own states using @E.info & E.state "trace"@ however this is discouraged as it doesn't show up nicely in riemann-dash. -} module Network.Monitoring.Riemann.Event where -import           Control.Concurrent import qualified Data.ByteString.Lazy.Char8                 as BC import           Data.Maybe+import           Data.Monoid                                ((<>)) import           Data.Sequence import           Data.Time.Clock.POSIX import           Network.HostName import qualified Network.Monitoring.Riemann.Proto.Attribute as Attribute-import qualified Network.Monitoring.Riemann.Proto.Event     as Event-import qualified Network.Monitoring.Riemann.Proto.Msg       as Msg+import           Network.Monitoring.Riemann.Proto.Event     (Event)+import qualified Network.Monitoring.Riemann.Proto.Event     as E import           Text.ProtocolBuffers.Basic                 as Basic import qualified Text.ProtocolBuffers.Header                as P' @@ -38,46 +38,47 @@  type State = String -type Event = Event.Event+emptyEvent :: Event+emptyEvent = P'.defaultValue  toField :: String -> Maybe Basic.Utf8 toField string = Just $ Basic.Utf8 $ BC.pack string -info :: Service -> Event.Event-info service = P'.defaultValue { Event.service = toField service }+info :: Service -> Event+info service = P'.defaultValue { E.service = toField service } -state :: State -> Event.Event -> Event.Event-state s e = e { Event.state = toField s }+state :: State -> Event -> Event+state s e = e { E.state = toField s } -ok :: Service -> Event.Event+ok :: Service -> Event ok service = state "ok" $ info service -warn :: Service -> Event.Event+warn :: Service -> Event warn service = state "warn" $ info service -failure :: Service -> Event.Event+failure :: Service -> Event failure service = state "failure" $ info service -description :: String -> Event.Event -> Event.Event-description d e = e { Event.description = toField d }+description :: String -> Event -> Event+description d e = e { E.description = toField d }  class Metric a where-    setMetric :: a -> Event.Event -> Event.Event+    setMetric :: a -> Event -> Event  instance Metric Int where-    setMetric m e = e { Event.metric_sint64 = Just $ fromIntegral m }+    setMetric m e = e { E.metric_sint64 = Just $ fromIntegral m }  instance Metric Integer where-    setMetric m e = e { Event.metric_sint64 = Just $ fromIntegral m }+    setMetric m e = e { E.metric_sint64 = Just $ fromIntegral m }  instance Metric Int64 where-    setMetric m e = e { Event.metric_sint64 = Just m }+    setMetric m e = e { E.metric_sint64 = Just m }  instance Metric Double where-    setMetric m e = e { Event.metric_d = Just m }+    setMetric m e = e { E.metric_d = Just m }  instance Metric Float where-    setMetric m e = e { Event.metric_f = Just m }+    setMetric m e = e { E.metric_f = Just m }  {-|     Note that since Riemann's protocol has separate types for integers, floats and doubles, you need to specify which@@ -93,19 +94,19 @@     metric (1 :: Int) myEvent     @ -}-metric :: (Metric a) => a -> Event.Event -> Event.Event+metric :: (Metric a) => a -> Event -> Event metric = setMetric -ttl :: Float -> Event.Event -> Event.Event-ttl t e = e { Event.ttl = Just t }+ttl :: Float -> Event -> Event+ttl t e = e { E.ttl = Just t } -tags :: [String] -> Event.Event -> Event.Event+tags :: [String] -> Event -> Event tags ts e = let tags' = fromList $ fmap (Basic.Utf8 . BC.pack) ts             in-                e { Event.tags = tags' }+                e { E.tags = tags' <> E.tags e } -attributes :: [Attribute.Attribute] -> Event.Event -> Event.Event-attributes as e = e { Event.attributes = fromList as }+attributes :: [Attribute.Attribute] -> Event -> Event+attributes as e = e { E.attributes = fromList as <> E.attributes e }  attribute :: String -> Maybe String -> Attribute.Attribute attribute k mv = let k' = (Basic.Utf8 . BC.pack) k@@ -120,16 +121,16 @@      This will not override any host or time in the provided event -}-withDefaults :: Seq Event.Event -> IO (Seq Event.Event)+withDefaults :: Seq Event -> IO (Seq Event) withDefaults e = do     now <- fmap round getPOSIXTime     hostname <- getHostName     return $ fmap (addTimeAndHost now hostname) e-  where-    addTimeAndHost now hostname e =-        let now' = if isJust $ Event.time e then Event.time e else Just now-            host = if isJust $ Event.host e-                   then Event.host e-                   else toField hostname-        in-            e { Event.time = now', Event.host = host }++addTimeAndHost :: Int64 -> String -> Event -> Event+addTimeAndHost now hostname e+    | isJust (E.time e) && isJust (E.host e) =+          e+    | isJust (E.time e) = e { E.host = toField hostname }+    | isJust (E.host e) = e { E.time = Just now }+    | otherwise = e { E.time = Just now, E.host = toField hostname }

@@ -0,0 +1,50 @@+module Network.Monitoring.Riemann.Event.Monoid where++import           Data.Monoid                                (Endo (..), appEndo)+import           Data.Time.Clock.POSIX                      (getPOSIXTime)+import           Network.HostName                           (getHostName)+import           Network.Monitoring.Riemann.Event           (Service)+import qualified Network.Monitoring.Riemann.Event           as E+import           Network.Monitoring.Riemann.Proto.Attribute (Attribute)+import           Network.Monitoring.Riemann.Proto.Event     (Event)+import qualified Network.Monitoring.Riemann.Proto.Event     as PE+import           Text.ProtocolBuffers.Basic                 (Int64)++append :: a -> Endo a -> a+append = flip appEndo++ok :: Service -> Endo Event -> Event+ok s = append $ E.ok s++warn :: Service -> Endo Event -> Event+warn s = append $ E.warn s++failure :: Service -> Endo Event -> Event+failure s = append $ E.warn s++desc :: String -> Endo Event+desc = Endo . E.description++ttl :: Float -> Endo Event+ttl = Endo . E.ttl++metric :: (E.Metric a) => a -> Endo Event+metric = Endo . E.metric++timestamp :: Int64 -> Endo Event+timestamp t = Endo $ \e -> e { PE.time = Just t }++attributes :: [Attribute] -> Endo Event+attributes = Endo . E.attributes++tags :: [String] -> Endo Event+tags = Endo . E.tags++timeAndHost :: IO (Endo Event)+timeAndHost = do+    now <- fmap round getPOSIXTime+    hostname <- getHostName+    return $ Endo $ E.addTimeAndHost now hostname++attribute :: String -> Maybe String -> Attribute+attribute = E.attribute

@@ -9,8 +9,9 @@      The LoggingClient is a 'Client' that will simply print events -}+loggingClient :: LoggingClient loggingClient = LoggingClient  instance Client LoggingClient where-    sendEvent client = print-    close client = print "close"+    sendEvent _ = print+    close _ = print "close"

@@ -10,20 +10,16 @@     ) where  import           Control.Concurrent-import           Control.Concurrent.MVar-import           Control.Exception import           Data.Binary.Put                        as Put import qualified Data.ByteString.Lazy                   as BS import qualified Data.ByteString.Lazy.Char8             as BC import qualified Data.Maybe                             as Maybe import qualified Data.Sequence                          as Seq-import           Data.Text                              (Text) import qualified Network.Monitoring.Riemann.Event       as Event import qualified Network.Monitoring.Riemann.Proto.Event as PE import qualified Network.Monitoring.Riemann.Proto.Msg   as Msg import           Network.Socket import           Network.Socket.ByteString.Lazy         as NSB-import           Text.ProtocolBuffers.Get               as Get import qualified Text.ProtocolBuffers.Header            as P' import           Text.ProtocolBuffers.WireMessage       as WM @@ -43,21 +39,18 @@     newMVar (h, p, CnxOpen connection)  getConnection :: ClientInfo -> IO (Socket, AddrInfo)-getConnection (h, p, CnxOpen (s, a)) =+getConnection (_, _, CnxOpen (s, a)) =     return (s, a) getConnection (h, p, CnxClosed) =     doConnect h p -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+    case addrs of         [] -> fail ("No accessible addresses in " ++ show addrs)         (addy : _) -> do             s <- socket AF_INET Stream defaultProtocol@@ -80,8 +73,8 @@  sendMsg :: TCPConnection -> Msg.Msg -> IO (Either Msg.Msg Msg.Msg) sendMsg client msg = do-    clientInfo@(h, p, state) <- takeMVar client-    (s, a) <- getConnection clientInfo+    clientInfo@(h, p, _) <- takeMVar client+    (s, _) <- getConnection clientInfo     sendAll s $ msgToByteString msg     bs <- NSB.recv s 4096     result <- pure $ decodeMsg bs@@ -89,7 +82,7 @@         Right m -> do             putMVar client clientInfo             return $ Right m-        Left e -> do+        Left _ -> do             putMVar client (h, p, CnxClosed)             return $ Left msg @@ -101,9 +94,9 @@ sendEvents :: TCPConnection -> Seq.Seq PE.Event -> IO () sendEvents connection events = do     eventsWithDefaults <- Event.withDefaults events---     print $ "sending " ++ show (Seq.length events) ++ " events"+    --     print $ "sending " ++ show (Seq.length events) ++ " events"     result <- sendMsg connection $                   P'.defaultValue { Msg.events = eventsWithDefaults }     case result of         Left msg -> print $ "failed to send" ++ show msg-        Right _  -> return ()+        Right _ -> return ()

@@ -1,7 +1,6 @@ module Network.Monitoring.Riemann.TCPClient where  import           Network.Monitoring.Riemann.Client-import           Network.Monitoring.Riemann.Event  as Event import           Network.Monitoring.Riemann.TCP    as TCP import           Network.Socket import Data.Sequence as Seq@@ -25,4 +24,4 @@ instance Client TCPClient where     sendEvent (TCPClient connection) event =         TCP.sendEvents connection $ Seq.singleton event-    close client = print "close"+    close _ = print "close"