wai-websockets-3.0.1.1/0000755000000000000000000000000012763016574013002 5ustar0000000000000000wai-websockets-3.0.1.1/ChangeLog.md0000644000000000000000000000053212763016574015153 0ustar0000000000000000## 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 wai-websockets-3.0.1.1/LICENSE0000644000000000000000000000207512763016574014013 0ustar0000000000000000Copyright (c) 2012 Michael Snoyman, http://www.yesodweb.com/ Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. wai-websockets-3.0.1.1/README.md0000644000000000000000000000013212763016574014255 0ustar0000000000000000## wai-websockets Use websockets with WAI applications, primarily those hosted via Warp. wai-websockets-3.0.1.1/server.lhs0000644000000000000000000001343712763016574015030 0ustar0000000000000000websockets example ================== This is the Haskell implementation of the example for the WebSockets library. We implement a simple multi-user chat program. A live demo of the example is available [here](http://jaspervdj.be/websockets-example). In order to understand this example, keep the [reference](http://jaspervdj.be/websockets/reference) nearby to check out the functions we use. > {-# LANGUAGE OverloadedStrings, TemplateHaskell #-} > import Data.Char (isPunctuation, isSpace) > import Data.Monoid (mappend) > import Data.Text (Text) > import Control.Exception (finally) > import Control.Monad (forM_, forever) > import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar, forkIO, 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 > import qualified Network.Wai.Handler.WebSockets as WaiWS > import qualified Network.Wai.Application.Static as Static > import Data.FileEmbed (embedDir) 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 an alias and some utility functions, so it will be easier to extend this state later on. > type ServerState = [Client] Create a new, initial state: > newServerState :: ServerState > newServerState = [] Get the number of active clients: > numClients :: ServerState -> Int > numClients = length Check if a user already exists (based on username): > clientExists :: Client -> ServerState -> Bool > clientExists client = any ((== fst client) . fst) 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: > removeClient :: Client -> ServerState -> ServerState > removeClient client = filter ((/= fst client) . fst) Send a message to all clients, and log it on stdout: > broadcast :: Text -> ServerState -> IO () > broadcast message clients = do > T.putStrLn message > forM_ clients $ \(_, conn) -> WS.sendTextData conn message The main function first creates a new state for the server, then spawns the actual server. > main :: IO () > main = do > putStrLn "http://localhost:9160/client.html" > state <- newMVar newServerState > 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") 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. > msg <- WS.receiveData conn > clients <- liftIO $ readMVar state > case msg of 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: > | any ($ fst client) > [T.null, T.any isPunctuation, T.any isSpace] -> > WS.sendTextData conn ("Name cannot " `mappend` > "contain punctuation or whitespace, and " `mappend` > "cannot be empty" :: Text) Check that the given username is not already taken: > | clientExists client clients -> > WS.sendTextData conn ("User already exists" :: Text) 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 -> 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 'talk' function. > liftIO $ modifyMVar_ state $ \s -> do > let s' = addClient client s > WS.sendTextData conn $ > "Welcome! Users: " `mappend` > T.intercalate ", " (map fst s) > broadcast (fst client `mappend` " joined") s' > return s' > talk conn state client > where > 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 (user, _) = forever $ do > msg <- WS.receiveData conn > liftIO $ readMVar state >>= broadcast > (user `mappend` ": " `mappend` msg) wai-websockets-3.0.1.1/Setup.lhs0000644000000000000000000000016212763016574014611 0ustar0000000000000000#!/usr/bin/env runhaskell > module Main where > import Distribution.Simple > main :: IO () > main = defaultMain wai-websockets-3.0.1.1/wai-websockets.cabal0000644000000000000000000000372112763016574016720 0ustar0000000000000000Name: wai-websockets Version: 3.0.1.1 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 Maintainer: michael@snoyman.com Homepage: http://github.com/yesodweb/wai Category: Web, Yesod Build-Type: Simple Cabal-Version: >=1.8 Stability: Stable 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 , wai >= 3.0 && < 3.3 , blaze-builder >= 0.2.1.4 && < 0.5 , case-insensitive >= 0.2 , network >= 2.2.1.5 , 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 Build-Depends: base >= 3 && < 5 , wai-websockets , websockets , warp , wai , wai-app-static , bytestring , case-insensitive , blaze-builder , transformers , network , text , file-embed , http-types else buildable: False ghc-options: -Wall -threaded main-is: server.lhs source-repository head type: git location: git://github.com/yesodweb/wai.git wai-websockets-3.0.1.1/Network/0000755000000000000000000000000012763016574014433 5ustar0000000000000000wai-websockets-3.0.1.1/Network/Wai/0000755000000000000000000000000012763016574015153 5ustar0000000000000000wai-websockets-3.0.1.1/Network/Wai/Handler/0000755000000000000000000000000012763016574016530 5ustar0000000000000000wai-websockets-3.0.1.1/Network/Wai/Handler/WebSockets.hs0000644000000000000000000001125312763016574021137 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Network.Wai.Handler.WebSockets ( websocketsOr , websocketsApp , isWebSocketsReq , getRequestHead , runWebSockets ) where import Control.Exception (bracket, tryJust) import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BC 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.WebSockets as WS import qualified Network.WebSockets.Connection as WS import qualified Network.WebSockets.Stream as WS -------------------------------------------------------------------------------- -- | 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" -------------------------------------------------------------------------------- -- | 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 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." -------------------------------------------------------------------------------- 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.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)) pc stream = WS.PendingConnection { WS.pendingOptions = opts , WS.pendingRequest = req , WS.pendingOnAccept = \_ -> return () , WS.pendingStream = stream } wai-websockets-3.0.1.1/static/0000755000000000000000000000000012763016574014271 5ustar0000000000000000wai-websockets-3.0.1.1/static/client.html0000644000000000000000000000277012763016574016443 0ustar0000000000000000 Haskell WebSockets example

