From 231b46d9fbafaff2a8cdcc7bd6c9a813b1a61742 Mon Sep 17 00:00:00 2001
From: Jasper Van der Jeugt
Date: Wed, 29 Jul 2020 21:51:54 +0200
Subject: Collect player sinks

---
 server/lib/Cafp/Main/Server.hs | 44 +++++++++++++++++++++++++++++++-----------
 1 file changed, 33 insertions(+), 11 deletions(-)

(limited to 'server/lib/Cafp/Main/Server.hs')

diff --git a/server/lib/Cafp/Main/Server.hs b/server/lib/Cafp/Main/Server.hs
index 4b59135..ac0c536 100644
--- a/server/lib/Cafp/Main/Server.hs
+++ b/server/lib/Cafp/Main/Server.hs
@@ -5,12 +5,15 @@ module Cafp.Main.Server
 
 import           Cafp.Messages
 import           Control.Concurrent             (threadDelay)
-import           Control.Concurrent.STM         (STM, TVar, newTVar)
+import Control.Exception (bracket)
+import           Control.Concurrent.STM         (STM, TVar, atomically)
+import           qualified Control.Concurrent.STM         as STM
 import           Control.Monad                  (forever, when)
 import qualified Data.Aeson                     as Aeson
 import qualified Data.HashMap.Strict            as HMS
 import           Data.Text                      (Text)
 import qualified Data.Text                      as T
+import qualified Data.ByteString as B
 import qualified Data.Text.Encoding             as T
 import qualified Data.Text.Lazy                 as TL
 import qualified Network.Wai                    as Wai
@@ -21,12 +24,21 @@ import qualified Web.Scotty                     as Scotty
 
 type RoomId = T.Text
 
+type PlayerId = Int
+
+type Sink = B.ByteString -> IO ()
+
 data Server = Server
-    { serverRooms :: TVar (HMS.HashMap RoomId ())
+    { serverRooms        :: TVar (HMS.HashMap RoomId ())
+    , serverSinks        :: TVar (HMS.HashMap PlayerId Sink)
+    , serverNextPlayerId :: TVar Int
     }
 
 newServer :: STM Server
-newServer = Server <$> newTVar HMS.empty
+newServer = Server
+    <$> STM.newTVar HMS.empty
+    <*> STM.newTVar HMS.empty
+    <*> STM.newTVar 0
 
 scottyApp :: IO Wai.Application
 scottyApp = Scotty.scottyApp $ do
@@ -48,21 +60,31 @@ routePendingConnection pending =
         [_, "rooms", roomId, "events"] -> Just roomId
         _                              -> Nothing
 
-wsApp :: WS.ServerApp
-wsApp pc = case routePendingConnection pc of
+wsApp :: Server -> WS.ServerApp
+wsApp server pc = case routePendingConnection pc of
     Nothing -> WS.rejectRequest pc "Invalid URL"
     Just roomId -> do
+        playerId <- atomically . STM.stateTVar (serverNextPlayerId server) $
+            \x -> (x, x + 1)
         conn <- WS.acceptRequest pc
-        WS.forkPingThread conn 30
-        WS.sendTextData conn $ Aeson.encode Welcome
-        forever $ do
-            WS.sendTextData conn $ Aeson.encode Bye
-            threadDelay $ 1 * 1000000
+        WS.withPingThread conn 30 (pure ()) $ do
+            WS.sendTextData conn $ Aeson.encode $ Welcome playerId
+            bracket
+                (atomically . STM.modifyTVar (serverSinks server) $
+                    HMS.insert playerId (\bs -> WS.sendTextData conn bs))
+                (\() -> atomically . STM.modifyTVar (serverSinks server) $
+                    HMS.delete playerId)
+                (\() -> loop conn)
+  where
+    loop conn = forever $ do
+        WS.sendTextData conn $ Aeson.encode Bye
+        threadDelay $ 1 * 1000000
 
 main :: IO ()
 main = do
     let port = 3000
         settings = Warp.setPort port Warp.defaultSettings
+    server <- atomically newServer
     sapp <- scottyApp
     Warp.runSettings settings $
-        WaiWs.websocketsOr WS.defaultConnectionOptions wsApp sapp
+        WaiWs.websocketsOr WS.defaultConnectionOptions (wsApp server) sapp
-- 
cgit v1.2.3