gameServer/ServerState.hs
author unc0rr
Sun, 30 Jan 2011 20:38:40 +0300
branchserver_refactor
changeset 4618 0f56fa511f65
parent 4601 08ae94dd4c0d
child 4622 8bdc879ee6b2
permissions -rw-r--r--
Reimplement KICK
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
     1
module ServerState
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
     2
    (
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
     3
    module RoomsAndClients,
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
     4
    clientRoomA,
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
     5
    ServerState(..),
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3458
diff changeset
     6
    client's,
3502
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
     7
    allClientsS,
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 3807
diff changeset
     8
    roomClientsS,
08ae94dd4c0d io = liftIO
unc0rr
parents: 3807
diff changeset
     9
    io
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    10
    ) where
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    11
3741
73246d25dfe1 Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents: 3645
diff changeset
    12
import Control.Monad.State.Strict
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3502
diff changeset
    13
import Data.Set as Set
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    14
----------------------
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    15
import RoomsAndClients
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    16
import CoreTypes
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    17
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    18
data ServerState = ServerState {
3807
7e4f7ed41790 zero span is undefined, use -1 instead
unc0rr
parents: 3741
diff changeset
    19
        clientIndex :: !(Maybe ClientIndex),
7e4f7ed41790 zero span is undefined, use -1 instead
unc0rr
parents: 3741
diff changeset
    20
        serverInfo :: !ServerInfo,
7e4f7ed41790 zero span is undefined, use -1 instead
unc0rr
parents: 3741
diff changeset
    21
        removedClients :: !(Set.Set ClientIndex),
7e4f7ed41790 zero span is undefined, use -1 instead
unc0rr
parents: 3741
diff changeset
    22
        roomsClients :: !MRnC
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    23
    }
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    24
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    25
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    26
clientRoomA :: StateT ServerState IO RoomIndex
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    27
clientRoomA = do
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    28
    (Just ci) <- gets clientIndex
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    29
    rnc <- gets roomsClients
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    30
    liftIO $ clientRoomM rnc ci
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    31
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3458
diff changeset
    32
client's :: (ClientInfo -> a) -> StateT ServerState IO a
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3458
diff changeset
    33
client's f = do
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    34
    (Just ci) <- gets clientIndex
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    35
    rnc <- gets roomsClients
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3458
diff changeset
    36
    liftIO $ client'sM rnc f ci
3645
c0b3f1bb9316 Reimplement REMOVE_TEAM
unc0rr
parents: 3566
diff changeset
    37
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3458
diff changeset
    38
allClientsS :: StateT ServerState IO [ClientInfo]
3502
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    39
allClientsS = gets roomsClients >>= liftIO . clientsM
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    40
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    41
roomClientsS :: RoomIndex -> StateT ServerState IO [ClientInfo]
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    42
roomClientsS ri = do
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    43
    rnc <- gets roomsClients
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    44
    liftIO $ roomClientsM rnc ri
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 3807
diff changeset
    45
08ae94dd4c0d io = liftIO
unc0rr
parents: 3807
diff changeset
    46
io :: IO a -> StateT ServerState IO a
08ae94dd4c0d io = liftIO
unc0rr
parents: 3807
diff changeset
    47
io = liftIO