websockets-simple 0.0.7 → 0.1.0
raw patch · 4 files changed
+35/−50 lines, 4 filesdep ~websockets
Dependency ranges changed: websockets
Files
- src/Network/WebSockets/Simple.hs +26/−41
- src/Test/WebSockets/Simple.hs +3/−3
- test/Spec.hs +2/−2
- websockets-simple.cabal +4/−4
src/Network/WebSockets/Simple.hs view
@@ -10,10 +10,11 @@ module Network.WebSockets.Simple ( -- * Types- WebSocketsApp (..), WebSocketsAppParams (..), WebSocketsAppThreads (..)- , Network.WebSockets.ConnectionException (..), WebSocketsSimpleError (..)+ WebSocketsApp (..), WebSocketsAppParams (..)+ , Network.WebSockets.ConnectionException (..), CloseOrigin (..), WebSocketsSimpleError (..) , -- * Running- toClientAppT, toClientAppT', toServerAppT+ toClientAppT+ , toServerAppT , -- * Utilities expBackoffStrategy , hoistWebSocketsApp@@ -26,12 +27,11 @@ import qualified Data.Aeson as Aeson import Data.ByteString.Lazy (ByteString) -import Control.Monad (void, forever)+import Control.Monad (forever) import Control.Monad.IO.Class (MonadIO (..)) 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, link) import Control.Concurrent.STM (atomically, newTVarIO, readTVarIO, writeTVar) import GHC.Generics (Generic)@@ -48,15 +48,21 @@ data WebSocketsApp m receive send = WebSocketsApp { onOpen :: WebSocketsAppParams m send -> m () , onReceive :: WebSocketsAppParams m send -> receive -> m ()- , onClose :: ConnectionException -> m () -- ^ Should be re-entrant; this exception is caught in all uses of 'send', even if used in a dead 'Network.WebSockets.Connection' in a lingering thread.+ , onClose :: CloseOrigin -> ConnectionException -> m () -- ^ Should be re-entrant; this exception is caught in all uses of 'send', even if used in a dead 'Network.WebSockets.Connection' in a lingering thread. } deriving (Generic, Typeable) +data CloseOrigin+ = ClosedOnSend+ | ClosedOnClose+ | ClosedOnReceive++ instance Profunctor (WebSocketsApp m) where dimap :: forall a b c d. (a -> b) -> (c -> d) -> WebSocketsApp m b c -> WebSocketsApp m a d dimap receiveF sendF WebSocketsApp{onOpen,onReceive,onClose} = WebSocketsApp { onOpen = \params -> onOpen (getParams params) , onReceive = \params r -> onReceive (getParams params) (receiveF r)- , onClose = onClose+ , onClose = \o e -> onClose o e } where getParams :: WebSocketsAppParams m d -> WebSocketsAppParams m c@@ -68,9 +74,9 @@ -> WebSocketsApp m receive send -> WebSocketsApp n receive send hoistWebSocketsApp f coF WebSocketsApp{onOpen,onReceive,onClose} = WebSocketsApp- { onOpen = \WebSocketsAppParams{send,close} -> f $ onOpen WebSocketsAppParams{send = coF . send, close = coF close}- , onReceive = \WebSocketsAppParams{send,close} r -> f $ onReceive WebSocketsAppParams{send = coF . send, close = coF close} r- , onClose = f . onClose+ { onOpen = \WebSocketsAppParams{send,close} -> f (onOpen WebSocketsAppParams{send = coF . send, close = coF close})+ , onReceive = \WebSocketsAppParams{send,close} r -> f (onReceive WebSocketsAppParams{send = coF . send, close = coF close} r)+ , onClose = \o e -> f (onClose o e) } @@ -79,12 +85,12 @@ mempty = WebSocketsApp { onOpen = \_ -> pure () , onReceive = \_ _ -> pure ()- , onClose = \_ -> pure ()+ , onClose = \_ _ -> pure () } mappend x y = WebSocketsApp { onOpen = \params -> onOpen x params *> onOpen y params , onReceive = \params r -> onReceive x params r *> onReceive y params r- , onClose = \mE -> onClose x mE *> onClose y mE+ , onClose = \o mE -> onClose x o mE *> onClose y o mE } @@ -98,21 +104,21 @@ , MonadCatch m ) => WebSocketsApp m receive send- -> ClientAppT m WebSocketsAppThreads+ -> ClientAppT m () -- WebSocketsAppThreads toClientAppT WebSocketsApp{onOpen,onReceive,onClose} conn = do let send :: send -> m ()- send x = liftIO (sendTextData conn (Aeson.encode x)) `catch` onClose+ send x = liftIO (sendTextData conn (Aeson.encode x)) `catch` (onClose ClosedOnSend) close :: m ()- close = liftIO (sendClose conn (Aeson.encode "requesting close")) `catch` onClose+ close = liftIO (sendClose conn (Aeson.encode "requesting close")) `catch` (onClose ClosedOnClose) params :: WebSocketsAppParams m send params = WebSocketsAppParams{send,close} onOpen params - receivingThread <- liftBaseWith $ \runInBase -> async $ forever $- let go' = do+ liftBaseWith $ \runInBase ->+ let go' = forever $ do data' <- receiveDataMessage conn let data'' = case data' of Text xs _ -> xs@@ -120,26 +126,10 @@ case Aeson.decode data'' of Nothing -> throwM (JSONParseError data'') Just received -> runInBase (onReceive params received)- in go' `catch` (runInBase . onClose)-- liftIO (link receivingThread)-- pure $ WebSocketsAppThreads- { wsAppReceivingThread = receivingThread- }+ in go' `catch` (\e -> () <$ (runInBase (onClose ClosedOnReceive e))) -toClientAppT' :: ( ToJSON send- , FromJSON receive- , MonadIO m- , MonadBaseControl IO m- , MonadThrow m- , MonadCatch m- ) => WebSocketsApp m receive send -> ClientAppT m ()-toClientAppT' wsApp conn = void (toClientAppT wsApp conn)-- toServerAppT :: ( ToJSON send , FromJSON receive , MonadIO m@@ -147,9 +137,8 @@ , MonadThrow m , MonadCatch m ) => WebSocketsApp m receive send -> ServerAppT m-toServerAppT wsApp pending = do- conn <- liftBaseWith $ \_ -> acceptRequest pending- toClientAppT' wsApp conn+toServerAppT wsApp pending =+ liftIO (acceptRequest pending) >>= toClientAppT wsApp @@ -183,7 +172,3 @@ instance Exception WebSocketsSimpleError --newtype WebSocketsAppThreads = WebSocketsAppThreads- { wsAppReceivingThread :: Async ()- }
src/Test/WebSockets/Simple.hs view
@@ -7,7 +7,7 @@ module Test.WebSockets.Simple where -import Network.WebSockets.Simple (WebSocketsApp (..), WebSocketsAppParams (..), ConnectionException (..))+import Network.WebSockets.Simple (WebSocketsApp (..), WebSocketsAppParams (..), ConnectionException (..), CloseOrigin (..)) import Control.Monad (forever, void) import Control.Monad.IO.Class (MonadIO (..)) import Control.Monad.Trans.Control (MonadBaseControl (..))@@ -36,8 +36,8 @@ close :: m () close = do- onClose sendsRreceivesS ConnectionClosed- onClose sendsSreceivesR ConnectionClosed+ onClose sendsRreceivesS ClosedOnClose ConnectionClosed+ onClose sendsSreceivesR ClosedOnClose ConnectionClosed sToR <- liftBaseWith $ \runInBase -> async $ forever $ do s <- atomically $ readTChan sendChan
test/Spec.hs view
@@ -23,7 +23,7 @@ putStrLn "sent." , onReceive = \_ x -> atomically $ writeTChan receivedChan x- , onClose = \_ -> pure ()+ , onClose = \_ _ -> pure () } testSendingApp :: WebSocketsApp IO Int Int@@ -34,7 +34,7 @@ threadDelay $ 10^6 * 10 send x putStrLn "sent."- , onClose = \_ -> pure ()+ , onClose = \_ _ -> pure () }
websockets-simple.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 0fd7a69684c73e2d69f006be6b9f3028e804149928f115366bc6ef246ebe1cf5+-- hash: d677af901275b84a23a53024bc83e2471998b8ed21dc32553b0a23c736723cd1 name: websockets-simple-version: 0.0.7+version: 0.1.0 synopsis: Composable websockets clients description: See README at <https://github.com/athanclark/websockets-simple#readme> category: Web@@ -46,7 +46,7 @@ , stm , transformers , wai-transformers- , websockets >=0.11+ , websockets >=0.12.3 default-language: Haskell2010 test-suite spec@@ -76,6 +76,6 @@ , tasty-hspec , transformers , wai-transformers- , websockets >=0.11+ , websockets >=0.12.3 , websockets-simple default-language: Haskell2010