hedgewars: comparison gameServer/Actions.hs

equal deleted inserted replaced

-:d24257910f8d
+:aaefa587e277
 | ByeClient B.ByteString
 | KickClient ClientIndex
 | KickRoomClient ClientIndex
 | BanClient NominalDiffTime B.ByteString ClientIndex
 | BanIP B.ByteString NominalDiffTime B.ByteString
+| BanNick B.ByteString NominalDiffTime B.ByteString
 | BanList
 | Unban B.ByteString
-| ChangeMaster
+| ChangeMaster (Maybe ClientIndex)
 | RemoveClientTeams ClientIndex
 | ModifyClient (ClientInfo -> ClientInfo)
 | ModifyClient2 ClientIndex (ClientInfo -> ClientInfo)
 | ModifyRoomClients (ClientInfo -> ClientInfo)
 | ModifyRoom (RoomInfo -> RoomInfo)
 | PingAll
 | StatsAction
 | RestartServer
 | AddNick2Bans B.ByteString B.ByteString UTCTime
 | AddIP2Bans B.ByteString B.ByteString UTCTime
-| CheckBanned
+| CheckBanned Bool
 | SaveReplay
 type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
 io $
 infoM "Clients" (show ci ++ " quits: " ++ B.unpack msg)
 when loggedIn $ processAction $ AnswerClients clientsChans ["LOBBY:LEFT", clNick, msg]
-mapM processAction
+mapM_ processAction
 [
 AnswerClients [chan] ["BYE", msg]
 , ModifyClient (\c -> c{nick = "", logonPassed = False}) -- this will effectively hide client from others while he isn't deleted from list
 ]
 clNick <- client's nick
 chans <- othersChans
 if master then
 if playersNum > 1 then
-mapM_ processAction [ChangeMaster, NoticeMessage AdminLeft, RemoveClientTeams ci, AnswerClients chans ["LEFT", clNick, msg]]
+mapM_ processAction [ChangeMaster Nothing, NoticeMessage AdminLeft, RemoveClientTeams ci, AnswerClients chans ["LEFT", clNick, msg]]
 else
 processAction RemoveRoom
 else
 mapM_ processAction [RemoveClientTeams ci, AnswerClients chans ["LEFT", clNick, msg]]
 readyPlayers = if ready then readyPlayers r - 1 else readyPlayers r
 }) ri
 moveClientToLobby rnc ci
-processAction ChangeMaster = do
+processAction (ChangeMaster delegateId)= do
 (Just ci) <- gets clientIndex
 proto <- client's clientProto
 ri <- clientRoomA
 rnc <- gets roomsClients
-newMasterId <- liftM (last . filter (/= ci)) . io $ roomClientsIndicesM rnc ri
+newMasterId <- liftM (\ids -> fromMaybe (last . filter (/= ci) $ ids) delegateId) . io $ roomClientsIndicesM rnc ri
 newMaster <- io $ client'sM rnc id newMasterId
 oldRoomName <- io $ room'sM rnc name ri
 oldMaster <- client's nick
+kicked <- client's isKickedFromServer
 thisRoomChans <- liftM (map sendChan) $ roomClientsS ri
-let newRoomName = if proto < 42 then nick newMaster else oldRoomName
+let newRoomName = if (proto < 42) || kicked then nick newMaster else oldRoomName
 mapM_ processAction [
 ModifyRoom (\r -> r{masterID = newMasterId
 , name = newRoomName
 , isRestrictedJoins = False
 , isRestrictedTeams = False
+, isRegisteredOnly = False
 , readyPlayers = if isReady newMaster then readyPlayers r else readyPlayers r + 1})
 , ModifyClient2 newMasterId (\c -> c{isMaster = True, isReady = True})
 , AnswerClients [sendChan newMaster] ["ROOM_CONTROL_ACCESS", "1"]
-, AnswerClients thisRoomChans ["WARNING", "New room admin is " `B.append` nick newMaster]
 , AnswerClients thisRoomChans ["CLIENT_FLAGS", "-h", oldMaster]
 , AnswerClients thisRoomChans ["CLIENT_FLAGS", "+hr", nick newMaster]
 ]
 newRoom' <- io $ room'sM rnc id ri
 readyPlayers = 0
 }
 )
 : UnreadyRoomClients
 : SendUpdateOnThisRoom
+: AnswerClients thisRoomChans ["ROUND_FINISHED"]
 : answerRemovedTeams
 processAction (SendTeamRemovalMessage teamName) = do
 chans <- othersChans
 p <- client's clientProto
 uid <- client's clUID
 haveSameNick <- liftM (not . null . tail . filter (\c -> caseInsensitiveCompare (nick c) n)) allClientsS
 if haveSameNick then
 if p < 38 then
-mapM_ processAction [ByeClient "Nickname is already in use", removeNick]
+processAction $ ByeClient "Nickname is already in use"
 else
-mapM_ processAction [NoticeMessage NickAlreadyInUse, removeNick]
+processAction $ NoticeMessage NickAlreadyInUse
 else
 do
 db <- gets (dbQueries . serverInfo)
 io $ writeChan db $ CheckAccount ci (hashUnique uid) n h
 return ()
-where
-removeNick = ModifyClient (\c -> c{nick = ""})
 processAction ClearAccountsCache = do
 dbq <- gets (dbQueries . serverInfo)
 io $ writeChan dbq ClearCache
 return ()
-processAction (ProcessAccountInfo info) =
+processAction (ProcessAccountInfo info) = do
 case info of
 HasAccount passwd isAdmin -> do
