Completely replace App.server by App.get, a function applying a projector to the server
This commit is contained in:
parent
fef08fd478
commit
25bcf0631c
4 changed files with 12 additions and 15 deletions
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Add table
Reference in a new issue