diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,27 @@ +## 3.0.1.2 + +* Drop unused dependency on blaze-builder + +## 3.0.1.1 + +* Doc improvement + +## 3.0.1 + +* Improved connection close logic + +## 3.0.0.9 + +* Clean up stream resources when websockets completes [#549](https://github.com/yesodweb/wai/pull/549) + +## 3.0.0.8 + +* Support wai 3.2 + +## 3.0.0.7 + +* Improved documentation [#471](https://github.com/yesodweb/wai/pull/471) + +## 3.0.0.5 + +Allow blaze-builder 0.4 diff --git a/Network/Wai/Handler/WebSockets.hs b/Network/Wai/Handler/WebSockets.hs --- a/Network/Wai/Handler/WebSockets.hs +++ b/Network/Wai/Handler/WebSockets.hs @@ -1,82 +1,118 @@ {-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.WebSockets - ( intercept - , interceptWith + ( websocketsOr + , websocketsApp + , isWebSocketsReq + , getRequestHead + , runWebSockets ) where -import Control.Monad.IO.Class (liftIO) -import Blaze.ByteString.Builder (Builder) -import qualified Blaze.ByteString.Builder as Builder +import Control.Exception (bracket, tryJust) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BC -import Data.Char (toLower) -import Data.Conduit +import qualified Data.ByteString.Lazy as BL +import qualified Data.CaseInsensitive as CI +import Network.HTTP.Types (status500) import qualified Network.Wai as Wai -import qualified Network.Wai.Handler.Warp as Warp import qualified Network.WebSockets as WS import qualified Network.WebSockets.Connection as WS -import System.IO.Streams (InputStream, OutputStream) -import qualified System.IO.Streams as Streams +import qualified Network.WebSockets.Stream as WS -------------------------------------------------------------------------------- --- | For use with 'settingsIntercept' from the Warp web server. -intercept :: WS.ServerApp - -> Wai.Request - -> Maybe (Source (ResourceT IO) ByteString -> Warp.Connection -> ResourceT IO ()) -intercept = interceptWith WS.defaultConnectionOptions +-- | Returns whether or not the given 'Wai.Request' is a WebSocket request. +isWebSocketsReq :: Wai.Request -> Bool +isWebSocketsReq req = + fmap CI.mk (lookup "upgrade" $ Wai.requestHeaders req) == Just "websocket" -------------------------------------------------------------------------------- --- | Variation of 'intercept' which allows custom options. -interceptWith :: WS.ConnectionOptions +-- | Upgrade a @websockets@ 'WS.ServerApp' to a @wai@ 'Wai.Application'. Uses +-- the given backup 'Wai.Application' to handle 'Wai.Request's that are not +-- WebSocket requests. +-- +-- @ +-- websocketsOr opts ws_app backup_app = \\req respond -> +-- __case__ 'websocketsApp' opts ws_app req __of__ +-- 'Nothing' -> backup_app req send_response +-- 'Just' res -> respond res +-- @ +-- +-- For example, below is an 'Wai.Application' that sends @"Hello, client!"@ to +-- each connected client. +-- +-- @ +-- app :: 'Wai.Application' +-- app = 'websocketsOr' 'WS.defaultConnectionOptions' wsApp backupApp +-- __where__ +-- wsApp :: 'WS.ServerApp' +-- wsApp pending_conn = do +-- conn <- 'WS.acceptRequest' pending_conn +-- 'WS.sendTextData' conn ("Hello, client!" :: 'Data.Text.Text') +-- +-- backupApp :: 'Wai.Application' +-- backupApp _ respond = respond $ 'Wai.responseLBS' 'Network.HTTP.Types.status400' [] "Not a WebSocket request" +-- @ +websocketsOr :: WS.ConnectionOptions + -> WS.ServerApp + -> Wai.Application + -> Wai.Application +websocketsOr opts app backup req sendResponse = + case websocketsApp opts app req of + Nothing -> backup req sendResponse + Just res -> sendResponse res + +-------------------------------------------------------------------------------- +-- | Handle a single @wai@ 'Wai.Request' with the given @websockets@ +-- 'WS.ServerApp'. Returns 'Nothing' if the 'Wai.Request' is not a WebSocket +-- request, 'Just' otherwise. +-- +-- Usually, 'websocketsOr' is more convenient. +websocketsApp :: WS.ConnectionOptions -> WS.ServerApp -> Wai.Request - -> Maybe (Source (ResourceT IO) ByteString -> Warp.Connection -> ResourceT IO ()) -interceptWith opts app req = case lookup "upgrade" (Wai.requestHeaders req) of - Just s - | BC.map toLower s == "websocket" -> Just $ runWebSockets opts req' app - | otherwise -> Nothing - _ -> Nothing - where - req' = WS.RequestHead (Wai.rawPathInfo req) (Wai.requestHeaders req) (Wai.isSecure req) + -> Maybe Wai.Response +websocketsApp opts app req + | isWebSocketsReq req = + Just $ flip Wai.responseRaw backup $ \src sink -> + runWebSockets opts req' app src sink + | otherwise = Nothing + where + req' = getRequestHead req + backup = Wai.responseLBS status500 [("Content-Type", "text/plain")] + "The web application attempted to send a WebSockets response, but WebSockets are not supported by your WAI handler." -------------------------------------------------------------------------------- ----- | Internal function to run the WebSocket io-streams using the conduit library +getRequestHead :: Wai.Request -> WS.RequestHead +getRequestHead req = WS.RequestHead + (Wai.rawPathInfo req `BC.append` Wai.rawQueryString req) + (Wai.requestHeaders req) + (Wai.isSecure req) + +-------------------------------------------------------------------------------- +-- | Internal function to run the WebSocket io-streams using the conduit library. runWebSockets :: WS.ConnectionOptions -> WS.RequestHead - -> WS.ServerApp - -> Source (ResourceT IO) ByteString - -> Warp.Connection - -> ResourceT IO () -runWebSockets opts req app _ conn = do - - (is, os) <- liftIO $ connectionToStreams conn - - let pc = WS.PendingConnection - { WS.pendingOptions = opts - , WS.pendingRequest = req - , WS.pendingOnAccept = \_ -> return () - , WS.pendingIn = is - , WS.pendingOut = os - } - - liftIO $ app pc - ------------------------------------------------------------------------------- --- | Converts a 'Connection' to an 'InputStream' \/ 'OutputStream' pair. Note that, --- as is usually the case in @io-streams@, writing a 'Nothing' to the generated --- 'OutputStream' does not cause the underlying 'Connection' to be closed. -connectionToStreams :: Warp.Connection - -> IO (InputStream ByteString, OutputStream Builder) -connectionToStreams connection = do - is <- Streams.makeInputStream input - os <- Streams.makeOutputStream output - return $! (is, os) - - where - input = do - s <- Warp.connRecv connection - return $! if BC.null s then Nothing else Just s + -> (WS.PendingConnection -> IO a) + -> IO ByteString + -> (ByteString -> IO ()) + -> IO a +runWebSockets opts req app src sink = bracket mkStream ensureClose (app . pc) + where + ensureClose = tryJust onConnectionException . WS.close + onConnectionException :: WS.ConnectionException -> Maybe () + onConnectionException WS.ConnectionClosed = Just () + onConnectionException _ = Nothing + mkStream = + WS.makeStream + (do + bs <- src + return $ if BC.null bs then Nothing else Just bs) + (\mbBl -> case mbBl of + Nothing -> return () + Just bl -> mapM_ sink (BL.toChunks bl)) - output Nothing = return $! () - output (Just s') = if BC.null s then return $! () else Warp.connSendAll connection s - where s = Builder.toByteString s' + pc stream = WS.PendingConnection + { WS.pendingOptions = opts + , WS.pendingRequest = req + , WS.pendingOnAccept = \_ -> return () + , WS.pendingStream = stream + } diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,3 @@ +## wai-websockets + +Use websockets with WAI applications, primarily those hosted via Warp. diff --git a/server.lhs b/server.lhs --- a/server.lhs +++ b/server.lhs @@ -11,13 +11,12 @@ > import Data.Char (isPunctuation, isSpace) > import Data.Monoid (mappend) > import Data.Text (Text) -> import Control.Exception (fromException, handle) +> import Control.Exception (finally) > import Control.Monad (forM_, forever) -> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar) +> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar, modifyMVar) > import Control.Monad.IO.Class (liftIO) > import qualified Data.Text as T > import qualified Data.Text.IO as T - > import qualified Network.WebSockets as WS > import qualified Network.Wai > import qualified Network.Wai.Handler.Warp as Warp @@ -25,8 +24,10 @@ > import qualified Network.Wai.Application.Static as Static > import Data.FileEmbed (embedDir) -We represent a client by his username and a 'WS.Connection'. We will see how we obtain this 'WS.Connection' later on. +We represent a client by their username and a `WS.Connection`. We will see how we +obtain this `WS.Connection` later on. + > type Client = (Text, WS.Connection) The state kept on the server is simply a list of connected clients. We've added @@ -35,33 +36,33 @@ > type ServerState = [Client] -Create a new, initial state +Create a new, initial state: > newServerState :: ServerState > newServerState = [] -Get the number of active clients +Get the number of active clients: > numClients :: ServerState -> Int > numClients = length -Check if a user already exists (based on username) +Check if a user already exists (based on username): > clientExists :: Client -> ServerState -> Bool > clientExists client = any ((== fst client) . fst) -Add a client (first, you should verify the client is not already connected using -'clientExists') +Add a client (this does not check if the client already exists, you should do +this yourself using `clientExists`): > addClient :: Client -> ServerState -> ServerState > addClient client clients = client : clients -Remove a client +Remove a client: > removeClient :: Client -> ServerState -> ServerState > removeClient client = filter ((/= fst client) . fst) -Send a message to all clients, and log it on stdout. +Send a message to all clients, and log it on stdout: > broadcast :: Text -> ServerState -> IO () > broadcast message clients = do @@ -69,40 +70,50 @@ > forM_ clients $ \(_, conn) -> WS.sendTextData conn message The main function first creates a new state for the server, then spawns the -actual server. For this purpose, we use the simple server provided by -'WS.runServer'. +actual server. > main :: IO () > main = do > putStrLn "http://localhost:9160/client.html" > state <- newMVar newServerState -> Warp.runSettings Warp.defaultSettings -> { Warp.settingsPort = 9160 -> , Warp.settingsIntercept = WaiWS.intercept (application state) -> } staticApp +> Warp.runSettings +> (Warp.setPort 9160 Warp.defaultSettings) +> $ WaiWS.websocketsOr WS.defaultConnectionOptions (application state) staticApp > staticApp :: Network.Wai.Application > staticApp = Static.staticApp $ Static.embeddedSettings $(embedDir "static") -When a client connects, we accept the connection, regardless of the path. +Our main application has the type: > application :: MVar ServerState -> WS.ServerApp + +Note that `WS.ServerApp` is nothing but a type synonym for +`WS.PendingConnection -> IO ()`. + +Our application starts by accepting the connection. In a more realistic +application, you probably want to check the path and headers provided by the +pending request. + +We also fork a pinging thread in the background. This will ensure the connection +stays alive on some browsers. + > application state pending = do > conn <- WS.acceptRequest pending +> WS.forkPingThread conn 30 When a client is succesfully connected, we read the first message. This should -be in the format of "Hi, I am Jasper", where Jasper is the requested username. +be in the format of "Hi! I am Jasper", where Jasper is the requested username. > msg <- WS.receiveData conn > clients <- liftIO $ readMVar state > case msg of -Check that the first message has the right format +Check that the first message has the right format: > _ | not (prefix `T.isPrefixOf` msg) -> > WS.sendTextData conn ("Wrong announcement" :: Text) -Check the validity of the username +Check the validity of the username: > | any ($ fst client) > [T.null, T.any isPunctuation, T.any isSpace] -> @@ -110,14 +121,15 @@ > "contain punctuation or whitespace, and " `mappend` > "cannot be empty" :: Text) -Check that the given username is not already taken +Check that the given username is not already taken: > | clientExists client clients -> > WS.sendTextData conn ("User already exists" :: Text) -All is right! +All is right! We're going to allow the client, but for safety reasons we *first* +setup a `disconnect` function that will be run when the exception is closed. -> | otherwise -> do +> | otherwise -> flip finally disconnect $ do We send a "Welcome!", according to our own little protocol. We add the client to the list and broadcast the fact that he has joined. Then, we give control to the @@ -132,22 +144,19 @@ > return s' > talk conn state client > where -> prefix = "Hi! I am " -> client = (T.drop (T.length prefix) msg, conn) +> prefix = "Hi! I am " +> client = (T.drop (T.length prefix) msg, conn) +> disconnect = do +> -- Remove client and return new state +> s <- modifyMVar state $ \s -> +> let s' = removeClient client s in return (s', s') +> broadcast (fst client `mappend` " disconnected") s The talk function continues to read messages from a single client until he disconnects. All messages are broadcasted to the other clients. > talk :: WS.Connection -> MVar ServerState -> Client -> IO () -> talk conn state client@(user, _) = handle catchDisconnect $ -> forever $ do -> msg <- WS.receiveData conn -> liftIO $ readMVar state >>= broadcast -> (user `mappend` ": " `mappend` msg) -> where -> catchDisconnect e = case fromException e of -> Just WS.ConnectionClosed -> liftIO $ modifyMVar_ state $ \s -> do -> let s' = removeClient client s -> broadcast (user `mappend` " disconnected") s' -> return s' -> _ -> return () +> talk conn state (user, _) = forever $ do +> msg <- WS.receiveData conn +> liftIO $ readMVar state >>= broadcast +> (user `mappend` ": " `mappend` msg) diff --git a/wai-websockets.cabal b/wai-websockets.cabal --- a/wai-websockets.cabal +++ b/wai-websockets.cabal @@ -1,6 +1,6 @@ Name: wai-websockets -Version: 1.3.2.1 -Synopsis: Provide a bridge betweeen WAI and the websockets package. +Version: 3.0.1.2 +Synopsis: Provide a bridge between WAI and the websockets package. License: MIT License-file: LICENSE Author: Michael Snoyman, Jasper Van der Jeugt, Ting-Yen Lai @@ -10,34 +10,29 @@ Build-Type: Simple Cabal-Version: >=1.8 Stability: Stable -Description: This is primarily intended for use with Warp and its settingsIntercept. +description: API docs and the README are available at . extra-source-files: static/client.js, static/client.html, static/screen.css + README.md ChangeLog.md flag example Library Build-Depends: base >= 3 && < 5 , bytestring >= 0.9.1.4 - , conduit >= 0.5 && < 1.1 - , wai >= 1.3 && < 1.5 - , blaze-builder >= 0.2.1.4 && < 0.4 + , wai >= 3.0 && < 3.3 , case-insensitive >= 0.2 , network >= 2.2.1.5 - , transformers >= 0.2 && < 0.4 - , websockets >= 0.8 - , warp >= 1.3 && < 1.4 - , io-streams >= 1.1 && < 1.2 + , transformers >= 0.2 + , websockets >= 0.9 + , http-types Exposed-modules: Network.Wai.Handler.WebSockets ghc-options: -Wall Executable wai-websockets-example if flag(example) buildable: True - else - buildable: False - Build-Depends: base >= 3 && < 5 - , conduit + Build-Depends: base >= 3 && < 5 , wai-websockets , websockets , warp @@ -45,12 +40,13 @@ , wai-app-static , bytestring , case-insensitive - , blaze-builder , transformers , network , text , file-embed - , io-streams + , http-types + else + buildable: False ghc-options: -Wall -threaded main-is: server.lhs