1 {-

     2  * Hedgewars, a free turn based strategy game

     3  * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>

     4  *

     5  * This program is free software; you can redistribute it and/or modify

     6  * it under the terms of the GNU General Public License as published by

     7  * the Free Software Foundation; version 2 of the License

     8  *

     9  * This program is distributed in the hope that it will be useful,

    10  * but WITHOUT ANY WARRANTY; without even the implied warranty of

    11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the

    12  * GNU General Public License for more details.

    13  *

    14  * You should have received a copy of the GNU General Public License

    15  * along with this program; if not, write to the Free Software

    16  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.

    17  \-}

    18 

    19 {-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings #-}

    20 module Main where

    21 

    22 import qualified Control.Exception as Exception

    23 import System.IO

    24 import System.Log.Logger

    25 import qualified Data.ConfigFile as CF

    26 import Control.Monad.Error

    27 import System.Directory

    28 import Control.Monad.State

    29 import Control.Concurrent.Chan

    30 import Control.Concurrent

    31 import Network

    32 import Network.BSD

    33 import Network.Socket hiding (recv, sClose)

    34 import Network.Socket.ByteString

    35 import qualified Data.ByteString.Char8 as B

    36 import qualified Data.ByteString as BW

    37 import qualified Codec.Binary.Base64 as Base64

    38 import System.Process

    39 import Data.Maybe

    40 import Data.Either

    41 import qualified Data.List as L

    42 #if !defined(mingw32_HOST_OS)

    43 import System.Posix

    44 #endif

    45 

    46 readInt_ :: (Num a) => B.ByteString -> a

    47 readInt_ str =

    48   case B.readInt str of

    49        Just (i, t) | B.null t -> fromIntegral i

    50        _                      -> 0

    51 

    52 data Message = Packet [B.ByteString]

    53              | CheckFailed B.ByteString

    54              | CheckSuccess [B.ByteString]

    55     deriving Show

    56 

    57 serverAddress = "netserver.hedgewars.org"

    58 protocolNumber = "55"

    59 

    60 getLines :: Handle -> IO [B.ByteString]

    61 getLines h = g

    62     where

    63         g = do

    64             l <- liftM Just (B.hGetLine h) `Exception.catch` (\(_ :: Exception.IOException) -> return Nothing)

    65             if isNothing l then

    66                 return []

    67                 else

    68                 do

    69                 lst <- g

    70                 return $ fromJust l : lst

    71 

    72 

    73 engineListener :: Chan Message -> Handle -> String -> IO ()

    74 engineListener coreChan h fileName = do

    75     stats <- liftM (ps . L.dropWhile (not . start)) $ getLines h

    76     debugM "Engine" $ show stats

    77     if null stats then

    78         writeChan coreChan $ CheckFailed "No stats msg"

    79         else

    80         writeChan coreChan $ CheckSuccess stats

    81 

    82     removeFile fileName

    83     where

    84         start = flip L.elem ["WINNERS", "DRAW"]

    85         ps ("DRAW" : bs) = "DRAW" : ps bs

    86         ps ("WINNERS" : n : bs) = let c = readInt_ n in "WINNERS" : n : take c bs ++ (ps $ drop c bs)

    87         ps ("GHOST_POINTS" : n : bs) = let c = 2 * (readInt_ n) in "GHOST_POINTS" : n : take c bs ++ (ps $ drop c bs)

    88         ps ("ACHIEVEMENT" : typ : teamname : location : value : bs) =

    89             "ACHIEVEMENT" : typ : teamname : location : value : ps bs

    90         ps _ = []

    91 

    92 checkReplay :: String -> String -> String -> Chan Message -> [B.ByteString] -> IO ()

    93 checkReplay home exe prefix coreChan msgs = do

    94     tempDir <- getTemporaryDirectory

    95     (fileName, h) <- openBinaryTempFile tempDir "checker-demo"

    96     B.hPut h . B.concat . map (either (const B.empty) id . Base64.decode) $ msgs

    97     hFlush h

    98     hClose h

    99 

   100     (_, _, Just hOut, _) <- createProcess (proc exe

   101                 [fileName

   102                 , "--user-prefix", home

   103                 , "--prefix", prefix

   104                 , "--nomusic"

   105                 , "--nosound"

   106                 , "--stats-only"

   107                 ])

   108             {std_err = CreatePipe}

   109     hSetBuffering hOut LineBuffering

   110     void $ forkIO $ engineListener coreChan hOut fileName

   111 

   112 

   113 takePacks :: State B.ByteString [[B.ByteString]]

   114 takePacks = do

   115     modify (until (not . B.isPrefixOf pDelim) (B.drop 2))

   116     packet <- state $ B.breakSubstring pDelim

   117     buf <- get

   118     if B.null buf then put packet >> return [] else

   119         if B.null packet then return [] else do

   120             packets <- takePacks

   121             return (B.splitWith (== '\n') packet : packets)

   122     where

   123     pDelim = "\n\n"

   124 

   125 

   126 recvLoop :: Socket -> Chan Message -> IO ()

   127 recvLoop s chan =

   128         ((receiveWithBufferLoop B.empty >> return "Connection closed")

   129             `Exception.catch` (\(e :: Exception.SomeException) -> return . B.pack . show $ e)

   130         )

   131         >>= disconnected

   132     where

   133         disconnected msg = writeChan chan $ Packet ["BYE", msg]

   134         receiveWithBufferLoop recvBuf = do

   135             recvBS <- recv s 4096

   136             unless (B.null recvBS) $ do

   137                 let (packets, newrecvBuf) = runState takePacks $ B.append recvBuf recvBS

   138                 forM_ packets sendPacket

   139                 receiveWithBufferLoop $ B.copy newrecvBuf

   140 

   141         sendPacket packet = writeChan chan $ Packet packet

   142 

   143 

   144 session :: B.ByteString -> B.ByteString -> String -> String -> String -> Socket -> IO ()

   145 session l p home exe prefix s = do

   146     noticeM "Core" "Connected"

   147     coreChan <- newChan

   148     forkIO $ recvLoop s coreChan

   149     forever $ do

   150         p <- readChan coreChan

   151         case p of

   152             Packet p -> do

   153                 debugM "Network" $ "Recv: " ++ show p

   154                 onPacket coreChan p

   155             CheckFailed msg -> do

   156                 warningM "Check" "Check failed"

   157                 answer ["CHECKED", "FAIL", msg]

   158                 threadDelay 1500000

   159                 answer ["READY"]

   160             CheckSuccess msgs -> do

   161                 warningM "Check" "Check succeeded"

   162                 answer ("CHECKED" : "OK" : msgs)

   163                 threadDelay 1500000

   164                 answer ["READY"]

   165     where

   166     answer :: [B.ByteString] -> IO ()

   167     answer p = do

   168         debugM "Network" $ "Send: " ++ show p

   169         sendAll s $ B.unlines p `B.snoc` '\n'

   170     onPacket :: Chan Message -> [B.ByteString] -> IO ()

   171     onPacket _ ("CONNECTED":_) = do

   172         answer ["CHECKER", protocolNumber, l, p]

   173     onPacket _ ["PING"] = answer ["PONG"]

   174     onPacket _ ["LOGONPASSED"] = answer ["READY"]

   175     onPacket chan ("REPLAY":msgs) = do

   176         checkReplay home exe prefix chan msgs

   177         warningM "Check" "Started check"

   178     onPacket _ ("BYE" : xs) = error $ show xs

   179     onPacket _ _ = return ()

   180 

   181 

   182 main :: IO ()

   183 main = withSocketsDo . forever $ do

   184 #if !defined(mingw32_HOST_OS)

   185     installHandler sigPIPE Ignore Nothing

   186     installHandler sigCHLD Ignore Nothing

   187 #endif

   188 

   189     updateGlobalLogger "Core" (setLevel DEBUG)

   190     updateGlobalLogger "Network" (setLevel WARNING)

   191     updateGlobalLogger "Check" (setLevel DEBUG)

   192     updateGlobalLogger "Engine" (setLevel DEBUG)

   193 

   194     d <- getHomeDirectory

   195     Right (login, password) <- runErrorT $ do

   196         conf <- join . liftIO . CF.readfile CF.emptyCP $ d ++ "/.hedgewars/settings.ini"

   197         l <- CF.get conf "net" "nick"

   198         p <- CF.get conf "net" "passwordhash"

   199         return (B.pack l, B.pack p)

   200 

   201     Right (exeFullname, dataPrefix) <- runErrorT $ do

   202         conf <- join . liftIO . CF.readfile CF.emptyCP $ d ++ "/.hedgewars/checker.ini"

   203         l <- CF.get conf "engine" "exe"

   204         p <- CF.get conf "engine" "prefix"

   205         return (l, p)

   206 

   207 

   208     Exception.bracket

   209         setupConnection

   210         (\s -> noticeM "Core" "Shutting down" >> sClose s)

   211         (session login password (d ++ "/.hedgewars") exeFullname dataPrefix)

   212     where

   213         setupConnection = do

   214             noticeM "Core" "Connecting to the server..."

   215 

   216             proto <- getProtocolNumber "tcp"

   217             let hints = defaultHints { addrFlags = [AI_ADDRCONFIG, AI_CANONNAME] }

   218             (addr:_) <- getAddrInfo (Just hints) (Just serverAddress) Nothing

   219             let (SockAddrInet _ host) = addrAddress addr

   220             sock <- socket AF_INET Stream proto

   221             connect sock (SockAddrInet 46631 host)

   222             return sock