websockets-simple 0.1.1 → 0.1.2
raw patch · 4 files changed
+45/−32 lines, 4 filesdep +extractable-singletondep +monad-control-aligneddep −monad-controldep ~wai-transformersdep ~websockets
Dependencies added: extractable-singleton, monad-control-aligned
Dependencies removed: monad-control
Dependency ranges changed: wai-transformers, websockets
Files
- src/Network/WebSockets/Simple.hs +21/−14
- src/Network/WebSockets/Simple/PingPong.hs +6/−4
- src/Test/WebSockets/Simple.hs +8/−6
- websockets-simple.cabal +10/−8
src/Network/WebSockets/Simple.hs view
@@ -21,16 +21,17 @@ ) where import Network.WebSockets (DataMessage (..), sendTextData, sendClose, receiveDataMessage, acceptRequest, ConnectionException (..))-import Network.Wai.Trans (ServerAppT, ClientAppT)+import Network.WebSockets.Trans (ServerAppT, ClientAppT) import Data.Profunctor (Profunctor (..)) import Data.Aeson (ToJSON (..), FromJSON (..)) import qualified Data.Aeson as Aeson 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.Trans.Control (MonadBaseControl (..))+import Control.Monad.Trans.Control.Aligned (MonadBaseControl (..)) import Control.Concurrent (threadDelay) import Control.Concurrent.STM (atomically, newTVarIO, readTVarIO, writeTVar) @@ -96,14 +97,14 @@ -- | This can throw a 'WebSocketSimpleError' to the main thread via 'Control.Concurrent.Async.link' when json parsing fails.-toClientAppT :: forall send receive m- . ( ToJSON send- , FromJSON receive- , MonadIO m- , MonadBaseControl IO m- , MonadThrow m- , MonadCatch m- )+toClientAppT :: forall send receive m stM+ . ToJSON send+ => FromJSON receive+ => MonadIO m+ => MonadBaseControl IO m stM+ => MonadThrow m+ => MonadCatch m+ => Extractable stM => WebSocketsApp m receive send -> ClientAppT m () -- WebSocketsAppThreads toClientAppT WebSocketsApp{onOpen,onReceive,onClose} conn = do@@ -119,24 +120,30 @@ onOpen params liftBaseWith $ \runInBase ->- let go' = forever $ do+ let runM :: forall a. m a -> IO a+ runM = fmap runSingleton . runInBase++ go' :: IO ()+ go' = forever $ do data' <- receiveDataMessage conn let data'' = case data' of Text xs _ -> xs Binary xs -> xs+ putStrLn $ show data'' case Aeson.decode data'' of Nothing -> throwM (JSONParseError data'')- Just received -> runInBase (onReceive params received)- in go' `catch` (\e -> () <$ (runInBase (onClose ClosedOnReceive e)))+ Just received -> runM (onReceive params received)+ in go' `catch` (runM . onClose ClosedOnReceive) toServerAppT :: ( ToJSON send , FromJSON receive , MonadIO m- , MonadBaseControl IO 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
src/Network/WebSockets/Simple/PingPong.hs view
@@ -11,8 +11,9 @@ 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 (MonadBaseControl (..))+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)@@ -38,13 +39,14 @@ -pingPong :: ( MonadBaseControl IO m+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} = do- pingingThread <- liftBaseWith $ \_ -> newEmptyTMVarIO+pingPong delay WebSocketsApp{onOpen,onReceive,onClose} = liftBaseWith $ \_ -> do+ pingingThread <- newEmptyTMVarIO pure WebSocketsApp { onOpen = \params@WebSocketsAppParams{send} -> do
src/Test/WebSockets/Simple.hs view
@@ -8,9 +8,10 @@ module Test.WebSockets.Simple where import Network.WebSockets.Simple (WebSocketsApp (..), WebSocketsAppParams (..), ConnectionException (..), CloseOrigin (..))-import Control.Monad (forever, void)+import Data.Singleton.Class (Extractable (..))+import Control.Monad (forever) import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.Trans.Control (MonadBaseControl (..))+import Control.Monad.Trans.Control.Aligned (MonadBaseControl (..)) import Control.Concurrent.Async (Async, async) import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TChan (TChan, newTChan, writeTChan, readTChan)@@ -18,9 +19,10 @@ -- | Runs two 'WebSocketsApp's together in a forged channel.-runConnected :: forall send receive m+runConnected :: forall send receive m stM . ( MonadIO m- , MonadBaseControl IO m+ , MonadBaseControl IO m stM+ , Extractable stM ) => WebSocketsApp m receive send -> WebSocketsApp m send receive@@ -41,14 +43,14 @@ sToR <- liftBaseWith $ \runInBase -> async $ forever $ do s <- atomically $ readTChan sendChan- void $ runInBase $ onReceive sendsRreceivesS WebSocketsAppParams+ fmap runSingleton $ runInBase $ onReceive sendsRreceivesS WebSocketsAppParams { send = sendToReceive , close } s rToS <- liftBaseWith $ \runInBase -> async $ forever $ do r <- atomically $ readTChan receiveChan- void $ runInBase $ onReceive sendsSreceivesR WebSocketsAppParams+ fmap runSingleton $ runInBase $ onReceive sendsSreceivesR WebSocketsAppParams { send = sendToSend , close } r
websockets-simple.cabal view
@@ -2,10 +2,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: b864ea883942ac76ccc4d385c87d3c8613080be5d10c29723565111d84ef549b+-- hash: bf5ddb451632a405334939c43f387b4312612ae76051e88ebd8cba2f80ac63dc name: websockets-simple-version: 0.1.1+version: 0.1.2 synopsis: Composable websockets clients description: See README at <https://github.com/athanclark/websockets-simple#readme> category: Web@@ -40,13 +40,14 @@ , base >=4.9 && <5 , bytestring , exceptions- , monad-control+ , extractable-singleton >=0.0.1+ , monad-control-aligned >=0.0.1 , profunctors , stm , transformers , vector- , wai-transformers- , websockets >=0.12.3+ , wai-transformers >=0.1.0+ , websockets >=0.12.4 default-language: Haskell2010 test-suite spec@@ -67,15 +68,16 @@ , base >=4.9 && <5 , bytestring , exceptions+ , extractable-singleton >=0.0.1 , hspec- , monad-control+ , monad-control-aligned >=0.0.1 , profunctors , stm , tasty , tasty-hspec , transformers , vector- , wai-transformers- , websockets >=0.12.3+ , wai-transformers >=0.1.0+ , websockets >=0.12.4 , websockets-simple default-language: Haskell2010