websockets-simple 0.0.2.2 → 0.0.3

raw patch · 3 files changed

+65/−2 lines, 3 filesdep +every

Dependencies added: every

Files

• src/Network/WebSockets/Simple.hs +5/−1
• src/Network/WebSockets/Simple/PingPong.hs +57/−0
• websockets-simple.cabal +3/−1

@@ -92,7 +92,11 @@                 toWait <- readIORef toWaitVar                 writeIORef toWaitVar (toWait+1)                 let second = 1000000-                threadDelay $ second * (2^toWait)+                    origDelayTime = 2^toWait+                    threadDelayTime+                      | origDelayTime > 5*60*origDelayTime = 5*60 -- limit at 5 mins+                      | otherwise = origDelayTime+                threadDelay $ second * threadDelayTime               go         in  go' `catch` onDisconnect   go

@@ -0,0 +1,57 @@+{-# LANGUAGE+    NamedFieldPuns+  , FlexibleContexts+  #-}++module Network.WebSockets.Simple.PingPong where++import Network.WebSockets.Simple (WebSocketsApp (..))++import Data.Aeson (ToJSON (..), FromJSON (..))+import Data.Aeson.Types (Value (Array))+import Control.Monad.Trans.Control (MonadBaseControl (..))+import Control.Concurrent.Async.Every (every, reset)+import Control.Concurrent.STM (atomically)+import Control.Concurrent.STM.TVar (newTVarIO, readTVar, writeTVar)+++newtype PingPong a = PingPong {getPingPong :: Maybe a}++-- | Assumes @a@ isn't an 'Data.Aeson.Types.Array' of anything+instance ToJSON a => ToJSON (PingPong a) where+  toJSON (PingPong Nothing) = toJSON ([] :: [()])+  toJSON (PingPong (Just x)) = toJSON x++-- | Assumes @a@ isn't an 'Data.Aeson.Types.Array' of anything+instance FromJSON a => FromJSON (PingPong a) where+  parseJSON (Array _) = pure (PingPong Nothing)+  parseJSON x = (PingPong . Just) <$> parseJSON x++++pingPong :: ( MonadBaseControl IO m+            )+         => Int -- ^ Delay in microseconds+         -> WebSocketsApp send receive m+         -> m (WebSocketsApp (PingPong send) (PingPong receive) m)+pingPong delay WebSocketsApp{onOpen,onReceive} = do+  counterVar <- liftBaseWith $ \_ -> newTVarIO Nothing++  let halfDelay = delay `div` 2++  pure WebSocketsApp+    { onOpen = \send -> do+        liftBaseWith $ \runInBase -> do+          counter <- every delay (Just halfDelay) $ runInBase $+            send (PingPong Nothing)+          atomically $ writeTVar counterVar (Just counter)+        onOpen (send . PingPong . Just)+    , onReceive = \send (PingPong mPingPong) -> do+        case mPingPong of+          Nothing -> liftBaseWith $ \_ -> do+            mCounter <- atomically $ readTVar counterVar+            case mCounter of+              Nothing -> error "somehow received message before socket was opened"+              Just counter -> reset (Just halfDelay) counter+          Just r -> onReceive (send . PingPong . Just) r+    }

@@ -1,5 +1,5 @@ name:                websockets-simple-version:             0.0.2.2+version:             0.0.3 synopsis:            Simpler interface to the websockets api -- description: homepage:            https://github.com/athanclark/websockets-simple#readme@@ -16,10 +16,12 @@ library   hs-source-dirs:      src   exposed-modules:     Network.WebSockets.Simple+                       Network.WebSockets.Simple.PingPong   build-depends:       base >= 4.8 && < 5                      , aeson                      , async                      , bytestring+                     , every >= 0.0.1                      , exceptions                      , monad-control                      , stm