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