websockets-simple 0.1.0 → 0.1.1

raw patch · 3 files changed

+37/−28 lines, 3 filesdep +vectordep −every

Dependencies added: vector

Dependencies removed: every

Files

• src/Network/WebSockets/Simple.hs +1/−0
• src/Network/WebSockets/Simple/PingPong.hs +32/−24
• websockets-simple.cabal +4/−4

@@ -55,6 +55,7 @@   = ClosedOnSend   | ClosedOnClose   | ClosedOnReceive+  deriving (Eq, Show)   instance Profunctor (WebSocketsApp m) where

@@ -1,6 +1,7 @@ {-# LANGUAGE     NamedFieldPuns   , FlexibleContexts+  , OverloadedStrings   #-}  module Network.WebSockets.Simple.PingPong where@@ -8,10 +9,13 @@ import Network.WebSockets.Simple (WebSocketsApp (..), WebSocketsAppParams (..))  import Data.Aeson (ToJSON (..), FromJSON (..))-import Data.Aeson.Types (Value (Array))+import Data.Aeson.Types (Value (Array, String), typeMismatch)+import qualified Data.Vector as V+import Control.Monad (forever) import Control.Monad.Trans.Control (MonadBaseControl (..))-import Control.Concurrent.Async.Every (every, reset)-import Control.Concurrent.STM (atomically, newTVarIO, readTVar, writeTVar)+import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (async, cancel)+import Control.Concurrent.STM (atomically, newEmptyTMVarIO, putTMVar, takeTMVar)   -- | Uses the JSON literal @[]@ as the ping message@@ -19,15 +23,18 @@  -- | 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+  toJSON (PingPong Nothing) = String ""+  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 x@(String xs)+    | xs == "" = pure (PingPong Nothing)+    | otherwise = typeMismatch "PingPong" x   parseJSON x@(Array xs)-    | null xs = pure (PingPong Nothing)-    | otherwise = (PingPong . Just) <$> parseJSON x-  parseJSON x = (PingPong . Just) <$> parseJSON x+    | V.length xs /= 1 = typeMismatch "PingPong" x+    | otherwise = (PingPong . Just) <$> parseJSON (xs V.! 0)+  parseJSON x = typeMismatch "PingPong" x   @@ -37,24 +44,25 @@          -> WebSocketsApp m receive send          -> m (WebSocketsApp m (PingPong receive) (PingPong send)) pingPong delay WebSocketsApp{onOpen,onReceive,onClose} = do-  counterVar <- liftBaseWith $ \_ -> newTVarIO Nothing--  let halfDelay = delay `div` 2+  pingingThread <- liftBaseWith $ \_ -> newEmptyTMVarIO    pure WebSocketsApp-    { onOpen = \WebSocketsAppParams{send,close} -> do+    { onOpen = \params@WebSocketsAppParams{send} -> do         liftBaseWith $ \runInBase -> do-          counter <- every delay (Just halfDelay) $ runInBase $-            send (PingPong Nothing)-          atomically $ writeTVar counterVar (Just counter)-        onOpen WebSocketsAppParams{send = send . PingPong . Just, close}-    , onReceive = \WebSocketsAppParams{send,close} (PingPong mPingPong) ->+          counter <- async $ forever $ do+            threadDelay delay+            runInBase $ send $ PingPong Nothing+          atomically $ putTMVar pingingThread counter+        onOpen (mkParams params)+    , onReceive = \params (PingPong mPingPong) ->         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 WebSocketsAppParams{send = send . PingPong . Just, close} r-    , onClose+          Nothing -> pure ()+          Just r -> onReceive (mkParams params) r+    , onClose = \o e -> do+        liftBaseWith $ \_ -> do+          thread <- atomically (takeTMVar pingingThread)+          cancel thread+        onClose o e     }+  where+    mkParams WebSocketsAppParams{send,close} = WebSocketsAppParams{send = send . PingPong . Just,close}

@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: d677af901275b84a23a53024bc83e2471998b8ed21dc32553b0a23c736723cd1+-- hash: b864ea883942ac76ccc4d385c87d3c8613080be5d10c29723565111d84ef549b  name:           websockets-simple-version:        0.1.0+version:        0.1.1 synopsis:       Composable websockets clients description:    See README at <https://github.com/athanclark/websockets-simple#readme> category:       Web@@ -39,12 +39,12 @@     , async     , base >=4.9 && <5     , bytestring-    , every >=0.0.1     , exceptions     , monad-control     , profunctors     , stm     , transformers+    , vector     , wai-transformers     , websockets >=0.12.3   default-language: Haskell2010@@ -66,7 +66,6 @@     , async     , base >=4.9 && <5     , bytestring-    , every >=0.0.1     , exceptions     , hspec     , monad-control@@ -75,6 +74,7 @@     , tasty     , tasty-hspec     , transformers+    , vector     , wai-transformers     , websockets >=0.12.3     , websockets-simple