diff --git a/hanafuda-webapp.cabal b/hanafuda-webapp.cabal index bf8ceeb..03a8a88 100644 --- a/hanafuda-webapp.cabal +++ b/hanafuda-webapp.cabal @@ -41,6 +41,7 @@ executable hanafudapi , http-types , aeson , mtl + , random , saltine , text , vector diff --git a/src/App.hs b/src/App.hs index c8d6a56..1047b55 100644 --- a/src/App.hs +++ b/src/App.hs @@ -2,20 +2,16 @@ module App ( T , Context(..) - , connection , debug - , get - , current + , exec , server - , try + , session , update - , update_ ) where -import Control.Concurrent (MVar, modifyMVar, putMVar, readMVar, takeMVar) +import Control.Concurrent (MVar, modifyMVar, readMVar) import Control.Monad.Reader (ReaderT(..), ask, asks, lift) import Data.Map ((!)) -import Network.WebSockets (Connection) import qualified Server (T(..)) import qualified Session (ID, T(..)) @@ -29,35 +25,25 @@ type T a = ReaderT Context IO a server :: T Server.T server = asks mServer >>= lift . readMVar -get :: Session.ID -> T Session.T -get sessionID = - (! sessionID) . Server.sessions <$> server +get :: (Server.T -> a) -> T a +get projector = + projector <$> server -current :: T Session.T -current = do - asks sessionID >>= get - -connection :: T Connection -connection = Session.connection <$> current +session :: T Session.T +session = do + Context {sessionID} <- ask + get $ (! sessionID) . Server.sessions debug :: String -> T () debug message = show <$> asks sessionID >>= lift . putStrLn . (++ ' ':message) -try :: (Server.T -> Either String Server.T) -> T (Maybe String) -try f = do - Context {mServer} <- ask - currentValue <- lift $ takeMVar mServer - lift $ case f currentValue of - Left message -> putMVar mServer currentValue >> return (Just message) - Right updated -> putMVar mServer updated >> return Nothing - {- Not using the previous to minimize the duration mServer gets locked -} -update :: (Server.T -> (Server.T, a)) -> T a -update f = do +exec :: (Server.T -> IO (Server.T, a)) -> T a +exec f = do Context {mServer} <- ask - lift $ modifyMVar mServer (return . f) + lift $ modifyMVar mServer f -update_ :: (Server.T -> Server.T) -> T () -update_ f = update $ (\x -> (x, ())) . f +update :: (Server.T -> Server.T) -> T () +update f = exec $ (\x -> return (x, ())) . f diff --git a/src/Automaton.hs b/src/Automaton.hs index a504ce7..cf44423 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -1,86 +1,74 @@ {-# LANGUAGE NamedFieldPuns #-} module Automaton ( - start + loop ) where -import qualified App (Context(..), T, current, debug, get, server, try, update_) +import qualified App (Context(..), T, exec, server, session, update) import Control.Monad.Reader (asks) import qualified Game (new, play) import qualified Hanafuda.Message as Message (FromClient(..), T(..)) import qualified Messaging ( broadcast, get, notifyPlayers, relay, send, sendTo ) -import qualified RW (RW(..)) -import qualified Server (logIn, logOut, update, players) -import qualified Session (Status(..), T(..), Update) +import qualified Player (T(..)) +import qualified Server (logIn, logOut, register, room, update) +import qualified Session (Status, T(..), setPlayer) -receive :: Message.FromClient -> Bool -> App.T () +receive :: Message.FromClient -> Session.Status -> App.T () -receive logIn@(Message.LogIn login) False = - asks App.playerID >>= App.try . (Server.logIn login) - >>= maybe - (Messaging.relay logIn Messaging.broadcast >> setSessionStatus (Session.Status True)) - sendError +receive (Message.Hello {Message.name}) Nothing = do + sessionID <- asks App.sessionID + playerID <- App.exec (Server.register sessionID) + room <- Server.room <$> App.server + App.update (Server.update sessionID $ Session.setPlayer playerID name) + Messaging.send $ Message.Welcome room playerID -receive logOut@Message.LogOut True = do +receive (Message.Hello {Message.name}) (Just player) = do + sessionID <- asks App.sessionID + App.update (Server.update sessionID setName) + where + setName session = session {Session.player = Just $ player {Player.name}} + +receive (Message.Tadaima {Message.myID, Message.name}) Nothing = do + sessionID <- asks App.sessionID + App.update $ Server.logIn name myID sessionID + Message.Okaeri . Server.room <$> App.server >>= Messaging.send + +receive (Message.Tadaima {}) (Just _) = sendError "You're already logged in" + +receive logOut@Message.LogOut (Just _) = do + asks App.sessionID >>= App.update . Server.logOut Messaging.relay logOut Messaging.broadcast - asks App.playerID >>= App.update_ . Server.logOut - setSessionStatus (Session.Status False) -receive invitation@(Message.Invitation {Message.to}) True = do - session <- App.get to - if Session.loggedIn $ Session.status session +receive invitation@(Message.Invitation {Message.to}) (Just _) = + Messaging.relay invitation (Messaging.sendTo [to]) + +receive answer@(Message.Answer {Message.accept, Message.to}) (Just player) = + if accept then do - from <- asks App.playerID - App.update_ (Server.update to (RW.set $ Session.Answering from :: Session.Update)) - else sendError "They just left" + game <- Game.new (Player.playerID player, to) + Messaging.notifyPlayers game [] + else Messaging.relay answer (Messaging.sendTo [to]) -receive (Session.LoggedIn True) message@(Message.Answer {Message.accept}) = do - session <- App.get to - playerID <- asks App.playerID - case Session.status session of - Session.Waiting for | for == playerID -> do - Messaging.relay message $ Messaging.sendTo [to] - newStatus <- - if accept - then do - game <- Game.new (for, to) - Messaging.notifyPlayers game [] - return Session.Playing - else do - return $ Session.LoggedIn True - App.update_ $ Server.update to (RW.set newStatus :: Session.Update) - setSessionStatus newStatus - _ -> sendError "They're not waiting for your answer" - -receive Session.Playing (Message.Play {Message.move, Message.onGame}) = do - playerID <- asks App.playerID - result <- Game.play playerID move onGame +receive (Message.Play {Message.move, Message.onGame}) (Just player) = do + result <- Game.play (Player.playerID player) move onGame case result of Left message -> sendError message Right (newGame, logs) -> Messaging.notifyPlayers newGame logs -receive Session.Playing Message.Quit = setSessionStatus (Session.LoggedIn True) - -receive state _ = sendError $ "Invalid message in state " ++ show state +receive message state = + sendError $ "Invalid message " ++ show message ++ " in " ++ showState + where + showState = + case state of + Nothing -> "disconnected state" + Just _ -> "connected state" sendError :: String -> App.T () sendError = Messaging.send . Message.Error -setSessionStatus :: Session.Status -> App.T () -setSessionStatus newStatus = do - playerID <- asks App.playerID - App.update_ $ Server.update playerID $ (RW.set newStatus :: Session.Update) - App.debug $ show newStatus - loop :: App.T () loop = do message <- Messaging.get - receive message (Status.loggedIn . Session.status <$> App.current) - loop - -start :: App.T () -start = do - App.debug "Initial state" - Message.Welcome . Server.players <$> App.server <*> asks App.playerID >>= Messaging.send + (receive message . Session.player) =<< App.session loop diff --git a/src/Main.hs b/src/Main.hs index dac33e8..c620c75 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,8 +2,8 @@ {-# LANGUAGE NamedFieldPuns #-} module Main where -import qualified App (Context(..), T, update_) -import qualified Automaton (start) +import qualified App (Context(..), T, update) +import qualified Automaton (loop) import qualified Config (listenPort) import Control.Concurrent (newMVar, modifyMVar) import Control.Exception (finally) @@ -16,21 +16,21 @@ import Network.Wai (responseLBS) import Network.Wai.Handler.Warp (run) import Network.Wai.Handler.WebSockets (websocketsOr) import Network.WebSockets (ServerApp, acceptRequest, defaultConnectionOptions) -import qualified Server (disconnect, new, register) +import qualified Server (logOut, new, register) import qualified Session (open) exit :: App.T () exit = do - asks App.playerID >>= App.update_ . Server.disconnect - relay Message.LogOut broadcast + asks App.sessionID >>= App.update . Server.logOut + Messaging.relay Message.LogOut broadcast serverApp :: App.T () -> App.T () -> IO ServerApp serverApp onEnter onExit = do mServer <- newMVar =<< Server.new return $ \pending -> do session <- Session.open <$> acceptRequest pending - playerID <- modifyMVar mServer (return . Server.register session) - let app = App.Context {App.mServer, App.playerID} + sessionID <- modifyMVar mServer (Server.register session) + let app = App.Context {App.mServer, App.sessionID} finally (runReaderT onEnter app) (runReaderT onExit app) @@ -38,7 +38,7 @@ serverApp onEnter onExit = do main :: IO () main = do sodiumInit - app <- serverApp Automaton.start exit + app <- serverApp Automaton.loop exit run Config.listenPort $ websocketsOr defaultConnectionOptions app blockNonWS where blockNonWS _ = ( $ responseLBS badRequest400 [] "Use a websocket") diff --git a/src/Messaging.hs b/src/Messaging.hs index 0a9ec5a..326f1f6 100644 --- a/src/Messaging.hs +++ b/src/Messaging.hs @@ -12,48 +12,59 @@ module Messaging ( , sendTo ) where -import qualified App (Context(..), T, connection, debug, server) -import Control.Monad.Reader (asks, lift) +import qualified App (T, debug, server, session) +import Control.Monad.Reader (lift) import Data.Aeson (eitherDecode', encode) import Data.ByteString.Lazy.Char8 (unpack) import Data.Foldable (forM_) import Data.List (intercalate) -import Data.Map (keys) +import Data.Map (elems, keys) +import Data.Maybe (maybeToList) +import qualified Data.Set as Set (fromList, member) +import qualified Game (exportGame) import qualified Hanafuda.KoiKoi as KoiKoi (Action, Game(..), PlayerID) import Hanafuda.Message (FromClient(..), T(..)) import qualified Hanafuda.Message as Message (T) import Network.WebSockets (receiveData, sendTextData) -import qualified Game (exportGame) -import qualified Server (T(..), get) +import Player (playerID, showDebug) +import qualified Server (T(..), sessionsWhere) import qualified Session (T(..)) +sendToSessions :: [Session.T] -> Message.T -> App.T () +sendToSessions sessions obj = do + App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded) + lift . mapM_ (flip sendTextData encoded) $ Session.connection <$> sessions + where + encoded = encode $ obj + recipients = fmap showDebug . maybeToList . Session.player =<< sessions + sendTo :: [KoiKoi.PlayerID] -> Message.T -> App.T () sendTo playerIDs obj = do - sessions <- getSessions <$> App.server - App.debug $ '(' : intercalate ", " recipients ++ ") <" ++ (unpack encoded) - lift $ forM_ (Session.connection <$> sessions) $ flip sendTextData encoded + sessions <- Server.sessionsWhere selectedPlayer <$> App.server + sendToSessions (elems sessions) obj where - encoded = encode $ obj - getSessions server = (\playerID -> Server.get playerID server) <$> playerIDs - recipients = show <$> playerIDs + selectedPlayer playerID _ = Set.member playerID $ Set.fromList playerIDs send :: Message.T -> App.T () send obj = do - sessionID <- asks App.sessionID - sendTo [sessionID] obj + currentSession <- App.session + sendToSessions [currentSession] obj broadcast :: Message.T -> App.T () broadcast obj = - App.server >>= flip sendTo obj . keys . Server.sessions + (elems . Server.sessions) <$> App.server >>= flip sendToSessions obj relay :: FromClient -> (Message.T -> App.T ()) -> App.T () relay message f = do App.debug "Relaying" - (\from -> f $ Relay {from, message}) =<< asks App.sessionID + maybe bounce doRelay . Session.player =<< App.session + where + doRelay player = f $ Relay {from = playerID player, message} + bounce = send (Error "Unidentified client can't relay messages") receive :: App.T FromClient receive = do - received <- ((lift . receiveData) =<< App.connection) + received <- ((lift . receiveData . Session.connection) =<< App.session) App.debug $ '>':(unpack received) case eitherDecode' received of Left errorMessage -> send (Error errorMessage) >> receive diff --git a/src/Player.hs b/src/Player.hs index 98b2ef1..ebfa6d3 100644 --- a/src/Player.hs +++ b/src/Player.hs @@ -1,11 +1,18 @@ +{-# LANGUAGE NamedFieldPuns #-} module Player ( - T(..) + T(..) + , showDebug ) where import Data.Text (Text) +import Hanafuda.ID (ID(..)) import Hanafuda.KoiKoi (PlayerID) +import Text.Printf (printf) data T = T { playerID :: PlayerID , name :: Text } deriving (Show) + +showDebug :: T -> String +showDebug (T {playerID, name}) = printf "%s (%d)" name (getID playerID) diff --git a/src/Server.hs b/src/Server.hs index a106805..43e2215 100644 --- a/src/Server.hs +++ b/src/Server.hs @@ -5,36 +5,40 @@ {-# LANGUAGE ScopedTypeVariables #-} module Server ( T(..) - , disconnect , get , logIn , logOut , new , register + , room + , select + , sessionsWhere , update ) where -import Data.Map (Map, (!), (!?), adjust, delete, insert, lookupMax) -import qualified Data.Map as Map (empty) +import Data.Map (Map, (!), (!?), adjust, delete, insert) +import qualified Data.Map as Map (empty, lookup, mapMaybeWithKey) import Data.Text (Text) import Hanafuda.KoiKoi (PlayerID) +import Hanafuda.Message (Room) import Keys (getKeys) import qualified Keys (T) import qualified Player (T(..)) import qualified RW (RW(..)) -import qualified Session (ID, T(..), Update) +import qualified Session (ID, T(..), setPlayer) +import System.Random (Random(..)) -type Players = Map PlayerID Session.ID +type SessionIDs = Map PlayerID Session.ID type Sessions = Map Session.ID Session.T data T = T { keys :: Keys.T - , players :: Players + , sessionIDsByPlayerID :: SessionIDs , sessions :: Sessions } -instance RW.RW Players T where - get = players - set players server = server {players} +instance RW.RW SessionIDs T where + get = sessionIDsByPlayerID + set sessionIDsByPlayerID server = server {sessionIDsByPlayerID} instance RW.RW Sessions T where get = sessions @@ -43,14 +47,28 @@ instance RW.RW Sessions T where new :: IO T new = getKeys >>= \keys -> return $ T { keys - , players = Map.empty + , sessionIDsByPlayerID = Map.empty , sessions = Map.empty } -register :: forall a b. (Enum a, Ord a, RW.RW (Map a b) T) => b -> T -> (T, a) -register x server = - let newID = maybe (toEnum 0) (\(n, _) -> succ n) $ lookupMax $ (RW.get server :: Map a b) in - (RW.update (insert newID x) server, newID) +room :: T -> Room +room = fmap Player.name . select (\_ -> Session.player) + +select :: (PlayerID -> Session.T -> Maybe a) -> T -> Map PlayerID a +select selector (T {sessionIDsByPlayerID, sessions}) = + Map.mapMaybeWithKey selected sessionIDsByPlayerID where + selected playerID sessionID = + Map.lookup sessionID sessions >>= selector playerID + +sessionsWhere :: (PlayerID -> Session.T -> Bool) -> T -> Map PlayerID Session.T +sessionsWhere predicate = select selectorOfPredicate where + selectorOfPredicate playerID session = + if predicate playerID session then Just session else Nothing + +register :: forall a b. (Random a, Ord a, RW.RW (Map a b) T) => b -> T -> IO (T, a) +register x server = do + newID <- randomIO + return (RW.update (insert newID x) server, newID) get :: forall a b. (Ord a, RW.RW (Map a b) T) => a -> T -> b get keyID server = (RW.get server :: Map a b) ! keyID @@ -59,20 +77,15 @@ update :: forall a b. (Ord a, RW.RW (Map a b) T) => a -> (b -> b) -> T -> T update keyID updator = RW.update (adjust updator keyID :: Map a b -> Map a b) -disconnect :: Session.ID -> T -> T -disconnect sessionID = - RW.update (delete sessionID :: Sessions -> Sessions) . logOut sessionID - logIn :: Text -> PlayerID -> Session.ID -> T -> T logIn name playerID sessionID = RW.update (insert playerID sessionID) . - update sessionID (RW.set $ Just player :: Session.Update) - where - player = Player.T {Player.playerID, Player.name} + update sessionID (Session.setPlayer playerID name) logOut :: Session.ID -> T -> T logOut sessionID server = + RW.update (delete sessionID :: Sessions -> Sessions) $ case (sessions server !? sessionID) >>= Session.player of Nothing -> server Just player -> - RW.update (delete (Player.playerID player) :: Players -> Players) server + RW.update (delete (Player.playerID player) :: SessionIDs -> SessionIDs) server diff --git a/src/Session.hs b/src/Session.hs index 4320de3..279329a 100644 --- a/src/Session.hs +++ b/src/Session.hs @@ -1,28 +1,31 @@ {-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} module Session ( ID + , Status , T(..) , Update , open + , setPlayer ) where +import Data.Text (Text) import qualified Hanafuda.ID as Hanafuda (ID) +import Hanafuda.KoiKoi (PlayerID) import Network.WebSockets (Connection) -import qualified Player (T) -import qualified RW (RW(..)) +import qualified Player (T(..)) +type ID = Hanafuda.ID T +type Status = Maybe Player.T data T = T { connection :: Connection - , player :: Maybe Player.T + , player :: Status } -type ID = Hanafuda.ID T type Update = T -> T -instance RW.RW (Maybe Player.T) T where - get = player - set player session = session {player} +setPlayer :: PlayerID -> Text -> Session.Update +setPlayer playerID name session = session { + player = Just $ Player.T {Player.playerID, Player.name} + } open :: Connection -> T open connection = T {