Fix yesod-websockets

yesod-websockets/Yesod/WebSockets.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP                   #-}
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 module Yesod.WebSockets
@@ -34,10 +33,9 @@ module Yesod.WebSockets
     , WS.ConnectionOptions (..)
     ) where
 
-import           Control.Monad                  (forever, void, when)
+import           Control.Monad                  (forever, when)
-import           Control.Monad.Trans.Reader     (ReaderT (ReaderT, runReaderT))
+import           Control.Monad.Reader           (ReaderT, runReaderT, MonadReader, ask)
-import qualified Data.Conduit                   as C
+import           Conduit
-import qualified Data.Conduit.List              as CL
 import qualified Network.Wai.Handler.WebSockets as WaiWS
 import qualified Network.WebSockets             as WS
 import qualified Yesod.Core                     as Y
@@ -55,28 +53,28 @@ type WebSocketsT = ReaderT WS.Connection
 -- instead.
 --
 -- Since 0.1.0
-webSockets :: (Y.MonadUnliftIO m, Y.MonadHandler m) => WebSocketsT m () -> m ()
+webSockets
+  :: (MonadUnliftIO m, Y.MonadHandler m)
+  => WebSocketsT m ()
+  -> m ()
 webSockets = webSocketsOptions WS.defaultConnectionOptions
 
 -- | Varient of 'webSockets' which allows you to specify
 -- the WS.ConnectionOptions setttings when upgrading to a websocket connection.
 --
 -- Since 0.2.5
-webSocketsOptions :: (Y.MonadUnliftIO m, Y.MonadHandler m)
+webSocketsOptions
-               => WS.ConnectionOptions
+  :: (MonadUnliftIO m, Y.MonadHandler m)
-               -> WebSocketsT m ()
+  => WS.ConnectionOptions
-               -> m ()
+  -> WebSocketsT m ()
-#if MIN_VERSION_websockets(0,10,0)
+  -> m ()
 webSocketsOptions opts = webSocketsOptionsWith opts $ const $ return $ Just $ WS.AcceptRequest Nothing []
-#else
-webSocketsOptions opts = webSocketsOptionsWith opts $ const $ return $ Just $ WS.AcceptRequest Nothing
-#endif
 
 -- | Varient of 'webSockets' which allows you to specify the 'WS.AcceptRequest'
 -- setttings when upgrading to a websocket connection.
 --
 -- Since 0.2.4
-webSocketsWith :: (Y.MonadUnliftIO m, Y.MonadHandler m)
+webSocketsWith :: (MonadUnliftIO m, Y.MonadHandler m)
                => (WS.RequestHead -> m (Maybe WS.AcceptRequest))
                -- ^ A Nothing indicates that the websocket upgrade request should not happen
                -- and instead the rest of the handler will be called instead.  This allows
@@ -93,7 +91,7 @@ webSocketsWith = webSocketsOptionsWith WS.defaultConnectionOptions
 -- setttings when upgrading to a websocket connection.
 --
 -- Since 0.2.5
-webSocketsOptionsWith :: (Y.MonadUnliftIO m, Y.MonadHandler m)
+webSocketsOptionsWith :: (MonadUnliftIO m, Y.MonadHandler m)
                => WS.ConnectionOptions
                -- ^ Custom websockets options
                -> (WS.RequestHead -> m (Maybe WS.AcceptRequest))
@@ -125,100 +123,157 @@ webSocketsOptionsWith wsConnOpts buildAr inner = do
                     sink
 
 -- | Wrapper for capturing exceptions
-wrapWSE :: MonadIO m => (WS.Connection -> a -> IO ())-> a -> WebSocketsT m (Either SomeException ())
+wrapWSE :: (MonadIO m, MonadReader WS.Connection m)
-wrapWSE ws x = ReaderT $ liftIO . tryAny . flip ws x
+        => (WS.Connection -> a -> IO ())
+        -> a
+        -> m (Either SomeException ())
+wrapWSE ws x = do
+  conn <- ask
+  liftIO $ tryAny $ ws conn x
 
-wrapWS :: MonadIO m => (WS.Connection -> a -> IO ()) -> a -> WebSocketsT m ()
+wrapWS :: (MonadIO m, MonadReader WS.Connection m)
-wrapWS ws x = ReaderT $ liftIO . flip ws x
+       => (WS.Connection -> a -> IO ())
+       -> a
+       -> m ()
+wrapWS ws x = do
+  conn <- ask
+  liftIO $ ws conn x
 
 -- | Receive a piece of data from the client.
 --
 -- Since 0.1.0
-receiveData :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m a
+receiveData
-receiveData = ReaderT $ liftIO . WS.receiveData
+  :: (MonadIO m, MonadReader WS.Connection m, WS.WebSocketsData a)
+  => m a
+receiveData = do
+  conn <- ask
+  liftIO $ WS.receiveData conn
 
 -- | Receive a piece of data from the client.
 -- Capture SomeException as the result or operation
 -- Since 0.2.2
-receiveDataE :: (MonadIO m, WS.WebSocketsData a) => WebSocketsT m (Either SomeException a)
+receiveDataE
-receiveDataE = ReaderT $ liftIO . tryAny . WS.receiveData
+  :: (MonadIO m, MonadReader WS.Connection m, WS.WebSocketsData a)
+  => m (Either SomeException a)
+receiveDataE = do
+  conn <- ask
+  liftIO $ tryAny $ WS.receiveData conn
 
 -- | Receive an application message.
 -- Capture SomeException as the result or operation
 -- Since 0.2.3
