server/src/Main.hs

{-# 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 Session (open)
import qualified Server (disconnect, new, register)
import qualified App (Context(..), T, update_)
import qualified Hanafuda.Message as Message (FromClient(..))
import Messaging (broadcast, relay)
import qualified Automaton (start)

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")