netserver/Miscutils.hs
author unc0rr
Mon, 27 Oct 2008 16:49:42 +0000
changeset 1431 21ca09524f9c
parent 1411 df78c9571bc7
child 1461 87e5a6c3882c
permissions -rw-r--r--
Draw dark background under chat text
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
849
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     1
module Miscutils where
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     2
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     3
import IO
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
     4
import Control.Concurrent.STM
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
     5
import Data.Word
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
     6
import Data.Char
901
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
     7
import Data.List
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
     8
import Maybe (fromJust)
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
     9
import qualified Data.Map as Map
849
82ac0596aa3c Start work on standalone server in Haskell
unc0rr
parents:
diff changeset
    10
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    11
data ClientInfo =
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    12
 ClientInfo
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    13
	{
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    14
		chan :: TChan [String],
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    15
		handle :: Handle,
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    16
		nick :: String,
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
    17
		protocol :: Word16,
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    18
		room :: String,
1391
735f6d43780b Implement kick
unc0rr
parents: 1383
diff changeset
    19
		isMaster :: Bool,
1403
b8c921ed0f13 Bring back old 'Go!' button behavior
unc0rr
parents: 1402
diff changeset
    20
		isReady :: Bool,
1391
735f6d43780b Implement kick
unc0rr
parents: 1383
diff changeset
    21
		forceQuit :: Bool
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    22
	}
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    23
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    24
instance Eq ClientInfo where
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    25
	a1 == a2 = handle a1 == handle a2
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    26
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
    27
data HedgehogInfo =
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
    28
	HedgehogInfo String String
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
    29
1083
3448dd03483f Further work on dedicated server
unc0rr
parents: 1082
diff changeset
    30
data TeamInfo =
3448dd03483f Further work on dedicated server
unc0rr
parents: 1082
diff changeset
    31
	TeamInfo
3448dd03483f Further work on dedicated server
unc0rr
parents: 1082
diff changeset
    32
	{
1329
69ddc231a911 - Only team owner can remove team from the list
unc0rr
parents: 1327
diff changeset
    33
		teamowner :: String,
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
    34
		teamname :: String,
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
    35
		teamcolor :: String,
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
    36
		teamgrave :: String,
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
    37
		teamfort :: String,
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
    38
		difficulty :: Int,
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
    39
		hhnum :: Int,
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
    40
		hedgehogs :: [HedgehogInfo]
1083
3448dd03483f Further work on dedicated server
unc0rr
parents: 1082
diff changeset
    41
	}
3448dd03483f Further work on dedicated server
unc0rr
parents: 1082
diff changeset
    42
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    43
data RoomInfo =
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    44
	RoomInfo
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    45
	{
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    46
		name :: String,
1083
3448dd03483f Further work on dedicated server
unc0rr
parents: 1082
diff changeset
    47
		password :: String,
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
    48
		roomProto :: Word16,
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
    49
		teams :: [TeamInfo],
1333
b0b0510eb82d - Fix a bug with chosen map (new clinet gets wrong information)
unc0rr
parents: 1329
diff changeset
    50
		gamemap :: String,
1350
99a921e292f4 - Reverse the order of client list
unc0rr
parents: 1333
diff changeset
    51
		gameinprogress :: Bool,
1396
abb28dcb6d0d - Send additional info on rooms
unc0rr
parents: 1391
diff changeset
    52
		playersIn :: Int,
1403
b8c921ed0f13 Bring back old 'Go!' button behavior
unc0rr
parents: 1402
diff changeset
    53
		readyPlayers :: Int,
1411
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
    54
		isRestrictedJoins :: Bool,
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
    55
		isRestrictedTeams :: Bool,
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
    56
		params :: Map.Map String [String]
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    57
	}
1411
df78c9571bc7 Room control menu works
unc0rr
parents: 1408
diff changeset
    58
createRoom = (RoomInfo "" "" 0 [] "+rnd+" False 1 0 False False Map.empty)
851
8ffa4ad0d8ea Introduce function to atomically change both lists
unc0rr
parents: 849
diff changeset
    59
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    60
type ClientsTransform = [ClientInfo] -> [ClientInfo]
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    61
type RoomsTransform = [RoomInfo] -> [RoomInfo]
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    62
type HandlesSelector = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [Handle]
1304
05cebf68ebd8 Start refactoring standalone server (prepare to change protocol)
unc0rr
parents: 1083
diff changeset
    63
type CmdHandler = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [String] -> (ClientsTransform, RoomsTransform, [(HandlesSelector, [String])])
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    64
901
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
    65
902
3cc10f0aae37 Finish conversion
unc0rr
parents: 901
diff changeset
    66
roomByName :: String -> [RoomInfo] -> RoomInfo
3cc10f0aae37 Finish conversion
unc0rr
parents: 901
diff changeset
    67
