diff --git a/src/App.hs b/src/App.hs index 1047b55..2f2e1a7 100644 --- a/src/App.hs +++ b/src/App.hs @@ -4,7 +4,7 @@ module App ( , Context(..) , debug , exec - , server + , get , session , update ) where @@ -22,12 +22,9 @@ data Context = Context { type T a = ReaderT Context IO a -server :: T Server.T -server = asks mServer >>= lift . readMVar - get :: (Server.T -> a) -> T a get projector = - projector <$> server + lift . fmap projector . readMVar =<< asks mServer session :: T Session.T session = do diff --git a/src/Automaton.hs b/src/Automaton.hs index cf44423..a89049a 100644 --- a/src/Automaton.hs +++ b/src/Automaton.hs @@ -3,7 +3,7 @@ module Automaton ( loop ) where -import qualified App (Context(..), T, exec, server, session, update) +import qualified App (Context(..), T, exec, get, session, update) import Control.Monad.Reader (asks) import qualified Game (new, play) import qualified Hanafuda.Message as Message (FromClient(..), T(..)) @@ -19,7 +19,7 @@ receive :: Message.FromClient -> Session.Status -> App.T () receive (Message.Hello {Message.name}) Nothing = do sessionID <- asks App.sessionID playerID <- App.exec (Server.register sessionID) - room <- Server.room <$> App.server + room <- App.get Server.room App.update (Server.update sessionID $ Session.setPlayer playerID name) Messaging.send $ Message.Welcome room playerID @@ -32,7 +32,7 @@ receive (Message.Hello {Message.name}) (Just player) = do 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 + Message.Okaeri <$> App.get Server.room >>= Messaging.send receive (Message.Tadaima {}) (Just _) = sendError "You're already logged in" diff --git a/src/Game.hs b/src/Game.hs index 4390a0b..eff01fd 100644 --- a/src/Game.hs +++ b/src/Game.hs @@ -5,7 +5,7 @@ module Game ( , play ) where -import qualified App (T, server) +import qualified App (T, get) import Control.Monad.Except (runExceptT) import Control.Monad.Reader (lift) import Control.Monad.Writer (runWriterT) @@ -78,7 +78,7 @@ publicState game = PublicState { exportGame :: PlayerID -> Game -> App.T PublicGame exportGame playerID game = do - Keys.T {encrypt, sign} <- Server.keys <$> App.server + Keys.T {encrypt, sign} <- App.get Server.keys n <- lift newNonce return $ PublicGame { nonce = Saltine.encode n @@ -114,7 +114,7 @@ gameOf public private = KoiKoi.Game { importGame :: PublicGame -> App.T (Either String Game) importGame PublicGame {nonce, private, public, publicSignature} = do - Keys.T {encrypt, sign} <- Server.keys <$> App.server + Keys.T {encrypt, sign} <- App.get Server.keys if signVerifyDetached (Keys.public sign) publicSignature $ toJSON public then return $ do n <- Saltine.decode nonce `orDie` "Could not decode nonce" diff --git a/src/Messaging.hs b/src/Messaging.hs index 326f1f6..fecbb9a 100644 --- a/src/Messaging.hs +++ b/src/Messaging.hs @@ -12,7 +12,7 @@ module Messaging ( , sendTo ) where -import qualified App (T, debug, server, session) +import qualified App (T, debug, get, session) import Control.Monad.Reader (lift) import Data.Aeson (eitherDecode', encode) import Data.ByteString.Lazy.Char8 (unpack) @@ -40,7 +40,7 @@ sendToSessions sessions obj = do sendTo :: [KoiKoi.PlayerID] -> Message.T -> App.T () sendTo playerIDs obj = do - sessions <- Server.sessionsWhere selectedPlayer <$> App.server + sessions <- App.get $ Server.sessionsWhere selectedPlayer sendToSessions (elems sessions) obj where selectedPlayer playerID _ = Set.member playerID $ Set.fromList playerIDs @@ -51,8 +51,8 @@ send obj = do sendToSessions [currentSession] obj broadcast :: Message.T -> App.T () -broadcast obj = - (elems . Server.sessions) <$> App.server >>= flip sendToSessions obj +broadcast obj = do + App.get (elems . Server.sessions) >>= flip sendToSessions obj relay :: FromClient -> (Message.T -> App.T ()) -> App.T () relay message f = do