47 lines
1.6 KiB
Haskell
47 lines
1.6 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE NamedFieldPuns #-}
|
|
module Main where
|
|
|
|
import qualified App (Context(..), T, exec)
|
|
import qualified Automaton (loop)
|
|
import qualified Config (listenPort)
|
|
import Control.Concurrent (newMVar, modifyMVar)
|
|
import Control.Exception (finally)
|
|
import Control.Monad.Reader (ReaderT(..), asks)
|
|
import Crypto.Saltine (sodiumInit)
|
|
import qualified Hanafuda.Message as Message (T(..))
|
|
import Messaging (broadcast)
|
|
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 (close, new, register)
|
|
import qualified Session (open)
|
|
|
|
exit :: App.T ()
|
|
exit = do
|
|
mPlayerID <- asks App.sessionID >>= App.exec . Server.close
|
|
case mPlayerID of
|
|
Nothing -> return ()
|
|
Just playerID -> Messaging.broadcast $ Message.LogOut playerID
|
|
|
|
serverApp :: App.T () -> App.T () -> IO ServerApp
|
|
serverApp onEnter onExit = do
|
|
mServer <- newMVar =<< Server.new
|
|
return $ \pending -> do
|
|
session <- Session.open <$> acceptRequest pending
|
|
sessionID <- modifyMVar mServer (Server.register session)
|
|
let app = App.Context {App.mServer, App.sessionID}
|
|
finally
|
|
(runReaderT onEnter app)
|
|
(runReaderT onExit app)
|
|
|
|
main :: IO ()
|
|
main = do
|
|
sodiumInit
|
|
app <- serverApp Automaton.loop exit
|
|
run Config.listenPort $ websocketsOr defaultConnectionOptions app blockNonWS
|
|
where
|
|
blockNonWS _ = ( $ responseLBS badRequest400 [] "Use a websocket")
|