From b90901b2c2597a72ff6fe2de92d72db51455e577 Mon Sep 17 00:00:00 2001 From: Jasper Van der Jeugt Date: Wed, 5 Aug 2020 15:48:27 +0200 Subject: Persistence with cookies --- server/lib/Cafp/Main/Server.hs | 76 ++++++++++++++++++++++++++---------------- 1 file changed, 47 insertions(+), 29 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 4b1bfe7..70e9a00 100644 --- a/server/lib/Cafp/Main/Server.hs +++ b/server/lib/Cafp/Main/Server.hs @@ -3,6 +3,7 @@ module Cafp.Main.Server ( main ) where +import qualified Cafp.CookieSocket as CookieSocket import Cafp.Game import Cafp.Messages import Control.Concurrent.MVar (MVar) @@ -15,10 +16,11 @@ import Control.Monad (forever, when) import qualified Data.Aeson as Aeson import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL +import Data.Char (isAlphaNum) import Data.Foldable (for_) import qualified Data.HashMap.Strict as HMS import qualified Data.List as L -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, isNothing) import Data.String (fromString) import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -33,8 +35,8 @@ import qualified System.IO as IO import System.Random (StdGen, newStdGen) import qualified Web.Scotty as Scotty -warning :: String -> IO () -warning = IO.hPutStrLn IO.stderr +info :: String -> IO () +info = IO.hPutStrLn IO.stderr type RoomId = T.Text @@ -46,8 +48,9 @@ data Room = Room } data Server = Server - { serverCards :: Cards - , serverRooms :: MVar (HMS.HashMap RoomId Room) + { serverCookieSocket :: CookieSocket.Handle Player + , serverCards :: Cards + , serverRooms :: MVar (HMS.HashMap RoomId Room) } readCards :: IO Cards @@ -58,14 +61,19 @@ readCards = Cards parseCards = V.fromList . filter (not . T.null) . map dropComment . T.lines dropComment = T.strip . fst . T.break (== '#') -newServer :: IO Server -newServer = Server <$> readCards <*> MVar.newMVar HMS.empty +withServer :: (Server -> IO a) -> IO a +withServer f = CookieSocket.withHandle 5 $ \cs -> + f =<< Server cs <$> readCards <*> MVar.newMVar HMS.empty newRoom :: Server -> StdGen -> STM Room newRoom server gen = Room <$> (STM.newTVar $ newGame (serverCards server) gen) <*> STM.newTVar HMS.empty +parseRoomId :: T.Text -> Either String T.Text +parseRoomId txt + | T.all isAlphaNum txt && T.length txt >= 6 = Right txt + | otherwise = Left "Bad room name" scottyApp :: IO Wai.Application scottyApp = Scotty.scottyApp $ do @@ -88,8 +96,8 @@ routePendingConnection :: WS.PendingConnection -> Maybe RoomId routePendingConnection pending = let path = T.decodeUtf8 . WS.requestPath $ WS.pendingRequest pending in case splitPath path of - ["rooms", roomId, "events"] -> Just roomId - _ -> Nothing + ["rooms", txt, "events"] | Right r <- parseRoomId txt -> Just r + _ -> Nothing getOrCreateRoom :: Server -> RoomId -> IO Room getOrCreateRoom server roomId = MVar.modifyMVar (serverRooms server) $ \rooms -> @@ -97,27 +105,27 @@ getOrCreateRoom server roomId = MVar.modifyMVar (serverRooms server) $ \rooms -> Just room -> pure (rooms, room) Nothing -> do gen <- newStdGen - warning $ "[" <> T.unpack roomId <> "] Created room" + info $ "[" <> T.unpack roomId <> "] Created room" room <- atomically $ newRoom server gen pure (HMS.insert roomId room rooms, room) deleteRoom :: Server -> RoomId -> IO () deleteRoom server roomId = do - warning $ "[" <> T.unpack roomId <> "] Deleting room" + info $ "[" <> T.unpack roomId <> "] Deleting room" MVar.modifyMVar_ (serverRooms server) $ pure . HMS.delete roomId -joinRoom :: Room -> Sink -> STM PlayerId -joinRoom room sink = do - pid <- STM.stateTVar (roomGame room) joinGame +joinRoom :: Room -> Sink -> Maybe Player -> STM PlayerId +joinRoom room sink mbRecovered = do + pid <- STM.stateTVar (roomGame room) $ joinGame mbRecovered STM.modifyTVar' (roomSinks room) $ HMS.insert pid sink pure pid -leaveRoom :: Room -> PlayerId -> STM Bool +leaveRoom :: Room -> PlayerId -> STM (Bool, Maybe Player) leaveRoom room pid = do - STM.modifyTVar' (roomGame room) $ leaveGame pid + player <- STM.stateTVar (roomGame room) $ leaveGame pid STM.stateTVar (roomSinks room) $ \sinks -> let sinks' = HMS.delete pid sinks in - (HMS.null sinks', sinks') + ((HMS.null sinks', player), sinks') syncRoom :: Room -> IO () syncRoom room = do @@ -126,7 +134,6 @@ syncRoom room = do <*> STM.readTVar (roomSinks room) for_ (HMS.toList sinks) $ \(pid, sink) -> do let view = gameViewForPlayer pid game - warning $ "New state: " ++ show view sink . Aeson.encode $ SyncGameView view wsApp :: Server -> WS.ServerApp @@ -134,13 +141,25 @@ wsApp server pc = case routePendingConnection pc of Nothing -> WS.rejectRequest pc "Invalid URL" Just roomId -> do room <- getOrCreateRoom server roomId - conn <- WS.acceptRequest pc + (conn, secret, mbRecovered) <- + CookieSocket.acceptRequest (serverCookieSocket server) roomId pc let sink = WS.sendTextData conn WS.withPingThread conn 30 (pure ()) $ bracket - (atomically $ joinRoom room sink) - (\playerId -> do - roomEmpty <- atomically $ leaveRoom room playerId - if roomEmpty then deleteRoom server roomId else syncRoom room) + (do + pid <- atomically $ joinRoom room sink mbRecovered + info $ "[" <> T.unpack roomId <> "] Player " <> show pid <> + if isNothing mbRecovered then " joined" else " rejoined" + pure pid) + (\pid -> do + (roomEmpty, mbPlayer) <- atomically $ leaveRoom room pid + info $ "[" <> T.unpack roomId <> + "] Player " <> show pid <> " left" + if roomEmpty + then deleteRoom server roomId + else do + for_ mbPlayer $ CookieSocket.persist + (serverCookieSocket server) secret + syncRoom room) (\playerId -> do sink . Aeson.encode $ Welcome roomId syncRoom room @@ -153,13 +172,12 @@ wsApp server pc = case routePendingConnection pc of msg <- WS.receiveData conn case Aeson.decode msg of Just cm -> do - warning $ "Client: " ++ show cm room <- getOrCreateRoom server roomId -- TODO: only get? atomically . STM.modifyTVar' (roomGame room) $ processClientMessage playerId cm syncRoom room Nothing -> do - warning $ "Could not decode client message: " ++ show msg + info $ "Could not decode client message: " ++ show msg splitPath :: T.Text -> [T.Text] splitPath = filter (not . T.null) . T.split (== '/') @@ -182,7 +200,7 @@ main = do port <- read <$> getEnv "CAFP_PORT" base <- splitPath . T.pack <$> getEnv "CAFP_BASE" let settings = Warp.setPort port . Warp.setHost host $ Warp.defaultSettings - server <- newServer - sapp <- scottyApp - Warp.runSettings settings $ baseUrl base $ - WaiWs.websocketsOr WS.defaultConnectionOptions (wsApp server) sapp + withServer $ \server -> do + sapp <- scottyApp + Warp.runSettings settings $ baseUrl base $ + WaiWs.websocketsOr WS.defaultConnectionOptions (wsApp server) sapp -- cgit v1.2.3