Accept websocket requests

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