summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorshmish111 <>2018-09-13 17:12:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2018-09-13 17:12:00 (GMT)
commit6d4409a9006d2506ca4837bf550c49f95e886c53 (patch)
tree5e3022a085d028f05c7349c95decc7400a8066d8
parent862f6684b25fff45126aafe541051ee2f8de3b32 (diff)
version 0.3.3.20.3.3.2
-rw-r--r--hriemann.cabal5
-rw-r--r--src/Network/Monitoring/Riemann/TCP.hs34
2 files changed, 22 insertions, 17 deletions
diff --git a/hriemann.cabal b/hriemann.cabal
index 655e092..8c5d513 100644
--- a/hriemann.cabal
+++ b/hriemann.cabal
@@ -2,10 +2,10 @@
--
-- see: https://github.com/sol/hpack
--
--- hash: 02c6f9cc6fa0ddb8bf2db0ae03e66a26f59d2620504af25e742ac84f44752bbf
+-- hash: 27fb5d42fe1036839a8e668517e27953974a2b64365c4f7be64b9ad838268da7
name: hriemann
-version: 0.3.3.1
+version: 0.3.3.2
synopsis: A Riemann Client for Haskell
description: A Riemann Client for Haskell
category: Monitoring
@@ -59,6 +59,7 @@ library
, protocol-buffers
, protocol-buffers-descriptor
, scientific
+ , stm
, text
, time
, unagi-chan
diff --git a/src/Network/Monitoring/Riemann/TCP.hs b/src/Network/Monitoring/Riemann/TCP.hs
index 842177c..f1d7504 100644
--- a/src/Network/Monitoring/Riemann/TCP.hs
+++ b/src/Network/Monitoring/Riemann/TCP.hs
@@ -11,8 +11,10 @@ module Network.Monitoring.Riemann.TCP
, Port
) where
-import Control.Concurrent (MVar, newMVar, putMVar, takeMVar)
-import Control.Exception (try)
+import Control.Concurrent.STM (atomically)
+import Control.Concurrent.STM.TVar (TVar, newTVarIO, readTVarIO, writeTVar)
+import Control.Exception (IOException, try)
+import Data.Bifunctor (first)
import qualified Data.Binary.Put as Put
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.Char8 as BC
@@ -49,7 +51,7 @@ data ClientInfo = ClientInfo
, _status :: TCPStatus
}
-type TCPConnection = MVar ClientInfo
+type TCPConnection = TVar ClientInfo
data TCPStatus
= CnxClosed
@@ -61,7 +63,7 @@ type Port = Int
tcpConnection :: HostName -> Port -> IO TCPConnection
tcpConnection _hostname _port = do
clientInfo <- doConnect $ ClientInfo {_status = CnxClosed, ..}
- newMVar clientInfo
+ newTVarIO clientInfo
doConnect :: ClientInfo -> IO ClientInfo
doConnect clientInfo@(_status -> CnxOpen _) = pure clientInfo
@@ -117,23 +119,25 @@ sendMsg :: TCPConnection -> Msg.Msg -> IO (Either Msg.Msg Msg.Msg)
sendMsg client msg = go True
where
go reconnect = do
- clientInfo <- takeMVar client
+ putStrLn $ "SENDING " <> show reconnect
+ clientInfo <- readTVarIO client
case (_status clientInfo, reconnect) of
- (CnxClosed, True) -> pure $ Left msg
- (CnxClosed, False) -> do
+ (CnxClosed, True) -> do
newInfo <- doConnect clientInfo
- putMVar client newInfo
+ atomically $ writeTVar client newInfo
go False
+ (CnxClosed, False) -> pure $ Left msg
(CnxOpen (s, _), _) -> do
- NSB.sendAll s $ msgToByteString msg
- bs <- NSB.recv s 4096
- case decodeMsg bs of
- Right m -> do
- putMVar client clientInfo
- pure $ Right m
+ response <-
+ first (show :: IOException -> String) <$>
+ try
+ (do NSB.sendAll s $ msgToByteString msg
+ NSB.recv s 4096)
+ case decodeMsg =<< response of
Left _ -> do
- putMVar client (clientInfo {_status = CnxClosed})
+ atomically $ writeTVar client (clientInfo {_status = CnxClosed})
pure $ Left msg
+ Right m -> pure $ Right m
{-|
Send a list of Riemann events