t3-server 0.1.1 → 0.2.0
raw patch · 9 files changed
+295/−248 lines, 9 filesdep +dejafudep +transformers
Dependencies added: dejafu, transformers
Files
- src/Control/Monad/Conc/ClassTmp.hs +35/−0
- src/T3/Match.hs +63/−59
- src/T3/Match/Types.hs +19/−13
- src/T3/Playback.hs +9/−9
- src/T3/Server.hs +68/−67
- src/T3/Server/Dispatch.hs +18/−17
- src/T3/Server/Lobby.hs +8/−7
- src/T3/Web.hs +25/−26
- t3-server.cabal +50/−50
+ src/Control/Monad/Conc/ClassTmp.hs view
@@ -0,0 +1,35 @@+module Control.Monad.Conc.ClassTmp+ ( MonadConc(..)+ ) where++import qualified Control.Concurrent.Async as IO+import qualified Control.Concurrent as IO+import qualified Control.Concurrent.STM as IO++class Monad m => MonadConc m where+ threadDelay :: Int -> m ()+ race :: m a -> m b -> m (Either a b)+ fork :: m () -> m IO.ThreadId+ newChan :: m (IO.Chan a)+ readChan :: IO.Chan a -> m a+ writeChan :: IO.Chan a -> a -> m ()+ killThread :: IO.ThreadId -> m ()+ newTVarIO :: a -> m (IO.TVar a)+ atomically :: IO.STM a -> m a+ newEmptyMVar :: m (IO.MVar a)+ putMVar :: IO.MVar a -> a -> m ()+ takeMVar :: IO.MVar a -> m a++instance MonadConc IO where+ threadDelay = IO.threadDelay+ race = IO.race+ fork = IO.forkIO+ newChan = IO.newChan+ readChan = IO.readChan+ writeChan = IO.writeChan+ killThread = IO.killThread+ newTVarIO = IO.newTVarIO+ atomically = IO.atomically+ newEmptyMVar = IO.newEmptyMVar+ putMVar = IO.putMVar+ takeMVar = IO.takeMVar
src/T3/Match.hs view
@@ -8,37 +8,41 @@ , delay ) where -import Prelude-import T3.Match.Types-import T3.Game-import Control.Concurrent-import Control.Concurrent.Async+import Control.Monad.Trans.Class import Control.Monad.Trans.Either- import Control.Monad.State.Strict+import Control.Monad.Conc.ClassTmp -type Callback = Step -> IO ()-type StartCallback = MatchInfo -> Users -> Step -> IO ()+import T3.Game+import T3.Match.Types +type Callback m = Step -> m ()+type StartCallback m = MatchInfo -> Users -> Step -> m ()+ newtype Seconds = Seconds Int deriving (Num, Show, Eq, Ord, Enum) -data MatchData = MatchData- { matchReq :: XO -> IO (Loc, Callback)- , matchRespX :: Callback- , matchRespO :: Callback- , matchLog :: [Action] -> Board -> Result -> IO ()- , matchBoard :: Board- , matchActions :: [Action]- , matchTimeoutLimit :: Maybe Seconds+data MatchData m = MatchData+ { _matchReq :: XO -> m (Loc, Callback m)+ , _matchRespX :: Callback m+ , _matchRespO :: Callback m+ , _matchLog :: [Action] -> Board -> Result -> m ()+ , _matchBoard :: Board+ , _matchActions :: [Action]+ , _matchTimeoutLimit :: Maybe Seconds } -newtype Match a = Match { unMatch :: StateT MatchData (EitherT (IO ()) IO) a }- deriving (Functor, Applicative, Monad, MonadIO, MonadState MatchData)+newtype MatchT m a = MatchT { unMatchT :: StateT (MatchData m) (EitherT (m ()) m) a }+ deriving (Functor, Applicative, Monad, MonadState (MatchData m)) -type UserInit = (Callback, IO (Loc, Callback))+instance MonadTrans MatchT where+ lift ma = MatchT . StateT $ \md -> do+ a <- EitherT (fmap return ma)+ return (a, md) -runMatch :: Maybe Seconds -> UserInit -> UserInit -> ([Action] -> Board -> Result -> IO ()) -> IO () -> IO ()+type UserInit m = (Callback m, m (Loc, Callback m))++runMatch :: MonadConc m => Maybe Seconds -> UserInit m -> UserInit m -> ([Action] -> Board -> Result -> m ()) -> m () -> m () runMatch timeoutLimit (xCB, xReq) (oCB, oReq) logger done = do let req X = xReq req O = oReq@@ -46,83 +50,83 @@ cb O = oCB let b = emptyBoard let matchDat = MatchData req (cb X) (cb O) logger b [] timeoutLimit- matchResult <- runEitherT (evalStateT (unMatch $ run b) matchDat)+ matchResult <- runEitherT (evalStateT (unMatchT $ run b) matchDat) either id (const $ return ()) matchResult done -sendGameState :: XO -> Match ()+sendGameState :: MonadConc m => XO -> MatchT m () sendGameState xo = do- s <- get- liftIO $ (respXO xo s) (Step (matchBoard s) Nothing)+ md <- get+ lift $ (respXO xo md) (Step (_matchBoard md) Nothing) -delay :: Seconds -> IO ()+delay :: MonadConc m => Seconds -> m () delay (Seconds n) = threadDelay (n * 1000000) -recvAction :: XO -> Match Loc+recvAction :: MonadConc m => XO -> MatchT m Loc recvAction xo = do- req <- gets (flip matchReq xo)- s <- get- let timeoutResponse = forfeitIO s (Win $ yinYang xo) (Lose xo)- timeoutOrLoc <- liftIO $+ md <- get+ let req = _matchReq md xo+ let timeoutResponse = forfeitIO md (Win $ yinYang xo) (Lose xo)+ timeoutOrLoc <- lift $ do maybe (fmap Right req) (\secs -> race (delay secs >> return timeoutResponse) req)- (matchTimeoutLimit s)+ (_matchTimeoutLimit md) case timeoutOrLoc of- Left timeout -> Match (lift $ left timeout)+ Left timeout -> MatchT $ lift (left timeout) Right (loc, resp) -> do updateResp resp return loc where updateResp resp = do- match <- get+ md <- get put $ case xo of- X -> match { matchRespX = resp }- O -> match { matchRespO = resp }+ X -> md{ _matchRespX = resp }+ O -> md{ _matchRespO = resp } -sendFinal :: XO -> Final -> Match ()-sendFinal xo final = do- s <- get- liftIO $ sendFinalIO s xo final+sendFinal :: MonadConc m => XO -> Final -> MatchT m ()+sendFinal xo f = do+ md <- get+ lift $ sendFinalIO md xo f -sendFinalIO :: MatchData -> XO -> Final -> IO ()-sendFinalIO s xo final = liftIO $ (respXO xo s) (Step (matchBoard s) (Just final))+sendFinalIO :: MonadConc m => MatchData m -> XO -> Final -> m ()+sendFinalIO md xo f = (respXO xo md) (Step (_matchBoard md) (Just f)) -tally :: Result -> Match ()+tally :: MonadConc m => Result -> MatchT m () tally res = do- s <- get- liftIO $ matchLog s (matchActions s) (matchBoard s) res+ md <- get+ lift $ tallyIO md res -tallyIO :: MatchData -> Result -> IO ()-tallyIO s res = matchLog s (matchActions s) (matchBoard s) res+tallyIO :: MonadConc m => MatchData m -> Result -> m ()+tallyIO md res = _matchLog md (_matchActions md) (_matchBoard md) res -forfeitIO :: MatchData -> Win XO -> Lose XO -> IO ()+forfeitIO :: MonadConc m => MatchData m -> Win XO -> Lose XO -> m () forfeitIO s (Win w) (Lose l) = do tallyIO s (Winner w) sendFinalIO s w WonByDQ sendFinalIO s l LossByDQ -updateBoard :: Board -> Match ()+updateBoard :: MonadConc m => Board -> MatchT m () updateBoard b = do- match <- get- put $ match { matchBoard = b }+ md <- get+ put $ md{ _matchBoard = b } -logAction :: XO -> Loc -> Match ()+logAction :: MonadConc m => XO -> Loc -> MatchT m () logAction xo loc = do- match <- get- put $ match { matchActions = matchActions match ++ [Action xo loc] }+ md <- get+ put md{ _matchActions = _matchActions md ++ [Action xo loc] } -respXO :: XO -> MatchData -> Callback-respXO X = matchRespX-respXO O = matchRespO+respXO :: MonadConc m => XO -> MatchData m -> Callback m+respXO X = _matchRespX+respXO O = _matchRespO -instance Game Match where+instance MonadConc m => Game (MatchT m) where move xo = do sendGameState xo recvAction xo forfeit w l = do- s <- get- liftIO $ forfeitIO s w l+ md <- get+ lift $ forfeitIO md w l end (Win w) (Lose l) = do tally (Winner w) sendFinal w Won
src/T3/Match/Types.hs view
@@ -1,8 +1,14 @@ {-# LANGUAGE DeriveGeneric #-}--- {-# LANGUAGE DeriveAnyClass #-}--- {-# LANGUAGE FlexibleContexts #-} -module T3.Match.Types where+module T3.Match.Types+ ( UserName(..)+ , MatchId(..)+ , MatchToken(..)+ , Users(..)+ , MatchInfo(..)+ , Step(..)+ , Final(..)+ ) where import GHC.Generics import Control.Monad (mzero)@@ -23,30 +29,30 @@ deriving (Show, Eq, Ord, FromJSON, ToJSON) data Users = Users- { uX :: UserName- , uO :: UserName+ { _uX :: UserName+ , _uO :: UserName } deriving (Show, Eq, Generic) instance FromJSON Users where- parseJSON = dropPrefixP "u"+ parseJSON = dropPrefixP "_u" instance ToJSON Users where- toJSON = dropPrefixJ "u"+ toJSON = dropPrefixJ "_u" data MatchInfo = MatchInfo- { miMatchId :: MatchId- , miMatchToken :: MatchToken+ { _miMatchId :: MatchId+ , _miMatchToken :: MatchToken } deriving (Show, Eq, Generic) instance FromJSON MatchInfo where- parseJSON = dropPrefixP "mi"+ parseJSON = dropPrefixP "_mi" instance ToJSON MatchInfo where- toJSON = dropPrefixJ "mi"+ toJSON = dropPrefixJ "_mi" data Step = Step- { stepBoard :: Board- , stepFinal :: Maybe Final+ { _stepBoard :: Board+ , _stepFinal :: Maybe Final } deriving (Show, Eq) data Final
src/T3/Playback.hs view
@@ -11,24 +11,24 @@ import qualified Data.HashMap.Lazy as HML data Playback = Playback- { pbMatchId :: MatchId- , pbUsers :: Users- , pbActions :: [Action]- , pbResult :: Result+ { _pbMatchId :: MatchId+ , _pbUsers :: Users+ , _pbActions :: [Action]+ , _pbResult :: Result } deriving (Show, Eq) writePlayback :: FilePath -> Playback -> IO () writePlayback prefix pb = BL.writeFile path (encode pb) where- (MatchId matchIdText) = pbMatchId pb+ (MatchId matchIdText) = _pbMatchId pb path = prefix `mappend` (T.unpack $ matchIdText `mappend` ".json") instance ToJSON Playback where toJSON pb = object- [ "matchId" .= pbMatchId pb- , "users" .= pbUsers pb- , "actions" .= pbActions pb- , "result" .= pbResult pb+ [ "matchId" .= _pbMatchId pb+ , "users" .= _pbUsers pb+ , "actions" .= _pbActions pb+ , "result" .= _pbResult pb ] instance FromJSON Playback where
src/T3/Server.hs view
@@ -31,9 +31,10 @@ import qualified Data.Text as T import Control.Applicative-import Control.Concurrent-import Control.Concurrent.STM+import Control.Concurrent.STM (TVar, STM, readTVar, modifyTVar)+import Control.Monad.Conc.ClassTmp import Control.Monad+import Control.Monad.Random import Data.Aeson hiding (Result) import Data.Aeson.Types (Options(..), defaultOptions, Parser) import Data.Text (Text)@@ -46,88 +47,88 @@ import T3.Server.Lobby import T3.Match -type GameLogger = MatchId -> Users -> [Action] -> Board -> Result -> IO ()+type GameLogger m = MatchId -> Users -> [Action] -> Board -> Result -> m () -data Server = Server- { srvLobby :: TVar Lobby- , srvMatches :: TVar (M.Map MatchId MatchConfig)- , srvUsers :: TVar (M.Map UserName UserKey)- , srvDie :: IO ()- , srvLogger :: GameLogger- , srvTimeoutLimit :: Maybe Seconds+data Server m = Server+ { _srvLobby :: TVar (Lobby m)+ , _srvMatches :: TVar (M.Map MatchId (MatchConfig m))+ , _srvUsers :: TVar (M.Map UserName UserKey)+ , _srvDie :: m ()+ , _srvLogger :: GameLogger m+ , _srvTimeoutLimit :: Maybe Seconds } -authenticate :: Server -> UserCreds -> STM Bool+authenticate :: MonadConc m => Server m -> UserCreds -> STM Bool authenticate srv uc = do- users <- readTVar (srvUsers srv)- return $ M.lookup (ucName uc) users == Just (ucKey uc)+ users <- readTVar (_srvUsers srv)+ return $ M.lookup (_ucName uc) users == Just (_ucKey uc) -authorize :: UserName -> MatchToken -> MatchConfig -> Maybe UserConfig-authorize userName matchToken matchCfg = (userCfgMay $ matchCfgX matchCfg) <|> (userCfgMay $ matchCfgO matchCfg)+authorize :: UserName -> MatchToken -> MatchConfig m -> Maybe (UserConfig m)+authorize un mt mc = (userCfgMay $ _matchCfgX mc) <|> (userCfgMay $ _matchCfgO mc) where userCfgMay cfg =- if userCfgUserName cfg == userName && userCfgMatchToken cfg == matchToken- then Just cfg- else Nothing+ if _userCfgUserName cfg == un && _userCfgMatchToken cfg == mt+ then Just cfg+ else Nothing -forkServer :: GameLogger -> Maybe Seconds -> M.Map UserName UserKey -> IO Server+forkServer :: (MonadConc m, MonadRandom m) => GameLogger m -> Maybe Seconds -> M.Map UserName UserKey -> m (Server m) forkServer logger timeoutLimit users = do lobby <- newTVarIO [] matches <- newTVarIO M.empty users <- newTVarIO users let srv = Server lobby matches users (return ()) logger timeoutLimit- thid <- forkIO $ serve srv+ thid <- fork $ serve srv let killMatches = do killers <- atomically $ do s <- readTVar matches- return $ map matchCfgDie (M.elems s)+ return $ map _matchCfgDie (M.elems s) sequence_ killers- return srv { srvDie = killMatches >> killThread thid }+ return srv{ _srvDie = killMatches >> killThread thid } -genBase64 :: Int -> IO Text+genBase64 :: MonadRandom m => Int -> m Text genBase64 n = fmap T.pack (sequence $ replicate n gen) where- gen = fmap (\x -> vals !! (mod x len)) randomIO+ gen = fmap (\x -> vals !! (mod x len)) getRandom len = length vals vals = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['-','_'] -genMatchToken :: IO MatchToken+genMatchToken :: MonadRandom m => m MatchToken genMatchToken = MatchToken <$> genBase64 16 -genMatchId :: IO MatchId+genMatchId :: MonadRandom m => m MatchId genMatchId = MatchId <$> genBase64 16 -genUserName :: IO UserName+genUserName :: MonadRandom m => m UserName genUserName = UserName <$> genBase64 32 -genUserKey :: IO UserKey+genUserKey :: MonadRandom m => m UserKey genUserKey = UserKey <$> genBase64 32 -serve :: Server -> IO ()+serve :: (MonadConc m, MonadRandom m) => Server m -> m () serve srv = do- musers <- userPairFromLobby (srvLobby srv)+ musers <- userPairFromLobby (_srvLobby srv) case musers of Nothing -> return () Just ((xUN, xCB), (oUN, oCB)) -> do matchId <- genMatchId xGT <- genMatchToken oGT <- genMatchToken- let removeSelf = atomically $ modifyTVar (srvMatches srv) (M.delete matchId)- let users = Users { uX = xUN, uO = oUN }- let xMatchInfo = MatchInfo { miMatchId = matchId, miMatchToken = xGT }- let oMatchInfo = MatchInfo { miMatchId = matchId, miMatchToken = oGT }+ let removeSelf = atomically $ modifyTVar (_srvMatches srv) (M.delete matchId)+ let users = Users { _uX = xUN, _uO= oUN }+ let xMatchInfo = MatchInfo matchId xGT + let oMatchInfo = MatchInfo matchId oGT sessCfg <- forkMatch- (srvTimeoutLimit srv)+ (_srvTimeoutLimit srv) (xUN, xGT, xCB xMatchInfo users) (oUN, oGT, oCB oMatchInfo users)- (srvLogger srv matchId users)+ (_srvLogger srv matchId users) removeSelf- atomically $ modifyTVar (srvMatches srv) (M.insert matchId sessCfg)+ atomically $ modifyTVar (_srvMatches srv) (M.insert matchId sessCfg) threadDelay (1 * 1000000) -- 1 second serve srv toGameState :: Step -> GameState-toGameState s = GameState (stepBoard s) (stepFinal s)+toGameState s = GameState (_stepBoard s) (_stepFinal s) -- @@ -135,86 +136,86 @@ deriving (Show, Eq, Ord, FromJSON, ToJSON) data RegisterRequest = RegisterRequest- { rreqName :: UserName+ { _rreqName :: UserName } deriving (Show, Eq, Generic) instance FromJSON RegisterRequest where- parseJSON = dropPrefixP "rreq"+ parseJSON = dropPrefixP "_rreq" instance ToJSON RegisterRequest where- toJSON = dropPrefixJ "rreq"+ toJSON = dropPrefixJ "_rreq" data RegisterResponse = RegisterResponse- { rrespCreds :: UserCreds+ { _rrespCreds :: UserCreds } deriving (Show, Eq, Generic) instance FromJSON RegisterResponse where- parseJSON = dropPrefixP "rresp"+ parseJSON = dropPrefixP "_rresp" instance ToJSON RegisterResponse where- toJSON = dropPrefixJ "rresp"+ toJSON = dropPrefixJ "_rresp" data UserCreds = UserCreds- { ucName :: UserName- , ucKey :: UserKey+ { _ucName :: UserName+ , _ucKey :: UserKey } deriving (Show, Eq, Generic) instance FromJSON UserCreds where- parseJSON = dropPrefixP "uc"+ parseJSON = dropPrefixP "_uc" instance ToJSON UserCreds where- toJSON = dropPrefixJ "uc"+ toJSON = dropPrefixJ "_uc" data StartRequest = StartRequest- { sreqCreds :: UserCreds+ { _sreqCreds :: UserCreds } deriving (Show, Eq, Generic) instance FromJSON StartRequest where- parseJSON = dropPrefixP "sreq"+ parseJSON = dropPrefixP "_sreq" instance ToJSON StartRequest where- toJSON = dropPrefixJ "sreq"+ toJSON = dropPrefixJ "_sreq" data PlayRequest = PlayRequest- { preqCreds :: UserCreds- , preqLoc :: Loc+ { _preqCreds :: UserCreds+ , _preqLoc :: Loc } deriving (Show, Eq, Generic) instance FromJSON PlayRequest where- parseJSON = dropPrefixP "preq"+ parseJSON = dropPrefixP "_preq" instance ToJSON PlayRequest where- toJSON = dropPrefixJ "preq"+ toJSON = dropPrefixJ "_preq" data StartResponse = StartResponse- { srespMatchInfo :: MatchInfo- , srespUsers :: Users- , srespState :: GameState+ { _srespMatchInfo :: MatchInfo+ , _srespUsers :: Users+ , _srespState :: GameState } deriving (Show, Eq, Generic) instance FromJSON StartResponse where- parseJSON = dropPrefixP "sresp"+ parseJSON = dropPrefixP "_sresp" instance ToJSON StartResponse where- toJSON = dropPrefixJ "sresp"+ toJSON = dropPrefixJ "_sresp" data PlayResponse = PlayResponse- { prespState :: GameState+ { _prespState :: GameState } deriving (Show, Eq, Generic) instance FromJSON PlayResponse where- parseJSON = dropPrefixP "presp"+ parseJSON = dropPrefixP "_presp" instance ToJSON PlayResponse where- toJSON = dropPrefixJ "presp"+ toJSON = dropPrefixJ "_presp" data GameState = GameState- { gsBoard :: Board- , gsFinal :: Maybe Final+ { _gsBoard :: Board+ , _gsFinal :: Maybe Final } deriving (Show, Eq, Generic) instance FromJSON GameState where- parseJSON = dropPrefixP "gs"+ parseJSON = dropPrefixP "_gs" instance ToJSON GameState where- toJSON = dropPrefixJ "gs"+ toJSON = dropPrefixJ "_gs"
src/T3/Server/Dispatch.hs view
@@ -1,35 +1,36 @@ module T3.Server.Dispatch where -import Prelude-import Control.Concurrent+import Control.Monad.Conc.ClassTmp+ import T3.Game import T3.Match -data UserConfig = UserConfig- { userCfgUserName :: UserName- , userCfgMatchToken :: MatchToken- , userCfgSendLoc :: (Loc, Callback) -> IO ()+data UserConfig m = UserConfig+ { _userCfgUserName :: UserName+ , _userCfgMatchToken :: MatchToken+ , _userCfgSendLoc :: (Loc, Callback m) -> m () } -data MatchConfig = MatchConfig- { matchCfgX :: UserConfig- , matchCfgO :: UserConfig- , matchCfgDie :: IO ()+data MatchConfig m = MatchConfig+ { _matchCfgX :: UserConfig m+ , _matchCfgO :: UserConfig m+ , _matchCfgDie :: m () } forkMatch- :: Maybe Seconds- -> (UserName, MatchToken, Callback)- -> (UserName, MatchToken, Callback)- -> ([Action] -> Board -> Result -> IO ())- -> IO ()- -> IO MatchConfig+ :: MonadConc m+ => Maybe Seconds+ -> (UserName, MatchToken, Callback m)+ -> (UserName, MatchToken, Callback m)+ -> ([Action] -> Board -> Result -> m ())+ -> m ()+ -> m (MatchConfig m) forkMatch timeoutLimit (xUI, xGT, xCB) (oUI, oGT, oCB) logger done = do xChan <- newChan oChan <- newChan let x = (xCB, readChan xChan) let o = (oCB, readChan oChan)- thid <- forkIO $ runMatch timeoutLimit x o logger done+ thid <- fork $ runMatch timeoutLimit x o logger done return $ MatchConfig (UserConfig xUI xGT (writeChan xChan)) (UserConfig oUI oGT (writeChan oChan))
src/T3/Server/Lobby.hs view
@@ -1,25 +1,26 @@ module T3.Server.Lobby where -import Prelude import Control.Monad-import Control.Concurrent.STM+import Control.Monad.Random+import Control.Monad.Conc.ClassTmp+import Control.Concurrent.STM (TVar, STM, readTVar, writeTVar) import System.Random import Data.Maybe import T3.Match -type Lobby = [(UserName, StartCallback)]+type Lobby m = [(UserName, StartCallback m)] -addUserToLobby :: TVar Lobby -> UserName -> (StartCallback) -> IO Bool+addUserToLobby :: MonadConc m => TVar (Lobby m) -> UserName -> StartCallback m -> m Bool addUserToLobby lobby un cb = atomically $ do lob <- readTVar lobby let shouldAdd = isNothing (lookup un lob) when shouldAdd $ writeTVar lobby ((un, cb) : lob) return shouldAdd -userPairFromLobby :: TVar Lobby -> IO (Maybe ((UserName, StartCallback), (UserName, StartCallback)))+userPairFromLobby :: (MonadConc m, MonadRandom m) => TVar (Lobby m) -> m (Maybe ((UserName, StartCallback m), (UserName, StartCallback m))) userPairFromLobby lobby = do- a <- randomIO- b <- randomIO+ a <- getRandom+ b <- getRandom atomically $ do lob <- readTVar lobby let len = length lob
src/T3/Web.hs view
@@ -4,9 +4,8 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.Text as T import Control.Applicative-import Control.Concurrent-import Control.Concurrent.Async-import Control.Concurrent.STM+import Control.Monad.Conc.ClassTmp (MonadConc(..))+import Control.Concurrent.STM (modifyTVar, readTVar, writeTVar) import Control.Monad (mzero, forever) import Data.Aeson import Data.IORef@@ -20,9 +19,9 @@ import T3.Game.Core import Control.Monad.Trans (MonadIO, liftIO) -class (MonadIO m) => HttpHandler m where+class MonadIO m => HttpHandler m where httpRequestEntity :: m BL.ByteString- server :: m Server+ server :: m (Server IO) unauthorized :: m a badRequest :: m a badFormat :: m a@@ -38,18 +37,18 @@ Nothing -> badFormat Just playReq -> do mUserCfg <- liftIO . atomically $ do- let creds = preqCreds playReq+ let creds = _preqCreds playReq authenicated <- authenticate srv creds if not authenicated then return Nothing else do- mMatchCfg <- M.lookup matchId <$> readTVar (srvMatches srv)- return $ authorize (ucName creds) matchToken =<< mMatchCfg+ mMatchCfg <- M.lookup matchId <$> readTVar (_srvMatches srv)+ return $ authorize (_ucName creds) matchToken =<< mMatchCfg case mUserCfg of Nothing -> unauthorized Just userCfg -> do resp <- liftIO newEmptyMVar- liftIO $ (userCfgSendLoc userCfg) (preqLoc playReq, putMVar resp . PlayResponse . toGameState)+ liftIO $ (_userCfgSendLoc userCfg) (_preqLoc playReq, putMVar resp . PlayResponse . toGameState) mPresp <- liftIO $ (either id id) <$> race (Just <$> takeMVar resp) (delay (Seconds 60) >> return Nothing) fromMaybe badRequest (return <$> mPresp) @@ -60,13 +59,13 @@ Nothing -> badFormat Just startReq -> do resp <- liftIO newEmptyMVar- authenticated <- liftIO . atomically $ authenticate srv (sreqCreds startReq)+ authenticated <- liftIO . atomically $ authenticate srv (_sreqCreds startReq) if not authenticated then unauthorized else do added <- liftIO $ addUserToLobby- (srvLobby srv)- (ucName $ sreqCreds startReq)+ (_srvLobby srv)+ (_ucName $ _sreqCreds startReq) (\matchInfo users step -> putMVar resp $ StartResponse matchInfo users (toGameState step)) if added then do@@ -80,7 +79,7 @@ Nothing -> badFormat Just startReq -> do srv <- server- authenticated <- liftIO . atomically $ authenticate srv (sreqCreds startReq)+ authenticated <- liftIO . atomically $ authenticate srv (_sreqCreds startReq) if not authenticated then unauthorized else do@@ -90,46 +89,46 @@ randomStep <- liftIO newEmptyMVar let randomCB = putMVar randomStep randomSendLocRef <- liftIO $ newIORef (const $ return ())- randomThid <- liftIO . forkIO . forever $ do+ randomThid <- liftIO . fork . forever $ do step <- takeMVar randomStep- mLoc <- randomLoc (stepBoard step)+ mLoc <- randomLoc (_stepBoard step) case mLoc of Nothing -> return () Just loc -> do sendLoc <- readIORef randomSendLocRef sendLoc (loc, randomCB)- let xUN = (ucName . sreqCreds) startReq+ let xUN = _ucName (_sreqCreds startReq) let oUN = UserName "random" let removeSelf = do killThread randomThid- atomically $ modifyTVar (srvMatches srv) (M.delete matchId)- let users = Users { uX = xUN, uO = oUN }- let xMatchInfo = MatchInfo { miMatchId = matchId, miMatchToken = xGT }+ atomically $ modifyTVar (_srvMatches srv) (M.delete matchId)+ let users = Users { _uX = xUN, _uO = oUN }+ let xMatchInfo = MatchInfo matchId xGT sessCfg <- liftIO $ forkMatch- (srvTimeoutLimit srv)+ (_srvTimeoutLimit srv) (xUN, xGT, const $ return ()) (oUN, oGT, randomCB) (\_ _ _ -> return ()) removeSelf- liftIO $ writeIORef randomSendLocRef (userCfgSendLoc $ matchCfgO sessCfg)- liftIO . atomically $ modifyTVar (srvMatches srv) (M.insert matchId sessCfg)- return $ StartResponse xMatchInfo Users{ uX = xUN, uO = oUN } (GameState emptyBoard Nothing)+ liftIO $ writeIORef randomSendLocRef (_userCfgSendLoc $ _matchCfgO sessCfg)+ liftIO . atomically $ modifyTVar (_srvMatches srv) (M.insert matchId sessCfg)+ return $ StartResponse xMatchInfo Users{ _uX = xUN, _uO = oUN } (GameState emptyBoard Nothing) register :: (HttpHandler m, DB m) => Maybe RegisterRequest -> m (Maybe RegisterResponse) register Nothing = badFormat register (Just rreq) = do- let name@(UserName un) = rreqName rreq+ let name@(UserName un) = _rreqName rreq srv <- server if T.null un then badRequest else do userKey <- liftIO genUserKey mUsers <- liftIO . atomically $ do- users <- readTVar (srvUsers srv)+ users <- readTVar (_srvUsers srv) let users' = M.insert name userKey users if M.member name users then return Nothing- else writeTVar (srvUsers srv) users' >> return (Just users')+ else writeTVar (_srvUsers srv) users' >> return (Just users') case mUsers of Nothing -> badRequest Just users -> do
t3-server.cabal view
@@ -1,7 +1,7 @@ name: t3-server synopsis: tic-tac-toe server description: Please see README.md-version: 0.1.1+version: 0.2.0 cabal-version: >= 1.10 build-type: Simple license: BSD3@@ -12,52 +12,52 @@ category: Game library- hs-source-dirs:- src- exposed-modules:- T3.Playback- T3.Random- T3.Web- T3.DB- T3.Server- T3.Server.Dispatch- T3.Server.Lobby- T3.Match- T3.Match.Types-- default-extensions:- OverlappingInstances- OverloadedStrings- MultiParamTypeClasses- TypeFamilies- GADTs- GeneralizedNewtypeDeriving- FlexibleContexts- FlexibleInstances- EmptyDataDecls- TupleSections-- build-depends:- base >= 4 && < 5- , bytestring >= 0.9 && < 0.11- , text >= 0.11 && < 2.0- , aeson >= 0.6 && < 0.11- , safe- , unordered-containers- , containers- , vector- , time- , case-insensitive- , wai- , async- , mtl- , stm- , random- , hashable- , hashmap- , either- , t3-game- , random- , MonadRandom- default-language:- Haskell2010+ hs-source-dirs:+ src+ exposed-modules:+ Control.Monad.Conc.ClassTmp+ T3.Playback+ T3.Random+ T3.Web+ T3.DB+ T3.Server+ T3.Server.Dispatch+ T3.Server.Lobby+ T3.Match+ T3.Match.Types+ default-extensions:+ -- OverlappingInstances+ OverloadedStrings+ MultiParamTypeClasses+ TypeFamilies+ GeneralizedNewtypeDeriving+ FlexibleContexts+ FlexibleInstances+ EmptyDataDecls+ TupleSections+ build-depends:+ base >= 4 && < 5+ , bytestring >= 0.9 && < 0.11+ , text >= 0.11 && < 2.0+ , aeson >= 0.6 && < 0.11+ , dejafu >= 0.2.0.0 && < 1.0.0.0+ , safe+ , unordered-containers+ , containers+ , vector+ , time+ , transformers+ , case-insensitive+ , wai+ , async+ , mtl+ , stm+ , random+ , hashable+ , hashmap+ , either+ , t3-game+ , random+ , MonadRandom+ default-language:+ Haskell2010