websockets-simple 0.0.4.1 → 0.0.5

raw patch · 2 files changed

+66/−48 lines, 2 files

Files

• src/Network/WebSockets/Simple.hs +65/−47
• websockets-simple.cabal +1/−1

@@ -39,10 +39,10 @@ data WebSocketsApp send receive m = WebSocketsApp   { onOpen    :: WebSocketsAppParams send m -> m ()   , onReceive :: WebSocketsAppParams send m -> receive -> m ()-  , onClose   :: Maybe (Word16, ByteString) -> m (Int -> Maybe Int) -- ^ Either was a clean close, with 'Network.WebSockets.CloseRequest' params, or was unclean.-                                                                    --   Returns a function which defines the backoff strategy - takes in total time (microseconds)-                                                                    --   elapsed during connection closed, and may return a new delay before attempting to connect again;-                                                                    --   if none, then it won't try again.+  , onClose   :: Maybe (Word16, ByteString) -> m () -- ^ Either was a clean close, with 'Network.WebSockets.CloseRequest' params, or was unclean.+                                                    --   Note that to implement backoff strategies, you should catch your 'Network.WebSockets.ConnectionException'+                                                    --   /outside/ this simple app, and only after you've 'Network.WebSockets.runClient' or server, because the+                                                    --   'Network.WebSockets.Connection' will be different.   } deriving (Generic, Typeable)  @@ -71,57 +71,45 @@              => WebSocketsApp send receive m              -> ClientAppT m (Maybe WebSocketsAppThreads) toClientAppT WebSocketsApp{onOpen,onReceive,onClose} conn = do-  soFarVar <- liftBaseWith $ \_ -> newIORef (0 :: Int)-  let go =-        let go' = do-              liftBaseWith $ \_ -> writeIORef soFarVar 0-              let send :: send -> m ()-                  send x = liftBaseWith $ \_ -> sendTextData conn (Aeson.encode x)+  let go = do+        let send :: send -> m ()+            send x = liftBaseWith $ \_ -> sendTextData conn (Aeson.encode x) -                  close :: m ()-                  close = liftBaseWith $ \_ -> sendClose conn (Aeson.encode "requesting close")+            close :: m ()+            close = liftBaseWith $ \_ -> sendClose conn (Aeson.encode "requesting close") -                  params :: WebSocketsAppParams send m-                  params = WebSocketsAppParams{send,close}+            params :: WebSocketsAppParams send m+            params = WebSocketsAppParams{send,close} -              onOpenThread <- liftBaseWith $ \runToBase ->-                async $ void $ runToBase $ onOpen params+        onOpenThread <- liftBaseWith $ \runToBase ->+          async $ void $ runToBase $ onOpen params -              onReceiveThreads <- liftBaseWith $ \_ -> newTChanIO+        onReceiveThreads <- liftBaseWith $ \_ -> newTChanIO -              forever $ do-                data' <- liftBaseWith $ \_ -> receiveDataMessage conn-                let data'' = case data' of-                              Text xs _ -> xs-                              Binary xs -> xs-                case Aeson.decode data'' of-                  Nothing -> throwM (JSONParseError data'')-                  Just received -> liftBaseWith $ \runToBase -> do-                    thread <- async $ void $ runToBase $ onReceive params received-                    atomically $ writeTChan onReceiveThreads thread+        void $ forever $ do+          data' <- liftBaseWith $ \_ -> receiveDataMessage conn+          let data'' = case data' of+                        Text xs _ -> xs+                        Binary xs -> xs+          case Aeson.decode data'' of+            Nothing -> throwM (JSONParseError data'')+            Just received -> liftBaseWith $ \runToBase -> do+              thread <- async $ void $ runToBase $ onReceive params received+              atomically $ writeTChan onReceiveThreads thread -              pure $ Just WebSocketsAppThreads-                { onOpenThread-                , onReceiveThreads-                }+        pure $ Just WebSocketsAppThreads+          { onOpenThread+          , onReceiveThreads+          } -            onDisconnect :: ConnectionException -> m (Maybe WebSocketsAppThreads)-            onDisconnect err = do-              backoffStrategy <- case err of-                CloseRequest code reason -> onClose (Just (code,reason))-                _                        -> onClose Nothing-              canGo <- liftBaseWith $ \_ -> do-                soFar <- readIORef soFarVar-                case backoffStrategy soFar of-                  Nothing -> pure False -- give up-                  Just delay -> do-                    writeIORef soFarVar (soFar + delay)-                    threadDelay delay-                    pure True-              if canGo then go else pure Nothing+      onDisconnect :: ConnectionException -> m (Maybe WebSocketsAppThreads)+      onDisconnect err = do+        case err of+          CloseRequest code reason -> onClose (Just (code,reason))+          _                        -> onClose Nothing+        pure Nothing -        in  go' `catch` onDisconnect-  go+  go `catch` onDisconnect   @@ -133,6 +121,36 @@ toServerAppT wsApp pending = do   conn <- liftBaseWith $ \_ -> acceptRequest pending   toClientAppT' wsApp conn++++-- | A simple backoff strategy, which (per second), will increasingly delay at @2^soFar@, until @soFar >= 5minutes@, where it will then routinely poll every+--   5 minutes.+expBackoffStrategy :: forall m a+                    . ( MonadBaseControl IO m+                      , MonadCatch m+                      )+                   => m a -- ^ The run app+                   -> m a+expBackoffStrategy app = do+  soFarVar <- liftBaseWith $ \_ -> newIORef (0 :: Int)++  let second = 1000000++  let go = app `catch` backoffStrat++      backoffStrat :: ConnectionException -> m a+      backoffStrat _ = do+        liftBaseWith $ \_ -> do+          soFar <- readIORef soFarVar+          let delay+                | soFar >= 5 * 60 = 5 * 60+                | otherwise       = 2 ^ soFar+          writeIORef soFarVar (soFar + delay)+          threadDelay (delay * second)+        go++  go   

@@ -1,5 +1,5 @@ name:                websockets-simple-version:             0.0.4.1+version:             0.0.5 synopsis:            Simpler interface to the websockets api -- description: homepage:            https://github.com/athanclark/websockets-simple#readme