-- | Server operations used when ending game and deciding whether to end.
module Game.LambdaHack.Server.EndM
  ( endOrLoop, dieSer, writeSaveAll
#ifdef EXPOSE_INTERNAL
    -- * Internal operations
  , gameExit
#endif
  ) where

import Prelude ()

import Game.LambdaHack.Core.Prelude

import qualified Data.EnumMap.Strict as EM

import Game.LambdaHack.Atomic
import Game.LambdaHack.Client (sbenchmark)
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.State
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Content.ModeKind
import Game.LambdaHack.Definition.Defs
import Game.LambdaHack.Server.CommonM
import Game.LambdaHack.Server.Fov
import Game.LambdaHack.Server.HandleEffectM
import Game.LambdaHack.Server.MonadServer
import Game.LambdaHack.Server.ProtocolM
import Game.LambdaHack.Server.ServerOptions
import Game.LambdaHack.Server.State

-- | Continue or exit or restart the game.
endOrLoop :: (MonadServerAtomic m, MonadServerComm m)
          => m () -> (Maybe (GroupName ModeKind) -> m ())
          -> m ()
endOrLoop :: m () -> (Maybe (GroupName ModeKind) -> m ()) -> m ()
endOrLoop loop :: m ()
loop restart :: Maybe (GroupName ModeKind) -> m ()
restart = do
  FactionDict
factionD <- (State -> FactionDict) -> m FactionDict
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> FactionDict
sfactionD
  let inGame :: Faction -> Bool
inGame fact :: Faction
fact = case Faction -> Maybe Status
gquit Faction
fact of
        Nothing -> Bool
True
        Just Status{stOutcome :: Status -> Outcome
stOutcome=Outcome
Camping} -> Bool
True
        _ -> Bool
False
      gameOver :: Bool
gameOver = Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Faction -> Bool) -> [Faction] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Faction -> Bool
inGame ([Faction] -> Bool) -> [Faction] -> Bool
forall a b. (a -> b) -> a -> b
$ FactionDict -> [Faction]
forall k a. EnumMap k a -> [a]
EM.elems FactionDict
factionD
  let getQuitter :: Faction -> Maybe (GroupName ModeKind)
getQuitter fact :: Faction
fact = case Faction -> Maybe Status
gquit Faction
fact of
        Just Status{stOutcome :: Status -> Outcome
stOutcome=Outcome
Restart, Maybe (GroupName ModeKind)
stNewGame :: Status -> Maybe (GroupName ModeKind)
stNewGame :: Maybe (GroupName ModeKind)
stNewGame} -> Maybe (GroupName ModeKind)
stNewGame
        _ -> Maybe (GroupName ModeKind)
forall a. Maybe a
Nothing
      quitters :: [GroupName ModeKind]
quitters = (Faction -> Maybe (GroupName ModeKind))
-> [Faction] -> [GroupName ModeKind]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Faction -> Maybe (GroupName ModeKind)
getQuitter ([Faction] -> [GroupName ModeKind])
-> [Faction] -> [GroupName ModeKind]
forall a b. (a -> b) -> a -> b
$ FactionDict -> [Faction]
forall k a. EnumMap k a -> [a]
EM.elems FactionDict
factionD
      restartNeeded :: Bool
restartNeeded = Bool
gameOver Bool -> Bool -> Bool
|| Bool -> Bool
not ([GroupName ModeKind] -> Bool
forall a. [a] -> Bool
null [GroupName ModeKind]
quitters)
  let isCamper :: Faction -> Bool
isCamper fact :: Faction
fact = case Faction -> Maybe Status
gquit Faction
fact of
        Just Status{stOutcome :: Status -> Outcome
stOutcome=Outcome
Camping} -> Bool
True
        _ -> Bool
False
      campers :: [(FactionId, Faction)]
campers = ((FactionId, Faction) -> Bool)
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Faction -> Bool
isCamper (Faction -> Bool)
-> ((FactionId, Faction) -> Faction)
-> (FactionId, Faction)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FactionId, Faction) -> Faction
forall a b. (a, b) -> b
snd) ([(FactionId, Faction)] -> [(FactionId, Faction)])
-> [(FactionId, Faction)] -> [(FactionId, Faction)]
forall a b. (a -> b) -> a -> b
$ FactionDict -> [(FactionId, Faction)]
forall k a. Enum k => EnumMap k a -> [(k, a)]
EM.assocs FactionDict
factionD
  -- Wipe out the quit flag for the savegame files.
  ((FactionId, Faction) -> m ()) -> [(FactionId, Faction)] -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(fid :: FactionId
fid, fact :: Faction
fact) ->
    UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ FactionId
