websockets-simple 0.1.3 → 0.2.0
raw patch · 3 files changed
+123/−110 lines, 3 filesdep +chandep +textdep −vector
Dependencies added: chan, text
Dependencies removed: vector
Files
- src/Network/WebSockets/Simple.hs +116/−33
- src/Network/WebSockets/Simple/PingPong.hs +0/−70
- websockets-simple.cabal +7/−7
src/Network/WebSockets/Simple.hs view
@@ -6,6 +6,7 @@ , NamedFieldPuns , FlexibleContexts , InstanceSigs+ , OverloadedStrings #-} module Network.WebSockets.Simple@@ -13,24 +14,31 @@ WebSocketsApp (..), WebSocketsAppParams (..) , Network.WebSockets.ConnectionException (..), CloseOrigin (..), WebSocketsSimpleError (..) , -- * Running- toClientAppT- , toServerAppT+ dimap', dimapJson, dimapStringify+ , toClientAppT, toClientAppTString, toClientAppTBinary, toClientAppTBoth+ , accept , -- * Utilities expBackoffStrategy , hoistWebSocketsApp ) where -import Network.WebSockets (DataMessage (..), sendTextData, sendClose, receiveDataMessage, acceptRequest, ConnectionException (..))+import Network.WebSockets+ ( DataMessage (..), sendTextData, sendBinaryData+ , sendClose, receiveDataMessage, acceptRequest, ConnectionException (..)) import Network.WebSockets.Trans (ServerAppT, ClientAppT) import Data.Profunctor (Profunctor (..))-import Data.Aeson (ToJSON (..), FromJSON (..))+import Data.Aeson (ToJSON (..), FromJSON (..), Value) import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson+import Data.Maybe (fromMaybe)+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy.Encoding as LT import Data.ByteString.Lazy (ByteString) import Data.Singleton.Class (Extractable (..)) import Control.Monad (forever) import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Catch (Exception, throwM, MonadThrow, catch, MonadCatch)+import Control.Monad.Catch (Exception, MonadThrow, catch, throwM, MonadCatch) import Control.Monad.Trans.Control.Aligned (MonadBaseControl (..)) import Control.Concurrent (threadDelay) import Control.Concurrent.STM (atomically, newTVarIO, readTVarIO, writeTVar)@@ -62,9 +70,9 @@ 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 = \o e -> onClose o e+ { onOpen = onOpen . getParams+ , onReceive = \params -> onReceive (getParams params) . receiveF+ , onClose = onClose } where getParams :: WebSocketsAppParams m d -> WebSocketsAppParams m c@@ -99,6 +107,46 @@ } +dimap' :: Monad m+ => (receive' -> m receive)+ -> (send -> send')+ -> WebSocketsApp m receive send+ -> WebSocketsApp m receive' send'+dimap' from to WebSocketsApp{onReceive,onOpen,onClose} = WebSocketsApp+ { onOpen = onOpen . newParams+ , onClose+ , onReceive = \params r -> from r >>= onReceive (newParams params)+ }+ where+ newParams WebSocketsAppParams{send,close} = WebSocketsAppParams+ { send = send . to+ , close+ }+++dimapJson :: ToJSON send+ => FromJSON receive+ => MonadThrow m+ => WebSocketsApp m receive send+ -> WebSocketsApp m Value Value+dimapJson = dimap' fromJson toJSON+ where+ fromJson x = case Aeson.parseMaybe parseJSON x of+ Nothing -> throwM (JSONValueError x)+ Just y -> pure y+++dimapStringify :: MonadThrow m+ => WebSocketsApp m Value Value+ -> WebSocketsApp m Text Text+dimapStringify = dimap' fromJson (LT.decodeUtf8 . Aeson.encode)+ where+ fromJson x = case Aeson.decode (LT.encodeUtf8 x) of+ Nothing -> throwM (JSONParseError x)+ Just y -> pure y+++ -- | This can throw a 'WebSocketSimpleError' to the main thread via 'Control.Concurrent.Async.link' when json parsing fails. toClientAppT :: forall send receive m stM . ToJSON send@@ -110,17 +158,57 @@ => Extractable stM => WebSocketsApp m receive send -> ClientAppT m () -- WebSocketsAppThreads-toClientAppT WebSocketsApp{onOpen,onReceive,onClose} conn = do- let send :: send -> m ()- send x = liftIO (sendTextData conn (Aeson.encode x)) `catch` (onClose ClosedOnSend)+toClientAppT = toClientAppTString . dimapStringify . dimapJson ++toClientAppTString :: MonadBaseControl IO m stM+ => Extractable stM+ => MonadCatch m+ => MonadIO m+ => WebSocketsApp m Text Text+ -> ClientAppT m ()+toClientAppTString x = toClientAppTBoth x mempty++++toClientAppTBinary :: MonadBaseControl IO m stM+ => Extractable stM+ => MonadCatch m+ => MonadIO m+ => WebSocketsApp m ByteString ByteString+ -> ClientAppT m ()+toClientAppTBinary = toClientAppTBoth mempty++++toClientAppTBoth :: forall m stM+ . MonadBaseControl IO m stM+ => Extractable stM+ => MonadCatch m+ => MonadIO m+ => WebSocketsApp m Text Text+ -> WebSocketsApp m ByteString ByteString+ -> ClientAppT m ()+toClientAppTBoth textApp binApp conn = do+ let sendText :: Text -> m ()+ sendText x = liftIO (sendTextData conn x) `catch` onClose textApp ClosedOnSend+ sendBin :: ByteString -> m ()+ sendBin x = liftIO (sendBinaryData conn x) `catch` onClose binApp ClosedOnSend+ catchBoth :: ConnectionException -> m ()+ catchBoth e = do+ onClose textApp ClosedOnReceive e+ onClose binApp ClosedOnReceive e+ close :: m ()- close = liftIO (sendClose conn (Aeson.encode "requesting close")) `catch` (onClose ClosedOnClose)+ close = liftIO (sendClose conn ("requesting close" :: ByteString)) `catch` catchBoth - params :: WebSocketsAppParams m send- params = WebSocketsAppParams{send,close}+ paramsText :: WebSocketsAppParams m Text+ paramsText = WebSocketsAppParams{send=sendText,close}+ paramsBin :: WebSocketsAppParams m ByteString+ paramsBin = WebSocketsAppParams{send=sendBin,close} - onOpen params+ onOpen textApp paramsText+ onOpen binApp paramsBin liftBaseWith $ \runInBase -> let runM :: forall a. m a -> IO a@@ -129,26 +217,20 @@ go' :: IO () go' = forever $ do data' <- receiveDataMessage conn- let data'' = case data' of- Text xs _ -> xs- Binary xs -> xs- case Aeson.decode data'' of- Nothing -> throwM (JSONParseError data'')- Just received -> runM (onReceive params received)- in go' `catch` (runM . onClose ClosedOnReceive)+ case data' of+ Text xs mt ->+ let t = fromMaybe (LT.decodeUtf8 xs) mt+ in runM (onReceive textApp paramsText t)+ Binary xs ->+ runM (onReceive binApp paramsBin xs)+ in go' `catch` (runM . catchBoth) -toServerAppT :: ( ToJSON send- , FromJSON receive- , MonadIO m- , MonadBaseControl IO m stM- , MonadThrow m- , MonadCatch m- , Extractable stM- ) => WebSocketsApp m receive send -> ServerAppT m-toServerAppT wsApp pending =- liftIO (acceptRequest pending) >>= toClientAppT wsApp+accept :: MonadIO m+ => ClientAppT m () -> ServerAppT m+accept wsApp pending =+ liftIO (acceptRequest pending) >>= wsApp @@ -177,7 +259,8 @@ data WebSocketsSimpleError- = JSONParseError ByteString+ = JSONParseError Text+ | JSONValueError Value deriving (Generic, Eq, Show) instance Exception WebSocketsSimpleError
− src/Network/WebSockets/Simple/PingPong.hs
@@ -1,70 +0,0 @@-{-# LANGUAGE- NamedFieldPuns- , FlexibleContexts- , OverloadedStrings- #-}--module Network.WebSockets.Simple.PingPong where--import Network.WebSockets.Simple (WebSocketsApp (..), WebSocketsAppParams (..))--import Data.Aeson (ToJSON (..), FromJSON (..))-import Data.Aeson.Types (Value (Array, String), typeMismatch)-import qualified Data.Vector as V-import Data.Singleton.Class (Extractable (..))-import Control.Monad (forever)-import Control.Monad.Trans.Control.Aligned (MonadBaseControl (..))-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-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) = 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)- | V.length xs /= 1 = typeMismatch "PingPong" x- | otherwise = (PingPong . Just) <$> parseJSON (xs V.! 0)- parseJSON x = typeMismatch "PingPong" x----pingPong :: ( MonadBaseControl IO m stM- , Extractable stM- )- => Int -- ^ Delay in microseconds- -> WebSocketsApp m receive send- -> m (WebSocketsApp m (PingPong receive) (PingPong send))-pingPong delay WebSocketsApp{onOpen,onReceive,onClose} = liftBaseWith $ \_ -> do- pingingThread <- newEmptyTMVarIO-- pure WebSocketsApp- { onOpen = \params@WebSocketsAppParams{send} -> do- liftBaseWith $ \runInBase -> do- 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 -> 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}
websockets-simple.cabal view
@@ -1,13 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.0.+-- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack ----- hash: c6c649d6e20c4061859caec35f547b3c3c7fe686cf1985bd22168192827c25b1+-- hash: d3277adc30d4a6957a76a3f79a3479037bce7a2d42c555a9723c781e58f09f61 name: websockets-simple-version: 0.1.3+version: 0.2.0 synopsis: Composable websockets clients description: See README at <https://github.com/athanclark/websockets-simple#readme> category: Web@@ -27,7 +27,6 @@ library exposed-modules: Network.WebSockets.Simple- Network.WebSockets.Simple.PingPong Test.WebSockets.Simple other-modules: Paths_websockets_simple@@ -39,13 +38,14 @@ , async , base >=4.11 && <5 , bytestring+ , chan >=0.0.4 , exceptions , extractable-singleton >=0.0.1 , monad-control-aligned >=0.0.1 , profunctors , stm+ , text , transformers- , vector , wai-transformers >=0.1.0 , websockets >=0.12.4 default-language: Haskell2010@@ -55,7 +55,6 @@ main-is: Spec.hs other-modules: Network.WebSockets.Simple- Network.WebSockets.Simple.PingPong Test.WebSockets.Simple Paths_websockets_simple hs-source-dirs:@@ -67,6 +66,7 @@ , async , base >=4.11 && <5 , bytestring+ , chan >=0.0.4 , exceptions , extractable-singleton >=0.0.1 , hspec@@ -75,8 +75,8 @@ , stm , tasty , tasty-hspec+ , text , transformers- , vector , wai-transformers >=0.1.0 , websockets >=0.12.4 , websockets-simple