Use ghc return value instead of looking for the stderr, do not throw error when an haskell module throws a build failure, e.g. because of false positives like this one (debian/arm*)
"You are using a new version of LLVM that hasn't been tested yet!
We will try though..."
{- * Hedgewars, a free turn based strategy game * Copyright (c) 2004-2014 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 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 = "47"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 ("ACHIEVEMENT" : typ : teamname : location : value : bs) = "ACHIEVEMENT" : typ : teamname : location : value : ps bs ps _ = []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 (fromMaybe [] . Base64.decode . B.unpack) $ msgs hFlush h hClose h (_, _, Just hOut, _) <- createProcess (proc "/usr/home/unC0Rr/Sources/Hedgewars/Releases/0.9.20/bin/hwengine" [fileName , "--user-prefix", "/usr/home/unC0Rr/.hedgewars" , "--prefix", "/usr/home/unC0Rr/Sources/Hedgewars/Releases/0.9.20/share/hedgewars/Data" , "--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 -> 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 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 :: 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 chan msgs warningM "Check" "Started check" onPacket _ ("BYE" : xs) = error $ show xs onPacket _ _ = return ()main :: IO ()main = withSocketsDo $ 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) Right (login, password) <- runErrorT $ do d <- liftIO $ getHomeDirectory 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) 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