--- a/gameServer/Actions.hs Sat Feb 09 15:26:10 2013 -0500
+++ b/gameServer/Actions.hs Sun Feb 10 01:54:24 2013 +0400
@@ -77,6 +77,7 @@
| CheckBanned Bool
| SaveReplay
| Stats
+ | CheckRecord
type CmdHandler = [B.ByteString] -> Reader (ClientIndex, IRnC) [Action]
@@ -430,7 +431,7 @@
uid <- client's clUID
-- allow multiple checker logins
haveSameNick <- liftM (not . null . tail . filter (\c -> (not $ isChecker c) && caseInsensitiveCompare (nick c) n)) allClientsS
- if haveSameNick && (not checker) then
+ if (not checker) && haveSameNick then
if p < 38 then
processAction $ ByeClient $ loc "Nickname is already in use"
else
@@ -670,6 +671,17 @@
io $ do
r <- room'sM rnc id ri
saveReplay r
+
+
+processAction CheckRecord = do
+ p <- client's clientProto
+ c <- client's sendChan
+ l <- io $ loadReplay (fromIntegral p)
+ when (not $ null l) $
+ processAction $ AnswerClients [c] ("REPLAY" : l)
+
+
#else
processAction SaveReplay = return ()
+processAction CheckRecord = return ()
#endif
--- a/gameServer/CoreTypes.hs Sat Feb 09 15:26:10 2013 -0500
+++ b/gameServer/CoreTypes.hs Sun Feb 10 01:54:24 2013 +0400
@@ -68,7 +68,7 @@
instance Eq TeamInfo where
(==) = (==) `on` teamname
-
+
data GameInfo =
GameInfo
{
--- a/gameServer/EngineInteraction.hs Sat Feb 09 15:26:10 2013 -0500
+++ b/gameServer/EngineInteraction.hs Sun Feb 10 01:54:24 2013 +0400
@@ -1,3 +1,5 @@
+{-# LANGUAGE OverloadedStrings #-}
+
module EngineInteraction where
import qualified Data.Set as Set
@@ -5,8 +7,14 @@
import qualified Codec.Binary.Base64 as Base64
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString as BW
+import qualified Data.Map as Map
+import qualified Data.List as L
+import Data.Word
+import Data.Bits
+import Control.Arrow
-------------
import CoreTypes
+import Utils
toEngineMsg :: B.ByteString -> B.ByteString
@@ -20,19 +28,124 @@
removeLength _ = Nothing
-checkNetCmd :: B.ByteString -> (Bool, Bool)
+splitMessages :: B.ByteString -> [B.ByteString]
+splitMessages = L.unfoldr (\b -> if B.null b then Nothing else Just $ B.splitAt (1 + fromIntegral (BW.head b)) b)
+
+
+checkNetCmd :: B.ByteString -> (B.ByteString, B.ByteString)
checkNetCmd msg = check decoded
where
- decoded = fromEngineMsg msg
- check Nothing = (False, False)
- check (Just ms) | B.length ms > 0 = let m = B.head ms in (m `Set.member` legalMessages, m == '+')
- | otherwise = (False, False)
+ decoded = liftM (splitMessages . BW.pack) $ Base64.decode $ B.unpack msg
+ check Nothing = (B.empty, B.empty)
+ check (Just msgs) = let (a, b) = (filter isLegal msgs, filter isNonEmpty a) in (encode a, encode b)
+ encode = B.pack . Base64.encode . BW.unpack . B.concat
+ isLegal m = (B.length m > 1) && (flip Set.member legalMessages . B.head . B.tail $ m)
+ isNonEmpty = (/=) '+' . B.head
legalMessages = Set.fromList $ "M#+LlRrUuDdZzAaSjJ,sNpPwtghbc12345" ++ slotMessages
slotMessages = "\128\129\130\131\132\133\134\135\136\137\138"
-gameInfo2Replay :: GameInfo -> B.ByteString
-gameInfo2Replay GameInfo{roundMsgs = rm,
- teamsAtStart = teams,
- giMapParams = params1,
- giParams = params2} = undefined
+replayToDemo :: [TeamInfo]
+ -> Map.Map B.ByteString B.ByteString
+ -> Map.Map B.ByteString [B.ByteString]
+ -> [B.ByteString]
+ -> [B.ByteString]
+replayToDemo teams mapParams params msgs = concat [
+ [em "TD"]
+ , maybeScript
+ , maybeMap
+ , [eml ["etheme ", head $ params Map.! "THEME"]]
+ , [eml ["eseed ", mapParams Map.! "SEED"]]
+ , [eml ["e$gmflags ", showB gameFlags]]
+ , schemeFlags
+ , [eml ["e$template_filter ", mapParams Map.! "TEMPLATE"]]
+ , [eml ["e$mapgen ", mapgen]]
+ , mapgenSpecific
+ , concatMap teamSetup teams
+ , msgs
+ , [em "!"]
+ ]
+ where
+ em = toEngineMsg
+ eml = em . B.concat
+ mapGenTypes = ["+rnd+", "+maze+", "+drawn+"]
+ maybeScript = let s = head $ params Map.! "SCRIPT" in if s == "Normal" then [] else [eml ["escript Scripts/Multiplayer/", s, ".lua"]]
+ maybeMap = let m = mapParams Map.! "MAP" in if m `elem` mapGenTypes then [] else [eml ["emap ", m]]
+ scheme = tail $ params Map.! "SCHEME"
+ mapgen = mapParams Map.! "MAPGEN"
+ mapgenSpecific = case mapgen of
+ "+maze+" -> [eml ["e$maze_size ", head $ params Map.! "MAZE_SIZE"]]
+ "+drawn" -> drawnMapData . head $ params Map.! "DRAWNMAP"
+ _ -> []
+ gameFlags :: Word32
+ gameFlags = foldl (\r (b, f) -> if b == "false" then r else r .|. f) 0 $ zip scheme gameFlagConsts
+ schemeFlags = map (\(v, (n, m)) -> eml [n, " ", showB $ (readInt_ v) * m])
+ $ filter (\(_, (n, _)) -> not $ B.null n)
+ $ zip (drop (length gameFlagConsts) scheme) schemeParams
+ ammoStr :: B.ByteString
+ ammoStr = head . tail $ params Map.! "AMMO"
+ ammo = let l = B.length ammoStr `div` 4; ((a, b), (c, d)) = (B.splitAt l . fst &&& B.splitAt l . snd) . B.splitAt (l * 2) $ ammoStr in
+ (map (\(x, y) -> eml [x, " ", y]) $ zip ["eammloadt", "eammprob", "eammdelay", "eammreinf"] [a, b, c, d])
+ ++ [em "eammstore" | scheme !! 14 == "true" || scheme !! 20 == "false"]
+ initHealth = scheme !! 27
+ teamSetup :: TeamInfo -> [B.ByteString]
+ teamSetup t =
+ eml ["eaddteam ", teamcolor t, " ", teamowner t, " <hash>"]
+ : em "erdriven"
+ : eml ["efort ", teamfort t]
+ : replicate (hhnum t) (eml ["eaddhh 0 ", initHealth, " hedgehog"])
+
+drawnMapData :: B.ByteString -> [B.ByteString]
+drawnMapData = error "drawnMapData"
+
+schemeParams :: [(B.ByteString, Int)]
+schemeParams = [
+ ("e$damagepct", 1)
+ , ("e$turntime", 1000)
+ , ("", 0)
+ , ("e$sd_turns", 1)
+ , ("e$casefreq", 1)
+ , ("e$minestime", 1000)
+ , ("e$minesnum", 1)
+ , ("e$minedudpct", 1)
+ , ("e$explosives", 1)
+ , ("e$healthprob", 1)
+ , ("e$hcaseamount", 1)
+ , ("e$waterrise", 1)
+ , ("e$healthdec", 1)
+ , ("e$ropepct", 1)
+ , ("e$getawaytime", 1)
+ ]
+
+
+gameFlagConsts :: [Word32]
+gameFlagConsts = [
+ 0x00001000
+ , 0x00000010
+ , 0x00000004
+ , 0x00000008
+ , 0x00000020
+ , 0x00000040
+ , 0x00000080
+ , 0x00000100
+ , 0x00000200
+ , 0x00000400
+ , 0x00000800
+ , 0x00002000
+ , 0x00004000
+ , 0x00008000
+ , 0x00010000
+ , 0x00020000
+ , 0x00040000
+ , 0x00080000
+ , 0x00100000
+ , 0x00200000
+ , 0x00400000
+ , 0x00800000
+ , 0x01000000
+ , 0x02000000
+ , 0x04000000
+ ]
+
+
+
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/HWProtoChecker.hs Sun Feb 10 01:54:24 2013 +0400
@@ -0,0 +1,21 @@
+{-# LANGUAGE OverloadedStrings #-}
+module HWProtoChecker where
+
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.List
+import Control.Monad.Reader
+--------------------------------------
+import CoreTypes
+import Actions
+import Utils
+import HandlerUtils
+import RoomsAndClients
+import EngineInteraction
+
+
+handleCmd_checker :: CmdHandler
+
+handleCmd_checker ["READY"] = return [CheckRecord]
+
+handleCmd_checker _ = return [ProtocolError "Unknown command"]
--- a/gameServer/HWProtoCore.hs Sat Feb 09 15:26:10 2013 -0500
+++ b/gameServer/HWProtoCore.hs Sun Feb 10 01:54:24 2013 +0400
@@ -11,6 +11,7 @@
import HWProtoNEState
import HWProtoLobbyState
import HWProtoInRoomState
+import HWProtoChecker
import HandlerUtils
import RoomsAndClients
import Utils
@@ -42,12 +43,18 @@
where
h ["DELEGATE", n] = handleCmd ["DELEGATE", n]
h ["STATS"] = handleCmd ["STATS"]
+ h ["PART", msg] = handleCmd ["PART", msg]
+ h ["QUIT", msg] = handleCmd ["QUIT", msg]
h c = return [Warning . B.concat . L.intersperse " " $ "Unknown cmd" : c]
handleCmd cmd = do
(ci, irnc) <- ask
- if logonPassed (irnc `client` ci) then
- handleCmd_loggedin cmd
+ let cl = irnc `client` ci
+ if logonPassed cl then
+ if isChecker cl then
+ handleCmd_checker cmd
+ else
+ handleCmd_loggedin cmd
else
handleCmd_NotEntered cmd
--- a/gameServer/HWProtoInRoomState.hs Sat Feb 09 15:26:10 2013 -0500
+++ b/gameServer/HWProtoInRoomState.hs Sun Feb 10 01:54:24 2013 +0400
@@ -123,7 +123,7 @@
cl <- thisClient
r <- thisRoom
clChan <- thisClientChans
- roomChans <- roomClientsChans
+ others <- roomOthersChans
let maybeTeam = findTeam r
let team = fromJust maybeTeam
@@ -137,7 +137,7 @@
[AnswerClients clChan ["HH_NUM", teamName, showB $ hhnum team]]
else
[ModifyRoom $ modifyTeam team{hhnum = hhNumber},
- AnswerClients roomChans ["HH_NUM", teamName, showB hhNumber]]
+ AnswerClients others ["HH_NUM", teamName, showB hhNumber]]
where
hhNumber = readInt_ numberStr
findTeam = find (\t -> teamName == teamname t) . teams
@@ -216,13 +216,13 @@
rm <- thisRoom
chans <- roomOthersChans
- if teamsInGame cl > 0 && (isJust $ gameInfo rm) && isLegal then
- return $ AnswerClients chans ["EM", msg]
- : [ModifyRoom (\r -> r{gameInfo = liftM (\g -> g{roundMsgs = msg : roundMsgs g}) $ gameInfo r}) | not isKeepAlive]
+ if teamsInGame cl > 0 && (isJust $ gameInfo rm) && (not $ B.null legalMsgs) then
+ return $ AnswerClients chans ["EM", legalMsgs]
+ : [ModifyRoom (\r -> r{gameInfo = liftM (\g -> g{roundMsgs = nonEmptyMsgs : roundMsgs g}) $ gameInfo r}) | not $ B.null nonEmptyMsgs]
else
return []
where
- (isLegal, isKeepAlive) = checkNetCmd msg
+ (legalMsgs, nonEmptyMsgs) = checkNetCmd msg
handleCmd_inRoom ["ROUNDFINISHED", correctly] = do
@@ -273,6 +273,7 @@
else
[ModifyRoom (\r -> r{isRegisteredOnly = not $ isRegisteredOnly r})]
+
handleCmd_inRoom ["ROOM_NAME", newName] = do
cl <- thisClient
rs <- allRoomInfos
@@ -324,6 +325,7 @@
where
engineMsg cl = toEngineMsg $ B.concat ["b", nick cl, "(team): ", msg, "\x20\x20"]
+
handleCmd_inRoom ["BAN", banNick] = do
(thisClientId, rnc) <- ask
maybeClientId <- clientByNick banNick
--- a/gameServer/HWProtoLobbyState.hs Sat Feb 09 15:26:10 2013 -0500
+++ b/gameServer/HWProtoLobbyState.hs Sun Feb 10 01:54:24 2013 +0400
@@ -135,13 +135,14 @@
handleCmd_lobby ["FOLLOW", asknick] = do
(_, rnc) <- ask
+ clChan <- liftM sendChan thisClient
ci <- clientByNick asknick
let ri = clientRoom rnc $ fromJust ci
- let clRoom = room rnc ri
+ let roomName = name $ room rnc ri
if isNothing ci || ri == lobbyId then
return []
else
- handleCmd_lobby ["JOIN_ROOM", name clRoom]
+ liftM ((:) (AnswerClients [clChan] ["JOINING", roomName])) $ handleCmd_lobby ["JOIN_ROOM", roomName]
---------------------------
-- Administrator's stuff --
--- a/gameServer/OfficialServer/GameReplayStore.hs Sat Feb 09 15:26:10 2013 -0500
+++ b/gameServer/OfficialServer/GameReplayStore.hs Sun Feb 10 01:54:24 2013 +0400
@@ -9,8 +9,12 @@
import Data.Maybe
import Data.Unique
import Control.Monad
+import Data.List
+import qualified Data.ByteString as B
+import System.Directory
---------------
import CoreTypes
+import EngineInteraction
saveReplay :: RoomInfo -> IO ()
@@ -19,8 +23,22 @@
when (allPlayersHaveRegisteredAccounts gi) $ do
time <- getCurrentTime
u <- liftM hashUnique newUnique
- let fileName = "replays/" ++ show time ++ "-" ++ show u
+ let fileName = "replays/" ++ show time ++ "-" ++ show u ++ "." ++ show (roomProto r)
let replayInfo = (teamsAtStart gi, Map.toList $ mapParams r, Map.toList $ params r, roundMsgs gi)
E.catch
(writeFile fileName (show replayInfo))
(\(e :: IOException) -> warningM "REPLAYS" $ "Couldn't write to " ++ fileName ++ ": " ++ show e)
+
+
+loadReplay :: Int -> IO [B.ByteString]
+loadReplay p = E.handle (\(e :: SomeException) -> warningM "REPLAYS" "Problems reading replay" >> return []) $ do
+ files <- liftM (filter (isSuffixOf ('.' : show p))) $ getDirectoryContents "replays"
+ if (not $ null files) then
+ loadFile $ head files
+ else
+ return []
+ where
+ loadFile :: String -> IO [B.ByteString]
+ loadFile fileName = E.handle (\(e :: SomeException) -> warningM "REPLAYS" ("Problems reading " ++ fileName) >> return []) $ do
+ (teams, params1, params2, roundMsgs) <- liftM read $ readFile fileName
+ return $ replayToDemo teams (Map.fromList params1) (Map.fromList params2) roundMsgs
--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/gameServer/OfficialServer/checker.hs Sun Feb 10 01:54:24 2013 +0400
@@ -0,0 +1,116 @@
+{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings #-}
+module Main where
+
+import qualified Control.Exception as Exception
+import System.IO
+import System.Log.Logger
+import qualified Data.ConfigFile as CF
+import Control.Monad.Error
+import System.Directory
+import Control.Monad.State
+import Control.Concurrent.Chan
+import Control.Concurrent
+import Network
+import Network.BSD
+import Network.Socket hiding (recv)
+import Network.Socket.ByteString
+import qualified Data.ByteString.Char8 as B
+#if !defined(mingw32_HOST_OS)
+import System.Posix
+#endif
+
+data Message = Packet [B.ByteString]
+ deriving Show
+
+protocolNumber = "43"
+
+takePacks :: State B.ByteString [[B.ByteString]]
+takePacks = do
+ modify (until (not . B.isPrefixOf pDelim) (B.drop 2))
+ packet <- state $ B.breakSubstring pDelim
+ buf <- get
+ if B.null buf then put packet >> return [] else
+ if B.null packet then return [] else do
+ packets <- takePacks
+ return (B.splitWith (== '\n') packet : packets)
+ where
+ pDelim = "\n\n"
+
+
+recvLoop :: Socket -> Chan Message -> IO ()
+recvLoop s chan =
+ ((receiveWithBufferLoop B.empty >> return "Connection closed")
+ `Exception.catch` (\(e :: Exception.SomeException) -> return . B.pack . show $ e)
+ )
+ >>= disconnected
+ where
+ disconnected msg = writeChan chan $ Packet ["BYE", msg]
+ receiveWithBufferLoop recvBuf = do
+ recvBS <- recv s 4096
+ unless (B.null recvBS) $ do
+ let (packets, newrecvBuf) = runState takePacks $ B.append recvBuf recvBS
+ forM_ packets sendPacket
+ receiveWithBufferLoop $ B.copy newrecvBuf
+
+ sendPacket packet = writeChan chan $ Packet packet
+
+
+session :: B.ByteString -> B.ByteString -> Socket -> IO ()
+session l p s = do
+ noticeM "Core" "Connected"
+ coreChan <- newChan
+ forkIO $ recvLoop s coreChan
+ forever $ do
+ p <- readChan coreChan
+ case p of
+ Packet p -> do
+ debugM "Network" $ "Recv: " ++ show p
+ onPacket p
+ where
+ answer :: [B.ByteString] -> IO ()
+ answer p = do
+ debugM "Network" $ "Send: " ++ show p
+ sendAll s $ B.unlines p `B.snoc` '\n'
+ onPacket :: [B.ByteString] -> IO ()
+ onPacket ("CONNECTED":_) = do
+ answer ["CHECKER", protocolNumber, l, p]
+ answer ["READY"]
+ onPacket ["PING"] = answer ["PONG"]
+ onPacket ("BYE" : xs) = error $ show xs
+ onPacket _ = return ()
+
+
+main :: IO ()
+main = withSocketsDo $ do
+#if !defined(mingw32_HOST_OS)
+ installHandler sigPIPE Ignore Nothing;
+#endif
+
+ updateGlobalLogger "Core" (setLevel DEBUG)
+ updateGlobalLogger "Network" (setLevel DEBUG)
+
+ Right (login, password) <- runErrorT $ do
+ d <- liftIO $ getHomeDirectory
+ conf <- join . liftIO . CF.readfile CF.emptyCP $ d ++ "/.hedgewars/hedgewars.ini"
+ l <- CF.get conf "net" "nick"
+ p <- CF.get conf "net" "passwordhash"
+ return (B.pack l, B.pack p)
+
+
+ Exception.bracket
+ setupConnection
+ (\s -> noticeM "Core" "Shutting down" >> sClose s)
+ (session login password)
+ where
+ setupConnection = do
+ noticeM "Core" "Connecting to the server..."
+
+ proto <- getProtocolNumber "tcp"
+ let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] }
+ (addr:_) <- getAddrInfo (Just hints) (Just serverAddress) Nothing
+ let (SockAddrInet _ host) = addrAddress addr
+ sock <- socket AF_INET Stream proto
+ connect sock (SockAddrInet 46631 host)
+ return sock
+
+ serverAddress = "netserver.hedgewars.org"