wai-websockets (empty) → 0.5.0
raw patch · 8 files changed
+488/−0 lines, 8 filesdep +basedep +blaze-builderdep +bytestringsetup-changed
Dependencies added: base, blaze-builder, bytestring, case-insensitive, enumerator, file-embed, network, network-enumerator, text, transformers, wai, wai-app-static, wai-websockets, warp, websockets
Files
- LICENSE +25/−0
- Network/Wai/Handler/WebSockets.hs +26/−0
- Setup.lhs +7/−0
- server.lhs +170/−0
- static/client.html +42/−0
- static/client.js +80/−0
- static/screen.css +86/−0
- wai-websockets.cabal +52/−0
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2010, Suite Solutions. All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Network/Wai/Handler/WebSockets.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE OverloadedStrings #-}+module Network.Wai.Handler.WebSockets+ ( intercept+ ) where++import Network.Wai (Request, requestHeaders, rawPathInfo, requestHeaders)+import Network.Socket (Socket)+import Data.Char (toLower)+import Data.Enumerator (Iteratee)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as S+import Network.WebSockets (WebSockets, runWebSockets, RequestHttpPart(RequestHttpPart), Protocol)+import qualified Network.WebSockets as WS+import Network.Socket.Enumerator (iterSocket)++intercept :: Protocol p+ => (WS.Request -> WebSockets p ())+ -> Request+ -> Maybe (Socket -> Iteratee ByteString IO ())+intercept app req =+ case lookup "upgrade" $ requestHeaders req of+ Just s | S.map toLower s=="websocket" -> Just $ \socket -> do+ runWebSockets req' app (iterSocket socket)+ _ -> Nothing+ where+ req' = RequestHttpPart (rawPathInfo req) (requestHeaders req)
+ Setup.lhs view
@@ -0,0 +1,7 @@+#!/usr/bin/env runhaskell++> module Main where+> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ server.lhs view
@@ -0,0 +1,170 @@+websockets 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 (fromException)+> import Control.Monad (forM_)+> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar)+> 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 his username and a 'WS.Sender'. We can use this sender+to asynchronously send 'Text' to the client later. Note that using `WS.Hybi00`+here does not imply that our server is only compatible with the `hybi-00`+version of the protocol, for more details on this, see the+[Network.WebSockets](http://jaspervdj.be/websockets/reference/Network-WebSockets.html) +reference.++> type Client = (Text, WS.Sink WS.Hybi00)++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 (first, you should verify the client is not already connected 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 $ \(_, sink) -> WS.sendSink sink $ WS.textData 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'.++> 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++> staticApp :: Network.Wai.Application+> staticApp = Static.staticApp Static.defaultFileServerSettings+> { Static.ssFolder = Static.embeddedLookup $ Static.toEmbedded $(embedDir "static")+> }++When a client connects, we accept the connection, regardless of the path.++> application :: MVar ServerState -> WS.Request -> WS.WebSockets WS.Hybi00 ()+> application state rq = do+> WS.acceptRequest rq++We log some information here: in particular, we are interested in the protocol+version our client is using (for debugging purposes).++> WS.getVersion >>= liftIO . putStrLn . ("Client version: " ++)++If we want to be able to send data to this client later, from another thread, we+obtain a sink. We will add this to the server state later.++> sink <- WS.getSink++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+> clients <- liftIO $ readMVar state+> case msg of++Check that the first message has the right format++> _ | not (prefix `T.isPrefixOf` msg) ->+> WS.sendTextData ("Wrong announcement" :: Text)++Check the validity of the username++> | any ($ fst client)+> [T.null, T.any isPunctuation, T.any isSpace] ->+> WS.sendTextData ("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 ("User already exists" :: Text)++All is right!++> | otherwise -> 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.sendSink sink $ WS.textData $+> "Welcome! Users: " `mappend`+> T.intercalate ", " (map fst s)+> broadcast (fst client `mappend` " joined") s'+> return s'+> talk state client+> where+> prefix = "Hi! I am "+> client = (T.drop (T.length prefix) msg, sink)++The talk function continues to read messages from a single client until he+disconnects. All messages are broadcasted to the other clients.++> talk :: WS.Protocol p => MVar ServerState -> Client -> WS.WebSockets p ()+> talk state client@(user, _) = flip WS.catchWsError catchDisconnect $ do+> msg <- WS.receiveData+> liftIO $ readMVar state >>= broadcast+> (user `mappend` ": " `mappend` msg)+> talk state client+> 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 ()
+ static/client.html view
@@ -0,0 +1,42 @@+<html>+ <head>+ <title>Haskell WebSockets example</title>+ <script type="text/JavaScript"+ src="http://code.jquery.com/jquery-1.6.3.min.js"></script>+ <script type="text/JavaScript" src="client.js"></script>+ <link rel="stylesheet" type="text/css" href="screen.css"></script>+ </head>+ <body>+ <h1>Haskell WebSockets example</h1>+ <div id="main">+ <div id="warnings">+ </div>+ <div id="join-section">+ <h2>Join</h2>+ <form id="join-form" action="">+ <label for="user">Username: </label>+ <input id="user" type="text" size="12" />+ <input id="send" type="submit" value="Join" />+ </form>+ </div>+ <div id="users-section" style="display: none">+ <h2>Users</h2>+ <ul id="users">+ </ul>+ </div>+ <div id="chat-section" style="display: none">+ <h2>Chat</h2>+ <div id="messages">+ </div>+ <br />+ <form id="message-form" action="">+ <input id="text" type="text" size="40" />+ <input id="send" type="submit" value="Send" />+ </form>+ </div>+ </div>+ <div id="footer">+ Source code available <a href="http://github.com/jaspervdj/websockets/tree/master/example">here</a>+ </div>+ </body>+</html>
+ static/client.js view
@@ -0,0 +1,80 @@+function 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;+ });+});
+ static/screen.css view
@@ -0,0 +1,86 @@+html {+ 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;+}
+ wai-websockets.cabal view
@@ -0,0 +1,52 @@+Name: wai-websockets+Version: 0.5.0+Synopsis: Provide a bridge betweeen WAI and the websockets package.+License: BSD3+License-file: LICENSE+Author: Michael Snoyman+Maintainer: michael@snoyman.com+Homepage: http://github.com/yesodweb/wai+Category: Web, Yesod+Build-Type: Simple+Cabal-Version: >=1.8+Stability: Stable+Description: This is primarily intended for use with Warp and its settingsIntercept.++extra-source-files: static/client.js, static/client.html, static/screen.css++Library+ Build-Depends: base >= 3 && < 5+ , bytestring >= 0.9.1.4 && < 0.10+ , wai >= 0.4 && < 0.5+ , enumerator >= 0.4.8 && < 0.5+ , network-enumerator >= 0.1.2 && < 0.2+ , blaze-builder >= 0.2.1.4 && < 0.4+ , case-insensitive >= 0.2 && < 0.4+ , network >= 2.2.1.5 && < 2.4+ , websockets >= 0.4 && < 0.5+ Exposed-modules: Network.Wai.Handler.WebSockets+ ghc-options: -Wall++Executable wai-websockets-example+ Build-Depends: base >=3 && < 5,+ wai-websockets,+ websockets,+ network-enumerator,+ warp,+ wai,+ wai-app-static,+ bytestring,+ case-insensitive,+ blaze-builder,+ enumerator,+ transformers,+ network,+ text,+ file-embed++ ghc-options: -Wall -threaded+ main-is: server.lhs++source-repository head+ type: git+ location: git://github.com/yesodweb/wai.git