diff options
Diffstat (limited to '')
| -rw-r--r-- | server/cafp.cabal | 1 | ||||
| -rw-r--r-- | server/lib/Cafp/Main/Server.hs | 44 | ||||
| -rw-r--r-- | server/lib/Cafp/Messages.hs | 2 |
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) |