-chan <- client's sendChan
+b <- isBanned
-mapM_ processAction [AnswerClients [chan] ["ASKPASSWORD"], ModifyClient (\c -> c{webPassword = passwd, isAdministrator = isAdmin})]
+when (not b) $ do
-Guest ->
+chan <- client's sendChan
-processAction JoinLobby
+mapM_ processAction [AnswerClients [chan] ["ASKPASSWORD"], ModifyClient (\c -> c{webPassword = passwd, isAdministrator = isAdmin})]
+Guest -> do
+b <- isBanned
+when (not b) $
+processAction JoinLobby
 Admin -> do
 mapM_ processAction [ModifyClient (\cl -> cl{isAdministrator = True}), JoinLobby]
 chan <- client's sendChan
 processAction $ AnswerClients [chan] ["ADMIN_ACCESS"]
+where
+isBanned = do
+processAction $ CheckBanned False
+liftM B.null $ client's nick
 processAction JoinLobby = do
 chan <- client's sendChan
 clientNick <- client's nick
 processAction (KickClient kickId) = do
 modify (\s -> s{clientIndex = Just kickId})
 clHost <- client's host
 currentTime <- io getCurrentTime
 mapM_ processAction [
-AddIP2Bans clHost "60 seconds cooldown after kick" (addUTCTime 60 currentTime),
+AddIP2Bans clHost "60 seconds cooldown after kick" (addUTCTime 60 currentTime)
-ByeClient "Kicked"
+, ModifyClient (\c -> c{isKickedFromServer = True})
+, ByeClient "Kicked"
 ]
 processAction (BanClient seconds reason banId) = do
 modify (\s -> s{clientIndex = Just banId})
 mapM_ processAction [
 AddIP2Bans clHost msg (addUTCTime seconds currentTime)
 , KickClient banId
 ]
 processAction (BanIP ip seconds reason) = do
 currentTime <- io getCurrentTime
 let msg = B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]
 processAction $
 AddIP2Bans ip msg (addUTCTime seconds currentTime)
+processAction (BanNick n seconds reason) = do
+currentTime <- io getCurrentTime
+let msg =
+if seconds > 60 * 60 * 24 * 365 then
+B.concat ["Permanent ban (", reason, ")"]
+else
+B.concat ["Ban for ", B.pack . show $ seconds, " (", reason, ")"]
+processAction $
+AddNick2Bans n msg (addUTCTime seconds currentTime)
 processAction BanList = do
+time <- io $ getCurrentTime
 ch <- client's sendChan
-b <- gets (B.pack . unlines . map show . bans . serverInfo)
+b <- gets (B.intercalate "\n" . concatMap (ban2Str time) . bans . serverInfo)
 processAction $
 AnswerClients [ch] ["BANLIST", b]
+where
+ban2Str time (BanByIP b r t) = ["I", b, r, B.pack . show $ t `diffUTCTime` time]
+ban2Str time (BanByNick b r t) = ["N", b, r, B.pack . show $ t `diffUTCTime` time]
 processAction (Unban entry) = do
-processAction $ ModifyServerInfo (\s -> s{bans = filter f $ bans s})
+processAction $ ModifyServerInfo (\s -> s{bans = filter (not . f) $ bans s})
 where
 f (BanByIP bip _ _) = bip == entry
 f (BanByNick bn _ _) = bn == entry
 processAction (KickRoomClient kickId) = do
 modify (\s -> s{clientIndex = Just kickId})
 ch <- client's sendChan
 mapM_ processAction [AnswerClients [ch] ["KICKED"], MoveToLobby "kicked"]
 modify (\s -> s{clientIndex = Just newClId})
 mapM_ processAction
 [
 AnswerClients [sendChan cl] ["CONNECTED", "Hedgewars server http://www.hedgewars.org/", serverVersion]
-, CheckBanned
+, CheckBanned True
 , AddIP2Bans (host cl) "Reconnected too fast" (addUTCTime 10 $ connectTime cl)
 ]
 processAction (AddNick2Bans n reason expiring) = do
 (Just ci) <- gets clientIndex
 rc <- gets removedClients
 when (not $ ci `Set.member` rc)
 $ processAction $ ModifyServerInfo (\s -> s{bans = BanByIP ip reason expiring : bans s})
-processAction CheckBanned = do
+processAction (CheckBanned byIP) = do
 clTime <- client's connectTime
 clNick <- client's nick
 clHost <- client's host
 si <- gets serverInfo
 let validBans = filter (checkNotExpired clTime) $ bans si
-let ban = L.find (checkBan clHost clNick) $ validBans
+let ban = L.find (checkBan byIP clHost clNick) $ validBans
 mapM_ processAction $
 ModifyServerInfo (\s -> s{bans = validBans})
 : [ByeClient (getBanReason $ fromJust ban) | isJust ban]
 where
 checkNotExpired testTime (BanByIP _ _ time) = testTime `diffUTCTime` time <= 0
 checkNotExpired testTime (BanByNick _ _ time) = testTime `diffUTCTime` time <= 0
-checkBan ip _ (BanByIP bip _ _) = bip `B.isPrefixOf` ip
+checkBan True ip _ (BanByIP bip _ _) = bip `B.isPrefixOf` ip
-checkBan _ n (BanByNick bn _ _) = bn == n
+checkBan False _ n (BanByNick bn _ _) = caseInsensitiveCompare bn n
+checkBan _ _ _ _ = False
 getBanReason (BanByIP _ msg _) = msg
 getBanReason (BanByNick _ msg _) = msg
 processAction PingAll = do
 rnc <- gets roomsClients

branch	webgl
changeset 8330	aaefa587e277
parent 8247	d7cf4a9ce685
child 8444	75db7bb8dce8