diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,21 +1,22 @@ module Main where -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 Control.Monad (forM_) +import Data.Function +import Network.Monitoring.Riemann.BatchClient +import Network.Monitoring.Riemann.Client +import qualified Network.Monitoring.Riemann.Event as Event main :: IO () main = do - client <- batchClient "localhost" 5555 100 100 print - putStrLn "doing some IO work" - event <- pure $ - Event.warn "my service" - & Event.description "my description" - & Event.metric (length [ "some data" ]) - & Event.ttl 20 - & Event.tags [ "tag1", "tag2" ] - forM_ [1 .. 1000000] $ \i -> sendEvent client $ event & Event.metric (i :: Int) - close client - putStrLn "finished" + client <- batchClient "localhost" 5555 100 100 print + putStrLn "doing some IO work" + event <- + pure $ + Event.warn "my service" & Event.description "my description" & + Event.metric (length ["some data"]) & + Event.ttl 20 & + Event.tags ["tag1", "tag2"] + forM_ [1 .. 1000000] $ \i -> + sendEvent client $ event & Event.metric (i :: Int) + close client + putStrLn "finished" diff --git a/hriemann.cabal b/hriemann.cabal --- a/hriemann.cabal +++ b/hriemann.cabal @@ -1,6 +1,6 @@ name: hriemann -version: 0.3.1.0 -synopsis: Initial project template from stack +version: 0.3.2.0 +synopsis: A Riemann Client for Haskell description: A Riemann Client for Haskell homepage: https://github.com/shmish111/hriemann license: MIT @@ -15,7 +15,7 @@ library hs-source-dirs: src - ghc-options: -Wall + ghc-options: -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wmissing-import-lists exposed-modules: Network.Monitoring.Riemann.Client Network.Monitoring.Riemann.Event Network.Monitoring.Riemann.Event.Monoid @@ -29,6 +29,7 @@ Network.Monitoring.Riemann.Proto.Msg Network.Monitoring.Riemann.Proto.Query Network.Monitoring.Riemann.Proto.State + Data.Sequence.Extra build-depends: base >= 4.7 && < 5 , aeson , protocol-buffers @@ -40,6 +41,7 @@ , containers , binary , time + , mtl , hostname , unagi-chan , kazura-queue @@ -58,8 +60,15 @@ type: exitcode-stdio-1.0 hs-source-dirs: test main-is: Spec.hs + other-modules: Network.Monitoring.Riemann.BatchClientSpec build-depends: base , hriemann + , containers + , HUnit + , hspec + , hspec-core + , QuickCheck + , kazura-queue ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 diff --git a/src/Data/Sequence/Extra.hs b/src/Data/Sequence/Extra.hs new file mode 100644 --- /dev/null +++ b/src/Data/Sequence/Extra.hs @@ -0,0 +1,13 @@ +module Data.Sequence.Extra + ( separate + ) where + +import Data.Sequence (Seq, (|>), empty) + +separate :: (a -> Either b c) -> Seq a -> (Seq b, Seq c) +separate f = foldl g (empty, empty) + where + g (bs, cs) a = + case f a of + Left b -> (bs |> b, cs) + Right c -> (bs, cs |> c) diff --git a/src/Network/Monitoring/Riemann/BatchClient.hs b/src/Network/Monitoring/Riemann/BatchClient.hs --- a/src/Network/Monitoring/Riemann/BatchClient.hs +++ b/src/Network/Monitoring/Riemann/BatchClient.hs @@ -1,20 +1,38 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE LambdaCase #-} + module Network.Monitoring.Riemann.BatchClient where -import Control.Concurrent -import Control.Concurrent.Chan.Unagi as Unagi -import Control.Concurrent.KazuraQueue -import Data.Sequence as Seq -import Network.Monitoring.Riemann.Client +import Control.Concurrent (MVar, forkIO, newEmptyMVar, putMVar, takeMVar) +import qualified Control.Concurrent.Chan.Unagi as Unagi +import Control.Concurrent.KazuraQueue + ( Queue + , lengthQueue + , newQueue + , readQueue + , tryReadQueue + , writeQueue + ) +import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Data.Sequence as Seq +import Data.Sequence (Seq, (|>)) +import qualified Data.Sequence.Extra as Seq +import Network.Monitoring.Riemann.Client (Client, close, sendEvent) import qualified Network.Monitoring.Riemann.Proto.Event as PE -import Network.Monitoring.Riemann.TCP as TCP -import Network.Socket +import qualified Network.Monitoring.Riemann.TCP as TCP +import Network.Socket (HostName) +import System.IO (hPutStrLn, stderr) -data BatchClient = BatchClient (Unagi.InChan LogCommand) +newtype BatchClient = + BatchClient (Unagi.InChan LogCommand) -data BatchClientNoBuffer = BatchClientNoBuffer (Queue LogCommand) +newtype BatchClientNoBuffer = + BatchClientNoBuffer (Queue LogCommand) -data LogCommand = Event PE.Event - | Stop (MVar ()) +data LogCommand + = Event PE.Event + | Stop (MVar ()) {-| A new BatchClient @@ -33,100 +51,94 @@ '''Note''': We never use IPv6 address resolved for given hostname. -} -batchClient :: HostName - -> Port - -> Int - -> Int - -> (PE.Event -> IO ()) - -> IO BatchClient +batchClient :: + HostName -> TCP.Port -> Int -> Int -> (PE.Event -> IO ()) -> IO BatchClient batchClient hostname port bufferSize batchSize overflow - | batchSize <= 0 = error "Batch Size must be positive" - | otherwise = do - connection <- TCP.tcpConnection hostname port - (inChan, outChan) <- Unagi.newChan - q <- newQueue - _ <- forkIO $ overflowConsumer outChan q bufferSize overflow - _ <- forkIO $ riemannConsumer batchSize q connection - return $ BatchClient inChan + | batchSize <= 0 = error "Batch Size must be positive" + | otherwise = do + connection <- TCP.tcpConnection hostname port + (inChan, outChan) <- Unagi.newChan + queue <- newQueue + _ <- forkIO $ overflowConsumer outChan queue bufferSize overflow + _ <- forkIO $ riemannConsumer batchSize queue connection + pure $ BatchClient inChan -bufferlessBatchClient :: HostName -> Port -> Int -> IO BatchClientNoBuffer +bufferlessBatchClient :: HostName -> TCP.Port -> Int -> IO BatchClientNoBuffer bufferlessBatchClient hostname port batchSize - | 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 + | batchSize <= 0 = error "Batch Size must be positive" + | otherwise = do + connection <- TCP.tcpConnection hostname port + queue <- newQueue + _ <- forkIO $ riemannConsumer batchSize queue connection + pure $ BatchClientNoBuffer queue -overflowConsumer :: Unagi.OutChan LogCommand - -> Queue LogCommand - -> Int - -> (PE.Event -> IO ()) - -> IO () -overflowConsumer outChan q bufferSize f = - loop +overflowConsumer :: + Unagi.OutChan LogCommand + -> Queue LogCommand + -> Int + -> (PE.Event -> IO ()) + -> IO () +overflowConsumer outChan queue bufferSize f = loop where loop = do - cmd <- Unagi.readChan outChan - case cmd of - Event event -> do - qSize <- lengthQueue q - if qSize >= bufferSize - then do - f event - loop - else do - writeQueue q cmd - loop - Stop _ -> do - putStrLn "stopping log consumer" - writeQueue q cmd + cmd <- Unagi.readChan outChan + case cmd of + Event event -> do + qSize <- lengthQueue queue + if qSize >= bufferSize + then do + f event + loop + else do + writeQueue queue cmd + loop + Stop _ -> do + hPutStrLn stderr "stopping log consumer" + writeQueue queue cmd drainAll :: Queue a -> Int -> IO (Seq a) -drainAll q n = do - msg <- readQueue q - loop $ singleton msg +drainAll queue limit = do + msg <- readQueue queue + loop (pure msg) (limit - 1) where - loop msgs = if Seq.length msgs >= n - then return msgs - else do - msg <- tryReadQueue q - case msg of - Just m -> loop $ msgs |> m - Nothing -> return msgs + loop msgs 0 = pure msgs + loop msgs n = + tryReadQueue queue >>= \case + Nothing -> pure msgs + Just msg -> loop (msgs |> msg) (n - 1) -riemannConsumer :: Int -> Queue LogCommand -> TCPConnection -> IO () -riemannConsumer batchSize q connection = - loop +riemannConsumer :: Int -> Queue LogCommand -> TCP.TCPConnection -> IO () +riemannConsumer batchSize queue connection = loop where loop = do - cmds <- drainAll q batchSize - let (events', stops') = Seq.partition (\cmd -> case cmd of - Event _ -> True - Stop _ -> False) - cmds - events = fmap (\(Event e) -> e) events' - stops = fmap (\(Stop s) -> s) stops' - TCP.sendEvents connection events - if Seq.null stops - then loop - else let s = Seq.index stops 0 - in do - putStrLn "stopping riemann consumer" - putMVar s () + cmds <- drainAll queue batchSize + let (events, stops) = + Seq.separate + (\case + Event e -> Left e + Stop s -> Right s) + cmds + TCP.sendEvents connection events + if Seq.null stops + then loop + else let s = Seq.index stops 0 + in do hPutStrLn stderr "stopping riemann consumer" + putMVar s () -instance Client BatchClient where - sendEvent (BatchClient inChan) event = - Unagi.writeChan inChan $ Event event - close (BatchClient inChan) = do - s <- newEmptyMVar - Unagi.writeChan inChan (Stop s) - takeMVar s +instance MonadIO m => Client m BatchClient where + sendEvent (BatchClient inChan) event = + liftIO . Unagi.writeChan inChan $ Event event + close (BatchClient inChan) = + liftIO $ do + s <- newEmptyMVar + Unagi.writeChan inChan (Stop s) + takeMVar s -instance Client BatchClientNoBuffer where - sendEvent (BatchClientNoBuffer q) event = - writeQueue q $ Event event - close (BatchClientNoBuffer q) = do - s <- newEmptyMVar - writeQueue q (Stop s) - takeMVar s +instance MonadIO m => Client m BatchClientNoBuffer where + sendEvent (BatchClientNoBuffer queue) event = + liftIO . writeQueue queue $ Event event + close (BatchClientNoBuffer queue) = + liftIO $ do + s <- newEmptyMVar + writeQueue queue (Stop s) + takeMVar s diff --git a/src/Network/Monitoring/Riemann/Client.hs b/src/Network/Monitoring/Riemann/Client.hs --- a/src/Network/Monitoring/Riemann/Client.hs +++ b/src/Network/Monitoring/Riemann/Client.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + module Network.Monitoring.Riemann.Client where import qualified Network.Monitoring.Riemann.Proto.Event as Event @@ -5,6 +7,6 @@ {-| A Client is able to send 'Network.Monitoring.Riemann.Proto.Event.Event's to Riemann -} -class Client a where - sendEvent :: a -> Event.Event -> IO () - close :: a -> IO () +class Client m a where + sendEvent :: a -> Event.Event -> m () + close :: a -> m () diff --git a/src/Network/Monitoring/Riemann/Event.hs b/src/Network/Monitoring/Riemann/Event.hs --- a/src/Network/Monitoring/Riemann/Event.hs +++ b/src/Network/Monitoring/Riemann/Event.hs @@ -22,17 +22,17 @@ -} module Network.Monitoring.Riemann.Event where -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 Network.Monitoring.Riemann.Json () +import qualified Data.ByteString.Lazy.Char8 as BC +import Data.Maybe (isJust) +import Data.Monoid ((<>)) +import Data.Sequence (Seq, fromList) +import Data.Time.Clock.POSIX (getPOSIXTime) +import Network.HostName (getHostName) +import Network.Monitoring.Riemann.Json () import qualified Network.Monitoring.Riemann.Proto.Attribute as Attribute -import qualified Network.Monitoring.Riemann.Proto.Event as E -import Text.ProtocolBuffers.Basic as Basic -import qualified Text.ProtocolBuffers.Header as P' +import qualified Network.Monitoring.Riemann.Proto.Event as E +import qualified Text.ProtocolBuffers.Basic as Basic +import qualified Text.ProtocolBuffers.Header as P' type Service = String @@ -47,10 +47,10 @@ toField string = Just $ Basic.Utf8 $ BC.pack string info :: Service -> Event -info service = P'.defaultValue { E.service = toField service } +info service = P'.defaultValue {E.service = toField service} state :: State -> Event -> Event -state s e = e { E.state = toField s } +state s e = e {E.state = toField s} ok :: Service -> Event ok service = state "ok" $ info service @@ -62,25 +62,25 @@ failure service = state "failure" $ info service description :: String -> Event -> Event -description d e = e { E.description = toField d } +description d e = e {E.description = toField d} class Metric a where - setMetric :: a -> Event -> Event + setMetric :: a -> Event -> Event instance Metric Int where - setMetric m e = e { E.metric_sint64 = Just $ fromIntegral m } + setMetric m e = e {E.metric_sint64 = Just $ fromIntegral m} instance Metric Integer where - setMetric m e = e { E.metric_sint64 = Just $ fromIntegral m } + setMetric m e = e {E.metric_sint64 = Just $ fromIntegral m} -instance Metric Int64 where - setMetric m e = e { E.metric_sint64 = Just m } +instance Metric P'.Int64 where + setMetric m e = e {E.metric_sint64 = Just m} instance Metric Double where - setMetric m e = e { E.metric_d = Just m } + setMetric m e = e {E.metric_d = Just m} instance Metric Float where - setMetric m e = e { E.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 @@ -100,23 +100,21 @@ metric = setMetric ttl :: Float -> Event -> Event -ttl t e = e { E.ttl = Just t } +ttl t e = e {E.ttl = Just t} tags :: [String] -> Event -> Event -tags ts e = let tags' = fromList $ fmap (Basic.Utf8 . BC.pack) ts - in - e { E.tags = tags' <> E.tags e } +tags ts e = + let tags' = fromList $ fmap (Basic.Utf8 . BC.pack) ts + in e {E.tags = tags' <> E.tags e} attributes :: [Attribute.Attribute] -> Event -> Event -attributes as e = e { E.attributes = fromList as <> E.attributes e } +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 - mv' = fmap (Basic.Utf8 . BC.pack) mv - in - P'.defaultValue { Attribute.key = k' - , Attribute.value = mv' - } +attribute k mv = + let k' = (Basic.Utf8 . BC.pack) k + mv' = fmap (Basic.Utf8 . BC.pack) mv + in P'.defaultValue {Attribute.key = k', Attribute.value = mv'} {-| Add local hostname and current time to an Event @@ -125,14 +123,13 @@ -} withDefaults :: Seq Event -> IO (Seq Event) withDefaults e = do - now <- fmap round getPOSIXTime - hostname <- getHostName - return $ fmap (addTimeAndHost now hostname) e + now <- fmap round getPOSIXTime + hostname <- getHostName + pure $ addTimeAndHost now hostname <$> e -addTimeAndHost :: Int64 -> String -> Event -> Event +addTimeAndHost :: P'.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 } + | 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} diff --git a/src/Network/Monitoring/Riemann/Event/Monoid.hs b/src/Network/Monitoring/Riemann/Event/Monoid.hs --- a/src/Network/Monitoring/Riemann/Event/Monoid.hs +++ b/src/Network/Monitoring/Riemann/Event/Monoid.hs @@ -1,13 +1,13 @@ 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 qualified Network.Monitoring.Riemann.Proto.Event as PE -import Text.ProtocolBuffers.Basic (Int64) +import Data.Monoid (Endo(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 qualified Network.Monitoring.Riemann.Proto.Event as PE +import Text.ProtocolBuffers.Basic (Int64) type Event = PE.Event @@ -33,7 +33,7 @@ metric = Endo . E.metric timestamp :: Int64 -> Endo Event -timestamp t = Endo $ \e -> e { PE.time = Just t } +timestamp t = Endo $ \e -> e {PE.time = Just t} attributes :: [Attribute] -> Endo Event attributes = Endo . E.attributes @@ -43,9 +43,9 @@ timeAndHost :: IO (Endo Event) timeAndHost = do - now <- fmap round getPOSIXTime - hostname <- getHostName - return $ Endo $ E.addTimeAndHost now hostname + now <- round <$> getPOSIXTime + hostname <- getHostName + pure . Endo $ E.addTimeAndHost now hostname attribute :: String -> Maybe String -> Attribute attribute = E.attribute diff --git a/src/Network/Monitoring/Riemann/Json.hs b/src/Network/Monitoring/Riemann/Json.hs --- a/src/Network/Monitoring/Riemann/Json.hs +++ b/src/Network/Monitoring/Riemann/Json.hs @@ -1,23 +1,27 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RecordWildCards #-} {-# OPTIONS_GHC -fno-warn-orphans #-} + module Network.Monitoring.Riemann.Json where -import Control.Applicative ((<|>)) -import Data.Aeson (FromJSON, ToJSON, - Value (String), - parseJSON, toJSON, - withObject, - withText, (.!=), - (.:?)) -import Data.Scientific (toBoundedInteger, - toBoundedRealFloat) -import qualified Data.Text as Text -import Network.Monitoring.Riemann.Proto.Attribute as PA -import Network.Monitoring.Riemann.Proto.Event as PE -import qualified Text.ProtocolBuffers.Header as P' +import Control.Applicative ((<|>)) +import Data.Aeson + ( FromJSON + , ToJSON + , Value(String) + , (.!=) + , (.:?) + , parseJSON + , toJSON + , withObject + , withText + ) +import Data.Scientific (toBoundedInteger, toBoundedRealFloat) +import qualified Data.Text as Text +import qualified Network.Monitoring.Riemann.Proto.Attribute as PA +import qualified Network.Monitoring.Riemann.Proto.Event as PE +import qualified Text.ProtocolBuffers.Header as P' instance ToJSON P'.Utf8 where toJSON v = String (Text.pack (P'.uToString v)) @@ -32,24 +36,27 @@ instance ToJSON PE.Event instance FromJSON PE.Event where - parseJSON = withObject "Event" $ \v -> do - time <- v .:? "time" - state <- v .:? "state" - service <- v .:? "service" - host <- v .:? "host" - description <- v .:? "description" - tags <- v .:? "tags" .!= [] - ttl <- v .:? "ttl" - attributes <- v .:? "attributes" .!= [] - mMetric_sint64 <- v .:? "metric_sint64" - mMetric_d <- v .:? "metric_d" - mMetric_f <- v .:? "metric_f" - mMetric <- v .:? "metric" - let metric_sint64 = mMetric_sint64 <|> (toBoundedInteger =<< mMetric) - metric_d = mMetric_d <|> (rightToJust . toBoundedRealFloat =<< mMetric) - metric_f = mMetric_f <|> (rightToJust . toBoundedRealFloat =<< mMetric) - pure Event { .. } + parseJSON = + withObject "Event" $ \v -> do + time <- v .:? "time" + state <- v .:? "state" + service <- v .:? "service" + host <- v .:? "host" + description <- v .:? "description" + tags <- v .:? "tags" .!= [] + ttl <- v .:? "ttl" + attributes <- v .:? "attributes" .!= [] + mMetric_sint64 <- v .:? "metric_sint64" + mMetric_d <- v .:? "metric_d" + mMetric_f <- v .:? "metric_f" + mMetric <- v .:? "metric" + let metric_sint64 = mMetric_sint64 <|> (toBoundedInteger =<< mMetric) + metric_d = + mMetric_d <|> (rightToJust . toBoundedRealFloat =<< mMetric) + metric_f = + mMetric_f <|> (rightToJust . toBoundedRealFloat =<< mMetric) + pure PE.Event {..} rightToJust :: Either l r -> Maybe r -rightToJust (Left _) = Nothing +rightToJust (Left _) = Nothing rightToJust (Right v) = Just v diff --git a/src/Network/Monitoring/Riemann/LoggingClient.hs b/src/Network/Monitoring/Riemann/LoggingClient.hs --- a/src/Network/Monitoring/Riemann/LoggingClient.hs +++ b/src/Network/Monitoring/Riemann/LoggingClient.hs @@ -1,8 +1,13 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + module Network.Monitoring.Riemann.LoggingClient where -import Network.Monitoring.Riemann.Client +import Control.Monad.IO.Class (MonadIO, liftIO) +import Network.Monitoring.Riemann.Client (Client, close, sendEvent) -data LoggingClient = LoggingClient +data LoggingClient = + LoggingClient {-| A new LoggingClient @@ -12,6 +17,6 @@ loggingClient :: LoggingClient loggingClient = LoggingClient -instance Client LoggingClient where - sendEvent _ = print - close _ = print "close" +instance MonadIO m => Client m LoggingClient where + sendEvent _ = liftIO . print + close _ = liftIO $ print "close" diff --git a/src/Network/Monitoring/Riemann/Proto/Attribute.hs b/src/Network/Monitoring/Riemann/Proto/Attribute.hs --- a/src/Network/Monitoring/Riemann/Proto/Attribute.hs +++ b/src/Network/Monitoring/Riemann/Proto/Attribute.hs @@ -1,53 +1,72 @@ -{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -module Network.Monitoring.Riemann.Proto.Attribute (Attribute(..)) where -import Prelude ((+), (/)) -import qualified Prelude as Prelude' -import qualified Data.Typeable as Prelude' -import qualified GHC.Generics as Prelude' +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, + FlexibleInstances, MultiParamTypeClasses #-} + +module Network.Monitoring.Riemann.Proto.Attribute + ( Attribute(..) + ) where + import qualified Data.Data as Prelude' +import qualified GHC.Generics as Prelude' +import Prelude ((+)) +import qualified Prelude as Prelude' import qualified Text.ProtocolBuffers.Header as P' -data Attribute = Attribute{key :: !(P'.Utf8), value :: !(P'.Maybe P'.Utf8)} - deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) +data Attribute = Attribute + { key :: !P'.Utf8 + , value :: !(P'.Maybe P'.Utf8) + } deriving ( Prelude'.Show + , Prelude'.Eq + , Prelude'.Ord + , Prelude'.Typeable + , Prelude'.Data + , Prelude'.Generic + ) instance P'.Mergeable Attribute where - mergeAppend (Attribute x'1 x'2) (Attribute y'1 y'2) = Attribute (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) + mergeAppend (Attribute x'1 x'2) (Attribute y'1 y'2) = + Attribute (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) instance P'.Default Attribute where defaultValue = Attribute P'.defaultValue P'.defaultValue instance P'.Wire Attribute where - wireSize ft' self'@(Attribute x'1 x'2) - = case ft' of - 10 -> calc'Size - 11 -> P'.prependMessageSize calc'Size - _ -> P'.wireSizeErr ft' self' - where - calc'Size = (P'.wireSizeReq 1 9 x'1 + P'.wireSizeOpt 1 9 x'2) - wirePut ft' self'@(Attribute x'1 x'2) - = case ft' of - 10 -> put'Fields - 11 -> do - P'.putSize (P'.wireSize 10 self') - put'Fields - _ -> P'.wirePutErr ft' self' + wireSize ft' self'@(Attribute x'1 x'2) = + case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' where + calc'Size = P'.wireSizeReq 1 9 x'1 + P'.wireSizeOpt 1 9 x'2 + wirePut ft' self'@(Attribute x'1 x'2) = + case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') put'Fields - = do - P'.wirePutReq 10 9 x'1 - P'.wirePutOpt 18 9 x'2 - wireGet ft' - = case ft' of - 10 -> P'.getBareMessageWith update'Self - 11 -> P'.getMessageWith update'Self - _ -> P'.wireGetErr ft' + _ -> P'.wirePutErr ft' self' where - update'Self wire'Tag old'Self - = case wire'Tag of - 10 -> Prelude'.fmap (\ !new'Field -> old'Self{key = new'Field}) (P'.wireGet 9) - 18 -> Prelude'.fmap (\ !new'Field -> old'Self{value = Prelude'.Just new'Field}) (P'.wireGet 9) - _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + put'Fields = do + P'.wirePutReq 10 9 x'1 + P'.wirePutOpt 18 9 x'2 + wireGet ft' = + case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self = + case wire'Tag of + 10 -> + Prelude'.fmap + (\ !new'Field -> old'Self {key = new'Field}) + (P'.wireGet 9) + 18 -> + Prelude'.fmap + (\ !new'Field -> old'Self {value = Prelude'.Just new'Field}) + (P'.wireGet 9) + _ -> + let (field'Number, wire'Type) = P'.splitWireTag wire'Tag + in P'.unknown field'Number wire'Type old'Self instance P'.MessageAPI msg' (msg' -> Attribute) Attribute where getVal m' f' = f' m' @@ -55,9 +74,12 @@ instance P'.GPB Attribute instance P'.ReflectDescriptor Attribute where - getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList [10]) (P'.fromDistinctAscList [10, 18]) - reflectDescriptorInfo _ - = Prelude'.read + getMessageInfo _ = + P'.GetMessageInfo + (P'.fromDistinctAscList [10]) + (P'.fromDistinctAscList [10, 18]) + reflectDescriptorInfo _ = + Prelude'.read "DescriptorInfo {descName = ProtoName {protobufName = FIName \".Proto.Attribute\", haskellPrefix = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule = [MName \"Proto\"], baseName = MName \"Attribute\"}, descFilePath = [\"Network\",\"Monitoring\",\"Riemann\",\"Proto\",\"Attribute.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Attribute.key\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Attribute\"], baseName' = FName \"key\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = True, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Attribute.value\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Attribute\"], baseName' = FName \"value\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" instance P'.TextType Attribute where @@ -65,22 +87,18 @@ getT = P'.getSubMessage instance P'.TextMsg Attribute where - textPut msg - = do - P'.tellT "key" (key msg) - P'.tellT "value" (value msg) - textGet - = do - mods <- P'.sepEndBy (P'.choice [parse'key, parse'value]) P'.spaces - Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + textPut msg = do + P'.tellT "key" (key msg) + P'.tellT "value" (value msg) + textGet = do + mods <- P'.sepEndBy (P'.choice [parse'key, parse'value]) P'.spaces + Prelude'.return (Prelude'.foldl (\v f -> f v) P'.defaultValue mods) where - parse'key - = P'.try - (do - v <- P'.getT "key" - Prelude'.return (\ o -> o{key = v})) - parse'value - = P'.try - (do - v <- P'.getT "value" - Prelude'.return (\ o -> o{value = v})) + parse'key = + P'.try + (do v <- P'.getT "key" + Prelude'.return (\o -> o {key = v})) + parse'value = + P'.try + (do v <- P'.getT "value" + Prelude'.return (\o -> o {value = v})) diff --git a/src/Network/Monitoring/Riemann/Proto/Event.hs b/src/Network/Monitoring/Riemann/Proto/Event.hs --- a/src/Network/Monitoring/Riemann/Proto/Event.hs +++ b/src/Network/Monitoring/Riemann/Proto/Event.hs @@ -1,23 +1,44 @@ -{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -module Network.Monitoring.Riemann.Proto.Event (Event(..)) where -import Prelude ((+), (/)) -import qualified Prelude as Prelude' -import qualified Data.Typeable as Prelude' -import qualified GHC.Generics as Prelude' +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, + FlexibleInstances, MultiParamTypeClasses #-} + +module Network.Monitoring.Riemann.Proto.Event + ( Event(..) + ) where + import qualified Data.Data as Prelude' -import qualified Text.ProtocolBuffers.Header as P' +import qualified GHC.Generics as Prelude' import qualified Network.Monitoring.Riemann.Proto.Attribute as Proto (Attribute) +import Prelude ((+)) +import qualified Prelude as Prelude' +import qualified Text.ProtocolBuffers.Header as P' -data Event = Event{time :: !(P'.Maybe P'.Int64), state :: !(P'.Maybe P'.Utf8), service :: !(P'.Maybe P'.Utf8), - host :: !(P'.Maybe P'.Utf8), description :: !(P'.Maybe P'.Utf8), tags :: !(P'.Seq P'.Utf8), - ttl :: !(P'.Maybe P'.Float), attributes :: !(P'.Seq Proto.Attribute), metric_sint64 :: !(P'.Maybe P'.Int64), - metric_d :: !(P'.Maybe P'.Double), metric_f :: !(P'.Maybe P'.Float)} - deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) +data Event = Event + { time :: !(P'.Maybe P'.Int64) + , state :: !(P'.Maybe P'.Utf8) + , service :: !(P'.Maybe P'.Utf8) + , host :: !(P'.Maybe P'.Utf8) + , description :: !(P'.Maybe P'.Utf8) + , tags :: !(P'.Seq P'.Utf8) + , ttl :: !(P'.Maybe P'.Float) + , attributes :: !(P'.Seq Proto.Attribute) + , metric_sint64 :: !(P'.Maybe P'.Int64) + , metric_d :: !(P'.Maybe P'.Double) + , metric_f :: !(P'.Maybe P'.Float) + } deriving ( Prelude'.Show + , Prelude'.Eq + , Prelude'.Ord + , Prelude'.Typeable + , Prelude'.Data + , Prelude'.Generic + ) instance P'.Mergeable Event where - mergeAppend (Event x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8 x'9 x'10 x'11) (Event y'1 y'2 y'3 y'4 y'5 y'6 y'7 y'8 y'9 y'10 y'11) - = Event (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) (P'.mergeAppend x'3 y'3) (P'.mergeAppend x'4 y'4) + mergeAppend (Event x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8 x'9 x'10 x'11) (Event y'1 y'2 y'3 y'4 y'5 y'6 y'7 y'8 y'9 y'10 y'11) = + Event + (P'.mergeAppend x'1 y'1) + (P'.mergeAppend x'2 y'2) + (P'.mergeAppend x'3 y'3) + (P'.mergeAppend x'4 y'4) (P'.mergeAppend x'5 y'5) (P'.mergeAppend x'6 y'6) (P'.mergeAppend x'7 y'7) @@ -27,70 +48,116 @@ (P'.mergeAppend x'11 y'11) instance P'.Default Event where - defaultValue - = Event P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue + defaultValue = + Event P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue + P'.defaultValue + P'.defaultValue + P'.defaultValue + P'.defaultValue + P'.defaultValue + P'.defaultValue + P'.defaultValue instance P'.Wire Event where - wireSize ft' self'@(Event x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8 x'9 x'10 x'11) - = case ft' of - 10 -> calc'Size - 11 -> P'.prependMessageSize calc'Size - _ -> P'.wireSizeErr ft' self' - where - calc'Size - = (P'.wireSizeOpt 1 3 x'1 + P'.wireSizeOpt 1 9 x'2 + P'.wireSizeOpt 1 9 x'3 + P'.wireSizeOpt 1 9 x'4 + - P'.wireSizeOpt 1 9 x'5 - + P'.wireSizeRep 1 9 x'6 - + P'.wireSizeOpt 1 2 x'7 - + P'.wireSizeRep 1 11 x'8 - + P'.wireSizeOpt 1 18 x'9 - + P'.wireSizeOpt 1 1 x'10 - + P'.wireSizeOpt 1 2 x'11) - wirePut ft' self'@(Event x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8 x'9 x'10 x'11) - = case ft' of - 10 -> put'Fields - 11 -> do - P'.putSize (P'.wireSize 10 self') - put'Fields - _ -> P'.wirePutErr ft' self' + wireSize ft' self'@(Event x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8 x'9 x'10 x'11) = + case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' where + calc'Size = + P'.wireSizeOpt 1 3 x'1 + P'.wireSizeOpt 1 9 x'2 + P'.wireSizeOpt 1 9 x'3 + + P'.wireSizeOpt 1 9 x'4 + + P'.wireSizeOpt 1 9 x'5 + + P'.wireSizeRep 1 9 x'6 + + P'.wireSizeOpt 1 2 x'7 + + P'.wireSizeRep 1 11 x'8 + + P'.wireSizeOpt 1 18 x'9 + + P'.wireSizeOpt 1 1 x'10 + + P'.wireSizeOpt 1 2 x'11 + wirePut ft' self'@(Event x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8 x'9 x'10 x'11) = + case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') put'Fields - = do - P'.wirePutOpt 8 3 x'1 - P'.wirePutOpt 18 9 x'2 - P'.wirePutOpt 26 9 x'3 - P'.wirePutOpt 34 9 x'4 - P'.wirePutOpt 42 9 x'5 - P'.wirePutRep 58 9 x'6 - P'.wirePutOpt 69 2 x'7 - P'.wirePutRep 74 11 x'8 - P'.wirePutOpt 104 18 x'9 - P'.wirePutOpt 113 1 x'10 - P'.wirePutOpt 125 2 x'11 - wireGet ft' - = case ft' of - 10 -> P'.getBareMessageWith update'Self - 11 -> P'.getMessageWith update'Self - _ -> P'.wireGetErr ft' + _ -> P'.wirePutErr ft' self' where - update'Self wire'Tag old'Self - = case wire'Tag of - 8 -> Prelude'.fmap (\ !new'Field -> old'Self{time = Prelude'.Just new'Field}) (P'.wireGet 3) - 18 -> Prelude'.fmap (\ !new'Field -> old'Self{state = Prelude'.Just new'Field}) (P'.wireGet 9) - 26 -> Prelude'.fmap (\ !new'Field -> old'Self{service = Prelude'.Just new'Field}) (P'.wireGet 9) - 34 -> Prelude'.fmap (\ !new'Field -> old'Self{host = Prelude'.Just new'Field}) (P'.wireGet 9) - 42 -> Prelude'.fmap (\ !new'Field -> old'Self{description = Prelude'.Just new'Field}) (P'.wireGet 9) - 58 -> Prelude'.fmap (\ !new'Field -> old'Self{tags = P'.append (tags old'Self) new'Field}) (P'.wireGet 9) - 69 -> Prelude'.fmap (\ !new'Field -> old'Self{ttl = Prelude'.Just new'Field}) (P'.wireGet 2) - 74 -> Prelude'.fmap (\ !new'Field -> old'Self{attributes = P'.append (attributes old'Self) new'Field}) (P'.wireGet 11) - 104 -> Prelude'.fmap (\ !new'Field -> old'Self{metric_sint64 = Prelude'.Just new'Field}) (P'.wireGet 18) - 113 -> Prelude'.fmap (\ !new'Field -> old'Self{metric_d = Prelude'.Just new'Field}) (P'.wireGet 1) - 125 -> Prelude'.fmap (\ !new'Field -> old'Self{metric_f = Prelude'.Just new'Field}) (P'.wireGet 2) - _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + put'Fields = do + P'.wirePutOpt 8 3 x'1 + P'.wirePutOpt 18 9 x'2 + P'.wirePutOpt 26 9 x'3 + P'.wirePutOpt 34 9 x'4 + P'.wirePutOpt 42 9 x'5 + P'.wirePutRep 58 9 x'6 + P'.wirePutOpt 69 2 x'7 + P'.wirePutRep 74 11 x'8 + P'.wirePutOpt 104 18 x'9 + P'.wirePutOpt 113 1 x'10 + P'.wirePutOpt 125 2 x'11 + wireGet ft' = + case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self = + case wire'Tag of + 8 -> + Prelude'.fmap + (\ !new'Field -> old'Self {time = Prelude'.Just new'Field}) + (P'.wireGet 3) + 18 -> + Prelude'.fmap + (\ !new'Field -> old'Self {state = Prelude'.Just new'Field}) + (P'.wireGet 9) + 26 -> + Prelude'.fmap + (\ !new'Field -> old'Self {service = Prelude'.Just new'Field}) + (P'.wireGet 9) + 34 -> + Prelude'.fmap + (\ !new'Field -> old'Self {host = Prelude'.Just new'Field}) + (P'.wireGet 9) + 42 -> + Prelude'.fmap + (\ !new'Field -> old'Self {description = Prelude'.Just new'Field}) + (P'.wireGet 9) + 58 -> + Prelude'.fmap + (\ !new'Field -> + old'Self {tags = P'.append (tags old'Self) new'Field}) + (P'.wireGet 9) + 69 -> + Prelude'.fmap + (\ !new'Field -> old'Self {ttl = Prelude'.Just new'Field}) + (P'.wireGet 2) + 74 -> + Prelude'.fmap + (\ !new'Field -> + old'Self + {attributes = P'.append (attributes old'Self) new'Field}) + (P'.wireGet 11) + 104 -> + Prelude'.fmap + (\ !new'Field -> + old'Self {metric_sint64 = Prelude'.Just new'Field}) + (P'.wireGet 18) + 113 -> + Prelude'.fmap + (\ !new'Field -> old'Self {metric_d = Prelude'.Just new'Field}) + (P'.wireGet 1) + 125 -> + Prelude'.fmap + (\ !new'Field -> old'Self {metric_f = Prelude'.Just new'Field}) + (P'.wireGet 2) + _ -> + let (field'Number, wire'Type) = P'.splitWireTag wire'Tag + in P'.unknown field'Number wire'Type old'Self instance P'.MessageAPI msg' (msg' -> Event) Event where getVal m' f' = f' m' @@ -98,10 +165,12 @@ instance P'.GPB Event instance P'.ReflectDescriptor Event where - getMessageInfo _ - = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [8, 18, 26, 34, 42, 58, 69, 74, 104, 113, 125]) - reflectDescriptorInfo _ - = Prelude'.read + getMessageInfo _ = + P'.GetMessageInfo + (P'.fromDistinctAscList []) + (P'.fromDistinctAscList [8, 18, 26, 34, 42, 58, 69, 74, 104, 113, 125]) + reflectDescriptorInfo _ = + Prelude'.read "DescriptorInfo {descName = ProtoName {protobufName = FIName \".Proto.Event\", haskellPrefix = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule = [MName \"Proto\"], baseName = MName \"Event\"}, descFilePath = [\"Network\",\"Monitoring\",\"Riemann\",\"Proto\",\"Event.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Event.time\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Event\"], baseName' = FName \"time\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 3}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Event.state\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Event\"], baseName' = FName \"state\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Event.service\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Event\"], baseName' = FName \"service\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 26}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Event.host\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Event\"], baseName' = FName \"host\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 4}, wireTag = WireTag {getWireTag = 34}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Event.description\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Event\"], baseName' = FName \"description\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 5}, wireTag = WireTag {getWireTag = 42}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Event.tags\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Event\"], baseName' = FName \"tags\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 7}, wireTag = WireTag {getWireTag = 58}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Event.ttl\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Event\"], baseName' = FName \"ttl\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 8}, wireTag = WireTag {getWireTag = 69}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 2}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Event.attributes\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Event\"], baseName' = FName \"attributes\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 9}, wireTag = WireTag {getWireTag = 74}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Proto.Attribute\", haskellPrefix = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule = [MName \"Proto\"], baseName = MName \"Attribute\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Event.metric_sint64\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Event\"], baseName' = FName \"metric_sint64\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 13}, wireTag = WireTag {getWireTag = 104}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 18}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Event.metric_d\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Event\"], baseName' = FName \"metric_d\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 14}, wireTag = WireTag {getWireTag = 113}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 1}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Event.metric_f\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Event\"], baseName' = FName \"metric_f\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 15}, wireTag = WireTag {getWireTag = 125}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 2}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" instance P'.TextType Event where @@ -109,80 +178,79 @@ getT = P'.getSubMessage instance P'.TextMsg Event where - textPut msg - = do - P'.tellT "time" (time msg) - P'.tellT "state" (state msg) - P'.tellT "service" (service msg) - P'.tellT "host" (host msg) - P'.tellT "description" (description msg) - P'.tellT "tags" (tags msg) - P'.tellT "ttl" (ttl msg) - P'.tellT "attributes" (attributes msg) - P'.tellT "metric_sint64" (metric_sint64 msg) - P'.tellT "metric_d" (metric_d msg) - P'.tellT "metric_f" (metric_f msg) - textGet - = do - mods <- P'.sepEndBy - (P'.choice - [parse'time, parse'state, parse'service, parse'host, parse'description, parse'tags, parse'ttl, parse'attributes, - parse'metric_sint64, parse'metric_d, parse'metric_f]) - P'.spaces - Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + textPut msg = do + P'.tellT "time" (time msg) + P'.tellT "state" (state msg) + P'.tellT "service" (service msg) + P'.tellT "host" (host msg) + P'.tellT "description" (description msg) + P'.tellT "tags" (tags msg) + P'.tellT "ttl" (ttl msg) + P'.tellT "attributes" (attributes msg) + P'.tellT "metric_sint64" (metric_sint64 msg) + P'.tellT "metric_d" (metric_d msg) + P'.tellT "metric_f" (metric_f msg) + textGet = do + mods <- + P'.sepEndBy + (P'.choice + [ parse'time + , parse'state + , parse'service + , parse'host + , parse'description + , parse'tags + , parse'ttl + , parse'attributes + , parse'metric_sint64 + , parse'metric_d + , parse'metric_f + ]) + P'.spaces + Prelude'.return (Prelude'.foldl (\v f -> f v) P'.defaultValue mods) where - parse'time - = P'.try - (do - v <- P'.getT "time" - Prelude'.return (\ o -> o{time = v})) - parse'state - = P'.try - (do - v <- P'.getT "state" - Prelude'.return (\ o -> o{state = v})) - parse'service - = P'.try - (do - v <- P'.getT "service" - Prelude'.return (\ o -> o{service = v})) - parse'host - = P'.try - (do - v <- P'.getT "host" - Prelude'.return (\ o -> o{host = v})) - parse'description - = P'.try - (do - v <- P'.getT "description" - Prelude'.return (\ o -> o{description = v})) - parse'tags - = P'.try - (do - v <- P'.getT "tags" - Prelude'.return (\ o -> o{tags = P'.append (tags o) v})) - parse'ttl - = P'.try - (do - v <- P'.getT "ttl" - Prelude'.return (\ o -> o{ttl = v})) - parse'attributes - = P'.try - (do - v <- P'.getT "attributes" - Prelude'.return (\ o -> o{attributes = P'.append (attributes o) v})) - parse'metric_sint64 - = P'.try - (do - v <- P'.getT "metric_sint64" - Prelude'.return (\ o -> o{metric_sint64 = v})) - parse'metric_d - = P'.try - (do - v <- P'.getT "metric_d" - Prelude'.return (\ o -> o{metric_d = v})) - parse'metric_f - = P'.try - (do - v <- P'.getT "metric_f" - Prelude'.return (\ o -> o{metric_f = v})) + parse'time = + P'.try + (do v <- P'.getT "time" + Prelude'.return (\o -> o {time = v})) + parse'state = + P'.try + (do v <- P'.getT "state" + Prelude'.return (\o -> o {state = v})) + parse'service = + P'.try + (do v <- P'.getT "service" + Prelude'.return (\o -> o {service = v})) + parse'host = + P'.try + (do v <- P'.getT "host" + Prelude'.return (\o -> o {host = v})) + parse'description = + P'.try + (do v <- P'.getT "description" + Prelude'.return (\o -> o {description = v})) + parse'tags = + P'.try + (do v <- P'.getT "tags" + Prelude'.return (\o -> o {tags = P'.append (tags o) v})) + parse'ttl = + P'.try + (do v <- P'.getT "ttl" + Prelude'.return (\o -> o {ttl = v})) + parse'attributes = + P'.try + (do v <- P'.getT "attributes" + Prelude'.return + (\o -> o {attributes = P'.append (attributes o) v})) + parse'metric_sint64 = + P'.try + (do v <- P'.getT "metric_sint64" + Prelude'.return (\o -> o {metric_sint64 = v})) + parse'metric_d = + P'.try + (do v <- P'.getT "metric_d" + Prelude'.return (\o -> o {metric_d = v})) + parse'metric_f = + P'.try + (do v <- P'.getT "metric_f" + Prelude'.return (\o -> o {metric_f = v})) diff --git a/src/Network/Monitoring/Riemann/Proto/Msg.hs b/src/Network/Monitoring/Riemann/Proto/Msg.hs --- a/src/Network/Monitoring/Riemann/Proto/Msg.hs +++ b/src/Network/Monitoring/Riemann/Proto/Msg.hs @@ -1,68 +1,114 @@ -{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -module Network.Monitoring.Riemann.Proto.Msg (Msg(..)) where -import Prelude ((+), (/)) -import qualified Prelude as Prelude' -import qualified Data.Typeable as Prelude' -import qualified GHC.Generics as Prelude' +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, + FlexibleInstances, MultiParamTypeClasses #-} + +module Network.Monitoring.Riemann.Proto.Msg + ( Msg(..) + ) where + import qualified Data.Data as Prelude' -import qualified Text.ProtocolBuffers.Header as P' +import qualified GHC.Generics as Prelude' import qualified Network.Monitoring.Riemann.Proto.Event as Proto (Event) import qualified Network.Monitoring.Riemann.Proto.Query as Proto (Query) import qualified Network.Monitoring.Riemann.Proto.State as Proto (State) +import Prelude ((+)) +import qualified Prelude as Prelude' +import qualified Text.ProtocolBuffers.Header as P' -data Msg = Msg{ok :: !(P'.Maybe P'.Bool), error :: !(P'.Maybe P'.Utf8), states :: !(P'.Seq Proto.State), - query :: !(P'.Maybe Proto.Query), events :: !(P'.Seq Proto.Event)} - deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) +data Msg = Msg + { ok :: !(P'.Maybe P'.Bool) + , error :: !(P'.Maybe P'.Utf8) + , states :: !(P'.Seq Proto.State) + , query :: !(P'.Maybe Proto.Query) + , events :: !(P'.Seq Proto.Event) + } deriving ( Prelude'.Show + , Prelude'.Eq + , Prelude'.Ord + , Prelude'.Typeable + , Prelude'.Data + , Prelude'.Generic + ) instance P'.Mergeable Msg where - mergeAppend (Msg x'1 x'2 x'3 x'4 x'5) (Msg y'1 y'2 y'3 y'4 y'5) - = Msg (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) (P'.mergeAppend x'3 y'3) (P'.mergeAppend x'4 y'4) + mergeAppend (Msg x'1 x'2 x'3 x'4 x'5) (Msg y'1 y'2 y'3 y'4 y'5) = + Msg + (P'.mergeAppend x'1 y'1) + (P'.mergeAppend x'2 y'2) + (P'.mergeAppend x'3 y'3) + (P'.mergeAppend x'4 y'4) (P'.mergeAppend x'5 y'5) instance P'.Default Msg where - defaultValue = Msg P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue + defaultValue = + Msg + P'.defaultValue + P'.defaultValue + P'.defaultValue + P'.defaultValue + P'.defaultValue instance P'.Wire Msg where - wireSize ft' self'@(Msg x'1 x'2 x'3 x'4 x'5) - = case ft' of - 10 -> calc'Size - 11 -> P'.prependMessageSize calc'Size - _ -> P'.wireSizeErr ft' self' - where - calc'Size - = (P'.wireSizeOpt 1 8 x'1 + P'.wireSizeOpt 1 9 x'2 + P'.wireSizeRep 1 11 x'3 + P'.wireSizeOpt 1 11 x'4 + - P'.wireSizeRep 1 11 x'5) - wirePut ft' self'@(Msg x'1 x'2 x'3 x'4 x'5) - = case ft' of - 10 -> put'Fields - 11 -> do - P'.putSize (P'.wireSize 10 self') - put'Fields - _ -> P'.wirePutErr ft' self' + wireSize ft' self'@(Msg x'1 x'2 x'3 x'4 x'5) = + case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' where + calc'Size = + P'.wireSizeOpt 1 8 x'1 + P'.wireSizeOpt 1 9 x'2 + + P'.wireSizeRep 1 11 x'3 + + P'.wireSizeOpt 1 11 x'4 + + P'.wireSizeRep 1 11 x'5 + wirePut ft' self'@(Msg x'1 x'2 x'3 x'4 x'5) = + case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') put'Fields - = do - P'.wirePutOpt 16 8 x'1 - P'.wirePutOpt 26 9 x'2 - P'.wirePutRep 34 11 x'3 - P'.wirePutOpt 42 11 x'4 - P'.wirePutRep 50 11 x'5 - wireGet ft' - = case ft' of - 10 -> P'.getBareMessageWith update'Self - 11 -> P'.getMessageWith update'Self - _ -> P'.wireGetErr ft' + _ -> P'.wirePutErr ft' self' where - update'Self wire'Tag old'Self - = case wire'Tag of - 16 -> Prelude'.fmap (\ !new'Field -> old'Self{ok = Prelude'.Just new'Field}) (P'.wireGet 8) - 26 -> Prelude'.fmap (\ !new'Field -> old'Self{error = Prelude'.Just new'Field}) (P'.wireGet 9) - 34 -> Prelude'.fmap (\ !new'Field -> old'Self{states = P'.append (states old'Self) new'Field}) (P'.wireGet 11) - 42 -> Prelude'.fmap (\ !new'Field -> old'Self{query = P'.mergeAppend (query old'Self) (Prelude'.Just new'Field)}) - (P'.wireGet 11) - 50 -> Prelude'.fmap (\ !new'Field -> old'Self{events = P'.append (events old'Self) new'Field}) (P'.wireGet 11) - _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + put'Fields = do + P'.wirePutOpt 16 8 x'1 + P'.wirePutOpt 26 9 x'2 + P'.wirePutRep 34 11 x'3 + P'.wirePutOpt 42 11 x'4 + P'.wirePutRep 50 11 x'5 + wireGet ft' = + case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self = + case wire'Tag of + 16 -> + Prelude'.fmap + (\ !new'Field -> old'Self {ok = Prelude'.Just new'Field}) + (P'.wireGet 8) + 26 -> + Prelude'.fmap + (\ !new'Field -> old'Self {error = Prelude'.Just new'Field}) + (P'.wireGet 9) + 34 -> + Prelude'.fmap + (\ !new'Field -> + old'Self {states = P'.append (states old'Self) new'Field}) + (P'.wireGet 11) + 42 -> + Prelude'.fmap + (\ !new'Field -> + old'Self + { query = + P'.mergeAppend (query old'Self) (Prelude'.Just new'Field) + }) + (P'.wireGet 11) + 50 -> + Prelude'.fmap + (\ !new'Field -> + old'Self {events = P'.append (events old'Self) new'Field}) + (P'.wireGet 11) + _ -> + let (field'Number, wire'Type) = P'.splitWireTag wire'Tag + in P'.unknown field'Number wire'Type old'Self instance P'.MessageAPI msg' (msg' -> Msg) Msg where getVal m' f' = f' m' @@ -70,9 +116,12 @@ instance P'.GPB Msg instance P'.ReflectDescriptor Msg where - getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [16, 26, 34, 42, 50]) - reflectDescriptorInfo _ - = Prelude'.read + getMessageInfo _ = + P'.GetMessageInfo + (P'.fromDistinctAscList []) + (P'.fromDistinctAscList [16, 26, 34, 42, 50]) + reflectDescriptorInfo _ = + Prelude'.read "DescriptorInfo {descName = ProtoName {protobufName = FIName \".Proto.Msg\", haskellPrefix = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule = [MName \"Proto\"], baseName = MName \"Msg\"}, descFilePath = [\"Network\",\"Monitoring\",\"Riemann\",\"Proto\",\"Msg.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Msg.ok\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Msg\"], baseName' = FName \"ok\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 16}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 8}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Msg.error\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Msg\"], baseName' = FName \"error\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 26}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Msg.states\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Msg\"], baseName' = FName \"states\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 4}, wireTag = WireTag {getWireTag = 34}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Proto.State\", haskellPrefix = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule = [MName \"Proto\"], baseName = MName \"State\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Msg.query\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Msg\"], baseName' = FName \"query\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 5}, wireTag = WireTag {getWireTag = 42}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Proto.Query\", haskellPrefix = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule = [MName \"Proto\"], baseName = MName \"Query\"}), hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Msg.events\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Msg\"], baseName' = FName \"events\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 6}, wireTag = WireTag {getWireTag = 50}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 11}, typeName = Just (ProtoName {protobufName = FIName \".Proto.Event\", haskellPrefix = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule = [MName \"Proto\"], baseName = MName \"Event\"}), hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" instance P'.TextType Msg where @@ -80,40 +129,37 @@ getT = P'.getSubMessage instance P'.TextMsg Msg where - textPut msg - = do - P'.tellT "ok" (ok msg) - P'.tellT "error" (error msg) - P'.tellT "states" (states msg) - P'.tellT "query" (query msg) - P'.tellT "events" (events msg) - textGet - = do - mods <- P'.sepEndBy (P'.choice [parse'ok, parse'error, parse'states, parse'query, parse'events]) P'.spaces - Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + textPut msg = do + P'.tellT "ok" (ok msg) + P'.tellT "error" (error msg) + P'.tellT "states" (states msg) + P'.tellT "query" (query msg) + P'.tellT "events" (events msg) + textGet = do + mods <- + P'.sepEndBy + (P'.choice + [parse'ok, parse'error, parse'states, parse'query, parse'events]) + P'.spaces + Prelude'.return (Prelude'.foldl (\v f -> f v) P'.defaultValue mods) where - parse'ok - = P'.try - (do - v <- P'.getT "ok" - Prelude'.return (\ o -> o{ok = v})) - parse'error - = P'.try - (do - v <- P'.getT "error" - Prelude'.return (\ o -> o{error = v})) - parse'states - = P'.try - (do - v <- P'.getT "states" - Prelude'.return (\ o -> o{states = P'.append (states o) v})) - parse'query - = P'.try - (do - v <- P'.getT "query" - Prelude'.return (\ o -> o{query = v})) - parse'events - = P'.try - (do - v <- P'.getT "events" - Prelude'.return (\ o -> o{events = P'.append (events o) v})) + parse'ok = + P'.try + (do v <- P'.getT "ok" + Prelude'.return (\o -> o {ok = v})) + parse'error = + P'.try + (do v <- P'.getT "error" + Prelude'.return (\o -> o {error = v})) + parse'states = + P'.try + (do v <- P'.getT "states" + Prelude'.return (\o -> o {states = P'.append (states o) v})) + parse'query = + P'.try + (do v <- P'.getT "query" + Prelude'.return (\o -> o {query = v})) + parse'events = + P'.try + (do v <- P'.getT "events" + Prelude'.return (\o -> o {events = P'.append (events o) v})) diff --git a/src/Network/Monitoring/Riemann/Proto/Query.hs b/src/Network/Monitoring/Riemann/Proto/Query.hs --- a/src/Network/Monitoring/Riemann/Proto/Query.hs +++ b/src/Network/Monitoring/Riemann/Proto/Query.hs @@ -1,15 +1,24 @@ -{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -module Network.Monitoring.Riemann.Proto.Query (Query(..)) where -import Prelude ((+), (/)) -import qualified Prelude as Prelude' -import qualified Data.Typeable as Prelude' -import qualified GHC.Generics as Prelude' +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, + FlexibleInstances, MultiParamTypeClasses #-} + +module Network.Monitoring.Riemann.Proto.Query + ( Query(..) + ) where + import qualified Data.Data as Prelude' +import qualified GHC.Generics as Prelude' +import qualified Prelude as Prelude' import qualified Text.ProtocolBuffers.Header as P' -data Query = Query{string :: !(P'.Maybe P'.Utf8)} - deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) +newtype Query = Query + { string :: P'.Maybe P'.Utf8 + } deriving ( Prelude'.Show + , Prelude'.Eq + , Prelude'.Ord + , Prelude'.Typeable + , Prelude'.Data + , Prelude'.Generic + ) instance P'.Mergeable Query where mergeAppend (Query x'1) (Query y'1) = Query (P'.mergeAppend x'1 y'1) @@ -18,34 +27,37 @@ defaultValue = Query P'.defaultValue instance P'.Wire Query where - wireSize ft' self'@(Query x'1) - = case ft' of - 10 -> calc'Size - 11 -> P'.prependMessageSize calc'Size - _ -> P'.wireSizeErr ft' self' - where - calc'Size = (P'.wireSizeOpt 1 9 x'1) - wirePut ft' self'@(Query x'1) - = case ft' of - 10 -> put'Fields - 11 -> do - P'.putSize (P'.wireSize 10 self') - put'Fields - _ -> P'.wirePutErr ft' self' + wireSize ft' self'@(Query x'1) = + case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' where + calc'Size = P'.wireSizeOpt 1 9 x'1 + wirePut ft' self'@(Query x'1) = + case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') put'Fields - = do - P'.wirePutOpt 10 9 x'1 - wireGet ft' - = case ft' of - 10 -> P'.getBareMessageWith update'Self - 11 -> P'.getMessageWith update'Self - _ -> P'.wireGetErr ft' + _ -> P'.wirePutErr ft' self' where - update'Self wire'Tag old'Self - = case wire'Tag of - 10 -> Prelude'.fmap (\ !new'Field -> old'Self{string = Prelude'.Just new'Field}) (P'.wireGet 9) - _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + put'Fields = P'.wirePutOpt 10 9 x'1 + wireGet ft' = + case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self = + case wire'Tag of + 10 -> + Prelude'.fmap + (\ !new'Field -> old'Self {string = Prelude'.Just new'Field}) + (P'.wireGet 9) + _ -> + let (field'Number, wire'Type) = P'.splitWireTag wire'Tag + in P'.unknown field'Number wire'Type old'Self instance P'.MessageAPI msg' (msg' -> Query) Query where getVal m' f' = f' m' @@ -53,9 +65,10 @@ instance P'.GPB Query instance P'.ReflectDescriptor Query where - getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [10]) - reflectDescriptorInfo _ - = Prelude'.read + getMessageInfo _ = + P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [10]) + reflectDescriptorInfo _ = + Prelude'.read "DescriptorInfo {descName = ProtoName {protobufName = FIName \".Proto.Query\", haskellPrefix = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule = [MName \"Proto\"], baseName = MName \"Query\"}, descFilePath = [\"Network\",\"Monitoring\",\"Riemann\",\"Proto\",\"Query.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.Query.string\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"Query\"], baseName' = FName \"string\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 10}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" instance P'.TextType Query where @@ -63,16 +76,12 @@ getT = P'.getSubMessage instance P'.TextMsg Query where - textPut msg - = do - P'.tellT "string" (string msg) - textGet - = do - mods <- P'.sepEndBy (P'.choice [parse'string]) P'.spaces - Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + textPut msg = P'.tellT "string" (string msg) + textGet = do + mods <- P'.sepEndBy (P'.choice [parse'string]) P'.spaces + Prelude'.return (Prelude'.foldl (\v f -> f v) P'.defaultValue mods) where - parse'string - = P'.try - (do - v <- P'.getT "string" - Prelude'.return (\ o -> o{string = v})) + parse'string = + P'.try + (do v <- P'.getT "string" + Prelude'.return (\o -> o {string = v})) diff --git a/src/Network/Monitoring/Riemann/Proto/State.hs b/src/Network/Monitoring/Riemann/Proto/State.hs --- a/src/Network/Monitoring/Riemann/Proto/State.hs +++ b/src/Network/Monitoring/Riemann/Proto/State.hs @@ -1,79 +1,132 @@ -{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses #-} -{-# OPTIONS_GHC -fno-warn-unused-imports #-} -module Network.Monitoring.Riemann.Proto.State (State(..)) where -import Prelude ((+), (/)) -import qualified Prelude as Prelude' -import qualified Data.Typeable as Prelude' -import qualified GHC.Generics as Prelude' +{-# LANGUAGE BangPatterns, DeriveDataTypeable, DeriveGeneric, + FlexibleInstances, MultiParamTypeClasses #-} + +module Network.Monitoring.Riemann.Proto.State + ( State(..) + ) where + import qualified Data.Data as Prelude' +import qualified GHC.Generics as Prelude' +import Prelude ((+)) +import qualified Prelude as Prelude' import qualified Text.ProtocolBuffers.Header as P' -data State = State{time :: !(P'.Maybe P'.Int64), state :: !(P'.Maybe P'.Utf8), service :: !(P'.Maybe P'.Utf8), - host :: !(P'.Maybe P'.Utf8), description :: !(P'.Maybe P'.Utf8), once :: !(P'.Maybe P'.Bool), - tags :: !(P'.Seq P'.Utf8), ttl :: !(P'.Maybe P'.Float)} - deriving (Prelude'.Show, Prelude'.Eq, Prelude'.Ord, Prelude'.Typeable, Prelude'.Data, Prelude'.Generic) +data State = State + { time :: !(P'.Maybe P'.Int64) + , state :: !(P'.Maybe P'.Utf8) + , service :: !(P'.Maybe P'.Utf8) + , host :: !(P'.Maybe P'.Utf8) + , description :: !(P'.Maybe P'.Utf8) + , once :: !(P'.Maybe P'.Bool) + , tags :: !(P'.Seq P'.Utf8) + , ttl :: !(P'.Maybe P'.Float) + } deriving ( Prelude'.Show + , Prelude'.Eq + , Prelude'.Ord + , Prelude'.Typeable + , Prelude'.Data + , Prelude'.Generic + ) instance P'.Mergeable State where - mergeAppend (State x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8) (State y'1 y'2 y'3 y'4 y'5 y'6 y'7 y'8) - = State (P'.mergeAppend x'1 y'1) (P'.mergeAppend x'2 y'2) (P'.mergeAppend x'3 y'3) (P'.mergeAppend x'4 y'4) + mergeAppend (State x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8) (State y'1 y'2 y'3 y'4 y'5 y'6 y'7 y'8) = + State + (P'.mergeAppend x'1 y'1) + (P'.mergeAppend x'2 y'2) + (P'.mergeAppend x'3 y'3) + (P'.mergeAppend x'4 y'4) (P'.mergeAppend x'5 y'5) (P'.mergeAppend x'6 y'6) (P'.mergeAppend x'7 y'7) (P'.mergeAppend x'8 y'8) instance P'.Default State where - defaultValue - = State P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue P'.defaultValue + defaultValue = + State P'.defaultValue + P'.defaultValue + P'.defaultValue + P'.defaultValue + P'.defaultValue + P'.defaultValue + P'.defaultValue + P'.defaultValue instance P'.Wire State where - wireSize ft' self'@(State x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8) - = case ft' of - 10 -> calc'Size - 11 -> P'.prependMessageSize calc'Size - _ -> P'.wireSizeErr ft' self' - where - calc'Size - = (P'.wireSizeOpt 1 3 x'1 + P'.wireSizeOpt 1 9 x'2 + P'.wireSizeOpt 1 9 x'3 + P'.wireSizeOpt 1 9 x'4 + - P'.wireSizeOpt 1 9 x'5 - + P'.wireSizeOpt 1 8 x'6 - + P'.wireSizeRep 1 9 x'7 - + P'.wireSizeOpt 1 2 x'8) - wirePut ft' self'@(State x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8) - = case ft' of - 10 -> put'Fields - 11 -> do - P'.putSize (P'.wireSize 10 self') - put'Fields - _ -> P'.wirePutErr ft' self' + wireSize ft' self'@(State x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8) = + case ft' of + 10 -> calc'Size + 11 -> P'.prependMessageSize calc'Size + _ -> P'.wireSizeErr ft' self' where + calc'Size = + P'.wireSizeOpt 1 3 x'1 + P'.wireSizeOpt 1 9 x'2 + P'.wireSizeOpt 1 9 x'3 + + P'.wireSizeOpt 1 9 x'4 + + P'.wireSizeOpt 1 9 x'5 + + P'.wireSizeOpt 1 8 x'6 + + P'.wireSizeRep 1 9 x'7 + + P'.wireSizeOpt 1 2 x'8 + wirePut ft' self'@(State x'1 x'2 x'3 x'4 x'5 x'6 x'7 x'8) = + case ft' of + 10 -> put'Fields + 11 -> do + P'.putSize (P'.wireSize 10 self') put'Fields - = do - P'.wirePutOpt 8 3 x'1 - P'.wirePutOpt 18 9 x'2 - P'.wirePutOpt 26 9 x'3 - P'.wirePutOpt 34 9 x'4 - P'.wirePutOpt 42 9 x'5 - P'.wirePutOpt 48 8 x'6 - P'.wirePutRep 58 9 x'7 - P'.wirePutOpt 69 2 x'8 - wireGet ft' - = case ft' of - 10 -> P'.getBareMessageWith update'Self - 11 -> P'.getMessageWith update'Self - _ -> P'.wireGetErr ft' + _ -> P'.wirePutErr ft' self' where - update'Self wire'Tag old'Self - = case wire'Tag of - 8 -> Prelude'.fmap (\ !new'Field -> old'Self{time = Prelude'.Just new'Field}) (P'.wireGet 3) - 18 -> Prelude'.fmap (\ !new'Field -> old'Self{state = Prelude'.Just new'Field}) (P'.wireGet 9) - 26 -> Prelude'.fmap (\ !new'Field -> old'Self{service = Prelude'.Just new'Field}) (P'.wireGet 9) - 34 -> Prelude'.fmap (\ !new'Field -> old'Self{host = Prelude'.Just new'Field}) (P'.wireGet 9) - 42 -> Prelude'.fmap (\ !new'Field -> old'Self{description = Prelude'.Just new'Field}) (P'.wireGet 9) - 48 -> Prelude'.fmap (\ !new'Field -> old'Self{once = Prelude'.Just new'Field}) (P'.wireGet 8) - 58 -> Prelude'.fmap (\ !new'Field -> old'Self{tags = P'.append (tags old'Self) new'Field}) (P'.wireGet 9) - 69 -> Prelude'.fmap (\ !new'Field -> old'Self{ttl = Prelude'.Just new'Field}) (P'.wireGet 2) - _ -> let (field'Number, wire'Type) = P'.splitWireTag wire'Tag in P'.unknown field'Number wire'Type old'Self + put'Fields = do + P'.wirePutOpt 8 3 x'1 + P'.wirePutOpt 18 9 x'2 + P'.wirePutOpt 26 9 x'3 + P'.wirePutOpt 34 9 x'4 + P'.wirePutOpt 42 9 x'5 + P'.wirePutOpt 48 8 x'6 + P'.wirePutRep 58 9 x'7 + P'.wirePutOpt 69 2 x'8 + wireGet ft' = + case ft' of + 10 -> P'.getBareMessageWith update'Self + 11 -> P'.getMessageWith update'Self + _ -> P'.wireGetErr ft' + where + update'Self wire'Tag old'Self = + case wire'Tag of + 8 -> + Prelude'.fmap + (\ !new'Field -> old'Self {time = Prelude'.Just new'Field}) + (P'.wireGet 3) + 18 -> + Prelude'.fmap + (\ !new'Field -> old'Self {state = Prelude'.Just new'Field}) + (P'.wireGet 9) + 26 -> + Prelude'.fmap + (\ !new'Field -> old'Self {service = Prelude'.Just new'Field}) + (P'.wireGet 9) + 34 -> + Prelude'.fmap + (\ !new'Field -> old'Self {host = Prelude'.Just new'Field}) + (P'.wireGet 9) + 42 -> + Prelude'.fmap + (\ !new'Field -> old'Self {description = Prelude'.Just new'Field}) + (P'.wireGet 9) + 48 -> + Prelude'.fmap + (\ !new'Field -> old'Self {once = Prelude'.Just new'Field}) + (P'.wireGet 8) + 58 -> + Prelude'.fmap + (\ !new'Field -> + old'Self {tags = P'.append (tags old'Self) new'Field}) + (P'.wireGet 9) + 69 -> + Prelude'.fmap + (\ !new'Field -> old'Self {ttl = Prelude'.Just new'Field}) + (P'.wireGet 2) + _ -> + let (field'Number, wire'Type) = P'.splitWireTag wire'Tag + in P'.unknown field'Number wire'Type old'Self instance P'.MessageAPI msg' (msg' -> State) State where getVal m' f' = f' m' @@ -81,9 +134,12 @@ instance P'.GPB State instance P'.ReflectDescriptor State where - getMessageInfo _ = P'.GetMessageInfo (P'.fromDistinctAscList []) (P'.fromDistinctAscList [8, 18, 26, 34, 42, 48, 58, 69]) - reflectDescriptorInfo _ - = Prelude'.read + getMessageInfo _ = + P'.GetMessageInfo + (P'.fromDistinctAscList []) + (P'.fromDistinctAscList [8, 18, 26, 34, 42, 48, 58, 69]) + reflectDescriptorInfo _ = + Prelude'.read "DescriptorInfo {descName = ProtoName {protobufName = FIName \".Proto.State\", haskellPrefix = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule = [MName \"Proto\"], baseName = MName \"State\"}, descFilePath = [\"Network\",\"Monitoring\",\"Riemann\",\"Proto\",\"State.hs\"], isGroup = False, fields = fromList [FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.State.time\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"State\"], baseName' = FName \"time\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 1}, wireTag = WireTag {getWireTag = 8}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 3}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.State.state\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"State\"], baseName' = FName \"state\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 2}, wireTag = WireTag {getWireTag = 18}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.State.service\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"State\"], baseName' = FName \"service\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 3}, wireTag = WireTag {getWireTag = 26}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.State.host\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"State\"], baseName' = FName \"host\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 4}, wireTag = WireTag {getWireTag = 34}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.State.description\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"State\"], baseName' = FName \"description\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 5}, wireTag = WireTag {getWireTag = 42}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.State.once\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"State\"], baseName' = FName \"once\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 6}, wireTag = WireTag {getWireTag = 48}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 8}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.State.tags\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"State\"], baseName' = FName \"tags\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 7}, wireTag = WireTag {getWireTag = 58}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = True, mightPack = False, typeCode = FieldType {getFieldType = 9}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing},FieldInfo {fieldName = ProtoFName {protobufName' = FIName \".Proto.State.ttl\", haskellPrefix' = [MName \"Network\",MName \"Monitoring\",MName \"Riemann\"], parentModule' = [MName \"Proto\",MName \"State\"], baseName' = FName \"ttl\", baseNamePrefix' = \"\"}, fieldNumber = FieldId {getFieldId = 8}, wireTag = WireTag {getWireTag = 69}, packedTag = Nothing, wireTagLength = 1, isPacked = False, isRequired = False, canRepeat = False, mightPack = False, typeCode = FieldType {getFieldType = 2}, typeName = Nothing, hsRawDefault = Nothing, hsDefault = Nothing}], descOneofs = fromList [], keys = fromList [], extRanges = [], knownKeys = fromList [], storeUnknown = False, lazyFields = False, makeLenses = False}" instance P'.TextType State where @@ -91,61 +147,60 @@ getT = P'.getSubMessage instance P'.TextMsg State where - textPut msg - = do - P'.tellT "time" (time msg) - P'.tellT "state" (state msg) - P'.tellT "service" (service msg) - P'.tellT "host" (host msg) - P'.tellT "description" (description msg) - P'.tellT "once" (once msg) - P'.tellT "tags" (tags msg) - P'.tellT "ttl" (ttl msg) - textGet - = do - mods <- P'.sepEndBy - (P'.choice - [parse'time, parse'state, parse'service, parse'host, parse'description, parse'once, parse'tags, parse'ttl]) - P'.spaces - Prelude'.return (Prelude'.foldl (\ v f -> f v) P'.defaultValue mods) + textPut msg = do + P'.tellT "time" (time msg) + P'.tellT "state" (state msg) + P'.tellT "service" (service msg) + P'.tellT "host" (host msg) + P'.tellT "description" (description msg) + P'.tellT "once" (once msg) + P'.tellT "tags" (tags msg) + P'.tellT "ttl" (ttl msg) + textGet = do + mods <- + P'.sepEndBy + (P'.choice + [ parse'time + , parse'state + , parse'service + , parse'host + , parse'description + , parse'once + , parse'tags + , parse'ttl + ]) + P'.spaces + Prelude'.return (Prelude'.foldl (\v f -> f v) P'.defaultValue mods) where - parse'time - = P'.try - (do - v <- P'.getT "time" - Prelude'.return (\ o -> o{time = v})) - parse'state - = P'.try - (do - v <- P'.getT "state" - Prelude'.return (\ o -> o{state = v})) - parse'service - = P'.try - (do - v <- P'.getT "service" - Prelude'.return (\ o -> o{service = v})) - parse'host - = P'.try - (do - v <- P'.getT "host" - Prelude'.return (\ o -> o{host = v})) - parse'description - = P'.try - (do - v <- P'.getT "description" - Prelude'.return (\ o -> o{description = v})) - parse'once - = P'.try - (do - v <- P'.getT "once" - Prelude'.return (\ o -> o{once = v})) - parse'tags - = P'.try - (do - v <- P'.getT "tags" - Prelude'.return (\ o -> o{tags = P'.append (tags o) v})) - parse'ttl - = P'.try - (do - v <- P'.getT "ttl" - Prelude'.return (\ o -> o{ttl = v})) + parse'time = + P'.try + (do v <- P'.getT "time" + Prelude'.return (\o -> o {time = v})) + parse'state = + P'.try + (do v <- P'.getT "state" + Prelude'.return (\o -> o {state = v})) + parse'service = + P'.try + (do v <- P'.getT "service" + Prelude'.return (\o -> o {service = v})) + parse'host = + P'.try + (do v <- P'.getT "host" + Prelude'.return (\o -> o {host = v})) + parse'description = + P'.try + (do v <- P'.getT "description" + Prelude'.return (\o -> o {description = v})) + parse'once = + P'.try + (do v <- P'.getT "once" + Prelude'.return (\o -> o {once = v})) + parse'tags = + P'.try + (do v <- P'.getT "tags" + Prelude'.return (\o -> o {tags = P'.append (tags o) v})) + parse'ttl = + P'.try + (do v <- P'.getT "ttl" + Prelude'.return (\o -> o {ttl = v})) diff --git a/src/Network/Monitoring/Riemann/TCP.hs b/src/Network/Monitoring/Riemann/TCP.hs --- a/src/Network/Monitoring/Riemann/TCP.hs +++ b/src/Network/Monitoring/Riemann/TCP.hs @@ -1,102 +1,122 @@ -{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeSynonymInstances #-} module Network.Monitoring.Riemann.TCP - ( tcpConnection - , sendEvents - , sendMsg - , TCPConnection - , Port - ) where + ( tcpConnection + , sendEvents + , sendMsg + , TCPConnection + , Port + ) where -import Control.Concurrent -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 qualified Network.Monitoring.Riemann.Event as Event +import Control.Concurrent (MVar, newMVar, putMVar, takeMVar) +import qualified 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 Data.Sequence (Seq) +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 qualified Text.ProtocolBuffers.Header as P' -import Text.ProtocolBuffers.WireMessage as WM +import qualified Network.Monitoring.Riemann.Proto.Msg as Msg +import Network.Socket + ( AddrInfo + , AddrInfoFlag(AI_NUMERICSERV) + , Family(AF_INET, AF_INET6) + , HostName + , Socket + , SocketType(Stream) + , addrAddress + , addrFlags + , connect + , defaultHints + , defaultProtocol + , getAddrInfo + , isSupportedFamily + , socket + ) +import qualified Network.Socket.ByteString.Lazy as NSB +import System.IO (hPutStrLn, stderr) +import qualified Text.ProtocolBuffers.Header as P' +import qualified Text.ProtocolBuffers.WireMessage as WM type ClientInfo = (HostName, Port, TCPStatus) type TCPConnection = MVar ClientInfo -data TCPStatus = CnxClosed - | CnxOpen (Socket, AddrInfo) - deriving (Show) +data TCPStatus + = CnxClosed + | CnxOpen (Socket, AddrInfo) + deriving (Show) type Port = Int tcpConnection :: HostName -> Port -> IO TCPConnection tcpConnection h p = do - connection <- doConnect h p - newMVar (h, p, CnxOpen connection) + connection <- doConnect h p + newMVar (h, p, CnxOpen connection) getConnection :: ClientInfo -> IO (Socket, AddrInfo) -getConnection (_, _, CnxOpen (s, a)) = - return (s, a) -getConnection (h, p, CnxClosed) = - doConnect h p +getConnection (_, _, CnxOpen (s, a)) = pure (s, a) +getConnection (h, p, CnxClosed) = doConnect h p doConnect :: HostName -> Port -> IO (Socket, AddrInfo) doConnect hn po = do - addrs <- getAddrInfo (Just $ - defaultHints { addrFlags = [ AI_NUMERICSERV ] }) - (Just hn) - (Just $ show po) - case addrs of - [] -> fail ("No accessible addresses in " ++ show addrs) - (addy : _) -> do - s <- socket AF_INET Stream defaultProtocol - connect s (addrAddress addy) - return (s, addy) + addrs <- + getAddrInfo + (Just $ defaultHints {addrFlags = [AI_NUMERICSERV]}) + (Just hn) + (Just $ show po) + let family = + if isSupportedFamily AF_INET6 + then AF_INET6 + else AF_INET + case addrs of + [] -> fail ("No accessible addresses in " ++ show addrs) + (addy:_) -> do + s <- socket family Stream defaultProtocol + connect s (addrAddress addy) + pure (s, addy) msgToByteString :: Msg.Msg -> BC.ByteString -msgToByteString msg = Put.runPut $ do +msgToByteString msg = + Put.runPut $ do Put.putWord32be $ fromIntegral $ WM.messageSize msg - messagePutM msg + WM.messagePutM msg decodeMsg :: BC.ByteString -> Either String Msg.Msg -decodeMsg bs = let result = messageGet (BS.drop 4 bs) - in - case result of - Left e -> Left e - Right (m, _) -> if Maybe.isNothing (Msg.ok m) - then Left "error" - else Right m +decodeMsg bs = + let result = WM.messageGet (BS.drop 4 bs) + in case result of + Left e -> Left e + Right (m, _) -> + if Maybe.isNothing (Msg.ok m) + then Left "error" + else Right m sendMsg :: TCPConnection -> Msg.Msg -> IO (Either Msg.Msg Msg.Msg) sendMsg client msg = do - clientInfo@(h, p, _) <- takeMVar client - (s, _) <- getConnection clientInfo - sendAll s $ msgToByteString msg - bs <- NSB.recv s 4096 - result <- pure $ decodeMsg bs - case result of - Right m -> do - putMVar client clientInfo - return $ Right m - Left _ -> do - putMVar client (h, p, CnxClosed) - return $ Left msg + clientInfo@(h, p, _) <- takeMVar client + (s, _) <- getConnection clientInfo + NSB.sendAll s $ msgToByteString msg + bs <- NSB.recv s 4096 + case decodeMsg bs of + Right m -> do + putMVar client clientInfo + pure $ Right m + Left _ -> do + putMVar client (h, p, CnxClosed) + pure $ Left msg {-| Send a list of Riemann events Host and Time will be added if they do not exist on the Event -} -sendEvents :: TCPConnection -> Seq.Seq PE.Event -> IO () +sendEvents :: TCPConnection -> Seq PE.Event -> IO () sendEvents connection events = do - eventsWithDefaults <- Event.withDefaults 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 () + eventsWithDefaults <- Event.withDefaults events + result <- + sendMsg connection $ P'.defaultValue {Msg.events = eventsWithDefaults} + case result of + Left msg -> hPutStrLn stderr $ "failed to send" ++ show msg + Right _ -> pure () diff --git a/src/Network/Monitoring/Riemann/TCPClient.hs b/src/Network/Monitoring/Riemann/TCPClient.hs --- a/src/Network/Monitoring/Riemann/TCPClient.hs +++ b/src/Network/Monitoring/Riemann/TCPClient.hs @@ -1,11 +1,17 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + module Network.Monitoring.Riemann.TCPClient where -import Network.Monitoring.Riemann.Client -import Network.Monitoring.Riemann.TCP as TCP -import Network.Socket -import Data.Sequence as Seq +import Control.Monad.IO.Class (MonadIO, liftIO) +import qualified Data.Sequence as Seq +import Network.Monitoring.Riemann.Client (Client, close, sendEvent) +import qualified Network.Monitoring.Riemann.TCP as TCP +import Network.Monitoring.Riemann.TCP (Port, TCPConnection) +import Network.Socket (HostName) -data TCPClient = TCPClient TCPConnection +newtype TCPClient = + TCPClient TCPConnection {-| A new TCPClient @@ -18,10 +24,10 @@ -} tcpClient :: HostName -> Port -> IO TCPClient tcpClient h p = do - c <- TCP.tcpConnection h p - return $ TCPClient c + c <- TCP.tcpConnection h p + pure $ TCPClient c -instance Client TCPClient where - sendEvent (TCPClient connection) event = - TCP.sendEvents connection $ Seq.singleton event - close _ = print "close" +instance MonadIO m => Client m TCPClient where + sendEvent (TCPClient connection) event = + liftIO $ TCP.sendEvents connection $ Seq.singleton event + close _ = liftIO $ print "close" diff --git a/test/Network/Monitoring/Riemann/BatchClientSpec.hs b/test/Network/Monitoring/Riemann/BatchClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/Network/Monitoring/Riemann/BatchClientSpec.hs @@ -0,0 +1,24 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Network.Monitoring.Riemann.BatchClientSpec where + +import Control.Concurrent.KazuraQueue (newQueue, writeQueue) +import Data.Foldable (for_) +import qualified Data.Sequence as Seq +import Network.Monitoring.Riemann.BatchClient (drainAll) +import Test.Hspec (Spec, describe, it, shouldBe) +import Test.QuickCheck (getPositive, property) + +spec :: Spec +spec = drainAllSpec + +drainAllSpec :: Spec +drainAllSpec = + describe "drainAll" $ + it "Should drain no more than the give batch size." $ + property $ \available toDrain -> do + queue <- newQueue + for_ [1 .. getPositive available] (writeQueue queue) + xs <- drainAll queue $ getPositive toDrain + Seq.length xs `shouldBe` getPositive (min available toDrain) + Seq.lookup 0 xs `shouldBe` Just 1 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,2 +1,1 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented" +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}