gameServer/HandlerUtils.hs
author unc0rr
Sun, 28 Sep 2014 00:49:04 +0400
branchqmlfrontend
changeset 10428 7c25297720f1
parent 10212 5fb3bb2de9d2
child 10460 8dcea9087d75
permissions -rw-r--r--
More refactoring: move PoC preview getting code into flib
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
     1
module HandlerUtils where
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
     2
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
     3
import Control.Monad.Reader
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3435
diff changeset
     4
import qualified Data.ByteString.Char8 as B
4614
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
     5
import Data.List
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
     6
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
     7
import RoomsAndClients
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
     8
import CoreTypes
9109
878f06e9c484 - Fix issue 521 by resending FULLMAPCONFIG on game finish to those who joined mid-game. Semitested.
unc0rr
parents: 6541
diff changeset
     9
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    10
10212
5fb3bb2de9d2 Some fixes to voting + small refactoring
unc0rr
parents: 10194
diff changeset
    11
type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
5fb3bb2de9d2 Some fixes to voting + small refactoring
unc0rr
parents: 10194
diff changeset
    12
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    13
thisClient :: Reader (ClientIndex, IRnC) ClientInfo
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    14
thisClient = do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    15
    (ci, rnc) <- ask
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    16
    return $ rnc `client` ci
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    17
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3543
diff changeset
    18
thisRoom :: Reader (ClientIndex, IRnC) RoomInfo
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3543
diff changeset
    19
thisRoom = do
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3543
diff changeset
    20
    (ci, rnc) <- ask
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3543
diff changeset
    21
    let ri = clientRoom rnc ci
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3543
diff changeset
    22
    return $ rnc `room` ri
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3543
diff changeset
    23
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3435
diff changeset
    24
clientNick :: Reader (ClientIndex, IRnC) B.ByteString
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    25
clientNick = liftM nick thisClient
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    26
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    27
roomOthersChans :: Reader (ClientIndex, IRnC) [ClientChan]
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    28
roomOthersChans = do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    29
    (ci, rnc) <- ask
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    30
    let ri = clientRoom rnc ci
3542
f216b24aeb7f - Fix a function
unc0rr
parents: 3501
diff changeset
    31
    return $ map (sendChan . client rnc) $ filter (/= ci) (roomClients rnc ri)
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    32
4614
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    33
roomSameClanChans :: Reader (ClientIndex, IRnC) [ClientChan]
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    34
roomSameClanChans = do
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    35
    (ci, rnc) <- ask
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    36
    let ri = clientRoom rnc ci
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    37
    let otherRoomClients = map (client rnc) . filter (/= ci) $ roomClients rnc ri
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    38
    let cl = rnc `client` ci
4986
33fe91b2bcbf Use Maybe for storing client's clan, allows less error-prone spectator checks
unc0rr
parents: 4975
diff changeset
    39
    let sameClanClients = Prelude.filter (\c -> clientClan c == clientClan cl) otherRoomClients
33fe91b2bcbf Use Maybe for storing client's clan, allows less error-prone spectator checks
unc0rr
parents: 4975
diff changeset
    40
    return $ map sendChan sameClanClients
4614
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    41
3543
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3542
diff changeset
    42
roomClientsChans :: Reader (ClientIndex, IRnC) [ClientChan]
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3542
diff changeset
    43
roomClientsChans = do
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3542
diff changeset
    44
    (ci, rnc) <- ask
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3542
diff changeset
    45
    let ri = clientRoom rnc ci
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3542
diff changeset
    46
    return $ map (sendChan . client rnc) (roomClients rnc ri)
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3542
diff changeset
    47
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    48
thisClientChans :: Reader (ClientIndex, IRnC) [ClientChan]
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    49
thisClientChans = do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    50
    (ci, rnc) <- ask
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4614
diff changeset
    51
    return [sendChan (rnc `client` ci)]
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    52
6541
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 4989
diff changeset
    53
sameProtoChans :: Reader (ClientIndex, IRnC) [ClientChan]
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 4989
diff changeset
    54
sameProtoChans = do
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 4989
diff changeset
    55
    (ci, rnc) <- ask
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 4989
diff changeset
    56
    let p = clientProto (rnc `client` ci)
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 4989
diff changeset
    57
    return . map sendChan . filter (\c -> clientProto c == p) . map (client rnc) $ allClients rnc
08ed346ed341 Send full room info on room add and update events. Less(?) traffic, but current frontend doesn't behave good with this change to server.
unc0rr
parents: 4989
diff changeset
    58
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4986
diff changeset
    59
answerClient :: [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4614
diff changeset
    60
answerClient msg = liftM ((: []) . flip AnswerClients msg) thisClientChans
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    61
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    62
allRoomInfos :: Reader (a, IRnC) [RoomInfo]
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    63
allRoomInfos = liftM ((\irnc -> map (room irnc) $ allRooms irnc) . snd) ask
4614
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    64
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    65
clientByNick :: B.ByteString -> Reader (ClientIndex, IRnC) (Maybe ClientIndex)
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    66
clientByNick n = do
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    67
    (_, rnc) <- ask
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    68
    let allClientIDs = allClients rnc
9433
f0a8ac191839 Push demo to idle checker on game finish
unc0rr
parents: 9109
diff changeset
    69
    return $ find (\clId -> let cl = client rnc clId in n == nick cl && not (isChecker cl)) allClientIDs
4614
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    70
10194
7025bd3c3131 Allow to save and delete room config in room
unc0rr
parents: 9433
diff changeset
    71
7025bd3c3131 Allow to save and delete room config in room
unc0rr
parents: 9433
diff changeset
    72
roomAdminOnly :: Reader (ClientIndex, IRnC) [Action] -> Reader (ClientIndex, IRnC) [Action]
7025bd3c3131 Allow to save and delete room config in room
unc0rr
parents: 9433
diff changeset
    73
roomAdminOnly h = thisClient >>= \cl -> if isMaster cl then h else return []
7025bd3c3131 Allow to save and delete room config in room
unc0rr
parents: 9433
diff changeset
    74
7025bd3c3131 Allow to save and delete room config in room
unc0rr
parents: 9433
diff changeset
    75
7025bd3c3131 Allow to save and delete room config in room
unc0rr
parents: 9433
diff changeset
    76
serverAdminOnly :: Reader (ClientIndex, IRnC) [Action] -> Reader (ClientIndex, IRnC) [Action]
7025bd3c3131 Allow to save and delete room config in room
unc0rr
parents: 9433
diff changeset
    77
serverAdminOnly h = thisClient >>= \cl -> if isAdministrator cl then h else return []