if a script is set, feature size can generate different maps
{- * Hedgewars, a free turn based strategy game * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com> * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; version 2 of the License * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. \-}{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings #-}module Main whereimport qualified Control.Exception as Exceptionimport System.IOimport System.Log.Loggerimport qualified Data.ConfigFile as CFimport Control.Monad.Errorimport System.Directoryimport Control.Monad.Stateimport Control.Concurrent.Chanimport Control.Concurrentimport Networkimport Network.BSDimport Network.Socket hiding (recv, sClose)import Network.Socket.ByteStringimport qualified Data.ByteString.Char8 as Bimport qualified Data.ByteString as BWimport qualified Codec.Binary.Base64 as Base64import System.Processimport Data.Maybeimport Data.Eitherimport qualified Data.List as L#if !defined(mingw32_HOST_OS)import System.Posix#endifreadInt_ :: (Num a) => B.ByteString -> areadInt_ str = case B.readInt str of Just (i, t) | B.null t -> fromIntegral i _ -> 0data Message = Packet [B.ByteString] | CheckFailed B.ByteString | CheckSuccess [B.ByteString] deriving ShowserverAddress = "netserver.hedgewars.org"protocolNumber = "55"getLines :: Handle -> IO [B.ByteString]getLines h = g where g = do l <- liftM Just (B.hGetLine h) `Exception.catch` (\(_ :: Exception.IOException) -> return Nothing) if isNothing l then return [] else do lst <- g return $ fromJust l : lstengineListener :: Chan Message -> Handle -> String -> IO ()engineListener coreChan h fileName = do stats <- liftM (ps . L.dropWhile (not . start)) $ getLines h debugM "Engine" $ show stats if null stats then writeChan coreChan $ CheckFailed "No stats msg" else writeChan coreChan $ CheckSuccess stats removeFile fileName where start = flip L.elem ["WINNERS", "DRAW"] ps ("DRAW" : bs) = "DRAW" : ps bs ps ("WINNERS" : n : bs) = let c = readInt_ n in "WINNERS" : n : take c bs ++ (ps $ drop c bs) ps ("GHOST_POINTS" : n : bs) = let c = 2 * (readInt_ n) in "GHOST_POINTS" : n : take c bs ++ (ps $ drop c bs) ps ("ACHIEVEMENT" : typ : teamname : location : value : bs) = "ACHIEVEMENT" : typ : teamname : location : value : ps bs ps _ = []checkReplay :: String -> String -> String -> Chan Message -> [B.ByteString] -> IO ()checkReplay home exe prefix coreChan msgs = do tempDir <- getTemporaryDirectory (fileName, h) <- openBinaryTempFile tempDir "checker-demo" B.hPut h . B.concat . map (either (const B.empty) id . Base64.decode) $ msgs hFlush h hClose h (_, _, Just hOut, _) <- createProcess (proc exe [fileName , "--user-prefix", home , "--prefix", prefix , "--nomusic" , "--nosound" , "--stats-only" ]) {std_err = CreatePipe} hSetBuffering hOut LineBuffering void $ forkIO $ engineListener coreChan hOut fileNametakePacks :: 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 packetsession :: B.ByteString -> B.ByteString -> String -> String -> String -> Socket -> IO ()session l p home exe prefix 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 coreChan p CheckFailed msg -> do warningM "Check" "Check failed" answer ["CHECKED", "FAIL", msg] threadDelay 1500000 answer ["READY"] CheckSuccess msgs -> do warningM "Check" "Check succeeded" answer ("CHECKED" : "OK" : msgs) threadDelay 1500000 answer ["READY"] where answer :: [B.ByteString] -> IO () answer p = do debugM "Network" $ "Send: " ++ show p sendAll s $ B.unlines p `B.snoc` '\n' onPacket :: Chan Message -> [B.ByteString] -> IO () onPacket _ ("CONNECTED":_) = do answer ["CHECKER", protocolNumber, l, p] onPacket _ ["PING"] = answer ["PONG"] onPacket _ ["LOGONPASSED"] = answer ["READY"] onPacket chan ("REPLAY":msgs) = do checkReplay home exe prefix chan msgs warningM "Check" "Started check" onPacket _ ("BYE" : xs) = error $ show xs onPacket _ _ = return ()main :: IO ()main = withSocketsDo . forever $ do#if !defined(mingw32_HOST_OS) installHandler sigPIPE Ignore Nothing installHandler sigCHLD Ignore Nothing#endif updateGlobalLogger "Core" (setLevel DEBUG) updateGlobalLogger "Network" (setLevel WARNING) updateGlobalLogger "Check" (setLevel DEBUG) updateGlobalLogger "Engine" (setLevel DEBUG) d <- getHomeDirectory Right (login, password) <- runErrorT $ do conf <- join . liftIO . CF.readfile CF.emptyCP $ d ++ "/.hedgewars/settings.ini" l <- CF.get conf "net" "nick" p <- CF.get conf "net" "passwordhash" return (B.pack l, B.pack p) Right (exeFullname, dataPrefix) <- runErrorT $ do conf <- join . liftIO . CF.readfile CF.emptyCP $ d ++ "/.hedgewars/checker.ini" l <- CF.get conf "engine" "exe" p <- CF.get conf "engine" "prefix" return (l, p) Exception.bracket setupConnection (\s -> noticeM "Core" "Shutting down" >> sClose s) (session login password (d ++ "/.hedgewars") exeFullname dataPrefix) 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