gameServer/HandlerUtils.hs
author Vekhir
Wed, 10 Jan 2024 20:54:29 +0100
changeset 16012 2c92499daa67
parent 15900 fc3cb23fd26f
permissions -rw-r--r--
Fix server build with modern mtl library
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
10460
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     1
{-
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     2
 * Hedgewars, a free turn based strategy game
11046
47a8c19ecb60 more copyright fixes
sheepluva
parents: 10460
diff changeset
     3
 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>
10460
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     4
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     5
 * This program is free software; you can redistribute it and/or modify
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     6
 * it under the terms of the GNU General Public License as published by
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     7
 * the Free Software Foundation; version 2 of the License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     8
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
     9
 * This program is distributed in the hope that it will be useful,
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    10
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    11
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    12
 * GNU General Public License for more details.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    13
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    14
 * You should have received a copy of the GNU General Public License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    15
 * along with this program; if not, write to the Free Software
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    16
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    17
 \-}
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 10212
diff changeset
    18
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    19
module HandlerUtils where
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    20
16012
2c92499daa67 Fix server build with modern mtl library
Vekhir
parents: 15900
diff changeset
    21
import Control.Monad
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    22
import Control.Monad.Reader
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3435
diff changeset
    23
import qualified Data.ByteString.Char8 as B
4614
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    24
import Data.List
15900
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 11046
diff changeset
    25
import Data.Word
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    26
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    27
import RoomsAndClients
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    28
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
    29
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    30
10212
5fb3bb2de9d2 Some fixes to voting + small refactoring
unc0rr
parents: 10194
diff changeset
    31
type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
5fb3bb2de9d2 Some fixes to voting + small refactoring
unc0rr
parents: 10194
diff changeset
    32
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    33
thisClient :: Reader (ClientIndex, IRnC) ClientInfo
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    34
thisClient = do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    35
    (ci, rnc) <- ask
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    36
    return $ rnc `client` ci
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    37
3568
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3543
diff changeset
    38
thisRoom :: Reader (ClientIndex, IRnC) RoomInfo
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3543
diff changeset
    39
thisRoom = do
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3543
diff changeset
    40
    (ci, rnc) <- ask
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3543
diff changeset
    41
    let ri = clientRoom rnc ci
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3543
diff changeset
    42
    return $ rnc `room` ri
ae89cf0735dc A bunch of reimplemented commands
unc0rr
parents: 3543
diff changeset
    43
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3435
diff changeset
    44
clientNick :: Reader (ClientIndex, IRnC) B.ByteString
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    45
clientNick = liftM nick thisClient
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    46
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    47
roomOthersChans :: Reader (ClientIndex, IRnC) [ClientChan]
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    48
roomOthersChans = do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    49
    (ci, rnc) <- ask
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    50
    let ri = clientRoom rnc ci
3542
f216b24aeb7f - Fix a function
unc0rr
parents: 3501
diff changeset
    51
    return $ map (sendChan . client rnc) $ filter (/= ci) (roomClients rnc ri)
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    52
4614
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    53
roomSameClanChans :: Reader (ClientIndex, IRnC) [ClientChan]
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    54
roomSameClanChans = do
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    55
    (ci, rnc) <- ask
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    56
    let ri = clientRoom rnc ci
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    57
    let otherRoomClients = map (client rnc) . filter (/= ci) $ roomClients rnc ri
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    58
    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
    59
    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
    60
    return $ map sendChan sameClanClients
4614
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    61
3543
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3542
diff changeset
    62
roomClientsChans :: Reader (ClientIndex, IRnC) [ClientChan]
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3542
diff changeset
    63
roomClientsChans = do
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3542
diff changeset
    64
    (ci, rnc) <- ask
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3542
diff changeset
    65
    let ri = clientRoom rnc ci
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3542
diff changeset
    66
    return $ map (sendChan . client rnc) (roomClients rnc ri)
d84a93b985c1 Reimplement TOGGLE_READY command
unc0rr
parents: 3542
diff changeset
    67
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    68
thisClientChans :: Reader (ClientIndex, IRnC) [ClientChan]
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    69
thisClientChans = do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    70
    (ci, rnc) <- ask
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4614
diff changeset
    71
    return [sendChan (rnc `client` ci)]
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents:
diff changeset
    72
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
    73
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
    74
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
    75
    (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
    76
    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
    77
    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
    78
15900
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 11046
diff changeset
    79
allChansProto :: Reader (ClientIndex, IRnC) [(ClientChan, Word16)]
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 11046
diff changeset
    80
allChansProto = do
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 11046
diff changeset
    81
    (ci, rnc) <- ask
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 11046
diff changeset
    82
    return . map ((\c -> (sendChan c, clientProto c)) . client rnc) $ allClients rnc
fc3cb23fd26f Allow to see rooms of incompatible versions in the lobby
S.D.
parents: 11046
diff changeset
    83
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4986
diff changeset
    84
answerClient :: [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4614
diff changeset
    85
answerClient msg = liftM ((: []) . flip AnswerClients msg) thisClientChans
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    86
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    87
allRoomInfos :: Reader (a, IRnC) [RoomInfo]
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3500
diff changeset
    88
allRoomInfos = liftM ((\irnc -> map (room irnc) $ allRooms irnc) . snd) ask
4614
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    89
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    90
clientByNick :: B.ByteString -> Reader (ClientIndex, IRnC) (Maybe ClientIndex)
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    91
clientByNick n = do
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    92
    (_, rnc) <- ask
26661bf28dd5 Reimplement some more protocol commands
unc0rr
parents: 3568
diff changeset
    93
    let allClientIDs = allClients rnc
9433
f0a8ac191839 Push demo to idle checker on game finish
unc0rr
parents: 9109
diff changeset
    94
    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
    95
10194
7025bd3c3131 Allow to save and delete room config in room
unc0rr
parents: 9433
diff changeset
    96
7025bd3c3131 Allow to save and delete room config in room
unc0rr
parents: 9433
diff changeset
    97
roomAdminOnly :: Reader (ClientIndex, IRnC) [Action] -> Reader (ClientIndex, IRnC) [Action]
7025bd3c3131 Allow to save and delete room config in room
unc0rr
parents: 9433
diff changeset
    98
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
    99
7025bd3c3131 Allow to save and delete room config in room
unc0rr
parents: 9433
diff changeset
   100
7025bd3c3131 Allow to save and delete room config in room
unc0rr
parents: 9433
diff changeset
   101
serverAdminOnly :: Reader (ClientIndex, IRnC) [Action] -> Reader (ClientIndex, IRnC) [Action]
7025bd3c3131 Allow to save and delete room config in room
unc0rr
parents: 9433
diff changeset
   102
serverAdminOnly h = thisClient >>= \cl -> if isAdministrator cl then h else return []