module Game.LambdaHack.Server.HandleRequestM
( handleRequestAI, handleRequestUI, handleRequestTimed, switchLeader
, reqMoveGeneric, reqDisplaceGeneric, reqAlterFail
, reqGameDropAndExit, reqGameSaveAndExit
#ifdef EXPOSE_INTERNAL
, execFailure, checkWaiting, processWatchfulness, managePerRequest
, handleRequestTimedCases, affectSmell, reqMove, reqMelee, reqMeleeChecked
, reqDisplace, reqAlter, reqWait, reqWait10, reqYell, reqMoveItems
, reqMoveItem, reqProject, reqApply
, reqGameRestart, reqGameSave, reqTactic, reqAutomate
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import qualified Data.EnumMap.Strict as EM
import qualified Data.Ord as Ord
import qualified Data.Text as T
import qualified Text.Show.Pretty as Show.Pretty
import Game.LambdaHack.Atomic
import Game.LambdaHack.Client (ReqAI (..), ReqUI (..),
RequestTimed (..))
import Game.LambdaHack.Client.UI.ItemDescription
import Game.LambdaHack.Common.Actor
import Game.LambdaHack.Common.ActorState
import Game.LambdaHack.Common.Analytics
import Game.LambdaHack.Common.Faction
import Game.LambdaHack.Common.Item
import qualified Game.LambdaHack.Common.ItemAspect as IA
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.Level
import Game.LambdaHack.Common.Misc
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.Point
import Game.LambdaHack.Common.ReqFailure
import Game.LambdaHack.Common.State
import qualified Game.LambdaHack.Common.Tile as Tile
import Game.LambdaHack.Common.Time
import Game.LambdaHack.Common.Types
import Game.LambdaHack.Common.Vector
import qualified Game.LambdaHack.Content.ItemKind as IK
import Game.LambdaHack.Content.ModeKind
import qualified Game.LambdaHack.Content.TileKind as TK
import qualified Game.LambdaHack.Definition.Ability as Ability
import Game.LambdaHack.Definition.Defs
import Game.LambdaHack.Server.CommonM
import Game.LambdaHack.Server.HandleEffectM
import Game.LambdaHack.Server.ItemM
import Game.LambdaHack.Server.MonadServer
import Game.LambdaHack.Server.PeriodicM
import Game.LambdaHack.Server.ServerOptions
import Game.LambdaHack.Server.State
execFailure :: MonadServerAtomic m
=> ActorId -> RequestTimed -> ReqFailure -> m ()
execFailure aid req failureSer = do
body <- getsState $ getActorBody aid
let fid = bfid body
msg = showReqFailure failureSer
impossible = impossibleReqFailure failureSer
debugShow :: Show a => a -> Text
debugShow = T.pack . Show.Pretty.ppShow
possiblyAlarm = if impossible
then debugPossiblyPrintAndExit
else debugPossiblyPrint
possiblyAlarm $
"Server: execFailure:" <+> msg <> "\n"
<> debugShow body <> "\n" <> debugShow req <> "\n" <> debugShow failureSer
execSfxAtomic $ SfxMsgFid fid $ SfxUnexpected failureSer
handleRequestAI :: MonadServerAtomic m
=> ReqAI
-> m (Maybe RequestTimed)
handleRequestAI cmd = case cmd of
ReqAITimed cmdT -> return $ Just cmdT
ReqAINop -> return Nothing
handleRequestUI :: MonadServerAtomic m
=> FactionId -> ActorId -> ReqUI
-> m (Maybe RequestTimed)
handleRequestUI fid aid cmd = case cmd of
ReqUITimed cmdT -> return $ Just cmdT
ReqUIGameRestart t d -> reqGameRestart aid t d >> return Nothing
ReqUIGameDropAndExit -> reqGameDropAndExit aid >> return Nothing
ReqUIGameSaveAndExit -> reqGameSaveAndExit aid >> return Nothing
ReqUIGameSave -> reqGameSave >> return Nothing
ReqUITactic toT -> reqTactic fid toT >> return Nothing
ReqUIAutomate -> reqAutomate fid >> return Nothing
ReqUINop -> return Nothing
checkWaiting :: RequestTimed -> Maybe Bool
checkWaiting cmd = case cmd of
ReqWait -> Just True
ReqWait10 -> Just False
_ -> Nothing
processWatchfulness :: MonadServerAtomic m => Maybe Bool -> ActorId -> m ()
processWatchfulness mwait aid = do
b <- getsState $ getActorBody aid
actorMaxSk <- getsState $ getActorMaxSkills aid
let uneasy = deltasSerious (bcalmDelta b) || not (calmEnough b actorMaxSk)
case bwatch b of
WSleep ->
if mwait /= Just False
&& (not (isJust mwait)
|| uneasy
|| not (deltaBenign $ bhpDelta b))
then execUpdAtomic $ UpdWaitActor aid WSleep WWake
else execUpdAtomic $ UpdRefillHP aid 10000
WWake -> unless (mwait == Just False) $
removeSleepSingle aid
WWait 0 -> case mwait of
Just True -> return ()
_ -> execUpdAtomic $ UpdWaitActor aid (WWait 0) WWatch
WWait n -> case mwait of
Just True ->
if n >= 500 then
if not uneasy
&& canSleep actorMaxSk
then do
nAll <- removeConditionSingle "braced" aid
let !_A = assert (nAll == 0) ()
addSleep aid
else
execUpdAtomic $ UpdWaitActor aid (WWait n) (WWait 1)
else
execUpdAtomic $ UpdWaitActor aid (WWait n) (WWait $ n + 1)
_ -> do
nAll <- removeConditionSingle "braced" aid
let !_A = assert (nAll == 0) ()
execUpdAtomic $ UpdWaitActor aid (WWait n) WWatch
WWatch ->
when (mwait == Just True) $
if Ability.getSk Ability.SkWait actorMaxSk >= 2 then do
addCondition "braced" aid
execUpdAtomic $ UpdWaitActor aid WWatch (WWait 1)
else
execUpdAtomic $ UpdWaitActor aid WWatch (WWait 0)
handleRequestTimed :: MonadServerAtomic m
=> FactionId -> ActorId -> RequestTimed -> m Bool
handleRequestTimed fid aid cmd = do
let mwait = checkWaiting cmd
b <- getsState $ getActorBody aid
unless (mwait == Just True) $ overheadActorTime fid (blid b)
advanceTime aid (if mwait == Just False then 10 else 100) True
handleRequestTimedCases aid cmd
managePerRequest aid
processWatchfulness mwait aid
return $! isNothing mwait
managePerRequest :: MonadServerAtomic m => ActorId -> m ()
managePerRequest aid = do
b <- getsState $ getActorBody aid
let clearMark = 0
unless (bcalmDelta b == ResDelta (0, 0) (0, 0)) $
execUpdAtomic $ UpdRefillCalm aid clearMark
unless (bhpDelta b == ResDelta (0, 0) (0, 0)) $
execUpdAtomic $ UpdRefillHP aid clearMark
handleRequestTimedCases :: MonadServerAtomic m
=> ActorId -> RequestTimed -> m ()
handleRequestTimedCases aid cmd = case cmd of
ReqMove target -> reqMove aid target
ReqMelee target iid cstore -> reqMelee aid target iid cstore
ReqDisplace target -> reqDisplace aid target
ReqAlter tpos -> reqAlter aid tpos
ReqWait -> reqWait aid
ReqWait10 -> reqWait10 aid
ReqYell -> reqYell aid
ReqMoveItems l -> reqMoveItems aid l
ReqProject p eps iid cstore -> reqProject aid p eps iid cstore
ReqApply iid cstore -> reqApply aid iid cstore
switchLeader :: MonadServerAtomic m => FactionId -> ActorId -> m ()
{-# INLINE switchLeader #-}
switchLeader fid aidNew = do
fact <- getsState $ (EM.! fid) . sfactionD
bPre <- getsState $ getActorBody aidNew
let mleader = gleader fact
!_A1 = assert (Just aidNew /= mleader
&& not (bproj bPre)
`blame` (aidNew, bPre, fid, fact)) ()
!_A2 = assert (bfid bPre == fid
`blame` "client tries to move other faction actors"
`swith` (aidNew, bPre, fid, fact)) ()
let (autoDun, _) = autoDungeonLevel fact
arena <- case mleader of
Nothing -> return $! blid bPre
Just leader -> do
b <- getsState $ getActorBody leader
return $! blid b
if | blid bPre /= arena && autoDun ->
execFailure aidNew ReqWait NoChangeDunLeader
| otherwise -> do
execUpdAtomic $ UpdLeadFaction fid mleader (Just aidNew)
case mleader of
Just aidOld | aidOld /= aidNew -> swapTime aidOld aidNew
_ -> return ()
affectSmell :: MonadServerAtomic m => ActorId -> m ()
affectSmell aid = do
COps{coTileSpeedup} <- getsState scops
b <- getsState $ getActorBody aid
lvl <- getLevel $ blid b
let aquatic = Tile.isAquatic coTileSpeedup $ lvl `at` bpos b
unless (bproj b || aquatic) $ do
actorMaxSk <- getsState $ getActorMaxSkills aid
let smellRadius = Ability.getSk Ability.SkSmell actorMaxSk
hasOdor = Ability.getSk Ability.SkOdor actorMaxSk > 0
when (hasOdor || smellRadius > 0) $ do
localTime <- getsState $ getLocalTime $ blid b
let oldS = fromMaybe timeZero $ EM.lookup (bpos b) . lsmell $ lvl
newTime = timeShift localTime smellTimeout
newS = if smellRadius > 0
then timeZero
else newTime
when (oldS /= newS) $
execUpdAtomic $ UpdAlterSmell (blid b) (bpos b) oldS newS
reqMove :: MonadServerAtomic m => ActorId -> Vector -> m ()
reqMove = reqMoveGeneric True True
reqMoveGeneric :: MonadServerAtomic m
=> Bool -> Bool -> ActorId -> Vector -> m ()
reqMoveGeneric voluntary mayAttack source dir = do
COps{coTileSpeedup} <- getsState scops
actorSk <- currentSkillsServer source
sb <- getsState $ getActorBody source
let abInSkill sk = isJust (btrajectory sb)
|| Ability.getSk sk actorSk > 0
lid = blid sb
lvl <- getLevel lid
let spos = bpos sb
tpos = spos `shift` dir
collides <- getsState $ \s tb ->
let sitemKind = getIidKindServer (btrunk sb) s
titemKind = getIidKindServer (btrunk tb) s
sar = sdiscoAspect s EM.! btrunk sb
tar = sdiscoAspect s EM.! btrunk tb
bursting arItem =
IA.checkFlag Ability.Fragile arItem
&& IA.checkFlag Ability.Lobable arItem
sbursting = bursting sar
tbursting = bursting tar
damaging itemKind = IK.idamage itemKind /= 0
sdamaging = damaging sitemKind
tdamaging = damaging titemKind
sameBlast = IA.checkFlag Ability.Blast sar
&& getIidKindIdServer (btrunk sb) s
== getIidKindIdServer (btrunk tb) s
in not sameBlast
&& (sbursting && (tdamaging || tbursting)
|| (tbursting && (sdamaging || sbursting)))
tgt <- getsState $ posToAidAssocs tpos lid
case tgt of
(target, tb) : _ | mayAttack && (not (bproj sb)
|| not (bproj tb)
|| collides tb) -> do
mweapon <- pickWeaponServer source
case mweapon of
Just (wp, cstore) | abInSkill Ability.SkMelee ->
reqMeleeChecked voluntary source target wp cstore
_ -> return ()
when (bproj sb) $ do
b2 <- getsState $ getActorBody source
unless (actorDying b2) $ reqMoveGeneric voluntary False source dir
_ ->
if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then
if abInSkill Ability.SkMove then do
execUpdAtomic $ UpdMoveActor source spos tpos
affectSmell source
void $ reqAlterFail voluntary source tpos
else execFailure source (ReqMove dir) MoveUnskilled
else
execFailure source (ReqMove dir) MoveNothing
reqMelee :: MonadServerAtomic m
=> ActorId -> ActorId -> ItemId -> CStore -> m ()
reqMelee source target iid cstore = do
actorSk <- currentSkillsServer source
if Ability.getSk Ability.SkMelee actorSk > 0 then
reqMeleeChecked True source target iid cstore
else execFailure source (ReqMelee target iid cstore) MeleeUnskilled
reqMeleeChecked :: forall m. MonadServerAtomic m
=> Bool -> ActorId -> ActorId -> ItemId -> CStore -> m ()
reqMeleeChecked voluntary source target iid cstore = do
sb <- getsState $ getActorBody source
tb <- getsState $ getActorBody target
let req = ReqMelee target iid cstore
if source == target then execFailure source req MeleeSelf
else if not (checkAdjacent sb tb) then execFailure source req MeleeDistant
else do
killer <- if | voluntary -> assert (not (bproj sb)) $ return source
| bproj sb -> getsServer $ EM.findWithDefault source source
. strajPushedBy
| otherwise -> return source
discoAspect <- getsState sdiscoAspect
let arTrunk = discoAspect EM.! btrunk tb
arWeapon = discoAspect EM.! iid
sfid = bfid sb
tfid = bfid tb
haltTrajectory :: KillHow -> ActorId -> Actor -> m ()
haltTrajectory killHow aid b = case btrajectory b of
btra@(Just (l, speed)) | not $ null l -> do
execUpdAtomic $ UpdTrajectory aid btra $ Just ([], speed)
let arTrunkAid = discoAspect EM.! btrunk b
when (bproj b && not (IA.checkFlag Ability.Blast arTrunkAid)) $
addKillToAnalytics killer killHow (bfid b) (btrunk b)
_ -> return ()
if bproj tb
&& EM.size (beqp tb) == 1
&& not (IA.checkFlag Ability.Blast arTrunk)
&& actorWaits sb
then do
execSfxAtomic $ SfxSteal source target iid cstore
case EM.assocs $ beqp tb of
[(iid2, (k, _))] -> do
upds <- generalMoveItem True iid2 k (CActor target CEqp)
(CActor source CInv)
mapM_ execUpdAtomic upds
itemFull <- getsState $ itemToFull iid2
discoverIfMinorEffects (CActor source CInv) iid2 (itemKindId itemFull)
err -> error $ "" `showFailure` err
haltTrajectory KillCatch target tb
else do
if bproj sb && bproj tb then do
when (bhp tb > oneM) $
execUpdAtomic $ UpdRefillHP target minusM
when (bhp tb <= oneM) $ do
let killHow | IA.checkFlag Ability.Blast arWeapon = KillKineticBlast
| otherwise = KillKineticRanged
haltTrajectory killHow target tb
unless (IA.checkFlag Ability.Blast arWeapon
&& IA.checkFlag Ability.Blast arTrunk) $
execSfxAtomic $ SfxStrike source target iid cstore
else do
execSfxAtomic $ SfxStrike source target iid cstore
let c = CActor source cstore
mayDestroy = not (bproj sb) || bhp sb <= oneM
kineticEffectAndDestroy voluntary killer source target iid c mayDestroy
sb2 <- getsState $ getActorBody source
case btrajectory sb2 of
Just{} -> do
when (bhp sb2 > oneM) $ do
execUpdAtomic $ UpdRefillHP source minusM
unless (bproj sb2) $ do
execSfxAtomic $
SfxMsgFid (bfid sb2) $ SfxCollideActor (blid tb) source target
unless (bproj tb) $
execSfxAtomic $
SfxMsgFid (bfid tb) $ SfxCollideActor (blid tb) source target
when (not (bproj sb2) || bhp sb2 <= oneM) $
haltTrajectory KillActorLaunch source sb2
_ -> return ()
sfact <- getsState $ (EM.! sfid) . sfactionD
let friendlyFire = bproj sb2 || bproj tb || not voluntary
fromDipl = EM.findWithDefault Unknown tfid (gdipl sfact)
unless (friendlyFire
|| isFoe sfid sfact tfid
|| isFriend sfid sfact tfid) $
execUpdAtomic $ UpdDiplFaction sfid tfid fromDipl War
reqDisplace :: MonadServerAtomic m => ActorId -> ActorId -> m ()
reqDisplace = reqDisplaceGeneric True
reqDisplaceGeneric :: MonadServerAtomic m => Bool -> ActorId -> ActorId -> m ()
reqDisplaceGeneric voluntary source target = do
COps{coTileSpeedup} <- getsState scops
actorSk <- currentSkillsServer source
sb <- getsState $ getActorBody source
let abInSkill sk = isJust (btrajectory sb)
|| Ability.getSk sk actorSk > 0
tb <- getsState $ getActorBody target
tfact <- getsState $ (EM.! bfid tb) . sfactionD
let spos = bpos sb
tpos = bpos tb
atWar = isFoe (bfid tb) tfact (bfid sb)
req = ReqDisplace target
actorMaxSk <- getsState $ getActorMaxSkills target
dEnemy <- getsState $ dispEnemy source target actorMaxSk
if | not (abInSkill Ability.SkDisplace) ->
execFailure source req DisplaceUnskilled
| not (checkAdjacent sb tb) -> execFailure source req DisplaceDistant
| atWar && not dEnemy -> do
mweapon <- pickWeaponServer source
case mweapon of
Just (wp, cstore) | abInSkill Ability.SkMelee ->
reqMeleeChecked voluntary source target wp cstore
_ -> return ()
| otherwise -> do
let lid = blid sb
lvl <- getLevel lid
if Tile.isWalkable coTileSpeedup $ lvl `at` tpos then
case posToAidsLvl tpos lvl of
[] -> error $ "" `showFailure` (source, sb, target, tb)
[_] -> do
execUpdAtomic $ UpdDisplaceActor source target
affectSmell source
affectSmell target
void $ reqAlterFail voluntary source tpos
void $ reqAlterFail voluntary target spos
_ -> execFailure source req DisplaceMultiple
else
execFailure source req DisplaceAccess
reqAlter :: MonadServerAtomic m => ActorId -> Point -> m ()
reqAlter source tpos = do
mfail <- reqAlterFail True source tpos
let req = ReqAlter tpos
maybe (return ()) (execFailure source req) mfail
reqAlterFail :: MonadServerAtomic m
=> Bool -> ActorId -> Point -> m (Maybe ReqFailure)
reqAlterFail voluntary source tpos = do
cops@COps{cotile, coTileSpeedup} <- getsState scops
sb <- getsState $ getActorBody source
actorMaxSk <- getsState $ getActorMaxSkills source
factionD <- getsState sfactionD
let calmE = calmEnough sb actorMaxSk
lid = blid sb
sClient <- getsServer $ (EM.! bfid sb) . sclientStates
itemToF <- getsState $ flip itemToFull
actorSk <- currentSkillsServer source
localTime <- getsState $ getLocalTime lid
let alterSkill = Ability.getSk Ability.SkAlter actorSk
embeds <- getsState $ getEmbedBag lid tpos
lvl <- getLevel lid
getKind <- getsState $ flip getIidKindServer
let serverTile = lvl `at` tpos
lvlClient = (EM.! lid) . sdungeon $ sClient
clientTile = lvlClient `at` tpos
hiddenTile = Tile.hideAs cotile serverTile
revealEmbeds = unless (EM.null embeds) $ do
s <- getState
let ais = map (\iid -> (iid, getItemBody iid s)) (EM.keys embeds)
execUpdAtomic $ UpdSpotItemBag (CEmbed lid tpos) embeds ais
tryApplyEmbeds = mapM_ tryApplyEmbed
(sortEmbeds cops getKind serverTile embeds)
tryApplyEmbed (iid, kit) = do
let itemFull = itemToF iid
legal = permittedApply localTime maxBound calmE itemFull kit
(object1, object2) = partItemShortest (bfid sb) factionD localTime
itemFull (1, [])
name = makePhrase [object1, object2]
case legal of
Left ApplyNoEffects -> return ()
Left reqFail ->
execSfxAtomic $ SfxMsgFid (bfid sb)
$ SfxExpected ("embedded" <+> name) reqFail
_ -> itemEffectEmbedded voluntary source lid tpos iid
underFeet = tpos == bpos sb
if chessDist tpos (bpos sb) > 1
then return $ Just AlterDistant
else if Just clientTile == hiddenTile then
if not underFeet && alterSkill <= 1
then return $ Just AlterUnskilled
else do
execUpdAtomic $ UpdSearchTile source tpos serverTile
revealEmbeds
case EM.lookup tpos $ lentry lvl of
Nothing -> return ()
Just entry -> execUpdAtomic $ UpdSpotEntry lid [(tpos, entry)]
unless (Tile.isDoor coTileSpeedup serverTile
|| Tile.isChangable coTileSpeedup serverTile
|| EM.null embeds) $ do
execSfxAtomic $ SfxTrigger source tpos
tryApplyEmbeds
return Nothing
else if clientTile == serverTile then
if not underFeet && alterSkill < Tile.alterMinSkill coTileSpeedup serverTile
then return $ Just AlterUnskilled
else do
let changeTo tgroup = do
lvl2 <- getLevel lid
let nightCond kt = not (Tile.kindHasFeature TK.Walkable kt
&& Tile.kindHasFeature TK.Clear kt)
|| (if lnight lvl2 then id else not)
(Tile.kindHasFeature TK.Dark kt)
mtoTile <- rndToAction $ opick cotile tgroup nightCond
toTile <- maybe (rndToAction
$ fromMaybe (error $ "" `showFailure` tgroup)
<$> opick cotile tgroup (const True))
return
mtoTile
unless (toTile == serverTile) $ do
execUpdAtomic $ UpdAlterTile lid tpos serverTile toTile
case hiddenTile of
Just tHidden ->
execUpdAtomic $ UpdAlterTile lid tpos tHidden toTile
Nothing -> return ()
case (Tile.isExplorable coTileSpeedup serverTile,
Tile.isExplorable coTileSpeedup toTile) of
(False, True) -> execUpdAtomic $ UpdAlterExplorable lid 1
(True, False) -> execUpdAtomic $ UpdAlterExplorable lid (-1)
_ -> return ()
case EM.lookup tpos (lembed lvl2) of
Just bag -> do
s <- getState
let ais = map (\iid -> (iid, getItemBody iid s)) (EM.keys bag)
execUpdAtomic $ UpdLoseItemBag (CEmbed lid tpos) bag ais
Nothing -> return ()
embedItem lid tpos toTile
feats = TK.tfeature $ okind cotile serverTile
toAlter feat =
case feat of
TK.OpenTo tgroup -> Just tgroup
TK.CloseTo tgroup -> Just tgroup
TK.ChangeTo tgroup -> Just tgroup
_ -> Nothing
groupsToAlterTo | underFeet = []
| otherwise = mapMaybe toAlter feats
if null groupsToAlterTo && EM.null embeds then
return $ Just AlterNothing
else
if underFeet || EM.notMember tpos (lfloor lvl) then
if underFeet || not (occupiedBigLvl tpos lvl)
&& not (occupiedProjLvl tpos lvl) then do
unless (EM.null embeds) $ do
unless (bproj sb || underFeet) $
execSfxAtomic $ SfxTrigger source tpos
revealEmbeds
tryApplyEmbeds
case groupsToAlterTo of
[] -> return ()
[groupToAlterTo] -> changeTo groupToAlterTo
l -> error $ "tile changeable in many ways" `showFailure` l
return Nothing
else return $ Just AlterBlockActor
else return $ Just AlterBlockItem
else
return $ Just AlterNothing
reqWait :: MonadServerAtomic m => ActorId -> m ()
{-# INLINE reqWait #-}
reqWait source = do
actorSk <- currentSkillsServer source
unless (Ability.getSk Ability.SkWait actorSk > 0) $
execFailure source ReqWait WaitUnskilled
reqWait10 :: MonadServerAtomic m => ActorId -> m ()
{-# INLINE reqWait10 #-}
reqWait10 source = do
actorSk <- currentSkillsServer source
unless (Ability.getSk Ability.SkWait actorSk >= 4) $
execFailure source ReqWait10 WaitUnskilled
reqYell :: MonadServerAtomic m => ActorId -> m ()
reqYell source = do
actorSk <- currentSkillsServer source
if | Ability.getSk Ability.SkWait actorSk > 0 ->
execSfxAtomic $ SfxTaunt True source
| Ability.getSk Ability.SkMove actorSk <= 0
|| Ability.getSk Ability.SkDisplace actorSk <= 0
|| Ability.getSk Ability.SkMelee actorSk <= 0 ->
execSfxAtomic $ SfxTaunt False source
| otherwise ->
return ()
reqMoveItems :: MonadServerAtomic m
=> ActorId -> [(ItemId, Int, CStore, CStore)] -> m ()
reqMoveItems source l = do
actorSk <- currentSkillsServer source
if Ability.getSk Ability.SkMoveItem actorSk > 0 then do
b <- getsState $ getActorBody source
actorMaxSk <- getsState $ getActorMaxSkills source
let calmE = calmEnough b actorMaxSk
mapM_ (reqMoveItem source calmE) l
else execFailure source (ReqMoveItems l) MoveItemUnskilled
reqMoveItem :: MonadServerAtomic m
=> ActorId -> Bool -> (ItemId, Int, CStore, CStore) -> m ()
reqMoveItem aid calmE (iid, k, fromCStore, toCStore) = do
b <- getsState $ getActorBody aid
let fromC = CActor aid fromCStore
req = ReqMoveItems [(iid, k, fromCStore, toCStore)]
toC <- case toCStore of
CGround -> pickDroppable False aid b
_ -> return $! CActor aid toCStore
bagBefore <- getsState $ getContainerBag toC
if
| k < 1 || fromCStore == toCStore -> execFailure aid req ItemNothing
| toCStore == CEqp && eqpOverfull b k ->
execFailure aid req EqpOverfull
| (fromCStore == CSha || toCStore == CSha) && not calmE ->
execFailure aid req ItemNotCalm
| otherwise -> do
upds <- generalMoveItem True iid k fromC toC
mapM_ execUpdAtomic upds
itemFull <- getsState $ itemToFull iid
when (fromCStore == CGround) $
discoverIfMinorEffects toC iid (itemKindId itemFull)
when (toCStore `elem` [CEqp, COrgan]
&& fromCStore `notElem` [CEqp, COrgan]
|| fromCStore == CSha) $ do
let beforeIt = case iid `EM.lookup` bagBefore of
Nothing -> []
Just (_, it2) -> it2
randomResetTimeout k iid itemFull beforeIt toC
reqProject :: MonadServerAtomic m
=> ActorId
-> Point
-> Int
-> ItemId
-> CStore
-> m ()
reqProject source tpxy eps iid cstore = do
let req = ReqProject tpxy eps iid cstore
b <- getsState $ getActorBody source
actorMaxSk <- getsState $ getActorMaxSkills source
let calmE = calmEnough b actorMaxSk
if cstore == CSha && not calmE then execFailure source req ItemNotCalm
else do
mfail <- projectFail source source tpxy eps False iid cstore False
maybe (return ()) (execFailure source req) mfail
reqApply :: MonadServerAtomic m
=> ActorId
-> ItemId
-> CStore
-> m ()
reqApply aid iid cstore = do
let req = ReqApply iid cstore
b <- getsState $ getActorBody aid
actorMaxSk <- getsState $ getActorMaxSkills aid
let calmE = calmEnough b actorMaxSk
if cstore == CSha && not calmE then execFailure aid req ItemNotCalm
else do
bag <- getsState $ getBodyStoreBag b cstore
case EM.lookup iid bag of
Nothing -> execFailure aid req ApplyOutOfReach
Just kit -> do
itemFull <- getsState $ itemToFull iid
actorSk <- currentSkillsServer aid
localTime <- getsState $ getLocalTime (blid b)
let skill = Ability.getSk Ability.SkApply actorSk
legal = permittedApply localTime skill calmE itemFull kit
case legal of
Left reqFail -> execFailure aid req reqFail
Right _ -> applyItem aid iid cstore
reqGameRestart :: MonadServerAtomic m
=> ActorId -> GroupName ModeKind -> Challenge
-> m ()
reqGameRestart aid groupName scurChalSer = do
isNoConfirms <- isNoConfirmsGame
factionD <- getsState sfactionD
let fidsUI = map fst $ filter (\(_, fact) -> fhasUI (gplayer fact))
(EM.assocs factionD)
itemD <- getsState sitemD
dungeon <- getsState sdungeon
let ais = EM.assocs itemD
minLid = fst $ minimumBy (Ord.comparing (ldepth . snd))
$ EM.assocs dungeon
unless isNoConfirms $
mapM_ (\fid -> do
execUpdAtomic $ UpdSpotItemBag (CTrunk fid minLid originPoint)
EM.empty ais
revealItems fid) fidsUI
b <- getsState $ getActorBody aid
oldSt <- getsState $ gquit . (EM.! bfid b) . sfactionD
factionAn <- getsServer sfactionAn
generationAn <- getsServer sgenerationAn
execUpdAtomic $ UpdQuitFaction
(bfid b)
oldSt
(Just $ Status Restart (fromEnum $ blid b) (Just groupName))
(Just (factionAn, generationAn))
modifyServer $ \ser -> ser { sbreakASAP = True
, soptionsNxt = (soptionsNxt ser) {scurChalSer} }
reqGameDropAndExit :: MonadServerAtomic m => ActorId -> m ()
reqGameDropAndExit aid = do
b <- getsState $ getActorBody aid
oldSt <- getsState $ gquit . (EM.! bfid b) . sfactionD
execUpdAtomic $ UpdQuitFaction
(bfid b)
oldSt
(Just $ Status Camping (fromEnum $ blid b) Nothing)
Nothing
modifyServer $ \ser -> ser { sbreakASAP = True
, sbreakLoop = True }
reqGameSaveAndExit :: MonadServerAtomic m => ActorId -> m ()
reqGameSaveAndExit aid = do
b <- getsState $ getActorBody aid
oldSt <- getsState $ gquit . (EM.! bfid b) . sfactionD
execUpdAtomic $ UpdQuitFaction
(bfid b)
oldSt
(Just $ Status Camping (fromEnum $ blid b) Nothing)
Nothing
modifyServer $ \ser -> ser { sbreakASAP = True
, swriteSave = True }
reqGameSave :: MonadServer m => m ()
reqGameSave =
modifyServer $ \ser -> ser { sbreakASAP = True
, swriteSave = True }
reqTactic :: MonadServerAtomic m => FactionId -> Ability.Tactic -> m ()
reqTactic fid toT = do
fromT <- getsState $ ftactic . gplayer . (EM.! fid) . sfactionD
execUpdAtomic $ UpdTacticFaction fid toT fromT
reqAutomate :: MonadServerAtomic m => FactionId -> m ()
reqAutomate fid = execUpdAtomic $ UpdAutoFaction fid True