packages feed

hriemann (empty) → 0.1.0.0

raw patch · 16 files changed

+1152/−0 lines, 16 filesdep +basedep +binarydep +bytestringsetup-changed

Dependencies added: base, binary, bytestring, containers, criterion, hostname, hriemann, kazura-queue, network, protocol-buffers, protocol-buffers-descriptor, text, time, unagi-chan

Files

+ LICENSE view
@@ -0,0 +1,7 @@+Copyright (c) 2016 David Smith++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,25 @@+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+    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"
+ hriemann.cabal view
@@ -0,0 +1,63 @@+name:                hriemann+version:             0.1.0.0+synopsis:            Initial project template from stack+description:         A Riemann Client for Haskell+homepage:            https://github.com/shmish111/hriemann+license:             MIT+license-file:        LICENSE+author:              David Smith+maintainer:          shmish111@gmail.com+copyright:           2016 David Smith+category:            Web+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:     Network.Monitoring.Riemann.Client+                       Network.Monitoring.Riemann.Event+                       Network.Monitoring.Riemann.TCP+                       Network.Monitoring.Riemann.LoggingClient+                       Network.Monitoring.Riemann.TCPClient+                       Network.Monitoring.Riemann.BatchClient+  other-modules:       Network.Monitoring.Riemann.Proto.Attribute+                       Network.Monitoring.Riemann.Proto.Event+                       Network.Monitoring.Riemann.Proto.Msg+                       Network.Monitoring.Riemann.Proto.Query+                       Network.Monitoring.Riemann.Proto.State+  build-depends:       base >= 4.7 && < 5+                     , protocol-buffers == 2.4.*+                     , protocol-buffers-descriptor == 2.4.*+                     , bytestring == 0.10.*+                     , network == 2.6.*+                     , text == 1.2.*+                     , containers == 0.5.*+                     , binary == 0.8.*+                     , time == 1.6.*+                     , hostname == 1.0.*+                     , unagi-chan == 0.4.*+                     , kazura-queue == 0.1.*+                     , criterion == 1.1.*+  default-language:    Haskell2010++executable hriemann-exe+  hs-source-dirs:      app+  main-is:             Main.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  build-depends:       base+                     , hriemann+  default-language:    Haskell2010++test-suite hriemann-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , hriemann+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/shmish111/hriemann
+ src/Network/Monitoring/Riemann/BatchClient.hs view
@@ -0,0 +1,133 @@+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           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++data BatchClient = BatchClient (Unagi.InChan LogCommand)++data BatchClientNoBuffer = BatchClientNoBuffer (Queue LogCommand)++data LogCommand = Event PE.Event+                | Stop (MVar ())++{-|+    A new BatchClient++    The BatchClient is a 'Client' that will do the following++    * Batch events into a specified batch size+    * If events are produced more quickly than Riemann can cope with, they will be passed to the overflow function++    Batching events is important for throughput, see <https://aphyr.com/posts/269-reaching-200k-events-sec>++    It is important to deal with back pressure, if the buffer of events to be sent to Riemann fills up, they will be+    passed to the overflow function until the buffer has space again. This overflow function can be as simple as 'print'++    Current time and host name will be set if not provided.++    '''Note''': We never use IPv6 address resolved for given hostname.+-}+batchClient :: HostName+            -> 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++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+                 -> (PE.Event -> IO ())+                 -> IO ()+overflowConsumer outChan q 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 s -> do+                putStrLn "stopping log consumer"+                writeQueue q cmd++drainAll :: Queue a -> Int -> IO (Seq a)+drainAll q n = do+    msg <- readQueue q+    loop $ singleton msg+  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++riemannConsumer :: Int -> Queue LogCommand -> TCPConnection -> IO ()+riemannConsumer batchSize q connection =+    loop+  where+    loop = do+        cmds <- drainAll q batchSize+        let (events', stops') = Seq.partition (\cmd -> case cmd of+                                                   Event event -> True+                                                   Stop s      -> 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 ()++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 Client BatchClientNoBuffer where+    sendEvent (BatchClientNoBuffer q) event =+        writeQueue q $ Event event+    close (BatchClientNoBuffer q) = do+        s <- newEmptyMVar+        writeQueue q (Stop s)+        takeMVar s
+ src/Network/Monitoring/Riemann/Client.hs view
@@ -0,0 +1,10 @@+module Network.Monitoring.Riemann.Client where++import qualified Network.Monitoring.Riemann.Proto.Event as Event++{-|+    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 ()
+ src/Network/Monitoring/Riemann/Event.hs view
@@ -0,0 +1,135 @@+{-|+Module      : Network.Monitoring.Riemann.Event+Description : A module for building Riemann events++Build an event which can then be sent to Riemann using a 'Network.Monitoring.Riemann.Client.Client'++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"]+@++With this design you are encouraged to create an event with one of 'Event.ok', 'Event.warn' or 'Event.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.+-}+module Network.Monitoring.Riemann.Event where++import           Control.Concurrent+import qualified Data.ByteString.Lazy.Char8                 as BC+import           Data.Maybe+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           Text.ProtocolBuffers.Basic                 as Basic+import qualified Text.ProtocolBuffers.Header                as P'++type Service = String++type State = String++type Event = Event.Event++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 }++state :: State -> Event.Event -> Event.Event+state s e = e { Event.state = toField s }++ok :: Service -> Event.Event+ok service = state "ok" $ info service++warn :: Service -> Event.Event+warn service = state "warn" $ info service++failure :: Service -> Event.Event+failure service = state "failure" $ info service++description :: String -> Event.Event -> Event.Event+description d e = e { Event.description = toField d }++class Metric a where+    setMetric :: a -> Event.Event -> Event.Event++instance Metric Int where+    setMetric m e = e { Event.metric_sint64 = Just $ fromIntegral m }++instance Metric Integer where+    setMetric m e = e { Event.metric_sint64 = Just $ fromIntegral m }++instance Metric Int64 where+    setMetric m e = e { Event.metric_sint64 = Just m }++instance Metric Double where+    setMetric m e = e { Event.metric_d = Just m }++instance Metric Float where+    setMetric m e = e { Event.metric_f = Just m }++{-|+    Note that since Riemann's protocol has separate types for integers, floats and doubles, you need to specify which+    type you are using. For example, this won't work:++    @+    metric 1 myEvent+    @++    Instead use:++    @+    metric (1 :: Int) myEvent+    @+-}+metric :: (Metric a) => a -> Event.Event -> Event.Event+metric = setMetric++ttl :: Float -> Event.Event -> Event.Event+ttl t e = e { Event.ttl = Just t }++tags :: [String] -> Event.Event -> Event.Event+tags ts e = let tags' = fromList $ fmap (Basic.Utf8 . BC.pack) ts+            in+                e { Event.tags = tags' }++attributes :: [Attribute.Attribute] -> Event.Event -> Event.Event+attributes as e = e { Event.attributes = fromList as }++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'+                                     }++{-|+    Add local hostname and current time to an Event++    This will not override any host or time in the provided event+-}+withDefaults :: Seq Event.Event -> IO (Seq Event.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 }
+ src/Network/Monitoring/Riemann/LoggingClient.hs view
@@ -0,0 +1,16 @@+module Network.Monitoring.Riemann.LoggingClient where++import           Network.Monitoring.Riemann.Client++data LoggingClient = LoggingClient++{-|+    A new LoggingClient++    The LoggingClient is a 'Client' that will simply print events+-}+loggingClient = LoggingClient++instance Client LoggingClient where+    sendEvent client = print+    close client = print "close"
+ src/Network/Monitoring/Riemann/Proto/Attribute.hs view
@@ -0,0 +1,86 @@+{-# 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'+import qualified Data.Data 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)++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)++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'+    where+        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'++instance P'.GPB Attribute++instance P'.ReflectDescriptor Attribute where+  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+  tellT = P'.tellSubMessage+  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)+    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}))
+ src/Network/Monitoring/Riemann/Proto/Event.hs view
@@ -0,0 +1,188 @@+{-# 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'+import qualified Data.Data as Prelude'+import qualified Text.ProtocolBuffers.Header as P'+import qualified Network.Monitoring.Riemann.Proto.Attribute as Proto (Attribute)++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)+      (P'.mergeAppend x'5 y'5)+      (P'.mergeAppend x'6 y'6)+      (P'.mergeAppend x'7 y'7)+      (P'.mergeAppend x'8 y'8)+      (P'.mergeAppend x'9 y'9)+      (P'.mergeAppend x'10 y'10)+      (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+      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'+    where+        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'++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+      "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+  tellT = P'.tellSubMessage+  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)+    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}))
+ src/Network/Monitoring/Riemann/Proto/Msg.hs view
@@ -0,0 +1,119 @@+{-# 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'+import qualified Data.Data as Prelude'+import qualified Text.ProtocolBuffers.Header as P'+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)++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)+      (P'.mergeAppend x'5 y'5)++instance P'.Default Msg where+  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'+    where+        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'++instance P'.GPB Msg++instance P'.ReflectDescriptor Msg where+  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+  tellT = P'.tellSubMessage+  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)+    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}))
+ src/Network/Monitoring/Riemann/Proto/Query.hs view
@@ -0,0 +1,78 @@+{-# 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'+import qualified Data.Data 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)++instance P'.Mergeable Query where+  mergeAppend (Query x'1) (Query y'1) = Query (P'.mergeAppend x'1 y'1)++instance P'.Default Query where+  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'+    where+        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'+    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'++instance P'.GPB Query++instance P'.ReflectDescriptor Query where+  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+  tellT = P'.tellSubMessage+  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)+    where+        parse'string+         = P'.try+            (do+               v <- P'.getT "string"+               Prelude'.return (\ o -> o{string = v}))
+ src/Network/Monitoring/Riemann/Proto/State.hs view
@@ -0,0 +1,151 @@+{-# 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'+import qualified Data.Data 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)++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)+      (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+      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'+    where+        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'++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+      "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+  tellT = P'.tellSubMessage+  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)+    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}))
+ src/Network/Monitoring/Riemann/TCP.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE FlexibleInstances    #-}+{-# LANGUAGE TypeSynonymInstances #-}++module Network.Monitoring.Riemann.TCP+    ( tcpConnection+    , sendEvents+    , sendMsg+    , TCPConnection+    , Port+    ) 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++type ClientInfo = (HostName, Port, TCPStatus)++type TCPConnection = MVar ClientInfo++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)++getConnection :: ClientInfo -> IO (Socket, AddrInfo)+getConnection (h, p, 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+        [] -> fail ("No accessible addresses in " ++ show addrs)+        (addy : _) -> do+            s <- socket AF_INET Stream defaultProtocol+            connect s (addrAddress addy)+            return (s, addy)++msgToByteString :: Msg.Msg -> BC.ByteString+msgToByteString msg = Put.runPut $ do+    Put.putWord32be $ fromIntegral $ WM.messageSize msg+    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++sendMsg :: TCPConnection -> Msg.Msg -> IO (Either Msg.Msg Msg.Msg)+sendMsg client msg = do+    clientInfo@(h, p, state) <- takeMVar client+    (s, a) <- 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 e -> do+            putMVar client (h, p, CnxClosed)+            return $ 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 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 ()
+ src/Network/Monitoring/Riemann/TCPClient.hs view
@@ -0,0 +1,28 @@+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++data TCPClient = TCPClient TCPConnection++{-|+    A new TCPClient++    The TCPClient is a 'Client' that will send single events synchronously over TCP.++    Current time and host name will be set if not provided.++    '''Note''': We never use IPv6 address resolved for given hostname.+-}+tcpClient :: HostName -> Port -> IO TCPClient+tcpClient h p = do+    c <- TCP.tcpConnection h p+    return $ TCPClient c++instance Client TCPClient where+    sendEvent (TCPClient connection) event =+        TCP.sendEvents connection $ Seq.singleton event+    close client = print "close"
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"