gameServer/OfficialServer/checker.hs
changeset 8515 222f43420615
parent 8507 f4475782cf45
child 8517 648bb1cb7ebc
--- a/gameServer/OfficialServer/checker.hs	Mon Feb 18 22:47:42 2013 +0400
+++ b/gameServer/OfficialServer/checker.hs	Mon Feb 18 23:04:38 2013 +0400
@@ -19,24 +19,39 @@
 import qualified Codec.Binary.Base64 as Base64
 import System.Process
 import Data.Maybe
+import qualified Data.List as L
 #if !defined(mingw32_HOST_OS)
 import System.Posix
 #endif
 
 data Message = Packet [B.ByteString]
+             | CheckFailed B.ByteString
+             | CheckSuccess [B.ByteString]
     deriving Show
 
 protocolNumber = "43"
 
-checkReplay :: [B.ByteString] -> IO ()
-checkReplay msgs = do
+
+engineListener :: Chan Message -> Handle -> IO ()
+engineListener coreChan h = do
+    output <- liftM lines $ hGetContents h
+    debugM "Engine" $ show output
+    if isNothing $ L.find start output then
+        writeChan coreChan $ CheckFailed "No stats msg"
+        else
+        writeChan coreChan $ CheckSuccess []
+    where
+        start = flip L.elem ["WINNERS", "DRAW"]
+
+checkReplay :: Chan Message -> [B.ByteString] -> IO ()
+checkReplay coreChan msgs = do
     tempDir <- getTemporaryDirectory
     (fileName, h) <- openBinaryTempFile tempDir "checker-demo"
     B.hPut h . BW.pack . concat . map (fromJust . Base64.decode . B.unpack) $ msgs
     hFlush h
     hClose h
 
-    (_, _, Just hErr, _) <- createProcess (proc "/usr/home/unC0Rr/Sources/Hedgewars/Releases/0.9.18/bin/hwengine"
+    (_, Just hErr, _, _) <- createProcess (proc "/usr/home/unC0Rr/Sources/Hedgewars/Releases/0.9.18/bin/hwengine"
                 ["/usr/home/unC0Rr/.hedgewars"
                 , "/usr/home/unC0Rr/Sources/Hedgewars/Releases/0.9.18/share/hedgewars/Data"
                 , fileName
@@ -45,8 +60,9 @@
                 , "0"
                 , "0"
                 ])
-            {std_err = CreatePipe}
+            {std_out = CreatePipe}
     hSetBuffering hErr LineBuffering
+    void $ forkIO $ engineListener coreChan hErr
 
 
 takePacks :: State B.ByteString [[B.ByteString]]
@@ -90,20 +106,28 @@
         case p of
             Packet p -> do
                 debugM "Network" $ "Recv: " ++ show p
-                onPacket p
+                onPacket coreChan p
+            CheckFailed msg -> do
+                warningM "Check" "Check failed"
+                answer ["CHECKED", "FAIL", msg]
+                answer ["READY"]
+            CheckSuccess msgs -> do
+                warningM "Check" "Check succeeded"
+                answer ("CHECKED" : "OK" : msgs)
+                answer ["READY"]
     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
+    onPacket :: Chan Message -> [B.ByteString] -> IO ()
+    onPacket _ ("CONNECTED":_) = do
         answer ["CHECKER", protocolNumber, l, p]
         answer ["READY"]
-    onPacket ["PING"] = answer ["PONG"]
-    onPacket ("REPLAY":msgs) = checkReplay msgs
-    onPacket ("BYE" : xs) = error $ show xs
-    onPacket _ = return ()
+    onPacket _ ["PING"] = answer ["PONG"]
+    onPacket chan ("REPLAY":msgs) = checkReplay chan msgs
+    onPacket _ ("BYE" : xs) = error $ show xs
+    onPacket _ _ = return ()
 
 
 main :: IO ()
@@ -115,6 +139,8 @@
 
     updateGlobalLogger "Core" (setLevel DEBUG)
     updateGlobalLogger "Network" (setLevel DEBUG)
+    updateGlobalLogger "Check" (setLevel DEBUG)
+    updateGlobalLogger "Engine" (setLevel DEBUG)
 
     Right (login, password) <- runErrorT $ do
         d <- liftIO $ getHomeDirectory