roomByName roomName rooms = fromJust $ find (\room -> roomName == name room) rooms
3cc10f0aae37 Finish conversion
unc0rr
parents: 901
diff changeset
    68
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    69
tselect :: [ClientInfo] -> STM ([String], ClientInfo)
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    70
tselect = foldl orElse retry . map (\ci -> (flip (,) ci) `fmap` readTChan (chan ci))
889
3bf9dc791f45 Some work on newhwserv
unc0rr
parents: 852
diff changeset
    71
894
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
    72
maybeRead :: Read a => String -> Maybe a
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
    73
maybeRead s = case reads s of
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
    74
	[(x, rest)] | all isSpace rest -> Just x
2ca76a7f3121 - Fixed some bugs
unc0rr
parents: 890
diff changeset
    75
	_         -> Nothing
901
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
    76
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
    77
deleteBy2t :: (a -> b -> Bool) -> b -> [a] -> [a]
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
    78
deleteBy2t _  _ [] = []
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
    79
deleteBy2t eq x (y:ys) = if y `eq` x then ys else y : deleteBy2t eq x ys
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
    80
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
    81
deleteFirstsBy2t :: (a -> b -> Bool) -> [a] -> [b] -> [a]
2f5ce9a584f9 Modify protocol implementation functions interface (convertation not yet finished)
unc0rr
parents: 895
diff changeset
    82
deleteFirstsBy2t eq =  foldl (flip (deleteBy2t eq))
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    83
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    84
sameRoom :: HandlesSelector
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    85
sameRoom client clients rooms = map handle $ filter (\ci -> room ci == room client) clients
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    86
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    87
othersInRoom :: HandlesSelector
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    88
othersInRoom client clients rooms = map handle $ filter (client /=) $ filter (\ci -> room ci == room client) clients
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    89
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    90
fromRoom :: String -> HandlesSelector
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    91
fromRoom roomName _ clients _ = map handle $ filter (\ci -> room ci == roomName) clients
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    92
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    93
clientOnly :: HandlesSelector
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    94
clientOnly client _ _ = [handle client]
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    95
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    96
noChangeClients :: ClientsTransform
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    97
noChangeClients a = a
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    98
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
    99
modifyClient :: ClientInfo -> ClientsTransform
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
   100
modifyClient _ [] = error "modifyClient: no such client"
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   101
modifyClient client (cl:cls) =
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   102
	if cl == client then
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   103
		client : cls
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   104
	else
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   105
		cl : (modifyClient client cls)
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   106
1408
fab171a17968 Unset ready status after round
unc0rr
parents: 1403
diff changeset
   107
modifyRoomClients :: RoomInfo -> (ClientInfo -> ClientInfo) -> ClientsTransform
fab171a17968 Unset ready status after round
unc0rr
parents: 1403
diff changeset
   108
modifyRoomClients clientsroom clientMod clients = map (\c -> if name clientsroom == room c then clientMod c else c) clients
fab171a17968 Unset ready status after round
unc0rr
parents: 1403
diff changeset
   109
1082
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   110
noChangeRooms :: RoomsTransform
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   111
noChangeRooms a = a
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   112
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   113
addRoom :: RoomInfo -> RoomsTransform
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   114
addRoom room rooms = room:rooms
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   115
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   116
removeRoom :: String -> RoomsTransform
596b1dcdc1df - Modify network protocol to use new delimiter
unc0rr
parents: 902
diff changeset
   117
removeRoom roomname rooms = filter (\rm -> roomname /= name rm) rooms
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
   118
1321
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
   119
modifyRoom :: RoomInfo -> RoomsTransform
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
   120
modifyRoom _ [] = error "changeRoomConfig: no such room"
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
   121
modifyRoom room (rm:rms) =
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
   122
	if name room == name rm then
d7dc4e86201e - Add protocol description (just started)
unc0rr
parents: 1317
diff changeset
   123
		room : rms
1317
13cf8c5a7428 Server now fully supports game options
unc0rr
parents: 1304
diff changeset
   124
	else
1402
c164f215f7d2 - Fix a bug screwing rooms list
unc0rr
parents: 1396
diff changeset
   125
		rm : modifyRoom room rms
1327
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   126
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   127
modifyTeam :: RoomInfo -> TeamInfo -> RoomInfo
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   128
modifyTeam room team = room{teams = replaceTeam team $ teams room}
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   129
	where
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   130
	replaceTeam _ [] = error "modifyTeam: no such team"
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   131
	replaceTeam team (t:teams) =
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   132
		if teamname team == teamname t then
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   133
			team : teams
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   134
		else
9d43a6e6b9ca Can choose hedgehogs number now
unc0rr
parents: 1321
diff changeset
   135
			t : replaceTeam team teams