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