-> Maybe Status
-> Maybe Status
-> Maybe (FactionAnalytics, GenerationAnalytics)
-> UpdAtomic
UpdQuitFaction FactionId
fid (Faction -> Maybe Status
gquit Faction
fact) Maybe Status
forall a. Maybe a
Nothing Maybe (FactionAnalytics, GenerationAnalytics)
forall a. Maybe a
Nothing) [(FactionId, Faction)]
campers
  Bool
swriteSave <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> Bool
swriteSave
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
swriteSave (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    (StateServer -> StateServer) -> m ()
forall (m :: * -> *).
MonadServer m =>
(StateServer -> StateServer) -> m ()
modifyServer ((StateServer -> StateServer) -> m ())
-> (StateServer -> StateServer) -> m ()
forall a b. (a -> b) -> a -> b
$ \ser :: StateServer
ser -> StateServer
ser {swriteSave :: Bool
swriteSave = Bool
False}
    Bool -> m ()
forall (m :: * -> *). MonadServerAtomic m => Bool -> m ()
writeSaveAll Bool
True
  if | Bool
restartNeeded -> do
       SfxAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => SfxAtomic -> m ()
execSfxAtomic SfxAtomic
SfxRestart
       Maybe (GroupName ModeKind) -> m ()
restart ([GroupName ModeKind] -> Maybe (GroupName ModeKind)
forall a. [a] -> Maybe a
listToMaybe [GroupName ModeKind]
quitters)
     | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [(FactionId, Faction)] -> Bool
forall a. [a] -> Bool
null [(FactionId, Faction)]
campers -> m ()
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
m ()
gameExit  -- and @loop@ is not called
     | Bool
otherwise -> m ()
loop  -- continue current game

gameExit :: (MonadServerAtomic m, MonadServerComm m) => m ()
gameExit :: m ()
gameExit = do
--  debugPossiblyPrint "Server: Verifying all perceptions."
  -- Verify that the possibly not saved caches are equal to future
  -- reconstructed. Otherwise, save/restore would change game state.
  -- This is done even in released binaries, because it only prolongs
  -- game shutdown a bit. The same checks at each periodic game save
  -- would icrease the game saving lag, so they are normally avoided.
  m ()
forall (m :: * -> *). MonadServer m => m ()
verifyCaches
  -- Kill all clients, including those that did not take part
  -- in the current game.
  -- Clients exit not now, but after they print all ending screens.
--  debugPossiblyPrint "Server: Killing all clients."
  m ()
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
m ()
killAllClients
--  debugPossiblyPrint "Server: All clients killed."
  () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

verifyCaches :: MonadServer m => m ()
verifyCaches :: m ()
verifyCaches = do
  PerCacheFid
sperCacheFid <- (StateServer -> PerCacheFid) -> m PerCacheFid
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> PerCacheFid
sperCacheFid
  PerValidFid
sperValidFid <- (StateServer -> PerValidFid) -> m PerValidFid
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> PerValidFid
sperValidFid
  ActorMaxSkills
sactorMaxSkills2 <- (State -> ActorMaxSkills) -> m ActorMaxSkills
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ActorMaxSkills
sactorMaxSkills
  FovLucidLid
sfovLucidLid <- (StateServer -> FovLucidLid) -> m FovLucidLid
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> FovLucidLid
sfovLucidLid
  FovClearLid
sfovClearLid <- (StateServer -> FovClearLid) -> m FovClearLid
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> FovClearLid
sfovClearLid
  FovLitLid
sfovLitLid <- (StateServer -> FovLitLid) -> m FovLitLid
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> FovLitLid
sfovLitLid
  PerFid
sperFid <- (StateServer -> PerFid) -> m PerFid
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer StateServer -> PerFid
sperFid
  ActorMaxSkills
actorMaxSkills <- (State -> ActorMaxSkills) -> m ActorMaxSkills
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State -> ActorMaxSkills
maxSkillsInDungeon
  ( fovLitLid :: FovLitLid
fovLitLid, fovClearLid :: FovClearLid
fovClearLid, fovLucidLid :: FovLucidLid
fovLucidLid
   ,perValidFid :: PerValidFid
perValidFid, perCacheFid :: PerCacheFid
perCacheFid, perFid :: PerFid
perFid ) <- (State
 -> (FovLitLid, FovClearLid, FovLucidLid, PerValidFid, PerCacheFid,
     PerFid))
-> m (FovLitLid, FovClearLid, FovLucidLid, PerValidFid,
      PerCacheFid, PerFid)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState State
-> (FovLitLid, FovClearLid, FovLucidLid, PerValidFid, PerCacheFid,
    PerFid)
perFidInDungeon
  let !_A7 :: ()
_A7 = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (FovLitLid
sfovLitLid FovLitLid -> FovLitLid -> Bool
forall a. Eq a => a -> a -> Bool
== FovLitLid
fovLitLid
                     Bool -> (String, (FovLitLid, FovLitLid)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` "wrong accumulated sfovLitLid"
                     String
-> (FovLitLid, FovLitLid) -> (String, (FovLitLid, FovLitLid))
forall v. String -> v -> (String, v)
`swith` (FovLitLid
sfovLitLid, FovLitLid
fovLitLid)) ()
      !_A6 :: ()
_A6 = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (FovClearLid
sfovClearLid FovClearLid -> FovClearLid -> Bool
forall a. Eq a => a -> a -> Bool
== FovClearLid
fovClearLid
                     Bool -> (String, (FovClearLid, FovClearLid)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` "wrong accumulated sfovClearLid"
                     String
-> (FovClearLid, FovClearLid)
-> (String, (FovClearLid, FovClearLid))
forall v. String -> v -> (String, v)
`swith` (FovClearLid
sfovClearLid, FovClearLid
fovClearLid)) ()
      !_A5 :: ()
_A5 = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (ActorMaxSkills
sactorMaxSkills2 ActorMaxSkills -> ActorMaxSkills -> Bool
forall a. Eq a => a -> a -> Bool
== ActorMaxSkills
actorMaxSkills
                     Bool -> (String, (ActorMaxSkills, ActorMaxSkills)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` "wrong accumulated sactorMaxSkills"
                     String
-> (ActorMaxSkills, ActorMaxSkills)
-> (String, (ActorMaxSkills, ActorMaxSkills))
forall v. String -> v -> (String, v)
`swith` (ActorMaxSkills
sactorMaxSkills2, ActorMaxSkills
actorMaxSkills)) ()
      !_A4 :: ()
_A4 = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (FovLucidLid
sfovLucidLid FovLucidLid -> FovLucidLid -> Bool
forall a. Eq a => a -> a -> Bool
== FovLucidLid
fovLucidLid
                     Bool -> (String, (FovLucidLid, FovLucidLid)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` "wrong accumulated sfovLucidLid"
                     String
-> (FovLucidLid, FovLucidLid)
-> (String, (FovLucidLid, FovLucidLid))
forall v. String -> v -> (String, v)
`swith` (FovLucidLid
sfovLucidLid, FovLucidLid
fovLucidLid)) ()
      !_A3 :: ()
_A3 = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PerValidFid
sperValidFid PerValidFid -> PerValidFid -> Bool
forall a. Eq a => a -> a -> Bool
== PerValidFid
perValidFid
                     Bool -> (String, (PerValidFid, PerValidFid)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` "wrong accumulated sperValidFid"
                     String
-> (PerValidFid, PerValidFid)
-> (String, (PerValidFid, PerValidFid))
forall v. String -> v -> (String, v)
`swith` (PerValidFid
sperValidFid, PerValidFid
perValidFid)) ()
      !_A2 :: ()
_A2 = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PerCacheFid
sperCacheFid PerCacheFid -> PerCacheFid -> Bool
forall a. Eq a => a -> a -> Bool
== PerCacheFid
perCacheFid
                     Bool -> (String, (PerCacheFid, PerCacheFid)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` "wrong accumulated sperCacheFid"
                     String
-> (PerCacheFid, PerCacheFid)
-> (String, (PerCacheFid, PerCacheFid))
forall v. String -> v -> (String, v)
`swith` (PerCacheFid
sperCacheFid, PerCacheFid
perCacheFid)) ()
      !_A1 :: ()
_A1 = Bool -> () -> ()
forall a. (?callStack::CallStack) => Bool -> a -> a
assert (PerFid
sperFid PerFid -> PerFid -> Bool
forall a. Eq a => a -> a -> Bool
== PerFid
perFid
                     Bool -> (String, (PerFid, PerFid)) -> Bool
forall a. Show a => Bool -> a -> Bool
`blame` "wrong accumulated perception"
                     String -> (PerFid, PerFid) -> (String, (PerFid, PerFid))
forall v. String -> v -> (String, v)
`swith` (PerFid
sperFid, PerFid
perFid)) ()
  () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

dieSer :: MonadServerAtomic m => ActorId -> Actor -> m ()
dieSer :: ActorId -> Actor -> m ()
dieSer aid :: ActorId
aid b :: Actor
b = do
  Actor
b2 <- if Actor -> Bool
bproj Actor
b then Actor -> m Actor
forall (m :: * -> *) a. Monad m => a -> m a
return Actor
b else do
    ContentId ItemKind
kindId <- (State -> ContentId ItemKind) -> m (ContentId ItemKind)
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> ContentId ItemKind) -> m (ContentId ItemKind))
-> (State -> ContentId ItemKind) -> m (ContentId ItemKind)
forall a b. (a -> b) -> a -> b
$ ItemId -> State -> ContentId ItemKind
getIidKindIdServer (ItemId -> State -> ContentId ItemKind)
-> ItemId -> State -> ContentId ItemKind
forall a b. (a -> b) -> a -> b
$ Actor -> ItemId
btrunk Actor
b
    UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> ContentId ItemKind -> Int -> UpdAtomic
UpdRecordKill ActorId
aid ContentId ItemKind
kindId 1
    -- At this point the actor's body exists and his items are not dropped.
    ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
deduceKilled ActorId
aid
    -- Most probabaly already done, but just in case (e.g., when actor
    -- created with 0 HP):
    FactionId -> LevelId -> ActorId -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
FactionId -> LevelId -> ActorId -> m ()
electLeader (Actor -> FactionId
bfid Actor
b) (Actor -> LevelId
blid Actor
b) ActorId
aid
    Faction
fact <- (State -> Faction) -> m Faction
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Faction) -> m Faction)
-> (State -> Faction) -> m Faction
forall a b. (a -> b) -> a -> b
$ (FactionDict -> FactionId -> Faction
forall k a. Enum k => EnumMap k a -> k -> a
EM.! Actor -> FactionId
bfid Actor
b) (FactionDict -> Faction)
-> (State -> FactionDict) -> State -> Faction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. State -> FactionDict
sfactionD
    -- Prevent faction's stash from being lost in case they are not spawners.
    -- Projectiles can't drop stash, because they are blind and so the faction
    -- would not see the actor that drops the stash, leading to a crash.
    -- But this is OK; projectiles can't be leaders, so stash dropped earlier.
    Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe ActorId -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe ActorId -> Bool) -> Maybe ActorId -> Bool
