From 0e2f396f26a490cfdd13b3fbda54a8ca53a28e26 Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt
Date: Wed, 29 Jul 2020 17:37:34 +0200
Subject: Accept websocket requests

---
 server/lib/Cafp/Main/Server.hs | 49 +++++++++++++++++++++++++++++++++++-------
 1 file changed, 41 insertions(+), 8 deletions(-)

(limited to 'server/lib')

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
-- 
cgit v1.2.3