module Game.LambdaHack.Server
( mainSer
) where
import System.Environment (getArgs)
import Game.LambdaHack.Common.Action
import Game.LambdaHack.Common.ClientCmd
import Game.LambdaHack.Common.Faction
import qualified Game.LambdaHack.Common.Kind as Kind
import Game.LambdaHack.Common.ServerCmd
import Game.LambdaHack.Frontend
import Game.LambdaHack.Server.Action
import Game.LambdaHack.Server.Fov
import Game.LambdaHack.Server.LoopAction
import Game.LambdaHack.Server.ServerSem
import Game.LambdaHack.Server.State
cmdSerSem :: (MonadAtomic m, MonadServer m) => CmdSer -> m Bool
cmdSerSem cmd = case cmd of
MoveSer aid dir -> moveSer aid dir False
ExploreSer aid dir -> moveSer aid dir True
RunSer aid dir -> runSer aid dir
WaitSer aid -> waitSer aid >> return True
PickupSer aid i k l -> pickupSer aid i k l >> return True
DropSer aid iid -> dropSer aid iid >> return True
ProjectSer aid p eps iid container -> projectSer aid p eps iid container
ApplySer aid iid container -> applySer aid iid container >> return True
TriggerSer aid p -> triggerSer aid p
SetPathSer aid path -> setPathSer aid path >> return True
GameRestartSer aid t -> gameRestartSer aid t >> return False
GameExitSer aid -> gameExitSer aid >> return False
GameSaveSer _ -> gameSaveSer >> return False
CfgDumpSer aid -> cfgDumpSer aid >> return False
debugArgs :: IO DebugModeSer
debugArgs = do
args <- getArgs
let usage =
[ "Configure server debug options here, gameplay in config.rules.ini."
, " --knowMap reveal map for all clients in the next game"
, " --knowEvents show all events in the next game (needs --knowMap)"
, " --sniffIn display all incoming commands on console "
, " --sniffOut display all outgoing commands on console "
, " --allClear let all map tiles be translucent"
, " --debugCli let clients emit their debug messages"
, " --tryFov m set a Field of View mode, where m can be"
, " Digital r, r > 0"
, " Permissive"
, " Shadow"
, " Blind"
]
parseArgs [] = defDebugModeSer
parseArgs ("--knowMap" : rest) =
(parseArgs rest) {sknowMap = True}
parseArgs ("--knowEvents" : rest) =
(parseArgs rest) {sknowEvents = True}
parseArgs ("--sniffIn" : rest) =
(parseArgs rest) {sniffIn = True}
parseArgs ("--sniffOut" : rest) =
(parseArgs rest) {sniffOut = True}
parseArgs ("--allClear" : rest) =
(parseArgs rest) {sallClear = True}
parseArgs ("--tryFov" : "Digital" : r : rest) | (read r :: Int) > 0 =
(parseArgs rest) {stryFov = Just $ Digital $ read r}
parseArgs ("--tryFov" : mode : rest) =
(parseArgs rest) {stryFov = Just $ read mode}
parseArgs ("--debugCli" : rest) =
(parseArgs rest) {sdebugCli = True}
parseArgs _ = error $ unlines usage
return $! parseArgs args
mainSer :: (MonadAtomic m, MonadConnServer m)
=> Kind.COps
-> (m () -> IO ())
-> (Kind.COps
-> ((FactionId -> ChanFrontend -> ChanServer CmdClientUI -> IO ())
-> (FactionId -> ChanServer CmdClientAI -> IO ())
-> IO ())
-> IO ())
-> IO ()
mainSer copsSlow exeSer exeFront = do
sdebugNxt <- debugArgs
let cops = speedupCOps False copsSlow
loopServer = loopSer sdebugNxt cmdSerSem
exeServer executorUI executorAI = do
exeSer (loopServer executorUI executorAI cops)
waitForChildren
exeFront cops exeServer