git.iko.soy/typeable/wai
on master help sign in
Modified websockets server.lhs to better detect client disconnects.
e230603dschalk
wai-websockets/server.lhs+45−35
compare with master
unifiedsplit
@@ -11,13 +11,12 @@ nearby to check out the functions we use.
11> import Data.Char (isPunctuation, isSpace)
11> import Data.Char (isPunctuation, isSpace)
12> import Data.Monoid (mappend)
12> import Data.Monoid (mappend)
13> import Data.Text (Text)
13> import Data.Text (Text)
14−> import Control.Exception (fromException, handle)
14+> import Control.Exception (finally)
15> import Control.Monad (forM_, forever)
15> import Control.Monad (forM_, forever)
16−> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar, forkIO)
16+> import Control.Concurrent (MVar, newMVar, modifyMVar_, readMVar, forkIO, modifyMVar)
17> import Control.Monad.IO.Class (liftIO)
17> import Control.Monad.IO.Class (liftIO)
18> import qualified Data.Text as T
18> import qualified Data.Text as T
19> import qualified Data.Text.IO as T
19> import qualified Data.Text.IO as T
20−
21> import qualified Network.WebSockets as WS
20> import qualified Network.WebSockets as WS
22> import qualified Network.Wai
21> import qualified Network.Wai
23> import qualified Network.Wai.Handler.Warp as Warp
22> import qualified Network.Wai.Handler.Warp as Warp
@@ -25,7 +24,9 @@ nearby to check out the functions we use.
25> import qualified Network.Wai.Application.Static as Static
24> import qualified Network.Wai.Application.Static as Static
26> import Data.FileEmbed (embedDir)
25> import Data.FileEmbed (embedDir)
27
26
27+
28−We represent a client by his username and a 'WS.Connection'. We will see how we obtain this 'WS.Connection' later on.
28+We represent a client by their username and a `WS.Connection`. We will see how we
29+obtain this `WS.Connection` later on.
29
30
30> type Client = (Text, WS.Connection)
31> type Client = (Text, WS.Connection)
31
32
@@ -35,42 +36,41 @@ later on.
35
36
36> type ServerState = [Client]
37> type ServerState = [Client]
37
38
38−Create a new, initial state
39+Create a new, initial state:
39
40
40> newServerState :: ServerState
41> newServerState :: ServerState
41> newServerState = []
42> newServerState = []
42
43
43−Get the number of active clients
44+Get the number of active clients:
44
45
45> numClients :: ServerState -> Int
46> numClients :: ServerState -> Int
46> numClients = length
47> numClients = length
47
48
48−Check if a user already exists (based on username)
49+Check if a user already exists (based on username):
49
50
50> clientExists :: Client -> ServerState -> Bool
51> clientExists :: Client -> ServerState -> Bool
51> clientExists client = any ((== fst client) . fst)
52> clientExists client = any ((== fst client) . fst)
52
53
53−Add a client (first, you should verify the client is not already connected using
54+Add a client (this does not check if the client already exists, you should do
54−'clientExists')
55+this yourself using `clientExists`):
55
56
56> addClient :: Client -> ServerState -> ServerState
57> addClient :: Client -> ServerState -> ServerState
57> addClient client clients = client : clients
58> addClient client clients = client : clients
58
59
59−Remove a client
60+Remove a client:
60
61
61> removeClient :: Client -> ServerState -> ServerState
62> removeClient :: Client -> ServerState -> ServerState
62> removeClient client = filter ((/= fst client) . fst)
63> removeClient client = filter ((/= fst client) . fst)
63
64
64−Send a message to all clients, and log it on stdout.
65+Send a message to all clients, and log it on stdout:
65
66
66> broadcast :: Text -> ServerState -> IO ()
67> broadcast :: Text -> ServerState -> IO ()
67> broadcast message clients = do
68> broadcast message clients = do
68> T.putStrLn message
69> T.putStrLn message
69−> forM_ clients $ \(_, conn) -> forkIO $ WS.sendTextData conn message
70+> forM_ clients $ \(_, conn) -> WS.sendTextData conn message
70
71
71The main function first creates a new state for the server, then spawns the
72The main function first creates a new state for the server, then spawns the
72−actual server. For this purpose, we use the simple server provided by
73+actual server.
73−'WS.runServer'.
74
74
75> main :: IO ()
75> main :: IO ()
76> main = do
76> main = do
@@ -83,25 +83,37 @@ actual server. For this purpose, we use the simple server provided by
83> staticApp :: Network.Wai.Application
83> staticApp :: Network.Wai.Application
84> staticApp = Static.staticApp $ Static.embeddedSettings $(embedDir "static")
84> staticApp = Static.staticApp $ Static.embeddedSettings $(embedDir "static")
85
85
86−When a client connects, we accept the connection, regardless of the path.
86+Our main application has the type:
87
87
88> application :: MVar ServerState -> WS.ServerApp
88> application :: MVar ServerState -> WS.ServerApp
89+
90+Note that `WS.ServerApp` is nothing but a type synonym for
91+`WS.PendingConnection -> IO ()`.
92+
93+Our application starts by accepting the connection. In a more realistic
94+application, you probably want to check the path and headers provided by the
95+pending request.
96+
97+We also fork a pinging thread in the background. This will ensure the connection
98+stays alive on some browsers.
99+
89> application state pending = do
100> application state pending = do
90> conn <- WS.acceptRequest pending
101> conn <- WS.acceptRequest pending
102+> WS.forkPingThread conn 30
91
103
92When a client is succesfully connected, we read the first message. This should
104When a client is succesfully connected, we read the first message. This should
93−be in the format of "Hi, I am Jasper", where Jasper is the requested username.
105+be in the format of "Hi! I am Jasper", where Jasper is the requested username.
94
106
95> msg <- WS.receiveData conn
107> msg <- WS.receiveData conn
96> clients <- liftIO $ readMVar state
108> clients <- liftIO $ readMVar state
97> case msg of
109> case msg of
98
110
99−Check that the first message has the right format
111+Check that the first message has the right format:
100
112
101> _ | not (prefix `T.isPrefixOf` msg) ->
113> _ | not (prefix `T.isPrefixOf` msg) ->
102> WS.sendTextData conn ("Wrong announcement" :: Text)
114> WS.sendTextData conn ("Wrong announcement" :: Text)
103
115
104−Check the validity of the username
116+Check the validity of the username:
105
117
106> | any ($ fst client)
118> | any ($ fst client)
107> [T.null, T.any isPunctuation, T.any isSpace] ->
119> [T.null, T.any isPunctuation, T.any isSpace] ->
@@ -109,14 +121,15 @@ Check the validity of the username
109> "contain punctuation or whitespace, and " `mappend`
121> "contain punctuation or whitespace, and " `mappend`
110> "cannot be empty" :: Text)
122> "cannot be empty" :: Text)
111
123
112−Check that the given username is not already taken
124+Check that the given username is not already taken:
113
125
114> | clientExists client clients ->
126> | clientExists client clients ->
115> WS.sendTextData conn ("User already exists" :: Text)
127> WS.sendTextData conn ("User already exists" :: Text)
116
128
117−All is right!
129+All is right! We're going to allow the client, but for safety reasons we *first*
130+setup a `disconnect` function that will be run when the exception is closed.
118
131
119−> | otherwise -> do
132+> | otherwise -> flip finally disconnect $ do
120
133
121We send a "Welcome!", according to our own little protocol. We add the client to
134We send a "Welcome!", according to our own little protocol. We add the client to
122the list and broadcast the fact that he has joined. Then, we give control to the
135the list and broadcast the fact that he has joined. Then, we give control to the
@@ -131,22 +144,19 @@ the list and broadcast the fact that he has joined. Then, we give control to the
131> return s'
144> return s'
132> talk conn state client
145> talk conn state client
133> where
146> where
134−> prefix = "Hi! I am "
147+> prefix = "Hi! I am "
135−> client = (T.drop (T.length prefix) msg, conn)
148+> client = (T.drop (T.length prefix) msg, conn)
149+> disconnect = do
150+> -- Remove client and return new state
151+> s <- modifyMVar state $ \s ->
152+> let s' = removeClient client s in return (s', s')
153+> broadcast (fst client `mappend` " disconnected") s
136
154
137The talk function continues to read messages from a single client until he
155The talk function continues to read messages from a single client until he
138disconnects. All messages are broadcasted to the other clients.
156disconnects. All messages are broadcasted to the other clients.
139
157
140> talk :: WS.Connection -> MVar ServerState -> Client -> IO ()
158> talk :: WS.Connection -> MVar ServerState -> Client -> IO ()
141−> talk conn state client@(user, _) = handle catchDisconnect $
159+> talk conn state (user, _) = forever $ do
142−> forever $ do
143−> msg <- WS.receiveData conn
160+> msg <- WS.receiveData conn
144−> liftIO $ readMVar state >>= broadcast
161+> liftIO $ readMVar state >>= broadcast
145−> (user `mappend` ": " `mappend` msg)
162+> (user `mappend` ": " `mappend` msg)
146−> where
147−> catchDisconnect e = case fromException e of
148−> Just WS.ConnectionClosed -> liftIO $ modifyMVar_ state $ \s -> do
149−> let s' = removeClient client s
150−> broadcast (user `mappend` " disconnected") s'
151−> return s'
152−> _ -> return ()