Skip to content
Browse files

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

  • Loading branch information...
1 parent 8318584 commit 4742c3b10e4169446cf9083e8e27485390538938 @clanehin committed Sep 22, 2012
Showing with 59 additions and 39 deletions.
  1. +45 −36 Roguestar/Lib/Roguestar.hs
  2. +13 −3 Roguestar/Server/Main.hs
  3. +1 −0 roguestar.cabal
View
81 Roguestar/Lib/Roguestar.hs
@@ -1,7 +1,9 @@
{-# 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
View
16 Roguestar/Server/Main.hs
@@ -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,15 +58,18 @@ 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),
("/hidden", handle404),
("/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"
View
1 roguestar.cabal
@@ -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

0 comments on commit 4742c3b

Please sign in to comment.
Something went wrong with that request. Please try again.