{-

 * 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 OfficialServer.DBInteraction

(

    startDBConnection

) where

import Prelude hiding (catch);

import Control.Concurrent

import Control.Monad

import Data.List as L

import Data.ByteString.Char8 as B

#if defined(OFFICIAL_SERVER)

import System.Process

import System.IO as SIO

import qualified Control.Exception as Exception

import qualified Data.Map as Map

import Data.Maybe

import Data.Time

import System.Log.Logger

#endif

------------------------

import CoreTypes

#if defined(OFFICIAL_SERVER)

import Utils

#endif

localAddressList :: [B.ByteString]

localAddressList = ["127.0.0.1", "0:0:0:0:0:0:0:1", "0:0:0:0:0:ffff:7f00:1"]

fakeDbConnection :: forall b. ServerInfo -> IO b

fakeDbConnection si = forever $ do

    q <- readChan $ dbQueries si

    case q of

        CheckAccount clId clUid _ clHost ->

            writeChan (coreChan si) $ ClientAccountInfo clId clUid (if clHost `L.elem` localAddressList then Admin else Guest)

        ClearCache -> return ()

        SendStats {} -> return ()

dbConnectionLoop :: ServerInfo -> IO ()

#if defined(OFFICIAL_SERVER)

flushRequests :: ServerInfo -> IO ()

flushRequests si = do

    e <- isEmptyChan $ dbQueries si

    unless e $ do

        q <- readChan $ dbQueries si

        case q of

            CheckAccount clId clUid _ clHost ->

                writeChan (coreChan si) $ ClientAccountInfo clId clUid (if clHost `L.elem` localAddressList then Admin else Guest)

            ClearCache -> return ()

            SendStats {} -> return ()

            GetReplayName {} -> return ()

            StoreAchievements {} -> return ()

        flushRequests si

pipeDbConnectionLoop :: Chan DBQuery -> Chan CoreMessage -> Handle -> Handle -> Map.Map ByteString (UTCTime, AccountInfo) -> Int -> IO (Map.Map ByteString (UTCTime, AccountInfo), Int)

pipeDbConnectionLoop queries cChan hIn hOut accountsCache req =

    Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return (accountsCache, req)) $

    do

    q <- readChan queries

    (updatedCache, newReq) <- case q of

        CheckAccount clId clUid clNick _ -> do

            let cacheEntry = clNick `Map.lookup` accountsCache

            currentTime <- getCurrentTime

            if (isNothing cacheEntry) || (currentTime `diffUTCTime` (fst . fromJust) cacheEntry > 10 * 60) then

                do

                    SIO.hPutStrLn hIn $ show q

                    hFlush hIn

                    (clId', clUid', accountInfo) <- SIO.hGetLine hOut >>= (maybeException . maybeRead)

                    writeChan cChan $ ClientAccountInfo clId' clUid' accountInfo

                    return $ (Map.insert clNick (currentTime, accountInfo) accountsCache, req + 1)

                `Exception.onException`

                    (unGetChan queries q)

                else

                do

                    writeChan cChan $ ClientAccountInfo clId clUid (snd $ fromJust cacheEntry)

                    return (accountsCache, req)

        GetReplayName {} -> do

            SIO.hPutStrLn hIn $ show q

            hFlush hIn

            (clId', clUid', accountInfo) <- SIO.hGetLine hOut >>= (maybeException . maybeRead)

            writeChan cChan $ ClientAccountInfo clId' clUid' accountInfo

            return (accountsCache, req)

        ClearCache -> return (Map.empty, req)

        StoreAchievements {} -> (

                (SIO.hPutStrLn hIn $ show q) >>

                hFlush hIn >>

                return (accountsCache, req))

                `Exception.onException`

                (unGetChan queries q)

        SendStats {} -> (

                (SIO.hPutStrLn hIn $ show q) >>

                hFlush hIn >>

                return (accountsCache, req))

                `Exception.onException`

                (unGetChan queries q)

    pipeDbConnectionLoop queries cChan hIn hOut updatedCache newReq

    where

        maybeException (Just a) = return a

        maybeException Nothing = ioError (userError "Can't read")

pipeDbConnection ::

        Map.Map ByteString (UTCTime, AccountInfo)

        -> ServerInfo

        -> Int

        -> IO ()

pipeDbConnection accountsCache si errNum = do

    (updatedCache, newErrNum) <-

        Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return (accountsCache, errNum + 1)) $ do

            (Just hIn, Just hOut, _, _) <- createProcess (proc "./OfficialServer/extdbinterface" [])

                    {std_in = CreatePipe,

                    std_out = CreatePipe}

            hSetBuffering hIn LineBuffering

            hSetBuffering hOut LineBuffering

            B.hPutStrLn hIn $ dbHost si

            B.hPutStrLn hIn $ dbName si

            B.hPutStrLn hIn $ dbLogin si

            B.hPutStrLn hIn $ dbPassword si

            (c, r) <- pipeDbConnectionLoop (dbQueries si) (coreChan si) hIn hOut accountsCache 0

            return (c, if r > 0 then 0 else errNum + 1)

    when (newErrNum > 1) $ flushRequests si

    threadDelay (3000000)

    pipeDbConnection updatedCache si newErrNum

dbConnectionLoop si =

        if (not . B.null $ dbHost si) then

            pipeDbConnection Map.empty si 0

        else

            fakeDbConnection si

#else

dbConnectionLoop = fakeDbConnection

#endif

startDBConnection :: ServerInfo -> IO ()

startDBConnection serverInfo =

    forkIO (dbConnectionLoop serverInfo) >> return ()