Server

zincy 2018-04-13 10:54:05.234772 UTC

1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE DeriveGeneric #-}
3
4module Main where
5import Prelude
6import Data.Char (isPunctuation, isSpace)
7import Data.Monoid
8import Data.Text (Text)
9import Control.Exception (finally)
10import Control.Monad (forM_, forever)
11import Control.Concurrent (MVar, newMVar, modifyMVar_, modifyMVar, readMVar)
12import qualified Data.Text as T
13import qualified Data.Text.IO as T
14import qualified Data.Text.Lazy.Encoding as D
15import qualified Data.Text.Lazy as X
16import qualified Network.WebSockets as WS
17import Data.Aeson
18
19--We represent a client by their username and a `WS.Connection`. We will see how we
20--obtain this `WS.Connection` later on.
21
22newtype Client = Client (Text, WS.Connection)
23
24instance Eq Client where
25 (Client (x, _)) == (Client (y, _)) = x == y
26
27--The state kept on the server is simply a list of connected clients. We've added
28--an alias and some utility functions, so it will be easier to extend this state
29--later on.
30
31type ServerState = [Client]
32
33
34instance ToJSON Client where
35 -- No need to provide a toJSON implementation.
36
37 -- For efficiency, we write a simple toEncoding implementation, as
38 -- the default version uses toJSON.
39 toJSON (Client (name, _)) = object ["name" .= (String name)]
40
41--Create a new, initial state:
42
43newServerState :: ServerState
44newServerState = []
45
46--Get the number of active clients:
47
48numClients :: ServerState -> Int
49numClients = length
50
51--Check if a user already exists (based on username):
52
53clientExists :: Client -> ServerState -> Bool
54clientExists client clients = elem client clients
55
56--Add a client (this does not check if the client already exists, you should do
57--this yourself using `clientExists`):
58
59addClient :: Client -> ServerState -> ServerState
60addClient client clients = client : clients
61
62--Remove a client:
63
64removeClient :: Client -> ServerState -> ServerState
65removeClient client = filter (/= client)
66
67--Send a message to all clients, and log it on stdout:
68
69broadcast :: Text -> ServerState -> IO ()
70broadcast message clients = do
71 T.putStrLn message
72 forM_ clients $ \(Client (_, conn)) -> WS.sendTextData conn message
73
74
75--The main function first creates a new state for the server, then spawns the
76--actual server. For this purpose, we use the simple server provided by
77--`WS.runServer`.
78
79main :: IO ()
80main = do
81 state <- newMVar newServerState
82 WS.runServer "127.0.0.1" 9140 $ application state
83
84--Our main application has the type:
85
86application :: MVar ServerState -> WS.ServerApp
87
88--Note that `WS.ServerApp` is nothing but a type synonym for
89--`WS.PendingConnection -> IO ()`.
90
91--Our application starts by accepting the connection. In a more realistic
92--application, you probably want to check the path and headers provided by the
93--pending request.
94
95--We also fork a pinging thread in the background. This will ensure the connection
96--stays alive on some browsers.
97
98application state pending = do
99 conn <- WS.acceptRequest pending
100 WS.forkPingThread conn 30
101
102--When a client is succesfully connected, we read the first message. This should
103--be in the format of "Hi! I am Jasper", where Jasper is the requested username.
104
105 msg <- WS.receiveData conn
106 clients <- readMVar state
107 case msg of
108
109--Check that the first message has the right format:
110
111 -- _ | not (prefix `T.isPrefixOf` msg) ->
112 -- WS.sendTextData conn ("Wrong announcement" :: Text)
113
114--Check the validity of the username:
115
116 -- | any ($ clientName)
117 -- [T.null, T.any isPunctuation, T.any isSpace] ->
118 -- WS.sendTextData conn ("Name cannot " `mappend`
119 -- "contain punctuation or whitespace, and " `mappend`
120 -- "cannot be empty" :: Text)
121
122--Check that the given username is not already taken:
123
124 _ | clientExists client clients ->
125 WS.sendTextData conn ("User already exists" :: Text)
126
127--All is right! We're going to allow the client, but for safety reasons we *first*
128--setup a `disconnect` function that will be run when the connection is closed.
129
130 | otherwise -> flip finally disconnect $ do
131
132--We send a "Welcome!", according to our own little protocol. We add the client to
133--the list and broadcast the fact that he has joined. Then, we give control to the
134--'talk' function.
135
136 modifyMVar_ state $ \s -> do
137 let s' = addClient client s
138 T.putStrLn clientName
139 putStrLn $ T.unpack jsonClient
140 WS.sendTextData conn $ T.pack "nnu"
141 broadcast jsonClient s'
142 return s'
143 talk conn state client
144 where
145 prefix = "Hi! I am "
146 clientName = T.filter (\c -> c `notElem` ['"',' ']) $ T.drop (T.length prefix) msg
147 client = Client (clientName, conn)
148 jsonClient = X.toStrict $ D.decodeUtf8 $ encode client
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 (clientName `mappend` " disconnected") s
154
155--The talk function continues to read messages from a single client until he
156--disconnects. All messages are broadcasted to the other clients.
157
158talk :: WS.Connection -> MVar ServerState -> Client -> IO ()
159talk conn state (Client(user, _)) = forever $ do
160 msg <- WS.receiveData conn
161 readMVar state >>= broadcast
162 (msg)