91 lines
3.2 KiB
Haskell
91 lines
3.2 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Main where
|
|
|
|
import Network.Wai.Handler.Warp (run)
|
|
import Network.HTTP.Types.Status (badRequest400)
|
|
import Network.WebSockets (defaultConnectionOptions)
|
|
import Network.Wai.Handler.WebSockets (websocketsOr)
|
|
import Network.Wai (responseLBS)
|
|
import Control.Monad.Reader (asks)
|
|
import qualified Config (listenPort)
|
|
import qualified Player (Session(..), Status(..))
|
|
import qualified Server (logIn, logOut, disconnect, setStatus)
|
|
import qualified Session (App, T(..), current, debug, get, serve, server, try, update)
|
|
import qualified Message (FromClient(..), T(..), broadcast, receive, relay, send, sendTo)
|
|
|
|
type Vertex = Session.App ()
|
|
type Edges = Message.FromClient -> Vertex
|
|
|
|
newVertex :: String -> Edges -> Vertex
|
|
newVertex name = do
|
|
(Session.debug name >> catchPings >>=)
|
|
where
|
|
catchPings = Message.receive >>= pong
|
|
pong Message.Ping = (Message.send Message.Pong >> catchPings)
|
|
pong m = return m
|
|
|
|
enter :: Vertex
|
|
enter = do
|
|
Session.debug "Initial state"
|
|
Message.Welcome <$> Session.server <*> asks Session.key >>= Message.send
|
|
connected
|
|
|
|
onErrorGoto :: Vertex -> String -> Session.App ()
|
|
onErrorGoto vertex message =
|
|
(Message.send $ Message.Error message) >> vertex
|
|
|
|
connected :: Vertex
|
|
connected = newVertex "Connected" edges
|
|
where
|
|
edges logIn@(Message.LogIn login) =
|
|
asks Session.key >>= Session.try . (Server.logIn login)
|
|
>>= maybe
|
|
(Message.relay logIn Message.broadcast >> loggedIn)
|
|
(onErrorGoto connected)
|
|
edges _ = Session.debug "Invalid message" >> connected
|
|
|
|
loggedIn :: Vertex
|
|
loggedIn = newVertex "Logged in" edges
|
|
where
|
|
edges logOut@Message.LogOut = do
|
|
Message.relay logOut Message.broadcast
|
|
asks Session.key >>= Session.update . Server.logOut
|
|
connected
|
|
edges invitation@(Message.Invitation {Message.to}) = do
|
|
session <- Session.get to
|
|
case Player.status session of
|
|
Player.LoggedIn True -> do
|
|
key <- asks Session.key
|
|
Session.update (Server.setStatus (Player.Waiting to) key)
|
|
Session.update (Server.setStatus (Player.Answering key) to)
|
|
(Message.relay invitation $ Message.sendTo (to, session))
|
|
loggedIn
|
|
_ -> onErrorGoto loggedIn "They just left"
|
|
edges (Message.Answer {Message.accept}) = do
|
|
current <- Session.current
|
|
case Player.status current of
|
|
Player.Answering to -> do
|
|
session <- Session.get to
|
|
key <- asks Session.key
|
|
case Player.status session of
|
|
Player.Waiting for | for == key ->
|
|
if accept
|
|
then Session.debug "Yeah ! Let's start a game" >> loggedIn
|
|
else Session.debug "Oh they said no" >> loggedIn
|
|
_ -> onErrorGoto loggedIn "They're not waiting for your answer"
|
|
_ -> onErrorGoto loggedIn "You haven't been invited yet"
|
|
edges _ = loggedIn
|
|
|
|
exit :: Vertex
|
|
exit = do
|
|
asks Session.key >>= Session.update . Server.disconnect
|
|
Message.relay Message.LogOut Message.broadcast
|
|
|
|
main :: IO ()
|
|
main = do
|
|
app <- Session.serve enter exit
|
|
run Config.listenPort $ websocketsOr defaultConnectionOptions app blockNonWS
|
|
where
|
|
blockNonWS _ = ( $ responseLBS badRequest400 [] "Use a websocket")
|