diff options
| -rw-r--r-- | client/src/Client.elm | 3 | ||||
| -rw-r--r-- | client/src/Messages.elm | 18 | ||||
| -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 |
5 files changed, 48 insertions, 20 deletions
diff --git a/client/src/Client.elm b/client/src/Client.elm index ffb2b0e..0644a12 100644 --- a/client/src/Client.elm +++ b/client/src/Client.elm @@ -46,7 +46,8 @@ update msg model = case msg of WebSocketIn json -> case Json.Decode.decodeString Messages.jsonDecServerMessage json of Err str -> (Error <| Json.Decode.errorToString str, Cmd.none) - Ok Messages.Welcome -> Debug.log "Welcome" (model, Cmd.none) + Ok (Messages.Welcome playerId) -> + Debug.log ("Welcome " ++ String.fromInt playerId) (model, Cmd.none) Ok Messages.Bye -> Debug.log "Bye" (model, Cmd.none) main : Program () Model Msg diff --git a/client/src/Messages.elm b/client/src/Messages.elm index 2510544..76b24f5 100644 --- a/client/src/Messages.elm +++ b/client/src/Messages.elm @@ -9,18 +9,22 @@ import Set exposing (Set) type ServerMessage = - Welcome + Welcome Int | Bye jsonDecServerMessage : Json.Decode.Decoder ( ServerMessage ) -jsonDecServerMessage = - let jsonDecDictServerMessage = Dict.fromList [("Welcome", Welcome), ("Bye", Bye)] - in decodeSumUnaries "ServerMessage" jsonDecDictServerMessage +jsonDecServerMessage = + let jsonDecDictServerMessage = Dict.fromList + [ ("Welcome", Json.Decode.lazy (\_ -> Json.Decode.map Welcome (Json.Decode.int))) + , ("Bye", Json.Decode.lazy (\_ -> Json.Decode.succeed Bye)) + ] + in decodeSumObjectWithSingleField "ServerMessage" jsonDecDictServerMessage jsonEncServerMessage : ServerMessage -> Value jsonEncServerMessage val = - case val of - Welcome -> Json.Encode.string "Welcome" - Bye -> Json.Encode.string "Bye" + let keyval v = case v of + Welcome v1 -> ("Welcome", encodeValue (Json.Encode.int v1)) + Bye -> ("Bye", encodeValue (Json.Encode.list identity [])) + in encodeSumObjectWithSingleField keyval val 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) |