73 lines
2.2 KiB
Haskell
73 lines
2.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 qualified Config (listenPort)
|
|
import qualified Player (Login(..), T(..))
|
|
import qualified Server (logIn, logOut, disconnect)
|
|
import qualified Session (App, debug, get, player, serve, update)
|
|
import qualified Message (FromClient(..), T(..), broadcast, receive, relay, send)
|
|
|
|
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"
|
|
Session.get id >>= (Message.send . Message.Welcome)
|
|
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) =
|
|
Session.update (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
|
|
Session.update Server.logOut
|
|
>>= maybe
|
|
connected
|
|
(onErrorGoto loggedIn)
|
|
edges _ = loggedIn
|
|
|
|
exit :: Vertex
|
|
exit = do
|
|
leaving <- Player.login <$> Session.player
|
|
_ <- Session.update Server.disconnect -- ignoring never-occuring error
|
|
case leaving of
|
|
Player.Login from -> Message.broadcast $
|
|
Message.Relay {Message.from, Message.message = Message.LogOut}
|
|
_ -> return ()
|
|
|
|
main :: IO ()
|
|
main = do
|
|
app <- Session.serve enter exit
|
|
run Config.listenPort $ websocketsOr defaultConnectionOptions app blockNonWS
|
|
where
|
|
blockNonWS _ = ( $ responseLBS badRequest400 [] "Use a websocket")
|