gameServer/ServerState.hs
author Vekhir
Sun, 11 Feb 2024 20:33:15 +0100
changeset 15985 e42d1819b150
parent 15983 2c92499daa67
permissions -rw-r--r--
Revive cabal build of the game server
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
10460
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 9973
diff changeset
     1
{-
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 9973
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: 9973
diff changeset
     4
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 9973
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: 9973
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: 9973
diff changeset
     7
 * the Free Software Foundation; version 2 of the License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 9973
diff changeset
     8
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 9973
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: 9973
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: 9973
diff changeset
    11
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 9973
diff changeset
    12
 * GNU General Public License for more details.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 9973
diff changeset
    13
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 9973
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: 9973
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: 9973
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: 9973
diff changeset
    17
 \-}
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 9973
diff changeset
    18
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    19
module ServerState
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    20
    (
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    21
    module RoomsAndClients,
9973
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 8452
diff changeset
    22
    module JoinsMonitor,
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    23
    clientRoomA,
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    24
    ServerState(..),
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3458
diff changeset
    25
    client's,
3502
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    26
    allClientsS,
8452
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8371
diff changeset
    27
    allRoomsS,
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 3807
diff changeset
    28
    roomClientsS,
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
    29
    sameProtoClientsS,
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 3807
diff changeset
    30
    io
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    31
    ) where
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    32
15983
2c92499daa67 Fix server build with modern mtl library
Vekhir
parents: 11046
diff changeset
    33
import Control.Monad
3741
73246d25dfe1 Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents: 3645
diff changeset
    34
import Control.Monad.State.Strict
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
    35
import Data.Set as Set(Set)
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
    36
import Data.Word
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    37
----------------------
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    38
import RoomsAndClients
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    39
import CoreTypes
9973
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 8452
diff changeset
    40
import JoinsMonitor
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    41
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4975
diff changeset
    42
data ServerState = ServerState {
3807
7e4f7ed41790 zero span is undefined, use -1 instead
unc0rr
parents: 3741
diff changeset
    43
        clientIndex :: !(Maybe ClientIndex),
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4975
diff changeset
    44
        serverInfo :: !ServerInfo,
3807
7e4f7ed41790 zero span is undefined, use -1 instead
unc0rr
parents: 3741
diff changeset
    45
        removedClients :: !(Set.Set ClientIndex),
9973
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 8452
diff changeset
    46
        roomsClients :: !MRnC,
7589978c9912 Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents: 8452
diff changeset
    47
        joinsMonitor :: !JoinsMonitor
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    48
    }
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    49
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    50
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4975
diff changeset
    51
clientRoomA :: StateT ServerState IO RoomIndex
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    52
clientRoomA = do
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    53
    (Just ci) <- gets clientIndex
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    54
    rnc <- gets roomsClients
4622
8bdc879ee6b2 Implement room delegation when admin lefts it
unc0rr
parents: 4601
diff changeset
    55
    io $ clientRoomM rnc ci
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    56
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4975
diff changeset
    57
client's :: (ClientInfo -> a) -> StateT ServerState IO a
3501
a3159a410e5c Reimplement more core actions
unc0rr
parents: 3458
diff changeset
    58
client's f = do
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    59
    (Just ci) <- gets clientIndex
11cd56019f00 Make some more protocol commands work
unc0rr
parents:
diff changeset
    60
    rnc <- gets roomsClients
4622
8bdc879ee6b2 Implement room delegation when admin lefts it
unc0rr
parents: 4601
diff changeset
    61
    io $ client'sM rnc f ci
3645
c0b3f1bb9316 Reimplement REMOVE_TEAM
unc0rr
parents: 3566
diff changeset
    62
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4975
diff changeset
    63
allClientsS :: StateT ServerState IO [ClientInfo]
3502
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    64
allClientsS = gets roomsClients >>= liftIO . clientsM
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    65
8452
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8371
diff changeset
    66
allRoomsS :: StateT ServerState IO [RoomInfo]
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8371
diff changeset
    67
allRoomsS = gets roomsClients >>= liftIO . roomsM
170afc3ac39f Also rooms per version stats
unc0rr
parents: 8371
diff changeset
    68
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4975
diff changeset
    69
roomClientsS :: RoomIndex -> StateT ServerState IO [ClientInfo]
3502
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    70
roomClientsS ri = do
ad38c653b7d9 Some more progress
unc0rr
parents: 3501
diff changeset
    71
    rnc <- gets roomsClients
4622
8bdc879ee6b2 Implement room delegation when admin lefts it
unc0rr
parents: 4601
diff changeset
    72
    io $ roomClientsM rnc ri
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 3807
diff changeset
    73
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
    74
sameProtoClientsS :: Word16 -> StateT ServerState IO [ClientInfo]
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
sameProtoClientsS p = liftM f allClientsS
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
    where
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
        f = filter (\c -> clientProto c == p)
8371
0551b5c3de9a - Start work on checker
unc0rr
parents: 6541
diff changeset
    78
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4975
diff changeset
    79
io :: IO a -> StateT ServerState IO a
4601
08ae94dd4c0d io = liftIO
unc0rr
parents: 3807
diff changeset
    80
io = liftIO