diff options
| -rw-r--r-- | server/cafp.cabal | 6 | ||||
| -rw-r--r-- | server/lib/Cafp/Main/Server.hs | 49 |
2 files changed, 46 insertions, 9 deletions
diff --git a/server/cafp.cabal b/server/cafp.cabal index 805979f..f97f958 100644 --- a/server/cafp.cabal +++ b/server/cafp.cabal @@ -26,7 +26,11 @@ Library scotty >= 0.11 && < 0.12, stm >= 2.5 && < 2.6, text >= 1.2 && < 1.3, - unordered-containers >= 0.2 && < 0.3 + unordered-containers >= 0.2 && < 0.3, + wai >= 3.2 && < 3.3, + wai-websockets >= 3.0 && < 3.1, + warp >= 3.3 && < 3.4, + websockets >= 0.12 && < 0.13 Executable cafp-generate-elm-types Hs-source-dirs: src 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 |