--- a/QTfrontend/main.cpp Sun Apr 12 12:50:43 2009 +0000
+++ b/QTfrontend/main.cpp Sun Apr 12 12:51:25 2009 +0000
@@ -250,12 +250,21 @@
bindir->cd("bin"); // workaround over NSIS installer
cfgdir->setPath(cfgdir->homePath());
+#ifdef __APPLE__
+ if (checkForDir(cfgdir->absolutePath() + "/Library/Application Support/Hedgewars"))
+ {
+ checkForDir(cfgdir->absolutePath() + "/Library/Application Support/Hedgewars/Demos");
+ checkForDir(cfgdir->absolutePath() + "/Library/Application Support/Hedgewars/Saves");
+ }
+ cfgdir->cd("/Library/Application Support/Hedgewars");
+#else
if (checkForDir(cfgdir->absolutePath() + "/.hedgewars"))
{
checkForDir(cfgdir->absolutePath() + "/.hedgewars/Demos");
checkForDir(cfgdir->absolutePath() + "/.hedgewars/Saves");
}
cfgdir->cd(".hedgewars");
+#endif
datadir->cd(bindir->absolutePath());
datadir->cd(*cDataDir);
--- a/hedgewars/uGears.pas Sun Apr 12 12:50:43 2009 +0000
+++ b/hedgewars/uGears.pas Sun Apr 12 12:51:25 2009 +0000
@@ -1543,7 +1543,7 @@
end;
// unC0Rr, while it is true user can watch value on map screen, IMO this (and check above) should be enforced in UI
// - is there a good place to put values for the different widgets to check? Right now they are kind of disconnected.
- //it'd be nice if divide teams, forts mode and hh per map could all be checked by the team widget, or maybe disable start button
+ //it would be nice if divide teams, forts mode and hh per map could all be checked by the team widget, or maybe disable start button
TryDo(Count <= MaxHedgehogs, 'Too many hedgehogs for this map! (max # is ' + inttostr(MaxHedgehogs) + ')', true);
while (Count > 0) do
begin
--- a/netserver/CMakeLists.txt Sun Apr 12 12:50:43 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,32 +0,0 @@
-find_program(ghc_executable ghc)
-
-if (NOT ghc_executable)
- message(FATAL_ERROR "Cannot find GHC")
-endif(NOT ghc_executable)
-
-set(hwserver_sources
- HWProto.hs
- Miscutils.hs
- Opts.hs
- hedgewars-server.hs
- )
-
-set(hwserv_main ${hedgewars_SOURCE_DIR}/netserver/hedgewars-server.hs)
-
-set(ghc_flags
- --make ${hwserv_main}
- -i${hedgewars_SOURCE_DIR}/netserver
- -o ${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX}
- -odir ${CMAKE_CURRENT_BINARY_DIR}
- -hidir ${CMAKE_CURRENT_BINARY_DIR})
-
-add_custom_command(OUTPUT "${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX}"
- COMMAND "${ghc_executable}"
- ARGS ${ghc_flags}
- MAIN_DEPENDENCY ${hwserv_main}
- DEPENDS ${hwserver_sources}
- )
-
-add_custom_target(hedgewars-server ALL DEPENDS "${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX}")
-
-install(PROGRAMS "${EXECUTABLE_OUTPUT_PATH}/hedgewars-server${CMAKE_EXECUTABLE_SUFFIX}" DESTINATION bin)
--- a/netserver/Codec/Binary/Base64.hs Sun Apr 12 12:50:43 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,113 +0,0 @@
--- |
--- Module : Codec.Binary.Base64
--- Copyright : (c) 2007 Magnus Therning
--- License : BSD3
---
--- Implemented as specified in RFC 4648
--- (<http://tools.ietf.org/html/rfc4648>).
---
--- Further documentation and information can be found at
--- <http://www.haskell.org/haskellwiki/Library/Data_encoding>.
-module Codec.Binary.Base64
- ( encode
- , decode
- , decode'
- , chop
- , unchop
- ) where
-
-import Control.Monad
-import Data.Array
-import Data.Bits
-import Data.Maybe
-import Data.Word
-import qualified Data.Map as M
-
--- {{{1 enc/dec map
-_encMap =
- [ (0, 'A'), (1, 'B'), (2, 'C'), (3, 'D'), (4, 'E')
- , (5, 'F') , (6, 'G'), (7, 'H'), (8, 'I'), (9, 'J')
- , (10, 'K'), (11, 'L'), (12, 'M'), (13, 'N'), (14, 'O')
- , (15, 'P'), (16, 'Q'), (17, 'R'), (18, 'S'), (19, 'T')
- , (20, 'U'), (21, 'V'), (22, 'W'), (23, 'X'), (24, 'Y')
- , (25, 'Z'), (26, 'a'), (27, 'b'), (28, 'c'), (29, 'd')
- , (30, 'e'), (31, 'f'), (32, 'g'), (33, 'h'), (34, 'i')
- , (35, 'j'), (36, 'k'), (37, 'l'), (38, 'm'), (39, 'n')
- , (40, 'o'), (41, 'p'), (42, 'q'), (43, 'r'), (44, 's')
- , (45, 't'), (46, 'u'), (47, 'v'), (48, 'w'), (49, 'x')
- , (50, 'y'), (51, 'z'), (52, '0'), (53, '1'), (54, '2')
- , (55, '3'), (56, '4'), (57, '5'), (58, '6'), (59, '7')
- , (60, '8'), (61, '9'), (62, '+'), (63, '/') ]
-
--- {{{1 encodeArray
-encodeArray :: Array Word8 Char
-encodeArray = array (0, 64) _encMap
-
--- {{{1 decodeMap
-decodeMap :: M.Map Char Word8
-decodeMap = M.fromList [(snd i, fst i) | i <- _encMap]
-
--- {{{1 encode
--- | Encode data.
-encode :: [Word8]
- -> String
-encode = let
- pad n = take n $ repeat 0
- enc [] = ""
- enc l@[o] = (++ "==") . take 2 .enc $ l ++ pad 2
- enc l@[o1, o2] = (++ "=") . take 3 . enc $ l ++ pad 1
- enc (o1:o2:o3:os) = let
- i1 = o1 `shiftR` 2
- i2 = (o1 `shiftL` 4 .|. o2 `shiftR` 4) .&. 0x3f
- i3 = (o2 `shiftL` 2 .|. o3 `shiftR` 6) .&. 0x3f
- i4 = o3 .&. 0x3f
- in (foldr (\ i s -> (encodeArray ! i) : s) "" [i1, i2, i3, i4]) ++ enc os
- in enc
-
--- {{{1 decode
--- | Decode data (lazy).
-decode' :: String
- -> [Maybe Word8]
-decode' = let
- pad n = take n $ repeat $ Just 0
- dec [] = []
- dec l@[Just eo1, Just eo2] = take 1 . dec $ l ++ pad 2
- dec l@[Just eo1, Just eo2, Just eo3] = take 2 . dec $ l ++ pad 1
- dec (Just eo1:Just eo2:Just eo3:Just eo4:eos) = let
- o1 = eo1 `shiftL` 2 .|. eo2 `shiftR` 4
- o2 = eo2 `shiftL` 4 .|. eo3 `shiftR` 2
- o3 = eo3 `shiftL` 6 .|. eo4
- in Just o1:Just o2:Just o3:(dec eos)
- dec _ = [Nothing]
- in
- dec . map (flip M.lookup decodeMap) . takeWhile (/= '=')
-
--- | Decode data (strict).
-decode :: String
- -> Maybe [Word8]
-decode = sequence . decode'
-
--- {{{1 chop
--- | Chop up a string in parts.
---
--- The length given is rounded down to the nearest multiple of 4.
---
--- /Notes:/
---
--- * PEM requires lines that are 64 characters long.
---
--- * MIME requires lines that are at most 76 characters long.
-chop :: Int -- ^ length of individual lines
- -> String
- -> [String]
-chop n "" = []
-chop n s = let
- enc_len | n < 4 = 4
- | otherwise = n `div` 4 * 4
- in (take enc_len s) : chop n (drop enc_len s)
-
--- {{{1 unchop
--- | Concatenate the strings into one long string.
-unchop :: [String]
- -> String
-unchop = foldr (++) ""
--- a/netserver/Codec/Binary/UTF8/String.hs Sun Apr 12 12:50:43 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,97 +0,0 @@
---
--- |
--- Module : Codec.Binary.UTF8.String
--- Copyright : (c) Eric Mertens 2007
--- License : BSD3-style (see LICENSE)
---
--- Maintainer: emertens@galois.com
--- Stability : experimental
--- Portability : portable
---
--- Support for encoding UTF8 Strings to and from @[Word8]@
---
-
-module Codec.Binary.UTF8.String (
- encode
- , decode
- , encodeString
- , decodeString
- ) where
-
-import Data.Word (Word8)
-import Data.Bits ((.|.),(.&.),shiftL,shiftR)
-import Data.Char (chr,ord)
-
-default(Int)
-
--- | Encode a string using 'encode' and store the result in a 'String'.
-encodeString :: String -> String
-encodeString xs = map (toEnum . fromEnum) (encode xs)
-
--- | Decode a string using 'decode' using a 'String' as input.
--- | This is not safe but it is necessary if UTF-8 encoded text
--- | has been loaded into a 'String' prior to being decoded.
-decodeString :: String -> String
-decodeString xs = decode (map (toEnum . fromEnum) xs)
-
-replacement_character :: Char
-replacement_character = '\xfffd'
-
--- | Encode a Haskell String to a list of Word8 values, in UTF8 format.
-encode :: String -> [Word8]
-encode = concatMap (map fromIntegral . go . ord)
- where
- go oc
- | oc <= 0x7f = [oc]
-
- | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6)
- , 0x80 + oc .&. 0x3f
- ]
-
- | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12)
- , 0x80 + ((oc `shiftR` 6) .&. 0x3f)
- , 0x80 + oc .&. 0x3f
- ]
- | otherwise = [ 0xf0 + (oc `shiftR` 18)
- , 0x80 + ((oc `shiftR` 12) .&. 0x3f)
- , 0x80 + ((oc `shiftR` 6) .&. 0x3f)
- , 0x80 + oc .&. 0x3f
- ]
-
---
--- | Decode a UTF8 string packed into a list of Word8 values, directly to String
---
-decode :: [Word8] -> String
-decode [ ] = ""
-decode (c:cs)
- | c < 0x80 = chr (fromEnum c) : decode cs
- | c < 0xc0 = replacement_character : decode cs
- | c < 0xe0 = multi1
- | c < 0xf0 = multi_byte 2 0xf 0x800
- | c < 0xf8 = multi_byte 3 0x7 0x10000
- | c < 0xfc = multi_byte 4 0x3 0x200000
- | c < 0xfe = multi_byte 5 0x1 0x4000000
- | otherwise = replacement_character : decode cs
- where
- multi1 = case cs of
- c1 : ds | c1 .&. 0xc0 == 0x80 ->
- let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|. fromEnum (c1 .&. 0x3f)
- in if d >= 0x000080 then toEnum d : decode ds
- else replacement_character : decode ds
- _ -> replacement_character : decode cs
-
- multi_byte :: Int -> Word8 -> Int -> [Char]
- multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask))
- where
- aux 0 rs acc
- | overlong <= acc && acc <= 0x10ffff &&
- (acc < 0xd800 || 0xdfff < acc) &&
- (acc < 0xfffe || 0xffff < acc) = chr acc : decode rs
- | otherwise = replacement_character : decode rs
-
- aux n (r:rs) acc
- | r .&. 0xc0 == 0x80 = aux (n-1) rs
- $ shiftL acc 6 .|. fromEnum (r .&. 0x3f)
-
- aux _ rs _ = replacement_character : decode rs
-
--- a/netserver/HWProto.hs Sun Apr 12 12:50:43 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,536 +0,0 @@
-module HWProto
-(
- handleCmd
-) where
-
-import IO
-import Data.List
-import Data.Word
-import Data.Sequence(Seq, (|>), (><), fromList, empty)
-import Data.Foldable(toList)
-import Miscutils
-import Maybe
-import qualified Data.Map as Map
-import Opts
-
-teamToNet protocol team =
- if protocol <= 21 then
- ["ADD_TEAM", teamname team, teamgrave team, teamfort team, show $ difficulty team] ++ hhsInfo
- else
- ["ADD_TEAM", teamname team, teamgrave team, teamfort team, teamvoicepack team, teamowner team, show $ difficulty team] ++ hhsInfo
- where
- hhsInfo = concatMap (\(HedgehogInfo name hat) -> [name, hat]) $ hedgehogs team
-
-makeAnswer :: HandlesSelector -> [String] -> [Answer]
-makeAnswer func msg = [\_ -> (func, msg)]
-answerClientOnly, answerOthersRoom, answerSameRoom :: [String] -> [Answer]
-answerClientOnly = makeAnswer clientOnly
-answerOthersRoom = makeAnswer othersInRoom
-answerSameRoom = makeAnswer sameRoom
-answerSameProtoLobby = makeAnswer sameProtoLobbyClients
-answerOtherLobby = makeAnswer otherLobbyClients
-answerAll = makeAnswer allClients
-
-answerBadCmd = answerClientOnly ["ERROR", "Bad command, state or incorrect parameter"]
-answerNotMaster = answerClientOnly ["ERROR", "You cannot configure room parameters"]
-answerBadParam = answerClientOnly ["ERROR", "Bad parameter"]
-answerErrorMsg msg = answerClientOnly ["ERROR", msg]
-answerQuit msg = answerClientOnly ["BYE", msg]
-answerNickChosen = answerClientOnly ["ERROR", "The nick already chosen"]
-answerNickChooseAnother = answerClientOnly ["WARNING", "Choose another nick"]
-answerNick nick = answerClientOnly ["NICK", nick]
-answerProtocolKnown = answerClientOnly ["ERROR", "Protocol number already known"]
-answerBadInput = answerClientOnly ["ERROR", "Bad input"]
-answerProto protoNum = answerClientOnly ["PROTO", show protoNum]
-answerRoomsList list = answerClientOnly $ "ROOMS" : list
-answerRoomExists = answerClientOnly ["WARNING", "There's already a room with that name"]
-answerNoRoom = answerClientOnly ["WARNING", "There's no room with that name"]
-answerWrongPassword = answerClientOnly ["WARNING", "Wrong password"]
-answerCantAdd reason = answerClientOnly ["WARNING", "Cannot add team: " ++ reason]
-answerTeamAccepted team = answerClientOnly ["TEAM_ACCEPTED", teamname team]
-answerTooFewClans = answerClientOnly ["ERROR", "Too few clans in game"]
-answerRestricted = answerClientOnly ["WARNING", "Room joining restricted"]
-answerConnected = answerClientOnly ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"]
-answerNotOwner = answerClientOnly ["ERROR", "You do not own this team"]
-answerCannotCreateRoom = answerClientOnly ["WARNING", "Cannot create more rooms"]
-answerInfo client = answerClientOnly ["INFO", nick client, host client, proto2ver $ protocol client, roomInfo]
- where
- roomInfo = if not $ null $ room client then "room " ++ (room client) else "lobby"
-
-answerAbandoned protocol =
- if protocol < 20 then
- answerOthersRoom ["BYE", "Room abandoned"]
- else
- answerOthersRoom ["ROOMABANDONED"]
-
-answerChatString nick msg = answerOthersRoom ["CHAT_STRING", nick, msg]
-answerAddTeam protocol team = answerOthersRoom $ teamToNet protocol team
-answerRemoveTeam teamName = answerOthersRoom ["REMOVE_TEAM", teamName]
-answerMap mapName = answerOthersRoom ["MAP", mapName]
-answerHHNum teamName hhNumber = answerOthersRoom ["HH_NUM", teamName, show hhNumber]
-answerTeamColor teamName newColor = answerOthersRoom ["TEAM_COLOR", teamName, newColor]
-answerConfigParam paramName paramStrs = answerOthersRoom $ "CONFIG_PARAM" : paramName : paramStrs
-answerQuitInform nick msg =
- if not $ null msg then
- answerOthersRoom ["LEFT", nick, msg]
- else
- answerOthersRoom ["LEFT", nick]
-
-answerPartInform nick = answerOthersRoom ["LEFT", nick, "bye room"]
-answerQuitLobby nick msg =
- if not $ null nick then
- if not $ null msg then
- answerAll ["LOBBY:LEFT", nick, msg]
- else
- answerAll ["LOBBY:LEFT", nick]
- else
- []
-
-answerJoined nick = answerSameRoom ["JOINED", nick]
-answerRunGame = answerSameRoom ["RUN_GAME"]
-answerIsReady nick = answerSameRoom ["READY", nick]
-answerNotReady nick = answerSameRoom ["NOT_READY", nick]
-
-answerRoomAdded name = answerSameProtoLobby ["ROOM", "ADD", name]
-answerRoomDeleted name = answerSameProtoLobby ["ROOM", "DEL", name]
-
-answerFullConfig room = concatMap toAnswer (Map.toList $ params room) ++ (answerClientOnly ["MAP", gamemap room])
- where
- toAnswer (paramName, paramStrs) =
- answerClientOnly $ "CONFIG_PARAM" : paramName : paramStrs
-
-answerAllTeams protocol teams = concatMap toAnswer teams
- where
- toAnswer team =
- (answerClientOnly $ teamToNet protocol team) ++
- (answerClientOnly ["TEAM_COLOR", teamname team, teamcolor team]) ++
- (answerClientOnly ["HH_NUM", teamname team, show $ hhnum team])
-
-answerServerMessage client clients = [\serverInfo -> (clientOnly, "SERVER_MESSAGE" :
- [(mainbody serverInfo) ++ updateInfo ++ clientsIn ++ (lastHour serverInfo)])]
- where
- mainbody serverInfo = serverMessage serverInfo ++
- if isDedicated serverInfo then
- "<p align=center>Dedicated server</p>"
- else
- "<p align=center>Private server</p>"
-
- updateInfo = if protocol client < 23 then "<font color=yellow><h3>Hedgewars 0.9.9 is out!!! Please, update. Support for previous versions will be dropped soon</h3><p align=center><a href=http://hedgewars.org/download.html>Download page here</a></p><h4>New features are:</h4><ul><li>Voice packs</li><li>Precise aim</li><li>RC Plane weapon</li><li>...</li></ul></font>" else ""
- clientsIn = if protocol client < 20 then "<p align=left>" ++ (show $ length nicks) ++ " clients in: " ++ clientslist ++ "</p>" else []
- clientslist = if not $ null nicks then foldr1 (\a b -> a ++ ", " ++ b) nicks else ""
- lastHour serverInfo =
- if isDedicated serverInfo then
- "<p align=left>" ++ (show $ length $ lastHourUsers serverInfo) ++ " user logins in last hour</p>"
- else
- ""
- nicks = filter (not . null) $ map nick clients
-
-answerPing = makeAnswer allClients ["PING"]
-
--- Main state-independent cmd handler
-handleCmd :: CmdHandler
-handleCmd client _ rooms ("QUIT" : xs) =
- if null (room client) then
- (noChangeClients, noChangeRooms, answerQuit msg ++ (answerQuitLobby (nick client) msg) )
- else if isMaster client then
- (modifyRoomClients clRoom (\cl -> cl{isReady = False, partRoom = True}), removeRoom (room client), (answerQuit msg) ++ (answerQuitLobby (nick client) msg) ++ (answerAbandoned $ protocol client) ++ (answerRoomDeleted $ room client)) -- core disconnects clients on ROOMABANDONED answer
- else
- if not $ gameinprogress clRoom then
- (noChangeClients,
- modifyRoom clRoom{
- teams = othersTeams,
- playersIn = (playersIn clRoom) - 1,
- readyPlayers = newReadyPlayers
- },
- (answerQuit msg) ++
- (answerQuitInform (nick client) msg) ++
- (answerQuitLobby (nick client) msg) ++
- answerRemoveClientTeams)
- else
- (noChangeClients,
- modifyRoom clRoom{
- teams = othersTeams,
- leftTeams = (map teamname clientTeams) ++ (leftTeams clRoom),
- roundMsgs = (roundMsgs clRoom) >< (fromList rmTeamsMsgs),
- playersIn = (playersIn clRoom) - 1,
- readyPlayers = newReadyPlayers
- },
- (answerQuit msg) ++
- (answerQuitInform (nick client) msg) ++
- (answerQuitLobby (nick client) msg) ++
- answerRemoveClientTeams ++
- answerEngineTeamsRemoveMsg)
- where
- clRoom = roomByName (room client) rooms
- answerRemoveClientTeams = concatMap (\tn -> answerOthersRoom ["REMOVE_TEAM", teamname tn]) clientTeams
- (clientTeams, othersTeams) = partition (\t -> teamowner t == nick client) $ teams clRoom
- newReadyPlayers = if isReady client then (readyPlayers clRoom) - 1 else readyPlayers clRoom
- msg = if not $ null xs then head xs else ""
- rmTeamsMsgs = map (\team -> toEngineMsg $ 'F' : teamname team) clientTeams
- answerEngineTeamsRemoveMsg =
- if not $ null rmTeamsMsgs then
- answerOthersRoom $ "GAMEMSG" : rmTeamsMsgs
- else
- []
-
-handleCmd _ _ _ ["PING"] = -- core requsted
- (noChangeClients, noChangeRooms, answerPing)
-
-handleCmd _ _ _ ["ASKME"] = -- core requsted
- (noChangeClients, noChangeRooms, answerConnected)
-
-handleCmd _ _ _ ["PONG"] =
- (noChangeClients, noChangeRooms, [])
-
-handleCmd _ _ _ ["ERROR", msg] =
- (noChangeClients, noChangeRooms, answerErrorMsg msg)
-
-handleCmd _ clients _ ["INFO", asknick] =
- if noSuchClient then
- (noChangeClients, noChangeRooms, [])
- else
- (noChangeClients, noChangeRooms, answerInfo client)
- where
- maybeClient = find (\cl -> asknick == nick cl) clients
- noSuchClient = isNothing maybeClient
- client = fromJust maybeClient
-
-
--- check state and call state-dependent commmand handlers
-handleCmd client clients rooms cmd =
- if null (nick client) || protocol client == 0 then
- handleCmd_noInfo client clients rooms cmd
- else if null (room client) then
- handleCmd_noRoom client clients rooms cmd
- else
- handleCmd_inRoom client clients rooms cmd
-
-
--- 'no info' state - need to get protocol number and nickname
-onLoginFinished client clients =
- if (null $ nick client) || (protocol client == 0) then
- []
- else
- answerLobbyNicks ++
- (answerAll ["LOBBY:JOINED", nick client]) ++
- (answerServerMessage client clients)
- where
- lobbyNicks = filter (\n -> (not (null n)) && n /= nick client) $ map nick $ clients
- answerLobbyNicks = if not $ null lobbyNicks then
- answerClientOnly $ ["LOBBY:JOINED"] ++ lobbyNicks
- else
- []
-
-handleCmd_noInfo :: CmdHandler
-handleCmd_noInfo client clients _ ["NICK", newNick] =
- if not . null $ nick client then
- (noChangeClients, noChangeRooms, answerNickChosen)
- else if haveSameNick then
- (noChangeClients, noChangeRooms, answerNickChooseAnother)
- else
- (modifyClient client{nick = newNick}, noChangeRooms, answerNick newNick ++ (onLoginFinished client{nick = newNick} clients))
- where
- haveSameNick = isJust $ find (\cl -> newNick == nick cl) clients
-
-handleCmd_noInfo client clients _ ["PROTO", protoNum] =
- if protocol client > 0 then
- (noChangeClients, noChangeRooms, answerProtocolKnown)
- else if parsedProto == 0 then
- (noChangeClients, noChangeRooms, answerBadInput)
- else
- (modifyClient client{protocol = parsedProto}, noChangeRooms, answerProto parsedProto ++ (onLoginFinished client{protocol = parsedProto} clients))
- where
- parsedProto = fromMaybe 0 (maybeRead protoNum :: Maybe Word16)
-
-handleCmd_noInfo _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)
-
-
--- 'noRoom' clients state command handlers
-handleCmd_noRoom :: CmdHandler
-handleCmd_noRoom client clients rooms ["LIST"] =
- (noChangeClients, noChangeRooms, (answerRoomsList $ concatMap roomInfo $ sameProtoRooms))
- where
- roomInfo room = [
- name room,
- (show $ playersIn room) ++ "(" ++ (show $ length $ teams room) ++ ")",
- show $ gameinprogress room
- ]
- sameProtoRooms = filter (\r -> (roomProto r == protocol client) && (not $ isRestrictedJoins r)) rooms
-
-handleCmd_noRoom client _ rooms ["CREATE", newRoom, roomPassword] =
- if haveSameRoom then
- (noChangeClients, noChangeRooms, answerRoomExists)
- else
- (modifyClient client{room = newRoom, isMaster = True}, addRoom createRoom{name = newRoom, password = roomPassword, roomProto = (protocol client)}, (answerJoined $ nick client) ++ (answerNotReady $ nick client) ++ (answerRoomAdded newRoom))
- where
- haveSameRoom = isJust $ find (\room -> newRoom == name room) rooms
-
-handleCmd_noRoom client clients rooms ["CREATE", newRoom] =
- handleCmd_noRoom client clients rooms ["CREATE", newRoom, ""]
-
-handleCmd_noRoom client clients rooms ["JOIN", roomName, roomPassword] =
- if noSuchRoom then
- (noChangeClients, noChangeRooms, answerNoRoom)
- else if roomPassword /= password clRoom then
- (noChangeClients, noChangeRooms, answerWrongPassword)
- else if isRestrictedJoins clRoom then
- (noChangeClients, noChangeRooms, answerRestricted)
- else
- (modifyClient client{room = roomName}, modifyRoom clRoom{playersIn = 1 + playersIn clRoom}, (answerJoined $ nick client) ++ answerNicks ++ answerReady ++ (answerNotReady $ nick client) ++ answerFullConfig clRoom ++ answerTeams ++ watchRound)
- where
- noSuchRoom = isNothing $ find (\room -> roomName == name room && roomProto room == protocol client) rooms
- answerNicks = if not $ null sameRoomClients then
- answerClientOnly $ ["JOINED"] ++ (map nick $ sameRoomClients)
- else
- []
- answerReady = concatMap (\c -> answerClientOnly [if isReady c then "READY" else "NOT_READY", nick c]) sameRoomClients
- sameRoomClients = filter (\ci -> room ci == roomName) clients
- clRoom = roomByName roomName rooms
- watchRound = if (roomProto clRoom < 20) || (not $ gameinprogress clRoom) then
- []
- else
- (answerClientOnly ["RUN_GAME"]) ++
- answerClientOnly ("GAMEMSG" : toEngineMsg "e$spectate 1" : (toList $ roundMsgs clRoom))
- answerTeams = if gameinprogress clRoom then
- answerAllTeams (protocol client) (teamsAtStart clRoom)
- else
- answerAllTeams (protocol client) (teams clRoom)
-
-handleCmd_noRoom client clients rooms ["JOIN", roomName] =
- handleCmd_noRoom client clients rooms ["JOIN", roomName, ""]
-
-handleCmd_noRoom client _ _ ["CHAT_STRING", msg] =
- (noChangeClients, noChangeRooms, answerChatString (nick client) msg)
-
-handleCmd_noRoom client _ _ ["GLOBALMSG", password, msg] =
- (noChangeClients, noChangeRooms, [answer])
- where
- answer = \serverInfo ->
- if (not $ null password) && (adminPassword serverInfo == password) then
- (allClients, ["CHAT_STRING", nick client, msg])
- else
- (clientOnly, ["ERROR", "Wrong password"])
-
-handleCmd_noRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)
-
-
--- 'inRoom' clients state command handlers
-handleCmd_inRoom :: CmdHandler
-handleCmd_inRoom client _ _ ["CHAT_STRING", msg] =
- (noChangeClients, noChangeRooms, answerChatString (nick client) msg)
-
-handleCmd_inRoom client _ rooms ("CONFIG_PARAM" : paramName : paramStrs) =
- if isMaster client then
- (noChangeClients, modifyRoom clRoom{params = Map.insert paramName paramStrs (params clRoom)}, answerConfigParam paramName paramStrs)
- else
- (noChangeClients, noChangeRooms, answerNotMaster)
- where
- clRoom = roomByName (room client) rooms
-
-handleCmd_inRoom client _ rooms ["PART"] =
- if isMaster client then
- (modifyRoomClients clRoom (\cl -> cl{isReady = False, isMaster = False, partRoom = True}), removeRoom (room client), (answerAbandoned $ protocol client) ++ (answerRoomDeleted $ room client))
- else
- if not $ gameinprogress clRoom then
- (modifyClient client{
- isReady = False,
- partRoom = True
- },
- modifyRoom clRoom{
- teams = othersTeams,
- playersIn = (playersIn clRoom) - 1,
- readyPlayers = newReadyPlayers
- },
- (answerPartInform (nick client)) ++ answerRemoveClientTeams)
- else
- (modifyClient client{
- isReady = False,
- partRoom = True
- },
- modifyRoom clRoom{
- teams = othersTeams,
- leftTeams = (map teamname clientTeams) ++ (leftTeams clRoom),
- roundMsgs = (roundMsgs clRoom) >< (fromList rmTeamsMsgs),
- playersIn = (playersIn clRoom) - 1,
- readyPlayers = newReadyPlayers
- },
- answerEngineTeamsRemoveMsg ++
- (answerPartInform (nick client)) ++
- answerRemoveClientTeams)
- where
- clRoom = roomByName (room client) rooms
- answerRemoveClientTeams = concatMap (\tn -> answerOthersRoom ["REMOVE_TEAM", teamname tn]) clientTeams
- (clientTeams, othersTeams) = partition (\t -> teamowner t == nick client) $ teams clRoom
- newReadyPlayers = if isReady client then (readyPlayers clRoom) - 1 else readyPlayers clRoom
- rmTeamsMsgs = map (\team -> toEngineMsg $ 'F' : teamname team) clientTeams
- answerEngineTeamsRemoveMsg =
- if not $ null rmTeamsMsgs then
- answerOthersRoom $ "GAMEMSG" : rmTeamsMsgs
- else
- []
-
-
-handleCmd_inRoom client _ rooms ["MAP", mapName] =
- if isMaster client then
- (noChangeClients, modifyRoom clRoom{gamemap = mapName}, answerMap mapName)
- else
- (noChangeClients, noChangeRooms, answerNotMaster)
- where
- clRoom = roomByName (room client) rooms
-
-handleCmd_inRoom client _ rooms ("ADD_TEAM" : name : color : grave : fort : voicepack : difStr : hhsInfo)
- | length hhsInfo == 16 =
- if length (teams clRoom) == 6 then
- (noChangeClients, noChangeRooms, answerCantAdd "too many teams")
- else if canAddNumber <= 0 then
- (noChangeClients, noChangeRooms, answerCantAdd "too many hedgehogs")
- else if isJust findTeam then
- (noChangeClients, noChangeRooms, answerCantAdd "already has a team with same name")
- else if gameinprogress clRoom then
- (noChangeClients, noChangeRooms, answerCantAdd "round in progress")
- else if isRestrictedTeams clRoom then
- (noChangeClients, noChangeRooms, answerCantAdd "restricted")
- else
- (noChangeClients, modifyRoom clRoom{teams = teams clRoom ++ [newTeam]}, answerTeamAccepted newTeam ++ answerAddTeam (protocol client) newTeam ++ answerTeamColor name color)
- where
- clRoom = roomByName (room client) rooms
- newTeam = (TeamInfo (nick client) name color grave fort voicepack difficulty newTeamHHNum (hhsList hhsInfo))
- findTeam = find (\t -> name == teamname t) $ teams clRoom
- difficulty = fromMaybe 0 (maybeRead difStr :: Maybe Int)
- hhsList [] = []
- hhsList (n:h:hhs) = HedgehogInfo n h : hhsList hhs
- canAddNumber = 48 - (sum . map hhnum $ teams clRoom)
- newTeamHHNum = min 4 canAddNumber
-
-handleCmd_inRoom client clients rooms ("ADD_TEAM" : name : color : grave : fort : difStr : hhsInfo) =
- handleCmd_inRoom client clients rooms ("ADD_TEAM" : name : color : grave : fort : "Default" : difStr : hhsInfo)
-
-
-handleCmd_inRoom client _ rooms ["HH_NUM", teamName, numberStr] =
- if not $ isMaster client then
- (noChangeClients, noChangeRooms, answerNotMaster)
- else
- if hhNumber < 1 || hhNumber > 8 || noSuchTeam || hhNumber > (canAddNumber + (hhnum team)) then
- (noChangeClients, noChangeRooms, [])
- else
- (noChangeClients, modifyRoom $ modifyTeam clRoom team{hhnum = hhNumber}, answerHHNum teamName hhNumber)
- where
- hhNumber = fromMaybe 0 (maybeRead numberStr :: Maybe Int)
- noSuchTeam = isNothing findTeam
- team = fromJust findTeam
- findTeam = find (\t -> teamName == teamname t) $ teams clRoom
- clRoom = roomByName (room client) rooms
- canAddNumber = 48 - (sum . map hhnum $ teams clRoom)
-
-handleCmd_inRoom client _ rooms ["TEAM_COLOR", teamName, newColor] =
- if not $ isMaster client then
- (noChangeClients, noChangeRooms, answerNotMaster)
- else
- if noSuchTeam then
- (noChangeClients, noChangeRooms, [])
- else
- (noChangeClients, modifyRoom $ modifyTeam clRoom team{teamcolor = newColor}, answerTeamColor teamName newColor)
- where
- noSuchTeam = isNothing findTeam
- team = fromJust findTeam
- findTeam = find (\t -> teamName == teamname t) $ teams clRoom
- clRoom = roomByName (room client) rooms
-
-handleCmd_inRoom client _ rooms ["REMOVE_TEAM", teamName] =
- if noSuchTeam then
- (noChangeClients, noChangeRooms, [])
- else
- if not $ nick client == teamowner team then
- (noChangeClients, noChangeRooms, answerNotOwner)
- else
- if not $ gameinprogress clRoom then
- (noChangeClients, modifyRoom clRoom{teams = filter (\t -> teamName /= teamname t) $ teams clRoom}, answerRemoveTeam teamName)
- else
- (noChangeClients,
- modifyRoom clRoom{
- teams = filter (\t -> teamName /= teamname t) $ teams clRoom,
- leftTeams = teamName : leftTeams clRoom,
- roundMsgs = roundMsgs clRoom |> rmTeamMsg
- },
- answerOthersRoom ["GAMEMSG", rmTeamMsg])
- where
- noSuchTeam = isNothing findTeam
- team = fromJust findTeam
- findTeam = find (\t -> teamName == teamname t) $ teams clRoom
- clRoom = roomByName (room client) rooms
- rmTeamMsg = toEngineMsg $ 'F' : teamName
-
-handleCmd_inRoom client _ rooms ["TOGGLE_READY"] =
- if isReady client then
- (modifyClient client{isReady = False}, modifyRoom clRoom{readyPlayers = newReadyPlayers}, answerNotReady $ nick client)
- else
- (modifyClient client{isReady = True}, modifyRoom clRoom{readyPlayers = newReadyPlayers}, answerIsReady $ nick client)
- where
- clRoom = roomByName (room client) rooms
- newReadyPlayers = (readyPlayers clRoom) + if isReady client then -1 else 1
-
-handleCmd_inRoom client _ rooms ["START_GAME"] =
- if isMaster client && (playersIn clRoom == readyPlayers clRoom) && (not $ gameinprogress clRoom) then
- if enoughClans then
- (noChangeClients, modifyRoom clRoom{gameinprogress = True, roundMsgs = empty, leftTeams = [], teamsAtStart = teams clRoom}, answerRunGame)
- else
- (noChangeClients, noChangeRooms, answerTooFewClans)
- else
- (noChangeClients, noChangeRooms, [])
- where
- clRoom = roomByName (room client) rooms
- enoughClans = not $ null $ drop 1 $ group $ map teamcolor $ teams clRoom
-
-handleCmd_inRoom client _ rooms ["TOGGLE_RESTRICT_JOINS"] =
- if isMaster client then
- (noChangeClients, modifyRoom clRoom{isRestrictedJoins = newStatus}, [])
- else
- (noChangeClients, noChangeRooms, answerNotMaster)
- where
- clRoom = roomByName (room client) rooms
- newStatus = not $ isRestrictedJoins clRoom
-
-handleCmd_inRoom client _ rooms ["TOGGLE_RESTRICT_TEAMS"] =
- if isMaster client then
- (noChangeClients, modifyRoom clRoom{isRestrictedTeams = newStatus}, [])
- else
- (noChangeClients, noChangeRooms, answerNotMaster)
- where
- clRoom = roomByName (room client) rooms
- newStatus = not $ isRestrictedTeams clRoom
-
-handleCmd_inRoom client clients rooms ["ROUNDFINISHED"] =
- if isMaster client then
- (modifyRoomClients clRoom (\cl -> cl{isReady = False}), modifyRoom clRoom{gameinprogress = False, readyPlayers = 0, roundMsgs = empty, leftTeams = [], teamsAtStart = []}, answerAllNotReady ++ answerRemovedTeams)
- else
- (noChangeClients, noChangeRooms, [])
- where
- clRoom = roomByName (room client) rooms
- sameRoomClients = filter (\ci -> room ci == name clRoom) clients
- answerAllNotReady = concatMap (\cl -> answerSameRoom ["NOT_READY", nick cl]) sameRoomClients
- answerRemovedTeams = concatMap (\t -> answerSameRoom ["REMOVE_TEAM", t]) $ leftTeams clRoom
-
-handleCmd_inRoom client _ rooms ["GAMEMSG", msg] =
- (noChangeClients, addMsg, answerOthersRoom ["GAMEMSG", msg])
- where
- addMsg = if roomProto clRoom < 20 then
- noChangeRooms
- else
- modifyRoom clRoom{roundMsgs = roundMsgs clRoom |> msg}
- clRoom = roomByName (room client) rooms
-
-handleCmd_inRoom client clients rooms ["KICK", kickNick] =
- if isMaster client then
- if noSuchClient || (kickClient == client) then
- (noChangeClients, noChangeRooms, [])
- else
- (modifyClient kickClient{forceQuit = True}, noChangeRooms, [])
- else
- (noChangeClients, noChangeRooms, [])
- where
- clRoom = roomByName (room client) rooms
- noSuchClient = isNothing findClient
- kickClient = fromJust findClient
- findClient = find (\t -> ((room t) == (room client)) && ((nick t) == kickNick)) $ clients
-
-handleCmd_inRoom _ _ _ _ = (noChangeClients, noChangeRooms, answerBadCmd)
--- a/netserver/Miscutils.hs Sun Apr 12 12:50:43 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,223 +0,0 @@
-module Miscutils where
-
-import IO
-import Control.Concurrent.STM
-import Data.Word
-import Data.Char
-import Data.List(find)
-import Maybe (fromJust)
-import qualified Data.Map as Map
-import Data.Time
-import Data.Sequence(Seq, empty)
-import Network
-import qualified Codec.Binary.Base64 as Base64
-import qualified Codec.Binary.UTF8.String as UTF8
-
-data ClientInfo =
- ClientInfo
- {
- chan :: TChan [String],
- sendChan :: TChan [String],
- handle :: Handle,
- host :: String,
- connectTime :: UTCTime,
- nick :: String,
- protocol :: Word16,
- room :: String,
- isMaster :: Bool,
- isReady :: Bool,
- forceQuit :: Bool,
- partRoom :: Bool
- }
-
-instance Eq ClientInfo where
- a1 == a2 = handle a1 == handle a2
-
-data HedgehogInfo =
- HedgehogInfo String String
-
-data TeamInfo =
- TeamInfo
- {
- teamowner :: String,
- teamname :: String,
- teamcolor :: String,
- teamgrave :: String,
- teamfort :: String,
- teamvoicepack :: String,
- difficulty :: Int,
- hhnum :: Int,
- hedgehogs :: [HedgehogInfo]
- }
-
-data RoomInfo =
- RoomInfo
- {
- name :: String,
- password :: String,
- roomProto :: Word16,
- teams :: [TeamInfo],
- gamemap :: String,
- gameinprogress :: Bool,
- playersIn :: Int,
- readyPlayers :: Int,
- isRestrictedJoins :: Bool,
- isRestrictedTeams :: Bool,
- roundMsgs :: Seq String,
- leftTeams :: [String],
- teamsAtStart :: [TeamInfo],
- params :: Map.Map String [String]
- }
-
-createRoom = (
- RoomInfo
- ""
- ""
- 0
- []
- "+rnd+"
- False
- 1
- 0
- False
- False
- Data.Sequence.empty
- []
- []
- Map.empty
- )
-
-data StatisticsInfo =
- StatisticsInfo
- {
- playersNumber :: Int,
- roomsNumber :: Int
- }
-
-data ServerInfo =
- ServerInfo
- {
- isDedicated :: Bool,
- serverMessage :: String,
- adminPassword :: String,
- listenPort :: PortNumber,
- loginsNumber :: Int,
- lastHourUsers :: [UTCTime],
- stats :: TMVar StatisticsInfo
- }
-
-newServerInfo = (
- ServerInfo
- True
- "<h2><p align=center><a href=\"http://www.hedgewars.org/\">http://www.hedgewars.org/</a></p></h2>"
- ""
- 46631
- 0
- []
- )
-
-type ClientsTransform = [ClientInfo] -> [ClientInfo]
-type RoomsTransform = [RoomInfo] -> [RoomInfo]
-type HandlesSelector = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [ClientInfo]
-type Answer = ServerInfo -> (HandlesSelector, [String])
-type CmdHandler = ClientInfo -> [ClientInfo] -> [RoomInfo] -> [String] -> (ClientsTransform, RoomsTransform, [Answer])
-
-
-roomByName :: String -> [RoomInfo] -> RoomInfo
-roomByName roomName rooms = fromJust $ find (\room -> roomName == name room) rooms
-
-tselect :: [ClientInfo] -> STM ([String], ClientInfo)
-tselect = foldl orElse retry . map (\ci -> (flip (,) ci) `fmap` readTChan (chan ci))
-
-maybeRead :: Read a => String -> Maybe a
-maybeRead s = case reads s of
- [(x, rest)] | all isSpace rest -> Just x
- _ -> Nothing
-
-deleteBy2t :: (a -> b -> Bool) -> b -> [a] -> [a]
-deleteBy2t _ _ [] = []
-deleteBy2t eq x (y:ys) = if y `eq` x then ys else y : deleteBy2t eq x ys
-
-deleteFirstsBy2t :: (a -> b -> Bool) -> [a] -> [b] -> [a]
-deleteFirstsBy2t eq = foldl (flip (deleteBy2t eq))
-
---clientByHandle :: Handle -> [ClientInfo] -> Maybe ClientInfo
---clientByHandle chandle clients = find (\c -> handle c == chandle) clients
-
-sameRoom :: HandlesSelector
-sameRoom client clients rooms = filter (\ci -> room ci == room client) clients
-
-sameProtoLobbyClients :: HandlesSelector
-sameProtoLobbyClients client clients rooms = filter (\ci -> room ci == [] && protocol ci == protocol client) clients
-
-otherLobbyClients :: HandlesSelector
-otherLobbyClients client clients rooms = filter (\ci -> room ci == []) clients
-
-noRoomSameProto :: HandlesSelector
-noRoomSameProto client clients _ = filter (null . room) $ filter (\ci -> protocol client == protocol ci) clients
-
-othersInRoom :: HandlesSelector
-othersInRoom client clients rooms = filter (client /=) $ filter (\ci -> room ci == room client) clients
-
-fromRoom :: String -> HandlesSelector
-fromRoom roomName _ clients _ = filter (\ci -> room ci == roomName) clients
-
-allClients :: HandlesSelector
-allClients _ clients _ = clients
-
-clientOnly :: HandlesSelector
-clientOnly client _ _ = [client]
-
-noChangeClients :: ClientsTransform
-noChangeClients a = a
-
-modifyClient :: ClientInfo -> ClientsTransform
-modifyClient _ [] = error "modifyClient: no such client"
-modifyClient client (cl:cls) =
- if cl == client then
- client : cls
- else
- cl : (modifyClient client cls)
-
-modifyRoomClients :: RoomInfo -> (ClientInfo -> ClientInfo) -> ClientsTransform
-modifyRoomClients clientsroom clientMod clients = map (\c -> if name clientsroom == room c then clientMod c else c) clients
-
-noChangeRooms :: RoomsTransform
-noChangeRooms a = a
-
-addRoom :: RoomInfo -> RoomsTransform
-addRoom room rooms = room:rooms
-
-removeRoom :: String -> RoomsTransform
-removeRoom roomname rooms = filter (\rm -> roomname /= name rm) rooms
-
-modifyRoom :: RoomInfo -> RoomsTransform
-modifyRoom _ [] = error "changeRoomConfig: no such room"
-modifyRoom room (rm:rms) =
- if name room == name rm then
- room : rms
- else
- rm : modifyRoom room rms
-
-modifyTeam :: RoomInfo -> TeamInfo -> RoomInfo
-modifyTeam room team = room{teams = replaceTeam team $ teams room}
- where
- replaceTeam _ [] = error "modifyTeam: no such team"
- replaceTeam team (t:teams) =
- if teamname team == teamname t then
- team : teams
- else
- t : replaceTeam team teams
-
-proto2ver :: Word16 -> String
-proto2ver 17 = "0.9.7-dev"
-proto2ver 19 = "0.9.7"
-proto2ver 20 = "0.9.8-dev"
-proto2ver 21 = "0.9.8"
-proto2ver 22 = "0.9.9-dev"
-proto2ver 23 = "0.9.9"
-proto2ver 24 = "0.9.10-dev"
-proto2ver _ = "Unknown"
-
-toEngineMsg :: String -> String
-toEngineMsg msg = Base64.encode (fromIntegral (length msg) : (UTF8.encode msg))
--- a/netserver/Opts.hs Sun Apr 12 12:50:43 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,38 +0,0 @@
-module Opts
-(
- getOpts,
-) where
-
-import System
-import System.Console.GetOpt
-import Network
-import Data.Maybe ( fromMaybe )
-import Miscutils
-import System.IO.Unsafe
-
-
-options :: [OptDescr (ServerInfo -> ServerInfo)]
-options = [
- Option ['p'] ["port"] (ReqArg readListenPort "PORT") "listen on PORT",
- Option ['d'] ["dedicated"] (ReqArg readDedicated "BOOL") "start as dedicated (True or False)",
- Option [] ["password"] (ReqArg readPassword "STRING") "admin password"
- ]
-
-readListenPort, readDedicated, readPassword :: String -> ServerInfo -> ServerInfo
-readListenPort str opts = opts{listenPort = readPort}
- where
- readPort = fromInteger $ fromMaybe 46631 (maybeRead str :: Maybe Integer)
-
-readDedicated str opts = opts{isDedicated = readDedicated}
- where
- readDedicated = fromMaybe True (maybeRead str :: Maybe Bool)
-
-readPassword str opts = opts{adminPassword = str}
-
-getOpts :: ServerInfo -> IO ServerInfo
-getOpts opts = do
- args <- getArgs
- case getOpt Permute options args of
- (o, [], []) -> return $ foldr ($) opts o
- (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))
- where header = "Usage: newhwserv [OPTION...]"
--- a/netserver/hedgewars-server.hs Sun Apr 12 12:50:43 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,236 +0,0 @@
-{-# LANGUAGE CPP, ScopedTypeVariables, PatternSignatures #-}
-
-module Main where
-
-import qualified Network
-import Network.Socket
-import IO
-import System.IO
-import Control.Concurrent
-import Control.Concurrent.STM
-import Control.Exception (handle, finally, Exception, IOException)
-import Control.Monad
-import Maybe (fromMaybe, isJust, fromJust)
-import Data.List
-import Miscutils
-import HWProto
-import Opts
-import Data.Time
-
-#if !defined(mingw32_HOST_OS)
-import System.Posix
-#endif
-
-
-data Messages =
- Accept ClientInfo
- | ClientMessage ([String], ClientInfo)
- | CoreMessage [String]
- | TimerTick
-
-messagesLoop :: TChan [String] -> IO()
-messagesLoop messagesChan = forever $ do
- threadDelay (25 * 10^6) -- 25 seconds
- atomically $ writeTChan messagesChan ["PING"]
-
-timerLoop :: TChan [String] -> IO()
-timerLoop messagesChan = forever $ do
- threadDelay (60 * 10^6) -- 60 seconds
- atomically $ writeTChan messagesChan ["MINUTELY"]
-
-acceptLoop :: Socket -> TChan ClientInfo -> IO ()
-acceptLoop servSock acceptChan =
- Control.Exception.handle (\(_ :: Exception) -> putStrLn "exception on connect" >> acceptLoop servSock acceptChan) $
- do
- (cHandle, host, _) <- Network.accept servSock
-
- currentTime <- getCurrentTime
- putStrLn $ (show currentTime) ++ " new client: " ++ host
-
- cChan <- atomically newTChan
- sendChan <- atomically newTChan
- forkIO $ clientRecvLoop cHandle cChan
- forkIO $ clientSendLoop cHandle cChan sendChan
-
- atomically $ writeTChan acceptChan
- (ClientInfo
- cChan
- sendChan
- cHandle
- host
- currentTime
- ""
- 0
- ""
- False
- False
- False
- False)
-
- atomically $ writeTChan cChan ["ASKME"]
- acceptLoop servSock acceptChan
-
-
-listenLoop :: Handle -> [String] -> TChan [String] -> IO ()
-listenLoop handle buf chan = do
- str <- hGetLine handle
- if str == "" then do
- atomically $ writeTChan chan buf
- listenLoop handle [] chan
- else
- listenLoop handle (buf ++ [str]) chan
-
-
-clientRecvLoop :: Handle -> TChan [String] -> IO ()
-clientRecvLoop handle chan =
- listenLoop handle [] chan
- `catch` (\e -> (clientOff $ show e) >> return ())
- where clientOff msg = atomically $ writeTChan chan ["QUIT", msg] -- if the client disconnects, we perform as if it sent QUIT message
-
-clientSendLoop :: Handle -> TChan[String] -> TChan[String] -> IO()
-clientSendLoop handle clChan chan = do
- answer <- atomically $ readTChan chan
- doClose <- Control.Exception.handle
- (\(e :: Exception) -> if isQuit answer then return True else sendQuit e >> return False) $ do
- forM_ answer (\str -> hPutStrLn handle str)
- hPutStrLn handle ""
- hFlush handle
- return $ isQuit answer
-
- if doClose then
- Control.Exception.handle (\(_ :: Exception) -> putStrLn "error on hClose") $ hClose handle
- else
- clientSendLoop handle clChan chan
-
- where
- sendQuit e = atomically $ writeTChan clChan ["QUIT", show e]
- isQuit answer = head answer == "BYE"
-
-sendAnswers [] _ clients _ = return clients
-sendAnswers ((handlesFunc, answer):answers) client clients rooms = do
- let recipients = handlesFunc client clients rooms
- --unless (null recipients) $ putStrLn ("< " ++ (show answer))
- when (head answer == "NICK") $ putStrLn (show answer)
-
- clHandles' <- forM recipients $
- \ch ->
- do
- atomically $ writeTChan (sendChan ch) answer
- if head answer == "BYE" then return [ch] else return []
-
- let outHandles = concat clHandles'
- unless (null outHandles) $ putStrLn ((show $ length outHandles) ++ " / " ++ (show $ length clients) ++ " : " ++ (show answer))
-
- let mclients = clients \\ outHandles
-
- sendAnswers answers client mclients rooms
-
-
-reactCmd :: ServerInfo -> [String] -> ClientInfo -> [ClientInfo] -> [RoomInfo] -> IO ([ClientInfo], [RoomInfo])
-reactCmd serverInfo cmd client clients rooms = do
- --putStrLn ("> " ++ show cmd)
-
- let (clientsFunc, roomsFunc, answerFuncs) = handleCmd client clients rooms $ cmd
- let mrooms = roomsFunc rooms
- let mclients = (clientsFunc clients)
- let mclient = fromMaybe client $ find (== client) mclients
- let answers = map (\x -> x serverInfo) answerFuncs
-
- clientsIn <- sendAnswers answers mclient mclients mrooms
- mapM_ (\cl -> atomically $ writeTChan (chan cl) ["QUIT", "Kicked"]) $ filter forceQuit $ clientsIn
-
- let clientsFinal = map (\cl -> if partRoom cl then cl{room = [], partRoom = False} else cl) clientsIn
- return (clientsFinal, mrooms)
-
-
-mainLoop :: ServerInfo -> TChan ClientInfo -> TChan [String] -> [ClientInfo] -> [RoomInfo] -> IO ()
-mainLoop serverInfo acceptChan messagesChan clients rooms = do
- r <- atomically $
- (Accept `fmap` readTChan acceptChan) `orElse`
- (ClientMessage `fmap` tselect clients) `orElse`
- (CoreMessage `fmap` readTChan messagesChan)
-
- case r of
- Accept ci -> do
- let sameHostClients = filter (\cl -> host ci == host cl) clients
- let haveJustConnected = not $ null $ filter (\cl -> connectTime ci `diffUTCTime` connectTime cl <= 25) sameHostClients
-
- when haveJustConnected $ do
- atomically $ do
- writeTChan (chan ci) ["QUIT", "Reconnected too fast"]
-
- currentTime <- getCurrentTime
- let newServerInfo = serverInfo{
- loginsNumber = loginsNumber serverInfo + 1,
- lastHourUsers = currentTime : lastHourUsers serverInfo
- }
- mainLoop newServerInfo acceptChan messagesChan (clients ++ [ci]) rooms
-
- ClientMessage (cmd, client) -> do
- (clientsIn, mrooms) <- reactCmd serverInfo cmd client clients rooms
-
- let hadRooms = (not $ null rooms) && (null mrooms)
- in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $
- mainLoop serverInfo acceptChan messagesChan clientsIn mrooms
-
- CoreMessage msg -> case msg of
- ["PING"] ->
- if not $ null $ clients then
- do
- let client = head clients -- don't care
- (clientsIn, mrooms) <- reactCmd serverInfo msg client clients rooms
- mainLoop serverInfo acceptChan messagesChan clientsIn mrooms
- else
- mainLoop serverInfo acceptChan messagesChan clients rooms
- ["MINUTELY"] -> do
- currentTime <- getCurrentTime
- let newServerInfo = serverInfo{
- lastHourUsers = filter (\t -> currentTime `diffUTCTime` t < 3600) $ lastHourUsers serverInfo
- }
- atomically $ swapTMVar
- (stats serverInfo)
- (StatisticsInfo
- (length clients)
- (length rooms)
- )
- mainLoop newServerInfo acceptChan messagesChan clients rooms
-
-startServer :: ServerInfo -> Socket -> IO()
-startServer serverInfo serverSocket = do
- acceptChan <- atomically newTChan
- forkIO $ acceptLoop serverSocket acceptChan
-
- messagesChan <- atomically newTChan
- forkIO $ messagesLoop messagesChan
- forkIO $ timerLoop messagesChan
-
- mainLoop serverInfo acceptChan messagesChan [] []
-
-socketEcho :: Socket -> TMVar StatisticsInfo -> IO ()
-socketEcho sock stats = do
- (msg, recv_count, client) <- recvFrom sock 128
- currStats <- atomically $ readTMVar stats
- send_count <- sendTo sock (statsMsg1 currStats) client
- socketEcho sock stats
- where
- statsMsg1 currStats = (show $ playersNumber currStats) ++ "," ++ (show $ roomsNumber currStats)
-
-startUDPserver :: TMVar StatisticsInfo -> IO ThreadId
-startUDPserver stats = do
- sock <- socket AF_INET Datagram 0
- bindSocket sock (SockAddrInet 46632 iNADDR_ANY)
- forkIO $ socketEcho sock stats
-
-main = withSocketsDo $ do
-#if !defined(mingw32_HOST_OS)
- installHandler sigPIPE Ignore Nothing;
-#endif
-
- stats <- atomically $ newTMVar (StatisticsInfo 0 0)
- serverInfo <- getOpts $ newServerInfo stats
-
- putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
- serverSocket <- Network.listenOn $ Network.PortNumber (listenPort serverInfo)
-
- startUDPserver stats
- startServer serverInfo serverSocket `finally` sClose serverSocket
--- a/netserver/stresstest.hs Sun Apr 12 12:50:43 2009 +0000
+++ /dev/null Thu Jan 01 00:00:00 1970 +0000
@@ -1,43 +0,0 @@
-module Main where
-
-import IO
-import System.IO
-import Control.Concurrent
-import Network
-import Control.Exception
-import Control.Monad
-import System.Random
-
-session1 nick room = ["NICK", nick, "", "PROTO", "20", "", "CREATE", room, "", "CHAT_STRING", "Hi", ""]
-session2 nick room = ["NICK", nick, "", "PROTO", "20", "", "JOIN", room, "", "CHAT_STRING", "Hello", ""]
-
-emulateSession sock s = do
- mapM_ (\x -> hPutStrLn sock x >> randomRIO (70000::Int, 120000) >>= threadDelay) s
- hFlush sock
- threadDelay 250000
-
-testing = Control.Exception.handle (\e -> putStrLn $ show e) $ do
- putStrLn "Start"
- sock <- connectTo "127.0.0.1" (PortNumber 46631)
-
- num1 <- randomRIO (70000::Int, 70100)
- num2 <- randomRIO (70000::Int, 70100)
- num3 <- randomRIO (0::Int, 7)
- num4 <- randomRIO (0::Int, 7)
- let nick1 = show $ num1
- let nick2 = show $ num2
- let room1 = show $ num3
- let room2 = show $ num4
- emulateSession sock $ session1 nick1 room1
- emulateSession sock $ session2 nick2 room2
- emulateSession sock $ session2 nick1 room1
- hClose sock
- putStrLn "Finish"
-
-forks = forever $ do
- delay <- randomRIO (40000::Int, 70000)
- threadDelay delay
- forkIO testing
-
-main = withSocketsDo $ do
- forks
\ No newline at end of file