blob: 4b59135703c1e8d57d673c70c20535fec4b3e67e (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
|
{-# LANGUAGE OverloadedStrings #-}
module Cafp.Main.Server
( main
) where
import Cafp.Messages
import Control.Concurrent (threadDelay)
import Control.Concurrent.STM (STM, TVar, newTVar)
import Control.Monad (forever, when)
import qualified Data.Aeson as Aeson
import qualified Data.HashMap.Strict as HMS
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Lazy as TL
import qualified Network.Wai as Wai
import qualified Network.Wai.Handler.Warp as Warp
import qualified Network.Wai.Handler.WebSockets as WaiWs
import qualified Network.WebSockets as WS
import qualified Web.Scotty as Scotty
type RoomId = T.Text
data Server = Server
{ serverRooms :: TVar (HMS.HashMap RoomId ())
}
newServer :: STM Server
newServer = Server <$> newTVar HMS.empty
scottyApp :: IO Wai.Application
scottyApp = Scotty.scottyApp $ do
Scotty.get "/rooms/:id/" $ do
roomId <- Scotty.param "id"
when (T.length roomId < 6) $
Scotty.raise "Room ID should be at least 6 characters"
Scotty.setHeader "Content-Type" "text/html"
Scotty.file "assets/client.html"
Scotty.get "/assets/client.js" $ do
Scotty.setHeader "Content-Type" "application/JavaScript"
Scotty.file "assets/client.js"
routePendingConnection :: WS.PendingConnection -> Maybe RoomId
routePendingConnection pending =
let path = T.decodeUtf8 . WS.requestPath $ WS.pendingRequest pending in
case T.split (== '/') path of
[_, "rooms", roomId, "events"] -> Just roomId
_ -> Nothing
wsApp :: WS.ServerApp
wsApp pc = case routePendingConnection pc of
Nothing -> WS.rejectRequest pc "Invalid URL"
Just roomId -> do
conn <- WS.acceptRequest pc
WS.forkPingThread conn 30
WS.sendTextData conn $ Aeson.encode Welcome
forever $ do
WS.sendTextData conn $ Aeson.encode Bye
threadDelay $ 1 * 1000000
main :: IO ()
main = do
let port = 3000
settings = Warp.setPort port Warp.defaultSettings
sapp <- scottyApp
Warp.runSettings settings $
WaiWs.websocketsOr WS.defaultConnectionOptions wsApp sapp
|
