gameServer/OfficialServer/extdbinterface.hs
author nemo
Sat, 01 Mar 2014 14:52:36 -0500
changeset 10171 00f41ff0bf2d
parent 10017 de822cd3df3a
child 10460 8dcea9087d75
permissions -rw-r--r--
Script might well override a static map, but can't risk it not doing it, and preview completely failing. Better to just not try it for static maps. Some script cfg might help. Could also avoid unnnecessary preview regenerations even if the script was doing nothing at all.

{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}

module Main where

import Prelude hiding (catch)
import Control.Monad
import Control.Exception
import System.IO
import Data.Maybe
import Database.HDBC
import Database.HDBC.MySQL
import Data.List (lookup)
import qualified Data.ByteString.Char8 as B
import Data.Word
--------------------------
import CoreTypes
import Utils


dbQueryAccount =
    "SELECT users.pass, \
    \ (SELECT COUNT(users_roles.rid) FROM users_roles WHERE users.uid = users_roles.uid AND users_roles.rid = 3), \
    \ (SELECT COUNT(users_roles.rid) FROM users_roles WHERE users.uid = users_roles.uid AND users_roles.rid = 13) \
    \ FROM users WHERE users.name = ?"

dbQueryStats =
    "INSERT INTO gameserver_stats (players, rooms, last_update) VALUES (?, ?, UNIX_TIMESTAMP())"

dbQueryAchievement =
    "INSERT INTO achievements (time, typeid, userid, value, filename, location, protocol) \
    \ VALUES (?, (SELECT id FROM achievement_types WHERE name = ?), (SELECT uid FROM users WHERE name = ?), \
    \ ?, ?, ?, ?)"

dbQueryReplayFilename = "SELECT filename FROM achievements WHERE id = ?"


dbInteractionLoop dbConn = forever $ do
    q <- liftM read getLine
    hPutStrLn stderr $ show q

    case q of
        CheckAccount clId clUid clNick _ -> do
                statement <- prepare dbConn dbQueryAccount
                execute statement [SqlByteString clNick]
                result <- fetchRow statement
                finish statement
                let response =
                        if isJust result then let [pass, adm, contr] = fromJust result in
                        (
                            clId,
                            clUid,
                            HasAccount
                                (fromSql pass)
                                (fromSql adm == Just (1 :: Int))
                                (fromSql contr == Just (1 :: Int))
                        )
                        else
                        (clId, clUid, Guest)
                print response
                hFlush stdout

        GetReplayName clId clUid fileId -> do
                statement <- prepare dbConn dbQueryReplayFilename
                execute statement [SqlByteString fileId]
                result <- fetchRow statement
                finish statement
                let fn = if (isJust result) then fromJust . fromSql . head . fromJust $ result else ""
                print (clId, clUid, ReplayName fn)
                hFlush stdout

        SendStats clients rooms ->
                run dbConn dbQueryStats [SqlInt32 $ fromIntegral clients, SqlInt32 $ fromIntegral rooms] >> return ()
--StoreAchievements (B.pack fileName) (map toPair teams) info
        StoreAchievements p fileName teams info ->
            mapM_ (run dbConn dbQueryAchievement) $ (parseStats p fileName teams) info


readTime = read . B.unpack . B.take 19 . B.drop 8


parseStats :: Word16 -> B.ByteString -> [(B.ByteString, B.ByteString)] -> [B.ByteString] -> [[SqlValue]]
parseStats p fileName teams = ps
    where
    time = readTime fileName
    ps [] = []
    ps ("DRAW" : bs) = ps bs
    ps ("WINNERS" : n : bs) = ps $ drop (readInt_ n) bs
    ps ("ACHIEVEMENT" : typ : teamname : location : value : bs) =
        [ SqlUTCTime time
        , SqlByteString typ
        , SqlByteString $ fromMaybe "" (lookup teamname teams)
        , SqlInt32 (readInt_ value)
        , SqlByteString fileName
        , SqlByteString location
        , SqlInt32 $ fromIntegral p
        ] : ps bs
    ps (b:bs) = ps bs


dbConnectionLoop mySQLConnectionInfo =
    Control.Exception.handle (\(e :: IOException) -> hPutStrLn stderr $ show e) $ handleSqlError $
        bracket
            (connectMySQL mySQLConnectionInfo)
            disconnect
            dbInteractionLoop


--processRequest :: DBQuery -> IO String
--processRequest (CheckAccount clId clUid clNick clHost) = return $ show (clclId, clUid, Guest)

main = do
        dbHost <- getLine
        dbName <- getLine
        dbLogin <- getLine
        dbPassword <- getLine

        let mySQLConnectInfo = defaultMySQLConnectInfo {mysqlHost = dbHost, mysqlDatabase = dbName, mysqlUser = dbLogin, mysqlPassword = dbPassword}

        dbConnectionLoop mySQLConnectInfo