git.iko.soy/typeable/wai
on master help sign in
Merge branch 'master' of https://github.com/banacorn/wai
commit6a4e2d5fc205f50cd0f23f7c838fbfbff9aa2f97 authorMichael Snoyman <michael@snoyman.com> dateWed 13 Nov 2013, 10:02 (13 years ago) parent7d881be248fe35
3 files changed+100−92
compare with master
unifiedsplit
wai-websockets/Network/Wai/Handler/WebSockets.hs+74−49 wai-websockets/server.lhs+21−36 wai-websockets/wai-websockets.cabal+5−7
wai-websockets/Network/Wai/Handler/WebSockets.hs+74−49
@@ -4,71 +4,96 @@ module Network.Wai.Handler.WebSockets
44 , interceptWith
55 ) where
66
7−import Control.Monad.IO.Class (liftIO)
8−import Data.ByteString (ByteString)
9−import Data.Char (toLower)
10−import qualified Data.ByteString.Char8 as S
11−import Data.Conduit
12−import qualified Data.Enumerator as E
13−import qualified Network.Wai as Wai
14−import qualified Network.Wai.Handler.Warp as Warp
15−import qualified Network.WebSockets as WS
7+import Control.Monad (forever)
8+import Control.Monad.IO.Class (liftIO)
9+import Control.Concurrent (forkIO, threadDelay)
10+import Control.Exception (SomeException (..), handle)
11+import Blaze.ByteString.Builder (Builder)
12+import qualified Blaze.ByteString.Builder as Builder
13+import Data.ByteString (ByteString)
14+import qualified Data.ByteString.Char8 as BC
15+import Data.Char (toLower)
16+import Data.Conduit
17+import qualified Network.Wai as Wai
18+import qualified Network.Wai.Handler.Warp as Warp
19+import qualified Network.WebSockets as WS
20+import qualified Network.WebSockets.Connection as WS
21+import System.IO.Streams (InputStream, OutputStream)
22+import qualified System.IO.Streams as Streams
1623
24+--------------------------------------------------------------------------------
1725-- | For use with 'settingsIntercept' from the Warp web server.
18−intercept :: WS.Protocol p
19− => (WS.Request -> WS.WebSockets p ())
26+intercept :: WS.ServerApp
2027 -> Wai.Request
2128 -> Maybe (Source (ResourceT IO) ByteString -> Warp.Connection -> ResourceT IO ())
22−intercept = interceptWith WS.defaultWebSocketsOptions
29+intercept = interceptWith WS.defaultConnectionOptions
2330
31+--------------------------------------------------------------------------------
2432-- | Variation of 'intercept' which allows custom options.
25−interceptWith :: WS.Protocol p
26− => WS.WebSocketsOptions
27− -> (WS.Request -> WS.WebSockets p ())
33+interceptWith :: WS.ConnectionOptions
34+ -> WS.ServerApp
2835 -> Wai.Request
2936 -> Maybe (Source (ResourceT IO) ByteString -> Warp.Connection -> ResourceT IO ())
30−interceptWith opts app req = case lookup "upgrade" $ Wai.requestHeaders req of
37+interceptWith opts app req = case lookup "upgrade" (Wai.requestHeaders req) of
3138 Just s
32− | S.map toLower s == "websocket" -> Just $ runWebSockets opts req' app
39+ | BC.map toLower s == "websocket" -> Just $ runWebSockets opts req' app
3340 | otherwise -> Nothing
3441 _ -> Nothing
35− where
36− req' = WS.RequestHttpPart (Wai.rawPathInfo req) (Wai.requestHeaders req)
37− (Wai.isSecure req)
42+ where
43+ req' = WS.RequestHead (Wai.rawPathInfo req) (Wai.requestHeaders req) (Wai.isSecure req)
3844
39−-- | Internal function to run the WebSocket iteratee using the conduit library
40−runWebSockets :: WS.Protocol p
41− => WS.WebSocketsOptions
42− -> WS.RequestHttpPart
43− -> (WS.Request -> WS.WebSockets p ())
45+--------------------------------------------------------------------------------
46+---- | Internal function to run the WebSocket io-streams using the conduit library
47+runWebSockets :: WS.ConnectionOptions
48+ -> WS.RequestHead
49+ -> WS.ServerApp
4450 -> Source (ResourceT IO) ByteString
4551 -> Warp.Connection
4652 -> ResourceT IO ()
47−runWebSockets opts req app source conn = do
48− step <- liftIO $ E.runIteratee $ WS.runWebSocketsWith opts req app send
49− source $$ sink (E.returnI step)
50− where
51− send = iterConnection conn
53+runWebSockets opts req app _ conn = do
5254
53− sink iter = await >>= maybe (close iter) (push iter)
55+ (is, os) <- liftIO $ connectionToStreams conn
5456
55− push iter bs = do
56− step <- liftIO $ E.runIteratee $ E.enumList 1 [bs] E.$$ iter
57− case step of
58− E.Continue _ -> sink $ E.returnI step
59− E.Yield out inp -> maybe (return ()) leftover (streamToMaybe inp) >> return out
60− E.Error e -> liftIO $ monadThrow e
61− close iter = do
62− _ <- liftIO $ E.runIteratee $ E.enumEOF E.$$ iter
63− return ()
57+ let pc = WS.PendingConnection
58+ { WS.pendingOptions = opts
59+ , WS.pendingRequest = req
60+ , WS.pendingOnAccept = forkPingThread
61+ , WS.pendingIn = is
62+ , WS.pendingOut = os
63+ }
6464
65−iterConnection :: Warp.Connection -> E.Iteratee ByteString IO ()
66−iterConnection c = E.continue go
67− where
68− go (E.Chunks []) = E.continue go
69− go (E.Chunks cs) = E.tryIO (Warp.connSendMany c cs) >> E.continue go
70− go E.EOF = E.continue go
65+ liftIO $ app pc
7166
72−streamToMaybe :: E.Stream S.ByteString -> Maybe S.ByteString
73−streamToMaybe E.EOF = Nothing
74−streamToMaybe (E.Chunks bs) = Just $ S.concat bs
67+--------------------------------------------------------------------------------
68+-- | Start a ping thread in the background
69+forkPingThread :: WS.Connection -> IO ()
70+forkPingThread conn = do
71+ _ <- forkIO pingThread
72+ return ()
73+ where
74+ pingThread = handle ignore $ forever $ do
75+ WS.sendPing conn (BC.pack "ping")
76+ threadDelay $ 30 * 1000 * 1000
77+
78+ ignore :: SomeException -> IO ()
79+ ignore _ = return ()
80+
81+------------------------------------------------------------------------------
82+-- | Converts a 'Connection' to an 'InputStream' \/ 'OutputStream' pair. Note that,
83+-- as is usually the case in @io-streams@, writing a 'Nothing' to the generated
84+-- 'OutputStream' does not cause the underlying 'Connection' to be closed.
85+connectionToStreams :: Warp.Connection
86+ -> IO (InputStream ByteString, OutputStream Builder)
87+connectionToStreams connection = do
88+ is <- Streams.makeInputStream input
89+ os <- Streams.makeOutputStream output
90+ return $! (is, os)
91+
92+ where
93+ input = do
94+ s <- Warp.connRecv connection
95+ return $! if BC.null s then Nothing else Just s
96+
97+ output Nothing = return $! ()
98+ output (Just s') = if BC.null s then return $! () else Warp.connSendAll connection s
99+ where s = Builder.toByteString s'
wai-websockets/server.lhs+21−36
@@ -11,8 +11,8 @@ nearby to check out the functions we use.
1111> import Data.Char (isPunctuation, isSpace)
1212> import Data.Monoid (mappend)
1313> import Data.Text (Text)
14−> import Control.Exception (fromException)
15−> import Control.Monad (forM_)
14+> import Control.Exception (fromException, handle)
15+> import Control.Monad (forM_, forever)
1616> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar)
1717> import Control.Monad.IO.Class (liftIO)
1818> import qualified Data.Text as T
@@ -25,14 +25,9 @@ nearby to check out the functions we use.
2525> import qualified Network.Wai.Application.Static as Static
2626> import Data.FileEmbed (embedDir)
2727
28−We represent a client by his username and a 'WS.Sender'. We can use this sender
29−to asynchronously send 'Text' to the client later. Note that using `WS.Hybi00`
30−here does not imply that our server is only compatible with the `hybi-00`
31−version of the protocol, for more details on this, see the
32−[Network.WebSockets](http://jaspervdj.be/websockets/reference/Network-WebSockets.html)
33−reference.
28+We represent a client by his username and a 'WS.Connection'. We will see how we obtain this 'WS.Connection' later on.
3429
35−> type Client = (Text, WS.Sink WS.Hybi00)
30+> type Client = (Text, WS.Connection)
3631
3732The state kept on the server is simply a list of connected clients. We've added
3833an alias and some utility functions, so it will be easier to extend this state
@@ -71,7 +66,7 @@ Send a message to all clients, and log it on stdout.
7166> broadcast :: Text -> ServerState -> IO ()
7267> broadcast message clients = do
7368> T.putStrLn message
74−> forM_ clients $ \(_, sink) -> WS.sendSink sink $ WS.textData message
69+> forM_ clients $ \(_, conn) -> WS.sendTextData conn message
7570
7671The main function first creates a new state for the server, then spawns the
7772actual server. For this purpose, we use the simple server provided by
@@ -91,44 +86,34 @@ actual server. For this purpose, we use the simple server provided by
9186
9287When a client connects, we accept the connection, regardless of the path.
9388
94−> application :: MVar ServerState -> WS.Request -> WS.WebSockets WS.Hybi00 ()
95−> application state rq = do
96−> WS.acceptRequest rq
97−
98−We log some information here: in particular, we are interested in the protocol
99−version our client is using (for debugging purposes).
100−
101−> WS.getVersion >>= liftIO . putStrLn . ("Client version: " ++)
102−
103−If we want to be able to send data to this client later, from another thread, we
104−obtain a sink. We will add this to the server state later.
105−
106−> sink <- WS.getSink
89+> application :: MVar ServerState -> WS.ServerApp
90+> application state pending = do
91+> conn <- WS.acceptRequest pending
10792
10893When a client is succesfully connected, we read the first message. This should
10994be in the format of "Hi, I am Jasper", where Jasper is the requested username.
11095
111−> msg <- WS.receiveData
96+> msg <- WS.receiveData conn
11297> clients <- liftIO $ readMVar state
11398> case msg of
11499
115100Check that the first message has the right format
116101
117102> _ | not (prefix `T.isPrefixOf` msg) ->
118−> WS.sendTextData ("Wrong announcement" :: Text)
103+> WS.sendTextData conn ("Wrong announcement" :: Text)
119104
120105Check the validity of the username
121106
122107> | any ($ fst client)
123108> [T.null, T.any isPunctuation, T.any isSpace] ->
124−> WS.sendTextData ("Name cannot " `mappend`
109+> WS.sendTextData conn ("Name cannot " `mappend`
125110> "contain punctuation or whitespace, and " `mappend`
126111> "cannot be empty" :: Text)
127112
128113Check that the given username is not already taken
129114
130115> | clientExists client clients ->
131−> WS.sendTextData ("User already exists" :: Text)
116+> WS.sendTextData conn ("User already exists" :: Text)
132117
133118All is right!
134119
@@ -140,25 +125,25 @@ the list and broadcast the fact that he has joined. Then, we give control to the
140125
141126> liftIO $ modifyMVar_ state $ \s -> do
142127> let s' = addClient client s
143−> WS.sendSink sink $ WS.textData $
128+> WS.sendTextData conn $
144129> "Welcome! Users: " `mappend`
145130> T.intercalate ", " (map fst s)
146131> broadcast (fst client `mappend` " joined") s'
147132> return s'
148−> talk state client
133+> talk conn state client
149134> where
150135> prefix = "Hi! I am "
151−> client = (T.drop (T.length prefix) msg, sink)
136+> client = (T.drop (T.length prefix) msg, conn)
152137
153138The talk function continues to read messages from a single client until he
154139disconnects. All messages are broadcasted to the other clients.
155140
156−> talk :: WS.Protocol p => MVar ServerState -> Client -> WS.WebSockets p ()
157−> talk state client@(user, _) = flip WS.catchWsError catchDisconnect $ do
158−> msg <- WS.receiveData
159−> liftIO $ readMVar state >>= broadcast
160−> (user `mappend` ": " `mappend` msg)
161−> talk state client
141+> talk :: WS.Connection -> MVar ServerState -> Client -> IO ()
142+> talk conn state client@(user, _) = handle catchDisconnect $
143+> forever $ do
144+> msg <- WS.receiveData conn
145+> liftIO $ readMVar state >>= broadcast
146+> (user `mappend` ": " `mappend` msg)
162147> where
163148> catchDisconnect e = case fromException e of
164149> Just WS.ConnectionClosed -> liftIO $ modifyMVar_ state $ \s -> do
wai-websockets/wai-websockets.cabal+5−7
@@ -1,9 +1,9 @@
11Name: wai-websockets
2−Version: 1.3.1.2
2+Version: 1.3.2.0
33Synopsis: Provide a bridge betweeen WAI and the websockets package.
44License: MIT
55License-file: LICENSE
6−Author: Michael Snoyman, Jasper Van der Jeugt
6+Author: Michael Snoyman, Jasper Van der Jeugt, Ting-Yen Lai
77Maintainer: michael@snoyman.com
88Homepage: http://github.com/yesodweb/wai
99Category: Web, Yesod
@@ -21,14 +21,13 @@ Library
2121 , bytestring >= 0.9.1.4
2222 , conduit >= 0.5 && < 1.1
2323 , wai >= 1.3 && < 1.5
24− , enumerator >= 0.4.8 && < 0.5
25− , network-enumerator >= 0.1.2 && < 0.2
2624 , blaze-builder >= 0.2.1.4 && < 0.4
2725 , case-insensitive >= 0.2
2826 , network >= 2.2.1.5
2927 , transformers >= 0.2 && < 0.4
30− , websockets >= 0.6 && < 0.8
28+ , websockets >= 0.8
3129 , warp >= 1.3 && < 1.4
30+ , io-streams >= 1.1 && < 1.2
3231 Exposed-modules: Network.Wai.Handler.WebSockets
3332 ghc-options: -Wall
3433
@@ -41,18 +40,17 @@ Executable wai-websockets-example
4140 , conduit
4241 , wai-websockets
4342 , websockets
44− , network-enumerator
4543 , warp
4644 , wai
4745 , wai-app-static
4846 , bytestring
4947 , case-insensitive
5048 , blaze-builder
51− , enumerator
5249 , transformers
5350 , network
5451 , text
5552 , file-embed
53+ , io-streams
5654
5755 ghc-options: -Wall -threaded
5856 main-is: server.lhs