wai-websockets-1.3.2.1/ 0000755 0000000 0000000 00000000000 12246410531 012767 5 ustar 00 0000000 0000000 wai-websockets-1.3.2.1/wai-websockets.cabal 0000644 0000000 0000000 00000004126 12246410531 016705 0 ustar 00 0000000 0000000 Name: wai-websockets
Version: 1.3.2.1
Synopsis: Provide a bridge betweeen 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: This is primarily intended for use with Warp and its settingsIntercept.
extra-source-files: static/client.js, static/client.html, static/screen.css
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
, 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
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
, wai-websockets
, websockets
, warp
, wai
, wai-app-static
, bytestring
, case-insensitive
, blaze-builder
, transformers
, network
, text
, file-embed
, io-streams
ghc-options: -Wall -threaded
main-is: server.lhs
source-repository head
type: git
location: git://github.com/yesodweb/wai.git
wai-websockets-1.3.2.1/LICENSE 0000644 0000000 0000000 00000002075 12246410531 014000 0 ustar 00 0000000 0000000 Copyright (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-1.3.2.1/server.lhs 0000644 0000000 0000000 00000012557 12246410531 015017 0 ustar 00 0000000 0000000 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, handle)
> import Control.Monad (forM_, forever)
> 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.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 (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 $ \(_, 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'.
> 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.embeddedSettings $(embedDir "static")
When a client connects, we accept the connection, regardless of the path.
> application :: MVar ServerState -> WS.ServerApp
> application state pending = do
> conn <- WS.acceptRequest pending
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!
> | 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.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)
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 ()
wai-websockets-1.3.2.1/Setup.lhs 0000644 0000000 0000000 00000000162 12246410531 014576 0 ustar 00 0000000 0000000 #!/usr/bin/env runhaskell
> module Main where
> import Distribution.Simple
> main :: IO ()
> main = defaultMain
wai-websockets-1.3.2.1/Network/ 0000755 0000000 0000000 00000000000 12246410531 014420 5 ustar 00 0000000 0000000 wai-websockets-1.3.2.1/Network/Wai/ 0000755 0000000 0000000 00000000000 12246410531 015140 5 ustar 00 0000000 0000000 wai-websockets-1.3.2.1/Network/Wai/Handler/ 0000755 0000000 0000000 00000000000 12246410531 016515 5 ustar 00 0000000 0000000 wai-websockets-1.3.2.1/Network/Wai/Handler/WebSockets.hs 0000644 0000000 0000000 00000007056 12246410531 021132 0 ustar 00 0000000 0000000 {-# LANGUAGE OverloadedStrings #-}
module Network.Wai.Handler.WebSockets
( intercept
, interceptWith
) where
import Control.Monad.IO.Class (liftIO)
import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder as Builder
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BC
import Data.Char (toLower)
import Data.Conduit
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
--------------------------------------------------------------------------------
-- | 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
--------------------------------------------------------------------------------
-- | Variation of 'intercept' which allows custom options.
interceptWith :: 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)
--------------------------------------------------------------------------------
---- | 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
output Nothing = return $! ()
output (Just s') = if BC.null s then return $! () else Warp.connSendAll connection s
where s = Builder.toByteString s' wai-websockets-1.3.2.1/static/ 0000755 0000000 0000000 00000000000 12246410531 014256 5 ustar 00 0000000 0000000 wai-websockets-1.3.2.1/static/client.html 0000644 0000000 0000000 00000002770 12246410531 016430 0 ustar 00 0000000 0000000
Haskell WebSockets example