Fix bug where session state wasn't being cleaned up. Adds unit tests.

parent 8318584c
{-# LANGUAGE Rank2Types, OverloadedStrings #-}
module Roguestar.Lib.Roguestar
(Game,
(GameConfiguration(..),
getConfiguration,
Game,
GameState,
createGameState,
createGame,
......@@ -49,71 +51,78 @@ import Data.Text as T
import System.Time
import Control.Concurrent
-- Session timeout information.
data GameConfiguration = GameConfiguration {
game_config_timeout_seconds :: Integer,
game_config_current_clock_time_seconds :: Integer }
-- Constructs a GameConfiguration using the current time and the desired session timeout in seconds.
getConfiguration :: Integer -> IO GameConfiguration
getConfiguration timeout_seconds =
do TOD now _ <- getClockTime
return $ GameConfiguration timeout_seconds now
-- A collection of games, i.e. all games on the server
data GameState = GameState {
game_state_gamelist :: TVar (Map.Map BS.ByteString Game),
game_state_last_cleanup :: TVar ClockTime }
game_state_last_cleanup :: TVar Integer }
-- The state information for a specific game.
data Game = Game {
game_db :: TVar DB_BaseType,
game_message_text :: TVar [T.Text],
game_last_touched :: TVar ClockTime }
game_last_touched :: TVar Integer }
newGame :: IO Game
newGame =
newGame :: GameConfiguration -> IO Game
newGame config =
do db <- newTVarIO initial_db
empty_messages <- newTVarIO []
starting_time <- newTVarIO =<< getClockTime
starting_time <- newTVarIO (game_config_current_clock_time_seconds config)
return $ Game db empty_messages starting_time
createGameState :: IO GameState
createGameState =
createGameState :: GameConfiguration -> IO GameState
createGameState config =
do gs <- newTVarIO Map.empty
starting_time <- newTVarIO =<< getClockTime
starting_time <- newTVarIO (game_config_current_clock_time_seconds config)
return $ GameState gs starting_time
cleanup_timeout :: Integer
cleanup_timeout = 15*60;
cleanupGameState :: GameState -> IO ()
cleanupGameState game_state =
do now@(TOD current_time _) <- getClockTime
needs_cleanup <- atomically $
do (TOD last_cleanup_time _) <- readTVar (game_state_last_cleanup game_state)
let needs_cleanup = current_time < last_cleanup_time + cleanup_timeout
when needs_cleanup $ writeTVar (game_state_last_cleanup game_state) now
cleanupGameState :: GameConfiguration -> GameState -> IO ()
cleanupGameState config game_state =
do needs_cleanup <- atomically $
do last_cleanup_time <- readTVar (game_state_last_cleanup game_state)
let needs_cleanup = (game_config_current_clock_time_seconds config) > last_cleanup_time + game_config_timeout_seconds config
when needs_cleanup $ writeTVar (game_state_last_cleanup game_state) (game_config_current_clock_time_seconds config)
return needs_cleanup
when needs_cleanup $
do forkIO $ doCleanup game_state
do forkIO $ doCleanup config game_state
return ()
doCleanup :: GameState -> IO ()
doCleanup game_state =
do (TOD now _) <- getClockTime
atomically $
doCleanup :: GameConfiguration -> GameState -> IO ()
doCleanup config game_state =
do atomically $
do game_list <- readTVar $ game_state_gamelist game_state
forM_ (Map.toList game_list) $ \(key,value) ->
do TOD last_touched _ <- readTVar $ game_last_touched value
when (last_touched + cleanup_timeout < now) $
do last_touched <- readTVar $ game_last_touched value
when (game_config_current_clock_time_seconds config > last_touched + game_config_timeout_seconds config) $
writeTVar (game_state_gamelist game_state) =<< liftM (Map.delete key) (readTVar $ game_state_gamelist game_state)
createGame :: GameState -> IO BS.ByteString
createGame game_state =
do cleanupGameState game_state
createGame :: GameConfiguration -> GameState -> IO BS.ByteString
createGame config game_state =
do cleanupGameState config game_state
uuid <- liftM (BS8.pack . show) V4.uuid
g <- newGame
g <- newGame config
atomically $
do gs <- readTVar (game_state_gamelist game_state)
writeTVar (game_state_gamelist game_state) $ Map.insert uuid g gs
return uuid
retrieveGame :: BS.ByteString -> GameState -> IO (Maybe Game)
retrieveGame uuid game_state =
do cleanupGameState game_state
current_time <- getClockTime
retrieveGame :: BS.ByteString -> GameConfiguration -> GameState -> IO (Maybe Game)
retrieveGame uuid config game_state =
do cleanupGameState config game_state
atomically $
do m_g <- liftM (Map.lookup uuid) $ readTVar (game_state_gamelist game_state)
case m_g of
Just g -> writeTVar (game_last_touched g) current_time
Just g -> writeTVar (game_last_touched g) (game_config_current_clock_time_seconds config)
Nothing -> return ()
return m_g
......
......@@ -41,6 +41,7 @@ import Roguestar.Lib.TerrainData as TerrainData
import Roguestar.Lib.CreatureData
import Roguestar.Lib.Facing
import Roguestar.Lib.Logging
import Roguestar.Lib.UnitTests
import Roguestar.Lib.DBData (Reference,ToolRef,toUID)
import Data.UUID
import qualified System.UUID.V4 as V4
......@@ -57,6 +58,7 @@ instance HasHeist App where heistLens = subSnaplet heist
appInit :: SnapletInit App App
appInit = makeSnaplet "roguestar-server-snaplet" "Roguestar Server" Nothing $
do hs <- nestSnaplet "heist" heist $ heistInit "templates"
(unit_test_result,unit_tests_passed) <- liftIO runTests
addRoutes [("/start", start),
("/play", play),
("/static", static),
......@@ -64,8 +66,10 @@ appInit = makeSnaplet "roguestar-server-snaplet" "Roguestar Server" Nothing $
("/fail", handle500 (do error "my brain exploded")),
("/feedback", feedback),
("/options", options),
("/unit", writeText unit_test_result),
("", heistServe)]
game <- liftIO createGameState
config <- liftIO $ getConfiguration default_timeout
game <- liftIO $ createGameState config
wrapSite (<|> handle404)
wrapSite handle500
return $ App hs game
......@@ -253,7 +257,8 @@ start = on_get <|> on_post
where on_get = method GET $ render "/hidden/start"
on_post = method POST $
do game_state <- gets _app_game_state
cookie <- liftIO $ createGame game_state
config <- liftIO $ getConfiguration default_timeout
cookie <- liftIO $ createGame config game_state
modifyResponse $ addResponseCookie (Cookie "game-uuid" cookie Nothing Nothing Nothing False False)
replay
......@@ -298,13 +303,18 @@ oops action =
r = setContentType "text/html" $
setResponseStatus 500 "Internal Server Error" emptyResponse
-- Session timeout in seconds (should be 15 minutes)
default_timeout :: Integer
default_timeout = 60*15
getGame :: Handler App App Game
getGame =
do game_session_cookie <- getsRequest $ List.find ((== "game-uuid") . cookieName) . rqCookies
game_state <- gets _app_game_state
config <- liftIO $ getConfiguration default_timeout
case game_session_cookie of
Just cookie ->
do result <- liftIO $ retrieveGame (cookieValue cookie) game_state
do result <- liftIO $ retrieveGame (cookieValue cookie) config game_state
case result of
Just g -> return g
Nothing -> redirect "/start"
......
......@@ -106,4 +106,5 @@ library
ghc-options: -threaded -fno-warn-type-defaults -rtsopts=all
else
ghc-options: -threaded -fno-warn-type-defaults
exposed-modules: Roguestar.Lib.UnitTests
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment