1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
{-# LANGUAGE FlexibleContexts #-}
-- | Semantics of responses sent by the server to clients.
module Game.LambdaHack.Client.HandleResponseM
( MonadClientAtomic(..), MonadClientWriteRequest(..)
, handleResponse
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import Game.LambdaHack.Atomic (UpdAtomic)
import Game.LambdaHack.Client.AI
import Game.LambdaHack.Client.HandleAtomicM
import Game.LambdaHack.Client.MonadClient
import Game.LambdaHack.Client.Request
import Game.LambdaHack.Client.Response
import Game.LambdaHack.Client.UI
import Game.LambdaHack.Common.MonadStateRead
import Game.LambdaHack.Common.State
-- | Monad for executing atomic game state transformations on a client.
class MonadClient m => MonadClientAtomic m where
-- | Execute an atomic update that changes the client's 'State'.
execUpdAtomic :: UpdAtomic -> m ()
-- | Put state that is intended to be the result of performing
-- an atomic update by the server on its copy of the client's 'State'.
execPutState :: State -> m ()
-- | Client monad in which one can send requests to the client.
class MonadClient m => MonadClientWriteRequest m where
sendRequestAI :: RequestAI -> m ()
sendRequestUI :: RequestUI -> m ()
clientHasUI :: m Bool
-- | Handle server responses.
--
-- Note that for clients communicating with the server over the net,
-- @RespUpdAtomicNoState@ should be used, because executing a single command
-- is cheaper than sending the whole state over the net.
-- However, for the standalone exe mode, with clients in the same process
-- as the server, a pointer to the state set with @execPutState@ is cheaper.
handleResponse :: ( MonadClientSetup m
, MonadClientUI m
, MonadClientAtomic m
, MonadClientWriteRequest m )
=> Response -> m ()
handleResponse cmd = case cmd of
RespUpdAtomic newState cmdA -> do
oldState <- getState
execPutState newState
cmdAtomicSemCli oldState cmdA
hasUI <- clientHasUI
when hasUI $ watchRespUpdAtomicUI cmdA
RespUpdAtomicNoState cmdA -> do
oldState <- getState
execUpdAtomic cmdA
cmdAtomicSemCli oldState cmdA
hasUI <- clientHasUI
when hasUI $ watchRespUpdAtomicUI cmdA
RespQueryAI aid -> do
cmdC <- queryAI aid
sendRequestAI cmdC
RespSfxAtomic sfx ->
watchRespSfxAtomicUI sfx
RespQueryUIunderAI -> do
req <- queryUIunderAI
sendRequestUI req
RespQueryUI -> do
-- Stop displaying the prompt, if any.
modifySession $ \sess -> sess {sreqDelay = ReqDelayNot}
sreqPending <- getsSession sreqPending
req <- case sreqPending of
Nothing -> do
-- Server sending @RespQueryUI@ means that it's sent everything
-- and is now ready to receive a request ASAP, so no point polling
-- and instead query the player repeatedly until request generated.
let loop = do
mreq <- queryUI
maybe loop pure mreq
loop
Just reqPending -> do
modifySession $ \sess -> sess {sreqPending = Nothing}
return reqPending
sendRequestUI req
|
