diff --git a/src/Control/Monad/Conc/ClassTmp.hs b/src/Control/Monad/Conc/ClassTmp.hs new file mode 100644 --- /dev/null +++ b/src/Control/Monad/Conc/ClassTmp.hs @@ -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 diff --git a/src/T3/Match.hs b/src/T3/Match.hs --- a/src/T3/Match.hs +++ b/src/T3/Match.hs @@ -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 diff --git a/src/T3/Match/Types.hs b/src/T3/Match/Types.hs --- a/src/T3/Match/Types.hs +++ b/src/T3/Match/Types.hs @@ -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 diff --git a/src/T3/Playback.hs b/src/T3/Playback.hs --- a/src/T3/Playback.hs +++ b/src/T3/Playback.hs @@ -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 diff --git a/src/T3/Server.hs b/src/T3/Server.hs --- a/src/T3/Server.hs +++ b/src/T3/Server.hs @@ -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" diff --git a/src/T3/Server/Dispatch.hs b/src/T3/Server/Dispatch.hs --- a/src/T3/Server/Dispatch.hs +++ b/src/T3/Server/Dispatch.hs @@ -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)) diff --git a/src/T3/Server/Lobby.hs b/src/T3/Server/Lobby.hs --- a/src/T3/Server/Lobby.hs +++ b/src/T3/Server/Lobby.hs @@ -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 diff --git a/src/T3/Web.hs b/src/T3/Web.hs --- a/src/T3/Web.hs +++ b/src/T3/Web.hs @@ -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 diff --git a/t3-server.cabal b/t3-server.cabal --- a/t3-server.cabal +++ b/t3-server.cabal @@ -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