t3-server (empty) → 0.1.0
raw patch · 12 files changed
+792/−0 lines, 12 filesdep +MonadRandomdep +aesondep +asyncsetup-changed
Dependencies added: MonadRandom, aeson, async, base, bytestring, case-insensitive, containers, either, hashable, hashmap, mtl, random, safe, stm, t3-game, text, time, unordered-containers, vector, wai
Files
- LICENSE +0/−0
- Setup.hs +2/−0
- src/T3/DB.hs +18/−0
- src/T3/Match.hs +136/−0
- src/T3/Match/Types.hs +74/−0
- src/T3/Playback.hs +54/−0
- src/T3/Random.hs +18/−0
- src/T3/Server.hs +220/−0
- src/T3/Server/Dispatch.hs +36/−0
- src/T3/Server/Lobby.hs +34/−0
- src/T3/Web.hs +137/−0
- t3-server.cabal +63/−0
+ LICENSE view
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/T3/DB.hs view
@@ -0,0 +1,18 @@+{-# OPTIONS -fno-warn-orphans #-}+module T3.DB where++import qualified Data.Map as M+import T3.Server+import T3.Server.Dispatch+import T3.Server.Lobby+import T3.Match+import T3.Random+import T3.Playback+import T3.Game.Core++class Monad m => DB m where+ storeUsers :: M.Map UserName UserKey -> m ()+ loadUsers :: m (M.Map UserName UserKey)+ loadMatchList :: m [MatchId]+ storePlayback :: Playback -> m ()+ loadPlayback :: MatchId -> m (Maybe Playback)
+ src/T3/Match.hs view
@@ -0,0 +1,136 @@+module T3.Match+ ( module T3.Match.Types+ , Seconds(..)+ , runMatch+ , UserInit+ , Callback+ , StartCallback+ , delay+ ) where++import Prelude+import T3.Match.Types+import T3.Game+import Control.Concurrent+import Control.Concurrent.Async+import Control.Monad.Trans.Either++import Control.Monad.State.Strict++type Callback = Step -> IO ()+type StartCallback = MatchInfo -> Users -> Step -> IO ()++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+ }++newtype Match a = Match { unMatch :: StateT MatchData (EitherT (IO ()) IO) a }+ deriving (Functor, Applicative, Monad, MonadIO, MonadState MatchData)++type UserInit = (Callback, IO (Loc, Callback))++runMatch :: Maybe Seconds -> UserInit -> UserInit -> ([Action] -> Board -> Result -> IO ()) -> IO () -> IO ()+runMatch timeoutLimit (xCB, xReq) (oCB, oReq) logger done = do+ let req X = xReq+ req O = oReq+ let cb X = xCB+ cb O = oCB+ let b = emptyBoard+ let matchDat = MatchData req (cb X) (cb O) logger b [] timeoutLimit+ matchResult <- runEitherT (evalStateT (unMatch $ run b) matchDat)+ either id (const $ return ()) matchResult+ done++sendGameState :: XO -> Match ()+sendGameState xo = do+ s <- get+ liftIO $ (respXO xo s) (Step (matchBoard s) Nothing)++delay :: Seconds -> IO ()+delay (Seconds n) = threadDelay (n * 1000000)++recvAction :: XO -> Match Loc+recvAction xo = do+ req <- gets (flip matchReq xo)+ s <- get+ let timeoutResponse = forfeitIO s (Win $ yinYang xo) (Lose xo)+ timeoutOrLoc <- liftIO $+ maybe+ (fmap Right req)+ (\secs -> race (delay secs >> return timeoutResponse) req)+ (matchTimeoutLimit s)+ case timeoutOrLoc of+ Left timeout -> Match (lift $ left timeout)+ Right (loc, resp) -> do+ updateResp resp+ return loc+ where+ updateResp resp = do+ match <- get+ put $ case xo of+ X -> match { matchRespX = resp }+ O -> match { matchRespO = resp }++sendFinal :: XO -> Final -> Match ()+sendFinal xo final = do+ s <- get+ liftIO $ sendFinalIO s xo final++sendFinalIO :: MatchData -> XO -> Final -> IO ()+sendFinalIO s xo final = liftIO $ (respXO xo s) (Step (matchBoard s) (Just final))++tally :: Result -> Match ()+tally res = do+ s <- get+ liftIO $ matchLog s (matchActions s) (matchBoard s) res++tallyIO :: MatchData -> Result -> IO ()+tallyIO s res = matchLog s (matchActions s) (matchBoard s) res++forfeitIO :: MatchData -> Win XO -> Lose XO -> IO ()+forfeitIO s (Win w) (Lose l) = do+ tallyIO s (Winner w)+ sendFinalIO s w WonByDQ+ sendFinalIO s l LossByDQ++updateBoard :: Board -> Match ()+updateBoard b = do+ match <- get+ put $ match { matchBoard = b }++logAction :: XO -> Loc -> Match ()+logAction xo loc = do+ match <- get+ put $ match { matchActions = matchActions match ++ [Action xo loc] }++respXO :: XO -> MatchData -> Callback+respXO X = matchRespX+respXO O = matchRespO++instance Game Match where+ move xo = do+ sendGameState xo+ recvAction xo+ forfeit w l = do+ s <- get+ liftIO $ forfeitIO s w l+ end (Win w) (Lose l) = do+ tally (Winner w)+ sendFinal w Won+ sendFinal l Loss+ tie = do+ tally Tie+ sendFinal X Tied+ sendFinal O Tied+ step b xo loc = do+ logAction xo loc+ updateBoard b
+ src/T3/Match/Types.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DeriveGeneric #-}+-- {-# LANGUAGE DeriveAnyClass #-}+-- {-# LANGUAGE FlexibleContexts #-}++module T3.Match.Types where++import GHC.Generics+import Control.Monad (mzero)+import Data.Char (toLower)+import Data.Aeson+import Data.Aeson.Types+import Data.Text (Text)+import T3.Game+import T3.Game.Core++newtype UserName = UserName Text+ deriving (Show, Eq, Ord, FromJSON, ToJSON)++newtype MatchId = MatchId Text+ deriving (Show, Eq, Ord, FromJSON, ToJSON)++newtype MatchToken = MatchToken Text+ deriving (Show, Eq, Ord, FromJSON, ToJSON)++data Users = Users+ { uX :: UserName+ , uO :: UserName+ } deriving (Show, Eq, Generic)++instance FromJSON Users where+ parseJSON = dropPrefixP "u"++instance ToJSON Users where+ toJSON = dropPrefixJ "u"++data MatchInfo = MatchInfo+ { miMatchId :: MatchId+ , miMatchToken :: MatchToken+ } deriving (Show, Eq, Generic)++instance FromJSON MatchInfo where+ parseJSON = dropPrefixP "mi"++instance ToJSON MatchInfo where+ toJSON = dropPrefixJ "mi"++data Step = Step+ { stepBoard :: Board+ , stepFinal :: Maybe Final+ } deriving (Show, Eq)++data Final+ = Won+ | WonByDQ+ | Loss+ | LossByDQ+ | Tied+ deriving (Show, Eq)++instance FromJSON Final where+ parseJSON (String "Won") = pure Won+ parseJSON (String "WonByDQ") = pure WonByDQ+ parseJSON (String "Loss") = pure Loss+ parseJSON (String "LossByDQ") = pure LossByDQ+ parseJSON (String "Tied") = pure Tied+ parseJSON _ = mzero++instance ToJSON Final where+ toJSON f = String $ case f of+ Won -> "Won"+ WonByDQ -> "WonByDQ"+ Loss -> "Loss"+ LossByDQ -> "LossByDQ"+ Tied -> "Tied"
+ src/T3/Playback.hs view
@@ -0,0 +1,54 @@+{-# OPTIONS -fno-warn-orphans #-}+module T3.Playback where++import Control.Monad (mzero)+import T3.Game+import T3.Match+import T3.Server ()+import Data.Aeson hiding (Result)+import qualified Data.Text as T+import qualified Data.ByteString.Lazy as BL+import qualified Data.HashMap.Lazy as HML++data Playback = Playback+ { 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+ 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+ ]++instance FromJSON Playback where+ parseJSON (Object o) = Playback+ <$> o .: "matchId"+ <*> o .: "users"+ <*> o .: "actions"+ <*> o .: "result"++instance ToJSON Result where+ toJSON Tie = object [ "tag" .= String "tie" ]+ toJSON Unfinished = object [ "tag" .= String "unfinished" ]+ toJSON (Winner xo) = object [ "tag" .= String "decision", "winner" .= xo, "loser" .= yinYang xo ]++instance FromJSON Result where+ parseJSON (Object o) = case HML.lookup "tag" o of+ Just (String "tie") -> pure Tie+ Just (String "unfinished") -> pure Unfinished+ Just (String "decision") -> case HML.lookup "winner" o of+ Just xo -> Winner <$> parseJSON xo+ _ -> mzero+ _ -> mzero+ parseJSON _ = mzero
+ src/T3/Random.hs view
@@ -0,0 +1,18 @@+module T3.Random where++import Data.Map (keys)+import T3.Game.Core+import Control.Monad.Random+import Data.List (notElem)++randomLoc :: MonadRandom m => Board -> m (Maybe Loc)+randomLoc b + | null available = return Nothing+ | otherwise = do+ r <- getRandom+ let idx = r `mod` (length available)+ return $ Just (available !! idx)+ where+ available = filter (flip notElem taken) allLocs+ taken = keys (boardMap b)+ allLocs = [Loc x y | x <- [0..2], y <- [0..2]]
+ src/T3/Server.hs view
@@ -0,0 +1,220 @@+{-# OPTIONS -fno-warn-orphans #-}+{-# LANGUAGE DeriveGeneric #-}+module T3.Server+ ( GameLogger+ , Server(..)+ , UserConfig(..)+ , MatchConfig(..)+ , UserCreds(..)+ , StartRequest(..)+ , PlayRequest(..)+ , GameState(..)+ , Users(..)+ , StartResponse(..)+ , PlayResponse(..)+ , UserName(..)+ , UserKey(..)+ , RegisterRequest(..)+ , RegisterResponse(..)+ , forkServer+ , genBase64+ , genMatchToken+ , genMatchId+ , genUserName+ , genUserKey+ , authenticate+ , authorize+ , toGameState+ ) where++import qualified Data.Map as M+import qualified Data.Text as T++import Control.Applicative+import Control.Concurrent+import Control.Concurrent.STM+import Control.Monad+import Data.Aeson hiding (Result)+import Data.Aeson.Types (Options(..), defaultOptions, Parser)+import Data.Text (Text)+import System.Random+import GHC.Generics+import Data.Char++import T3.Game+import T3.Server.Dispatch+import T3.Server.Lobby+import T3.Match++type GameLogger = MatchId -> Users -> [Action] -> Board -> Result -> IO ()++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+ }++authenticate :: Server -> UserCreds -> STM Bool+authenticate srv uc = do+ 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)+ where+ userCfgMay cfg =+ if userCfgUserName cfg == userName && userCfgMatchToken cfg == matchToken+ then Just cfg+ else Nothing++forkServer :: GameLogger -> Maybe Seconds -> M.Map UserName UserKey -> IO Server+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+ let killMatches = do+ killers <- atomically $ do+ s <- readTVar matches+ return $ map matchCfgDie (M.elems s)+ sequence_ killers+ return srv { srvDie = killMatches >> killThread thid }++genBase64 :: Int -> IO Text+genBase64 n = fmap T.pack (sequence $ replicate n gen)+ where+ gen = fmap (\x -> vals !! (mod x len)) randomIO+ len = length vals+ vals = ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ ['-','_']++genMatchToken :: IO MatchToken+genMatchToken = MatchToken <$> genBase64 16++genMatchId :: IO MatchId+genMatchId = MatchId <$> genBase64 16++genUserName :: IO UserName+genUserName = UserName <$> genBase64 32++genUserKey :: IO UserKey+genUserKey = UserKey <$> genBase64 32++serve :: Server -> IO ()+serve srv = do+ 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 }+ sessCfg <- forkMatch+ (srvTimeoutLimit srv)+ (xUN, xGT, xCB xMatchInfo users)+ (oUN, oGT, oCB oMatchInfo users)+ (srvLogger srv matchId users)+ removeSelf+ 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)++--++newtype UserKey = UserKey Text+ deriving (Show, Eq, Ord, FromJSON, ToJSON)++data RegisterRequest = RegisterRequest+ { rreqName :: UserName+ } deriving (Show, Eq, Generic)++instance FromJSON RegisterRequest where+ parseJSON = dropPrefixP "rreq"++instance ToJSON RegisterRequest where+ toJSON = dropPrefixJ "rreq"++data RegisterResponse = RegisterResponse+ { rrespCreds :: UserCreds+ } deriving (Show, Eq, Generic)++instance FromJSON RegisterResponse where+ parseJSON = dropPrefixP "rresp"++instance ToJSON RegisterResponse where+ toJSON = dropPrefixJ "rresp"++data UserCreds = UserCreds+ { ucName :: UserName+ , ucKey :: UserKey+ } deriving (Show, Eq, Generic)++instance FromJSON UserCreds where+ parseJSON = dropPrefixP "uc"++instance ToJSON UserCreds where+ toJSON = dropPrefixJ "uc"++data StartRequest = StartRequest+ { sreqCreds :: UserCreds+ } deriving (Show, Eq, Generic)++instance FromJSON StartRequest where+ parseJSON = dropPrefixP "sreq"++instance ToJSON StartRequest where+ toJSON = dropPrefixJ "sreq"++data PlayRequest = PlayRequest+ { preqCreds :: UserCreds+ , preqLoc :: Loc+ } deriving (Show, Eq, Generic)++instance FromJSON PlayRequest where+ parseJSON = dropPrefixP "preq"++instance ToJSON PlayRequest where+ toJSON = dropPrefixJ "preq"++data StartResponse = StartResponse+ { srespMatchInfo :: MatchInfo+ , srespUsers :: Users+ , srespState :: GameState+ } deriving (Show, Eq, Generic)++instance FromJSON StartResponse where+ parseJSON = dropPrefixP "sresp"++instance ToJSON StartResponse where+ toJSON = dropPrefixJ "sresp"++data PlayResponse = PlayResponse+ { prespState :: GameState+ } deriving (Show, Eq, Generic)++instance FromJSON PlayResponse where+ parseJSON = dropPrefixP "presp"++instance ToJSON PlayResponse where+ toJSON = dropPrefixJ "presp"++data GameState = GameState+ { gsBoard :: Board+ , gsFinal :: Maybe Final+ } deriving (Show, Eq, Generic)++instance FromJSON GameState where+ parseJSON = dropPrefixP "gs"++instance ToJSON GameState where+ toJSON = dropPrefixJ "gs"
+ src/T3/Server/Dispatch.hs view
@@ -0,0 +1,36 @@+module T3.Server.Dispatch where++import Prelude+import Control.Concurrent+import T3.Game+import T3.Match++data UserConfig = UserConfig+ { userCfgUserName :: UserName+ , userCfgMatchToken :: MatchToken+ , userCfgSendLoc :: (Loc, Callback) -> IO ()+ }++data MatchConfig = MatchConfig+ { matchCfgX :: UserConfig+ , matchCfgO :: UserConfig+ , matchCfgDie :: IO ()+ }++forkMatch+ :: Maybe Seconds+ -> (UserName, MatchToken, Callback)+ -> (UserName, MatchToken, Callback)+ -> ([Action] -> Board -> Result -> IO ())+ -> IO ()+ -> IO MatchConfig+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+ return $ MatchConfig+ (UserConfig xUI xGT (writeChan xChan))+ (UserConfig oUI oGT (writeChan oChan))+ (killThread thid >> done)
+ src/T3/Server/Lobby.hs view
@@ -0,0 +1,34 @@+module T3.Server.Lobby where++import Prelude+import Control.Monad+import Control.Concurrent.STM+import System.Random+import Data.Maybe+import T3.Match++type Lobby = [(UserName, StartCallback)]++addUserToLobby :: TVar Lobby -> UserName -> (StartCallback) -> IO 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 lobby = do+ a <- randomIO+ b <- randomIO+ atomically $ do+ lob <- readTVar lobby+ let len = length lob+ if len < 2 then return Nothing else grabEm lob (mod a len) (mod b (len - 1))+ where+ grabEm lob i j = do+ let (x, lob') = grab lob i+ let (y, lob'') = grab lob' j+ writeTVar lobby lob''+ return $ Just (x, y)+ grab :: [a] -> Int -> (a, [a])+ grab xs idx = (xs !! idx, take idx xs ++ drop (idx + 1) xs)
+ src/T3/Web.hs view
@@ -0,0 +1,137 @@+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)
+ t3-server.cabal view
@@ -0,0 +1,63 @@+name: t3-server+synopsis: tic-tac-toe server+description: Please see README.md+version: 0.1.0+cabal-version: >= 1.10+build-type: Simple+license: BSD3+license-file: LICENSE+author: Joe Vargas+maintainer: http://github.com/jxv+copyright: 2016 Joe Vargas+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