aboutsummaryrefslogtreecommitdiff
path: root/server/lib/Cafp/Main
diff options
context:
space:
mode:
authorJasper Van der Jeugt2020-07-29 21:51:54 +0200
committerJasper Van der Jeugt2020-07-29 21:51:54 +0200
commit231b46d9fbafaff2a8cdcc7bd6c9a813b1a61742 (patch)
treeac4136d80b8fbaa94b55850beba8e46d7a5fd789 /server/lib/Cafp/Main
parent49b346b7ebe98051a618d88a39d9b02f13edf33c (diff)
Collect player sinks
Diffstat (limited to 'server/lib/Cafp/Main')
-rw-r--r--server/lib/Cafp/Main/Server.hs44
1 files changed, 33 insertions, 11 deletions
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