forall a b. (a -> b) -> a -> b
$ Faction -> Maybe ActorId
gleader Faction
fact) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Bool -> ActorId -> CStore -> CStore -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
Bool -> ActorId -> CStore -> CStore -> m ()
moveStores Bool
False ActorId
aid CStore
CSha CStore
CInv
    (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  -- If the actor was a projectile and no effect was triggered by hitting
  -- an enemy, the item still exists and @OnSmash@ effects will be triggered:
  ActorId -> Actor -> m ()
forall (m :: * -> *).
MonadServerAtomic m =>
ActorId -> Actor -> m ()
dropAllItems ActorId
aid Actor
b2
  Actor
b3 <- (State -> Actor) -> m Actor
forall (m :: * -> *) a. MonadStateRead m => (State -> a) -> m a
getsState ((State -> Actor) -> m Actor) -> (State -> Actor) -> m Actor
forall a b. (a -> b) -> a -> b
$ ActorId -> State -> Actor
getActorBody ActorId
aid
  UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic (UpdAtomic -> m ()) -> UpdAtomic -> m ()
forall a b. (a -> b) -> a -> b
$ ActorId -> Actor -> [(ItemId, Item)] -> UpdAtomic
UpdDestroyActor ActorId
aid Actor
b3 []

-- | Save game on server and all clients.
writeSaveAll :: MonadServerAtomic m => Bool -> m ()
writeSaveAll :: Bool -> m ()
writeSaveAll uiRequested :: Bool
uiRequested = do
  Bool
bench <- (StateServer -> Bool) -> m Bool
forall (m :: * -> *) a. MonadServer m => (StateServer -> a) -> m a
getsServer ((StateServer -> Bool) -> m Bool)
-> (StateServer -> Bool) -> m Bool
forall a b. (a -> b) -> a -> b
$ ClientOptions -> Bool
sbenchmark (ClientOptions -> Bool)
-> (StateServer -> ClientOptions) -> StateServer -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerOptions -> ClientOptions
sclientOptions (ServerOptions -> ClientOptions)
-> (StateServer -> ServerOptions) -> StateServer -> ClientOptions
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateServer -> ServerOptions
soptions
  Bool
noConfirmsGame <- m Bool
forall (m :: * -> *). MonadStateRead m => m Bool
isNoConfirmsGame
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
uiRequested Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
bench Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
noConfirmsGame) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    UpdAtomic -> m ()
forall (m :: * -> *). MonadServerAtomic m => UpdAtomic -> m ()
execUpdAtomic UpdAtomic
UpdWriteSave
    m ()
forall (m :: * -> *). MonadServer m => m ()
saveServer
#ifdef WITH_EXPENSIVE_ASSERTIONS
    -- This check is sometimes repeated in @gameExit@, but we don't care about
    -- speed of shutdown and even more so in WITH_EXPENSIVE_ASSERTIONS mode.
    verifyCaches
#endif