-receiveDataMessageE :: (MonadIO m) => WebSocketsT m (Either SomeException WS.DataMessage)
+receiveDataMessageE
-receiveDataMessageE = ReaderT $ liftIO . tryAny . WS.receiveDataMessage
+  :: (MonadIO m, MonadReader WS.Connection m)
+  => m (Either SomeException WS.DataMessage)
+receiveDataMessageE = do
+  conn <- ask
+  liftIO $ tryAny $ WS.receiveDataMessage conn
 
 -- | Send a textual message to the client.
 --
 -- Since 0.1.0
-sendTextData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
+sendTextData
+  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  => a
+  -> m ()
 sendTextData = wrapWS WS.sendTextData
 
 -- | Send a textual message to the client.
 -- Capture SomeException as the result or operation
--- and can be used like 
+-- and can be used like
 -- `either handle_exception return =<< sendTextDataE ("Welcome" :: Text)`
 -- Since 0.2.2
-sendTextDataE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ())
+sendTextDataE
+  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  => a
+  -> m (Either SomeException ())
 sendTextDataE = wrapWSE WS.sendTextData
 
 -- | Send a binary message to the client.
 --
 -- Since 0.1.0
-sendBinaryData :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
+sendBinaryData
+  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  => a
+  -> m ()
 sendBinaryData = wrapWS WS.sendBinaryData
 
 -- | Send a binary message to the client.
 -- Capture SomeException as the result of operation
 -- Since 0.2.2
-sendBinaryDataE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ())
+sendBinaryDataE
+  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  => a
+  -> m (Either SomeException ())
 sendBinaryDataE = wrapWSE WS.sendBinaryData
 
 -- | Send a ping message to the client.
 --
 -- Since 0.2.2
-sendPing :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
+sendPing
+  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  => a
+  -> WebSocketsT m ()
 sendPing = wrapWS WS.sendPing
 
--- | Send a ping message to the client. 
+-- | Send a ping message to the client.
 -- Capture SomeException as the result of operation
 -- Since 0.2.2
-sendPingE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ())
+sendPingE
+  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  => a
+  -> m (Either SomeException ())
 sendPingE = wrapWSE WS.sendPing
 
--- | Send a DataMessage to the client. 
+-- | Send a DataMessage to the client.
 -- Capture SomeException as the result of operation
 -- Since 0.2.3
-sendDataMessageE :: (MonadIO m) => WS.DataMessage -> WebSocketsT m (Either SomeException ())
+sendDataMessageE
-sendDataMessageE x = ReaderT $ liftIO . tryAny . (`WS.sendDataMessage` x)
+  :: (MonadIO m, MonadReader WS.Connection m)
+  => WS.DataMessage
+  -> m (Either SomeException ())
+sendDataMessageE x = do
+  conn <- ask
+  liftIO $ tryAny $ WS.sendDataMessage conn x
 
--- | Send a close request to the client. 
+-- | Send a close request to the client.
--- 
+--
 -- Since 0.2.2
-sendClose :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m ()
+sendClose
+  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  => a
+  -> WebSocketsT m ()
 sendClose = wrapWS WS.sendClose
 
--- | Send a close request to the client. 
+-- | Send a close request to the client.
 -- Capture SomeException as the result of operation
 -- Since 0.2.2
-sendCloseE :: (MonadIO m, WS.WebSocketsData a) => a -> WebSocketsT m (Either SomeException ())
+sendCloseE
+  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  => a
+  -> m (Either SomeException ())
 sendCloseE = wrapWSE WS.sendClose
 
 -- | A @Source@ of WebSockets data from the user.
 --
 -- Since 0.1.0
-sourceWS :: (MonadIO m, WS.WebSocketsData a) => C.Producer (WebSocketsT m) a
+sourceWS
-sourceWS = forever $ Y.lift receiveData >>= C.yield
+  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  => ConduitT i a m ()
+sourceWS = forever $ lift receiveData >>= yield
 
 -- | A @Sink@ for sending textual data to the user.
 --
 -- Since 0.1.0
-sinkWSText :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) ()
+sinkWSText
-sinkWSText = CL.mapM_ sendTextData
+  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  => ConduitT a o m ()
+sinkWSText = mapM_C sendTextData
 
 -- | A @Sink@ for sending binary data to the user.
 --
 -- Since 0.1.0
-sinkWSBinary :: (MonadIO m, WS.WebSocketsData a) => C.Consumer a (WebSocketsT m) ()
+sinkWSBinary
-sinkWSBinary = CL.mapM_ sendBinaryData
+  :: (MonadIO m, WS.WebSocketsData a, MonadReader WS.Connection m)
+  => ConduitT a o m ()
+sinkWSBinary = mapM_C sendBinaryData

yesod-websockets/yesod-websockets.cabal

@@ -21,11 +21,12 @@ library
                      , wai
 
                      , wai-websockets    >= 2.1
-                     , websockets        >= 0.9
+                     , websockets        >= 0.10
                      , transformers      >= 0.2
                      , yesod-core        >= 1.6
                      , unliftio
                      , conduit           >= 1.3
+                     , mtl
 
 source-repository head
   type:     git