{-

 * 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 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, sClose)

import Network.Socket.ByteString

import qualified Data.ByteString.Char8 as B

import qualified Data.ByteString as BW

import qualified Codec.Binary.Base64 as Base64

import System.Process

import Data.Maybe

import Data.Either

import qualified Data.List as L

#if !defined(mingw32_HOST_OS)

import System.Posix

#endif

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

readInt_ str =

  case B.readInt str of

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

       _                      -> 0

data Message = Packet [B.ByteString]

             | CheckFailed B.ByteString

             | CheckSuccess [B.ByteString]

    deriving Show

serverAddress = "netserver.hedgewars.org"

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 : lst

engineListener :: 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 fileName

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 -> 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