Collect player sinks

3 files changed, 35 insertions, 12 deletions

diff --git a/server/cafp.cabal b/server/cafp.cabal
index 733c3e3..df178c7 100644
--- a/server/cafp.cabal
+++ b/server/cafp.cabal
@@ -23,6 +23,7 @@ Library
   Build-depends:
     aeson                >= 1.4  && < 1.5,
     base                 >= 4.9  && < 5,
+    bytestring           >= 0.10 && < 0.11,
     elm-bridge           >= 0.5  && < 0.6,
     scotty               >= 0.11 && < 0.12,
     stm                  >= 2.5  && < 2.6,
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
diff --git a/server/lib/Cafp/Messages.hs b/server/lib/Cafp/Messages.hs
index bde199d..682e80b 100644
--- a/server/lib/Cafp/Messages.hs
+++ b/server/lib/Cafp/Messages.hs
@@ -6,7 +6,7 @@ module Cafp.Messages
 import           Elm.Derive
 
 data ServerMessage
-    = Welcome
+    = Welcome Int
     | Bye
     deriving (Show)