websockets-simple 0.0.1 → 0.0.2

raw patch · 3 files changed

+45/−38 lines, 3 filesdep −websockets-simpledep ~base

Dependencies removed: websockets-simple

Dependency ranges changed: base

Files

• src/Network/WebSockets/Simple.hs +43/−25
• test/Spec.hs +0/−2
• websockets-simple.cabal +2/−11

@@ -9,15 +9,17 @@  module Network.WebSockets.Simple where -import Network.WebSockets (DataMessage (..), sendTextData, receiveDataMessage, acceptRequest)+import Network.WebSockets (DataMessage (..), sendTextData, receiveDataMessage, acceptRequest, ConnectionException) import Network.Wai.Trans (ServerAppT, ClientAppT) import Data.Aeson (ToJSON (..), FromJSON (..)) import qualified Data.Aeson as Aeson import Data.ByteString.Lazy (ByteString)+import Data.IORef (newIORef, writeIORef, readIORef)  import Control.Monad (void, forever)-import Control.Monad.Catch (Exception, throwM, MonadThrow)+import Control.Monad.Catch (Exception, throwM, MonadThrow, catch, MonadCatch) import Control.Monad.Trans.Control (MonadBaseControl (..))+import Control.Concurrent (threadDelay) import Control.Concurrent.Async (Async, async) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TChan (TChan, newTChanIO, writeTChan)@@ -41,41 +43,57 @@                 , FromJSON receive                 , MonadBaseControl IO m                 , MonadThrow m+                , MonadCatch m                 )              => WebSocketsApp send receive m-             -> ClientAppT m WebSocketsAppThreads-toClientAppT WebSocketsApp{onOpen,onReceive} = \conn -> do-  let send :: send -> m ()-      send x = liftBaseWith $ \_ -> sendTextData conn (Aeson.encode x)+             -> ClientAppT m (Maybe WebSocketsAppThreads)+toClientAppT WebSocketsApp{onOpen,onReceive} conn = do+  toWaitVar <- liftBaseWith $ \_ -> newIORef (0 :: Int)+  let go =+        let go' = do+              liftBaseWith $ \_ -> writeIORef toWaitVar 0+              let send :: send -> m ()+                  send x = liftBaseWith $ \_ -> sendTextData conn (Aeson.encode x) -  onOpenThread <- liftBaseWith $ \runToBase ->-    async $ void $ runToBase $ onOpen send+              onOpenThread <- liftBaseWith $ \runToBase ->+                async $ void $ runToBase $ onOpen send -  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 send received-        atomically $ writeTChan onReceiveThreads thread+              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 send received+                    atomically $ writeTChan onReceiveThreads thread -  pure WebSocketsAppThreads-    { onOpenThread-    , onReceiveThreads-    }+              pure $ Just WebSocketsAppThreads+                { onOpenThread+                , onReceiveThreads+                } +            onDisconnect :: ConnectionException -> m (Maybe WebSocketsAppThreads)+            onDisconnect _ = do+              liftBaseWith $ \_ -> do+                toWait <- readIORef toWaitVar+                writeIORef toWaitVar (toWait+1)+                let second = 1000000+                threadDelay $ second * (2^toWait)+              go+        in  go' `catch` onDisconnect+  go  -toClientAppT' :: (ToJSON send, FromJSON receive, MonadBaseControl IO m, MonadThrow m) => WebSocketsApp send receive m -> ClientAppT m ()++toClientAppT' :: (ToJSON send, FromJSON receive, MonadBaseControl IO m, MonadThrow m, MonadCatch m) => WebSocketsApp send receive m -> ClientAppT m () toClientAppT' wsApp conn = void (toClientAppT wsApp conn)  -toServerAppT :: (ToJSON send, FromJSON receive, MonadBaseControl IO m, MonadThrow m) => WebSocketsApp send receive m -> ServerAppT m+toServerAppT :: (ToJSON send, FromJSON receive, MonadBaseControl IO m, MonadThrow m, MonadCatch m) => WebSocketsApp send receive m -> ServerAppT m toServerAppT wsApp pending = do   conn <- liftBaseWith $ \_ -> acceptRequest pending   toClientAppT' wsApp conn

@@ -1,2 +0,0 @@-main :: IO ()-main = putStrLn "Test suite not yet implemented"

@@ -1,5 +1,5 @@ name:                websockets-simple-version:             0.0.1+version:             0.0.2 synopsis:            Simpler interface to the websockets api -- description: homepage:            https://github.com/athanclark/websockets-simple#readme@@ -27,15 +27,6 @@                      , websockets   default-language:    Haskell2010 -test-suite websockets-simple-test-  type:                exitcode-stdio-1.0-  hs-source-dirs:      test-  main-is:             Spec.hs-  build-depends:       base-                     , websockets-simple-  ghc-options:         -threaded -rtsopts -with-rtsopts=-N-  default-language:    Haskell2010- source-repository head   type:     git-  location: https://github.com/githubuser/websockets-simple+  location: https://github.com/athanclark/websockets-simple