module Game.LambdaHack.Server.EndM
( endOrLoop, dieSer, writeSaveAll
#ifdef EXPOSE_INTERNAL
, 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
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
((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
| Bool
otherwise -> m ()
loop
gameExit :: (MonadServerAtomic m, MonadServerComm m) => m ()
gameExit :: m ()
gameExit = do
m ()
forall (m :: * -> *). MonadServer m => m ()
verifyCaches
m ()
forall (m :: * -> *).
(MonadServerAtomic m, MonadServerComm m) =>
m ()
killAllClients
() -> 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
ActorId -> m ()
forall (m :: * -> *). MonadServerAtomic m => ActorId -> m ()
deduceKilled ActorId
aid
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
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
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 []
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
verifyCaches
#endif