diff options
author | Jasper Van der Jeugt | 2020-07-29 17:37:34 +0200 |
---|---|---|
committer | Jasper Van der Jeugt | 2020-07-29 17:37:34 +0200 |
commit | 0e2f396f26a490cfdd13b3fbda54a8ca53a28e26 (patch) | |
tree | 817ea981ce7a46be807c825a9b1d0ac813505312 /server/lib | |
parent | 676bf9936b9b51e24979657d50d8f019b2f64ac2 (diff) |
Accept websocket requests
Diffstat (limited to 'server/lib')
-rw-r--r-- | server/lib/Cafp/Main/Server.hs | 49 |
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 |