diff --git a/src/Network/WebSockets/Simple.hs b/src/Network/WebSockets/Simple.hs --- a/src/Network/WebSockets/Simple.hs +++ b/src/Network/WebSockets/Simple.hs @@ -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 diff --git a/src/Network/WebSockets/Simple/PingPong.hs b/src/Network/WebSockets/Simple/PingPong.hs deleted file mode 100644 --- a/src/Network/WebSockets/Simple/PingPong.hs +++ /dev/null @@ -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} diff --git a/websockets-simple.cabal b/websockets-simple.cabal --- a/websockets-simple.cabal +++ b/websockets-simple.cabal @@ -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 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