gameServer/ServerState.hs
author koda
Sat, 05 Feb 2011 22:22:16 +0100
changeset 4924 616b618814b5
parent 4622 8bdc879ee6b2
child 4975 31da8979e5b1
permissions -rw-r--r--
show dual head mode some love
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
4622
8bdc879ee6b2 Implement room delegation when admin lefts it
unc0rr
parents: 4601
diff changeset
    30
    io $ clientRoomM rnc ci
3458
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
4622
8bdc879ee6b2 Implement room delegation when admin lefts it
unc0rr
parents: 4601
diff changeset
    36
    io $ 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
4622
8bdc879ee6b2 Implement room delegation when admin lefts it
unc0rr
parents: 4601
diff changeset
    44
    io $ 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