43 lines
1.5 KiB
Haskell
43 lines
1.5 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Main where
|
|
|
|
import Network.Wai.Handler.Warp (run)
|
|
import Network.HTTP.Types.Status (badRequest400)
|
|
import Network.WebSockets (ServerApp, acceptRequest, defaultConnectionOptions)
|
|
import Network.Wai.Handler.WebSockets (websocketsOr)
|
|
import Network.Wai (responseLBS)
|
|
import Control.Monad.Reader (ReaderT(..), asks)
|
|
import Control.Concurrent (newMVar, modifyMVar)
|
|
import Control.Exception (finally)
|
|
import qualified Config (listenPort)
|
|
import qualified Player (openSession)
|
|
import qualified Server (disconnect, join, new)
|
|
import qualified Session (App, T(..), update)
|
|
import qualified Message (FromClient(..), broadcast, relay)
|
|
import qualified Automaton (start)
|
|
|
|
exit :: Session.App ()
|
|
exit = do
|
|
asks Session.key >>= Session.update . Server.disconnect
|
|
Message.relay Message.LogOut Message.broadcast
|
|
|
|
serverApp :: Session.App () -> Session.App () -> IO ServerApp
|
|
serverApp onEnter onExit = do
|
|
mServer <- newMVar Server.new
|
|
return $ \pending -> do
|
|
key <- acceptRequest pending
|
|
>>= return . Player.openSession
|
|
>>= modifyMVar mServer . Server.join
|
|
let session = Session.T {Session.mServer, Session.key}
|
|
finally
|
|
(runReaderT onEnter session)
|
|
(runReaderT onExit session)
|
|
|
|
main :: IO ()
|
|
main = do
|
|
app <- serverApp Automaton.start exit
|
|
run Config.listenPort $ websocketsOr defaultConnectionOptions app blockNonWS
|
|
where
|
|
blockNonWS _ = ( $ responseLBS badRequest400 [] "Use a websocket")
|