# HG changeset patch
# User unc0rr
# Date 1360446864 -14400
# Node ID ec8391680132405f22f0890831132a8439ce0cad
# Parent  9a65baafd7d741c42a81eef71ec0ce6a2e143d56# Parent  f605bc59c603dcb2db78a03f9d49b1cffda8f086
Fine, merge :-\

diff -r f605bc59c603 -r ec8391680132 gameServer/Actions.hs
--- 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
diff -r f605bc59c603 -r ec8391680132 gameServer/CoreTypes.hs
--- 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
     {
diff -r f605bc59c603 -r ec8391680132 gameServer/EngineInteraction.hs
--- 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
+        ]
+
+
+
diff -r f605bc59c603 -r ec8391680132 gameServer/HWProtoChecker.hs
--- /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"]
diff -r f605bc59c603 -r ec8391680132 gameServer/HWProtoCore.hs
--- 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
 
diff -r f605bc59c603 -r ec8391680132 gameServer/HWProtoInRoomState.hs
--- 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
diff -r f605bc59c603 -r ec8391680132 gameServer/HWProtoLobbyState.hs
--- 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 --
diff -r f605bc59c603 -r ec8391680132 gameServer/OfficialServer/GameReplayStore.hs
--- 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
diff -r f605bc59c603 -r ec8391680132 gameServer/OfficialServer/checker.hs
--- /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"