aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--server/cafp.cabal6
-rw-r--r--server/lib/Cafp/Main/Server.hs49
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