wizard-wipeout/src-server/Main.hs

{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where

import qualified Control.Concurrent.STM as STM

import Control.Monad.RWS.Strict

import qualified Data.ByteString.Char8 as B8

import Data.String (fromString)

import Data.Time

import Data.Yaml

import Network.Socket as Net

import Options.Applicative

-- internal imports

import Library.Types

import Server.Communication
import Server.Game
import Server.Map (generateArena)
import Server.Types
import Server.Util

main :: IO ()
main = do
  putStrLn "Hello, Wizards!"
  (Options optSettingLoc) <- execParser opts
  raw <- B8.readFile optSettingLoc
  case decodeEither' raw of
    Left msg -> 
      error (optSettingLoc <> ":" <>
        " error: " <>
        fromString (prettyPrintParseException msg)
        )
    Right (Settings {..}) -> do
      sock <- bindSocket setSocketPath
      putStrLn "Bound and listening to socket:"
      print =<< getSocketName sock
      putStrLn "-----------------------------------------------------------------------------------"
      arena <- generateArena setMapRows setMapColumns setSpawnerProbability
      putStrLn "generated arena:"
      print (arenaMap arena)
      putStrLn "-----------------------------------------------------------------------------------"
      putStrLn "starting game…"
      now <- getCurrentTime
      sockList <- STM.newTMVarIO []
      messageQueue <- STM.newTQueueIO
      serverState <- STM.newTMVarIO (ServerState False False)
      emptyPLayers <- STM.newTMVarIO []
      let initRead  = ReaderContainer (arenaMap arena) setFPS sock
          initState = StateContainer (arenaSpawners arena) emptyPLayers serverState now sockList messageQueue
      (finalState, finalWrite) <- execRWST
        (do
          terminateGameOnSigint setSocketPath
          runGame
        )
        initRead
        initState
      removeIfExists setSocketPath
      putStrLn "bye bye"
  where
    opts = info (options <**> helper)
      ( fullDesc
        <> progDesc "Run the \"wizard-wipeout\" Server."
        <> header "wizard-wipeout - Last Mage standing"
        )