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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
|
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- | The implementation of our custom game server monads. Just as any other
-- component of the library, this implementation can be substituted.
module Implementation.MonadServerImplementation
( executorSer
#ifdef EXPOSE_INTERNAL
-- * Internal operations
, SerState(..), SerImplementation(..)
#endif
) where
import Prelude ()
import Game.LambdaHack.Core.Prelude
import Control.Concurrent
import Control.Concurrent.Async
import qualified Control.Exception as Ex
import qualified Control.Monad.IO.Class as IO
import Control.Monad.Trans.State.Strict hiding (State)
import qualified Data.EnumMap.Strict as EM
import qualified Data.Text.IO as T
import Options.Applicative
(defaultPrefs, execParserPure, handleParseResult)
import System.Exit (ExitCode)
import System.IO (hFlush, stdout)
import Game.LambdaHack.Atomic
import Game.LambdaHack.Client
import Game.LambdaHack.Common.Kind
import Game.LambdaHack.Common.MonadStateRead
import qualified Game.LambdaHack.Common.Save as Save
import Game.LambdaHack.Common.State
import Game.LambdaHack.Common.Thread
import Game.LambdaHack.Server
import Game.LambdaHack.Server.BroadcastAtomic
import Game.LambdaHack.Server.HandleAtomicM
import Game.LambdaHack.Server.MonadServer
import Game.LambdaHack.Server.ProtocolM
import Game.LambdaHack.Server.State
import Implementation.MonadClientImplementation (executorCli)
data SerState = SerState
{ serState :: State -- ^ current global state
, serServer :: StateServer -- ^ current server state
, serDict :: ConnServerDict -- ^ client-server connection information
, serToSave :: Save.ChanSave (State, StateServer)
-- ^ connection to the save thread
}
-- | Server state transformation monad.
newtype SerImplementation a =
SerImplementation {runSerImplementation :: StateT SerState IO a}
deriving (Monad, Functor, Applicative)
instance MonadStateRead SerImplementation where
{-# INLINE getsState #-}
getsState f = SerImplementation $ gets $ f . serState
instance MonadStateWrite SerImplementation where
{-# INLINE modifyState #-}
modifyState f = SerImplementation $ state $ \serS ->
let !newSerS = serS {serState = f $ serState serS}
in ((), newSerS)
{-# INLINE putState #-}
putState newSerState = SerImplementation $ state $ \serS ->
let !newSerS = serS {serState = newSerState}
in ((), newSerS)
instance MonadServer SerImplementation where
{-# INLINE getsServer #-}
getsServer f = SerImplementation $ gets $ f . serServer
{-# INLINE modifyServer #-}
modifyServer f = SerImplementation $ state $ \serS ->
let !newSerS = serS {serServer = f $ serServer serS}
in ((), newSerS)
chanSaveServer = SerImplementation $ gets serToSave
liftIO = SerImplementation . IO.liftIO
instance MonadServerComm SerImplementation where
{-# INLINE getsDict #-}
getsDict f = SerImplementation $ gets $ f . serDict
{-# INLINE putDict #-}
putDict newSerDict = SerImplementation $ state $ \serS ->
let !newSerS = serS {serDict = newSerDict}
in ((), newSerS)
liftIO = SerImplementation . IO.liftIO
instance MonadServerAtomic SerImplementation where
execUpdAtomic cmd = do
oldState <- getState
(ps, atomicBroken, executedOnServer) <- handleCmdAtomicServer cmd
when executedOnServer $ cmdAtomicSemSer oldState cmd
handleAndBroadcast ps atomicBroken (UpdAtomic cmd)
execUpdAtomicSer cmd = SerImplementation $ StateT $ \cliS -> do
cliSNewOrE <- Ex.try
$ execStateT (runSerImplementation $ handleUpdAtomic cmd)
cliS
case cliSNewOrE of
Left AtomicFail{} -> return (False, cliS)
Right !cliSNew ->
-- We know @cliSNew@ differs only in @serState@.
return (True, cliSNew)
execUpdAtomicFid fid cmd = SerImplementation $ StateT $ \cliS -> do
-- Don't catch anything; assume exceptions impossible.
let sFid = sclientStates (serServer cliS) EM.! fid
cliSNew <- execStateT (runSerImplementation $ handleUpdAtomic cmd)
cliS {serState = sFid}
-- We know @cliSNew@ differs only in @serState@.
let serServerNew = (serServer cliS)
{sclientStates = EM.insert fid (serState cliSNew)
$ sclientStates $ serServer cliS}
!newCliS = cliS {serServer = serServerNew}
return ((), newCliS)
execUpdAtomicFidCatch fid cmd = SerImplementation $ StateT $ \cliS -> do
let sFid = sclientStates (serServer cliS) EM.! fid
cliSNewOrE <- Ex.try
$ execStateT (runSerImplementation $ handleUpdAtomic cmd)
cliS {serState = sFid}
case cliSNewOrE of
Left AtomicFail{} -> return (False, cliS)
Right cliSNew -> do
-- We know @cliSNew@ differs only in @serState@.
let serServerNew = (serServer cliS)
{sclientStates = EM.insert fid (serState cliSNew)
$ sclientStates $ serServer cliS}
!newCliS = cliS {serServer = serServerNew}
return (True, newCliS)
execSfxAtomic sfx = do
ps <- posSfxAtomic sfx
handleAndBroadcast ps [] (SfxAtomic sfx)
execSendPer = sendPer
-- Don't inline this, to keep GHC hard work inside the library
-- for easy access of code analysis tools.
-- | Run the main server loop, with the given arguments and empty
-- initial states, in the @IO@ monad.
executorSer :: COps -> CCUI -> ServerOptions -> UIOptions -> IO ()
executorSer cops@COps{corule} ccui soptionsNxtCmdline sUIOptions = do
soptionsNxtRaw <- case uOverrideCmdline sUIOptions of
[] -> return soptionsNxtCmdline
args -> handleParseResult $ execParserPure defaultPrefs serverOptionsPI args
-- Options for the clients modified with the configuration file.
let clientOptions = applyUIOptions cops sUIOptions
$ sclientOptions soptionsNxtRaw
soptionsNxt = soptionsNxtRaw {sclientOptions = clientOptions}
-- Partially applied main loop of the clients.
executorClient startsNewGame =
executorCli ccui sUIOptions clientOptions startsNewGame cops
-- Wire together game content, the main loop of game clients
-- and the game server loop.
let stateToFileName (_, ser) =
ssavePrefixSer (soptions ser) <> Save.saveNameSer corule
totalState serToSave = SerState
{ serState = updateCOpsAndCachedData (const cops) emptyState
-- state is empty, so the cached data is left empty and untouched
, serServer = emptyStateServer
, serDict = EM.empty
, serToSave
}
m = loopSer soptionsNxt executorClient
exe = evalStateT (runSerImplementation m) . totalState
exeWithSaves = Save.wrapInSaves cops stateToFileName exe
unwrapEx e = case Ex.fromException e of
Just (ExceptionInLinkedThread _ ex) -> unwrapEx ex
_ -> e
-- Wait for clients to exit even in case of server crash
-- (or server and client crash), which gives them time to save
-- and report their own inconsistencies, if any.
Ex.handle (\ex -> case Ex.fromException (unwrapEx ex) :: Maybe ExitCode of
Just{} ->
-- User-forced shutdown, not crash, so the intention is
-- to keep old saves and also clients may be not ready to save.
Ex.throwIO ex
_ -> do
Ex.uninterruptibleMask_ $ threadDelay 1000000
-- let clients report their errors and save
moveAside <- Save.bkpAllSaves corule clientOptions
when moveAside $
T.hPutStrLn stdout
"The game crashed, so savefiles are moved aside."
hFlush stdout
Ex.throwIO ex -- crash eventually, which kills clients
)
exeWithSaves
-- T.hPutStrLn stdout "Server exiting, waiting for clients."
-- hFlush stdout
waitForChildren childrenServer -- no crash, wait for clients indefinitely
-- T.hPutStrLn stdout "Server exiting now."
-- hFlush stdout
|
