aboutsummaryrefslogtreecommitdiff
path: root/server/lib
diff options
context:
space:
mode:
Diffstat (limited to 'server/lib')
-rw-r--r--server/lib/Cafp/CookieSocket.hs86
-rw-r--r--server/lib/Cafp/Game.hs33
-rw-r--r--server/lib/Cafp/Main/Server.hs76
3 files changed, 153 insertions, 42 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 20:46:52 +0000