aboutsummaryrefslogtreecommitdiff
path: root/server/lib/Cafp/Main
diff options
context:
space:
mode:
authorJasper Van der Jeugt2020-08-05 15:48:27 +0200
committerJasper Van der Jeugt2020-08-05 15:48:27 +0200
commitb90901b2c2597a72ff6fe2de92d72db51455e577 (patch)
tree5ce24eee2535886c020ef7a11fb82bbd8decd2e7 /server/lib/Cafp/Main
parent7ff45befe94cd248ea5505e4ca74005358d5e329 (diff)
Persistence with cookies
Diffstat (limited to 'server/lib/Cafp/Main')
-rw-r--r--server/lib/Cafp/Main/Server.hs76
1 files changed, 47 insertions, 29 deletions
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