wai-websockets 1.3.2.1 → 3.0.1.2
raw patch · 5 files changed
Files
- ChangeLog.md +27/−0
- Network/Wai/Handler/WebSockets.hs +98/−62
- README.md +3/−0
- server.lhs +47/−38
- wai-websockets.cabal +12/−16
+ ChangeLog.md view
@@ -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
Network/Wai/Handler/WebSockets.hs view
@@ -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+ }
+ README.md view
@@ -0,0 +1,3 @@+## wai-websockets++Use websockets with WAI applications, primarily those hosted via Warp.
server.lhs view
@@ -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)
wai-websockets.cabal view
@@ -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 <http://www.stackage.org/package/wai-websockets>. 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