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.Concurrent
import Control.Concurrent.Async
import Control.Concurrent.STM
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
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 . forkIO . 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 { miMatchId = matchId, miMatchToken = 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 return Nothing
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 -> return Nothing
Just users -> do
storeUsers users
return . Just $ RegisterResponse (UserCreds name userKey)