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/CookieSocket.hs | 86 +++++++++++++++++++++++++++++++++++++++++ server/lib/Cafp/Game.hs | 33 +++++++++------- server/lib/Cafp/Main/Server.hs | 76 ++++++++++++++++++++++-------------- 3 files changed, 153 insertions(+), 42 deletions(-) create mode 100644 server/lib/Cafp/CookieSocket.hs (limited to 'server/lib/Cafp') diff --git a/server/lib/Cafp/CookieSocket.hs b/server/lib/Cafp/CookieSocket.hs new file mode 100644 index 0000000..5770a3b --- /dev/null +++ b/server/lib/Cafp/CookieSocket.hs @@ -0,0 +1,86 @@ +-- | Allows websockets to reconnect and recover state by storing a cookie client +-- side. +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +module Cafp.CookieSocket + ( Handle + , withHandle + , CookieName + , acceptRequest + , persist + ) where + +import Control.Concurrent (threadDelay) +import qualified Control.Concurrent.Async as Async +import Control.Concurrent.MVar (MVar) +import qualified Control.Concurrent.MVar as MVar +import Control.Monad (forever, guard) +import Data.Hashable (Hashable) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as HMS +import Data.Maybe (listToMaybe) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Time as Time +import Data.UUID (UUID) +import qualified Data.UUID as UUID +import qualified Data.UUID.V4 as UUID.V4 +import qualified Network.WebSockets as WS + +type CookieName = T.Text + +newtype Secret = Secret UUID deriving (Eq, Hashable) + +data Handle v = Handle + { hMinutes :: Int -- Minutes after which expiry happens + , hStore :: MVar (HashMap Secret (Time.UTCTime, v)) + } + +withHandle :: Int -> (Handle v -> IO a) -> IO a +withHandle minutes f = do + store <- MVar.newMVar HMS.empty + Async.withAsync (reaper store) $ \_ -> f $ Handle minutes store + where + -- This is really shitty and we should probably do something with + -- monotonic time. + reaper store = forever $ do + threadDelay $ minutes * 60 * 1000 * 1000 + now <- Time.getCurrentTime + MVar.modifyMVar_ store $ pure . HMS.filter ((> now) . fst) + +parseCookie :: CookieName -> WS.PendingConnection -> Maybe T.Text +parseCookie name pc = listToMaybe $ do + (header, values) <- WS.requestHeaders $ WS.pendingRequest pc + guard $ header == "Cookie" + part <- T.split (== ';') $ T.decodeUtf8 values + let (key, val) = T.break (== '=') part + guard $ T.strip key == name + guard $ "=" `T.isPrefixOf` val + pure . T.strip $ T.drop 1 val + +makeCookie :: CookieName -> T.Text -> WS.Headers +makeCookie name val = [("Set-Cookie", T.encodeUtf8 $ name <> "=" <> val)] + +acceptRequest + :: Handle a -> CookieName -> WS.PendingConnection + -> IO (WS.Connection, Secret, Maybe a) +acceptRequest h name pc = case parseCookie name pc >>= UUID.fromText of + Just uuid -> do + conn <- WS.acceptRequest pc + store <- MVar.readMVar (hStore h) + pure (conn, Secret uuid, snd <$> HMS.lookup (Secret uuid) store) + Nothing -> do + uuid <- UUID.V4.nextRandom + conn <- WS.acceptRequestWith pc WS.defaultAcceptRequest + { WS.acceptHeaders = + makeCookie name (UUID.toText uuid) <> + WS.acceptHeaders WS.defaultAcceptRequest + } + pure (conn, Secret uuid, Nothing) + +persist :: Handle a -> Secret -> a -> IO () +persist h key x = MVar.modifyMVar_ (hStore h) $ \store -> do + expiry <- Time.addUTCTime diffTime <$> Time.getCurrentTime + pure $ HMS.insert key (expiry, x) store + where + diffTime = fromIntegral (60 * hMinutes h) diff --git a/server/lib/Cafp/Game.hs b/server/lib/Cafp/Game.hs index d4e1b4b..96b24dc 100644 --- a/server/lib/Cafp/Game.hs +++ b/server/lib/Cafp/Game.hs @@ -21,9 +21,9 @@ module Cafp.Game import Cafp.Messages import Control.Lens (Lens', at, iall, ifor_, imap, ix, - orOf, over, to, (%%=), (%=), - (%~), (&), (+=), (.=), (.~), - (^.), (^..), (^?), _1, _2, _3) + orOf, to, (%%=), (%=), (%~), (&), + (+=), (.=), (.~), (^.), (^..), + (^?), _1, _2, _3) import Control.Lens.TH (makeLenses, makePrisms) import Control.Monad (guard) import Control.Monad.State (State, execState, modify, @@ -60,7 +60,8 @@ data Table deriving (Show) data Player = Player - { _playerName :: !Text + { _playerId :: !PlayerId + , _playerName :: !Text , _playerHand :: !(V.Vector WhiteCard) , _playerAdmin :: !Bool , _playerPoints :: !Int @@ -134,17 +135,23 @@ assignAdmin game -- No players | otherwise = game -joinGame :: Game -> (PlayerId, Game) -joinGame = runState $ do - pid <- gameNextPlayerId %%= (\x -> (x, x + 1)) - let name = "Player " <> T.pack (show pid) - hand <- V.replicateM defaultHandSize popWhiteCard - gamePlayers %= HMS.insert pid (Player name hand False 0) +joinGame :: Maybe Player -> Game -> (PlayerId, Game) +joinGame mbPlayer = runState $ do + player <- case mbPlayer of + Nothing -> do + pid <- gameNextPlayerId %%= (\x -> (x, x + 1)) + let name = "Player " <> T.pack (show pid) + hand <- V.replicateM defaultHandSize popWhiteCard + pure $ Player pid name hand False 0 + Just p -> pure $ p & playerAdmin .~ False + gamePlayers %= HMS.insert (player ^. playerId) player modify assignAdmin - pure pid + pure $ player ^. playerId -leaveGame :: PlayerId -> Game -> Game -leaveGame pid = assignAdmin . over gamePlayers (HMS.delete pid) +leaveGame :: PlayerId -> Game -> (Maybe Player, Game) +leaveGame pid game = case game ^? gamePlayers . ix pid of + Nothing -> (Nothing, game) + Just p -> (Just p, assignAdmin $ game & gamePlayers %~ HMS.delete pid) blackCardBlanks :: Cards -> BlackCard -> Int blackCardBlanks cards (BlackCard c) = 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