/
SampleMonadServer.hs
122 lines (110 loc) · 4.87 KB
/
SampleMonadServer.hs
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
{-# LANGUAGE CPP, GeneralizedNewtypeDeriving #-}
-- | The main game action monad type implementation. Just as any other
-- component of the library, this implementation can be substituted.
-- This module should not be imported anywhere except in 'Action'
-- to expose the executor to any code using the library.
module Game.LambdaHack.SampleImplementation.SampleMonadServer
( executorSer
#ifdef EXPOSE_INTERNAL
-- * Internal operations
, SerImplementation
#endif
) where
import Prelude ()
import Prelude.Compat
import Control.Concurrent
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 Data.Maybe
import System.FilePath
import Game.LambdaHack.Atomic.BroadcastAtomicWrite
import Game.LambdaHack.Atomic.CmdAtomic
import Game.LambdaHack.Atomic.MonadAtomic
import Game.LambdaHack.Atomic.MonadStateWrite
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.CommonServer
import Game.LambdaHack.Server.FileServer
import Game.LambdaHack.Server.MonadServer
import Game.LambdaHack.Server.ProtocolServer
import Game.LambdaHack.Server.State
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
getState = SerImplementation $ gets serState
getsState f = SerImplementation $ gets $ f . serState
instance MonadStateWrite SerImplementation where
modifyState f = SerImplementation $ state $ \serS ->
let newSerS = serS {serState = f $ serState serS}
in newSerS `seq` ((), newSerS)
putState s = SerImplementation $ state $ \serS ->
let newSerS = serS {serState = s}
in newSerS `seq` ((), newSerS)
instance MonadServer SerImplementation where
getServer = SerImplementation $ gets serServer
getsServer f = SerImplementation $ gets $ f . serServer
modifyServer f = SerImplementation $ state $ \serS ->
let newSerS = serS {serServer = f $ serServer serS}
in newSerS `seq` ((), newSerS)
putServer s = SerImplementation $ state $ \serS ->
let newSerS = serS {serServer = s}
in newSerS `seq` ((), newSerS)
liftIO = SerImplementation . IO.liftIO
saveChanServer = SerImplementation $ gets serToSave
instance MonadServerReadRequest SerImplementation where
getDict = SerImplementation $ gets serDict
getsDict f = SerImplementation $ gets $ f . serDict
modifyDict f =
SerImplementation $ modify $ \serS -> serS {serDict = f $ serDict serS}
putDict s =
SerImplementation $ modify $ \serS -> serS {serDict = s}
liftIO = SerImplementation . IO.liftIO
-- | The game-state semantics of atomic commands
-- as computed on the server.
instance MonadAtomic SerImplementation where
execAtomic = handleAndBroadcastServer
-- | Send an atomic action to all clients that can see it.
handleAndBroadcastServer :: (MonadStateWrite m, MonadServerReadRequest m)
=> CmdAtomic -> m ()
handleAndBroadcastServer atomic = do
persOld <- getsServer sper
knowEvents <- getsServer $ sknowEvents . sdebugSer
handleAndBroadcast knowEvents persOld resetFidPerception resetLitInDungeon
sendUpdateAI sendUpdateUI atomic
-- | Run an action in the @IO@ monad, with undefined state.
executorSer :: SerImplementation () -> IO ()
executorSer m = do
let saveFile (_, ser) =
fromMaybe "save" (ssavePrefixSer (sdebugSer ser))
<.> saveName
exe serToSave =
evalStateT (runSerImplementation m)
SerState { serState = emptyState
, serServer = emptyStateServer
, serDict = EM.empty
, serToSave
}
exeWithSaves = Save.wrapInSaves tryCreateDir encodeEOF saveFile exe
-- 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.
-- TODO: send them a message to tell users "server crashed"
-- and then wait for them to exit normally.
Ex.handle (\(ex :: Ex.SomeException) -> do
threadDelay 1000000 -- let clients report their errors
Ex.throw ex) -- crash eventually, which kills clients
exeWithSaves
waitForChildren childrenServer -- no crash, wait for clients indefinitely