module T3.Web where
import qualified Data.Map as M
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import Control.Applicative
import Control.Monad.Conc.ClassTmp (MonadConc(..))
import Control.Concurrent.STM (modifyTVar, readTVar, writeTVar)
import Control.Monad (mzero, forever)
import Data.Aeson
import Data.IORef
import Data.Maybe
import T3.Server
import T3.Server.Dispatch
import T3.Server.Lobby
import T3.DB
import T3.Match
import T3.Random
import T3.Game.Core
import Control.Monad.Trans (MonadIO, liftIO)
class MonadIO m => HttpHandler m where
httpRequestEntity :: m BL.ByteString
server :: m (Server IO)
unauthorized :: m a
badRequest :: m a
badFormat :: m a
alreadyInLobby :: m a
httpJSONEntity :: FromJSON a => m (Maybe a)
httpJSONEntity = fmap decode httpRequestEntity
play :: HttpHandler m => MatchId -> MatchToken -> Maybe PlayRequest -> m PlayResponse
play matchId matchToken mPlayRequest = do
srv <- server
case mPlayRequest of
Nothing -> badFormat
Just playReq -> do
mUserCfg <- liftIO . atomically $ do
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
case mUserCfg of
Nothing -> unauthorized
Just userCfg -> do
resp <- liftIO newEmptyMVar
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)
start :: HttpHandler m => Maybe StartRequest -> m StartResponse
start mStartReq = do
srv <- server
case mStartReq of
Nothing -> badFormat
Just startReq -> do
resp <- liftIO newEmptyMVar
authenticated <- liftIO . atomically $ authenticate srv (_sreqCreds startReq)
if not authenticated
then unauthorized
else do
added <- liftIO $ addUserToLobby
(_srvLobby srv)
(_ucName $ _sreqCreds startReq)
(\matchInfo users step -> putMVar resp $ StartResponse matchInfo users (toGameState step))
if added
then do
sresp <- liftIO $ takeMVar resp
return sresp
else alreadyInLobby
randomHandler :: HttpHandler m => Maybe StartRequest -> m StartResponse
randomHandler mStartReq = do
case mStartReq of
Nothing -> badFormat
Just startReq -> do
srv <- server
authenticated <- liftIO . atomically $ authenticate srv (_sreqCreds startReq)
if not authenticated
then unauthorized
else do
matchId <- liftIO genMatchId
xGT <- liftIO genMatchToken
oGT <- liftIO genMatchToken
randomStep <- liftIO newEmptyMVar
let randomCB = putMVar randomStep
randomSendLocRef <- liftIO $ newIORef (const $ return ())
randomThid <- liftIO . fork . forever $ do
step <- takeMVar randomStep
mLoc <- randomLoc (_stepBoard step)
case mLoc of
Nothing -> return ()
Just loc -> do
sendLoc <- readIORef randomSendLocRef
sendLoc (loc, randomCB)
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 matchId xGT
sessCfg <- liftIO $ forkMatch
(_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)
register :: (HttpHandler m, DB m) => Maybe RegisterRequest -> m (Maybe RegisterResponse)
register Nothing = badFormat
register (Just rreq) = do
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)
let users' = M.insert name userKey users
if M.member name users
then return Nothing
else writeTVar (_srvUsers srv) users' >> return (Just users')
case mUsers of
Nothing -> badRequest
Just users -> do
storeUsers users
return . Just $ RegisterResponse (UserCreds name userKey)