aboutsummaryrefslogtreecommitdiff
path: root/server/lib/Cafp/Main
diff options
context:
space:
mode:
authorJasper Van der Jeugt2020-07-29 17:37:34 +0200
committerJasper Van der Jeugt2020-07-29 17:37:34 +0200
commit0e2f396f26a490cfdd13b3fbda54a8ca53a28e26 (patch)
tree817ea981ce7a46be807c825a9b1d0ac813505312 /server/lib/Cafp/Main
parent676bf9936b9b51e24979657d50d8f019b2f64ac2 (diff)
Accept websocket requests
Diffstat (limited to 'server/lib/Cafp/Main')
-rw-r--r--server/lib/Cafp/Main/Server.hs49
1 files changed, 41 insertions, 8 deletions
diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs
index fdace52..6451e17 100644
--- a/server/lib/Cafp/Main/Server.hs
+++ b/server/lib/Cafp/Main/Server.hs
@@ -4,12 +4,19 @@ module Cafp.Main.Server
) where
import Cafp.Messages
-import Control.Concurrent.STM (STM, TVar, newTVar)
-import Control.Monad (when)
-import qualified Data.HashMap.Strict as HMS
-import qualified Data.Text as T
-import qualified Data.Text.Lazy as TL
-import qualified Web.Scotty as Scotty
+import Control.Concurrent (threadDelay)
+import Control.Concurrent.STM (STM, TVar, newTVar)
+import Control.Monad (forever, when)
+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
@@ -20,8 +27,8 @@ data Server = Server
newServer :: STM Server
newServer = Server <$> newTVar HMS.empty
-main :: IO ()
-main = Scotty.scotty 3000 $ do
+scottyApp :: IO Wai.Application
+scottyApp = Scotty.scottyApp $ do
Scotty.get "/rooms/:id/" $ do
roomId <- Scotty.param "id"
when (T.length roomId < 6) $
@@ -32,3 +39,29 @@ main = Scotty.scotty 3000 $ do
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 $ "Welcome to room " <> roomId
+ forever $ do
+ WS.sendTextData conn $ ("loop data" :: Text)
+ 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