Haskell WebSockets example

Join

wai-websockets-3.0.1.1/static/client.js0000644000000000000000000000432512763016574016111 0ustar0000000000000000function createWebSocket(path) { var host = window.location.hostname; if(host == '') host = 'localhost'; var uri = 'ws://' + host + ':9160' + path; var Socket = "MozWebSocket" in window ? MozWebSocket : WebSocket; return new Socket(uri); } var users = []; function refreshUsers() { $('#users').html(''); for(i in users) { $('#users').append($(document.createElement('li')).text(users[i])); } } function onMessage(event) { var p = $(document.createElement('p')).text(event.data); $('#messages').append(p); $('#messages').animate({scrollTop: $('#messages')[0].scrollHeight}); if(event.data.match(/^[^:]* joined/)) { var user = event.data.replace(/ .*/, ''); users.push(user); refreshUsers(); } if(event.data.match(/^[^:]* disconnected/)) { var user = event.data.replace(/ .*/, ''); var idx = users.indexOf(user); users = users.slice(0, idx).concat(users.slice(idx + 1)); refreshUsers(); } } $(document).ready(function () { $('#join-form').submit(function () { $('#warnings').html(''); var user = $('#user').val(); var ws = createWebSocket('/'); ws.onopen = function() { ws.send('Hi! I am ' + user); }; ws.onmessage = function(event) { if(event.data.match('^Welcome! Users: ')) { /* Calculate the list of initial users */ var str = event.data.replace(/^Welcome! Users: /, ''); if(str != "") { users = str.split(", "); refreshUsers(); } $('#join-section').hide(); $('#chat-section').show(); $('#users-section').show(); ws.onmessage = onMessage; $('#message-form').submit(function () { var text = $('#text').val(); ws.send(text); $('#text').val(''); return false; }); } else { $('#warnings').append(event.data); ws.close(); } }; $('#join').append('Connecting...'); return false; }); }); wai-websockets-3.0.1.1/static/screen.css0000644000000000000000000000214412763016574016263 0ustar0000000000000000html { font-family: sans-serif; background-color: #335; font-size: 16px; } body { } h1 { text-align: center; font-size: 20px; color: #fff; padding: 10px 10px 20px 10px; } h2 { border-bottom: 1px solid black; display: block; font-size: 18px; } div#main { width: 600px; margin: 0px auto 0px auto; padding: 0px; background-color: #fff; height: 460px; } div#warnings { color: red; font-weight: bold; margin: 10px; } div#join-section { float: left; margin: 10px; } div#users-section { width: 170px; float: right; padding: 0px; margin: 10px; } ul#users { list-style-type: none; padding-left: 0px; height: 300px; overflow: auto; } div#chat-section { width: 390px; float: left; margin: 10px; } div#messages { margin: 0px; height: 300px; overflow: auto; } div#messages p { margin: 0px; padding: 0px; } div#footer { text-align: center; font-size: 12px; color: #fff; margin: 10px 0px 30px 0px; } div#footer a { color: #fff; } div.clear { clear: both; }