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 Message (FromClient(..), broadcast, relay)
import qualified Automaton (start)

exit :: App.T ()
exit = do
  asks App.key >>= App.update_ . Server.disconnect
  Message.relay Message.LogOut Message.broadcast

serverApp :: App.T () -> App.T () -> IO ServerApp
serverApp onEnter onExit = do
  mServer <- newMVar Server.new
  return $ \pending -> do
    session <- Session.open <$> acceptRequest pending
    key <- modifyMVar mServer (return . Server.register session)
    let app = App.Context {App.mServer, App.key}
    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")