gameServer/OfficialServer/extdbinterface.hs
author Xeli
Thu, 09 Feb 2012 14:12:50 +0100
changeset 6654 120e95c10532
parent 6040 a740069c21e3
child 8909 95542e198bc8
permissions -rw-r--r--
use the way actions are initiated the same way as koda implemented with PascalExports, using boolean values such as upKey and enterKey, this prevents the user from being able to control the AI
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
4906
22cc9c2b5ae5 Fix even more
unc0rr
parents: 4568
diff changeset
     1
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
2348
b39d826e1ccd Drop support for ghc 6.8, use 6.10 instead
unc0rr
parents: 2195
diff changeset
     2
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
     3
module Main where
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
     4
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
     5
import Prelude hiding (catch)
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
     6
import Control.Monad
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
     7
import Control.Exception
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
     8
import System.IO
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
     9
import Data.Maybe
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    10
import Database.HDBC
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    11
import Database.HDBC.MySQL
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    12
--------------------------
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    13
import CoreTypes
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    14
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    15
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2117
diff changeset
    16
dbQueryAccount =
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    17
    "SELECT users.pass, users_roles.rid FROM users LEFT JOIN users_roles ON users.uid = users_roles.uid WHERE users.name = ?"
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    18
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2117
diff changeset
    19
dbQueryStats =
6040
a740069c21e3 - Add unique id to replay file name
unc0rr
parents: 4982
diff changeset
    20
    "INSERT INTO gameserver_stats (players, rooms, last_update) VALUES (?, ?, UNIX_TIMESTAMP())"
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2117
diff changeset
    21
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    22
dbInteractionLoop dbConn = forever $ do
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    23
    q <- liftM read getLine
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    24
    hPutStrLn stderr $ show q
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
    25
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    26
    case q of
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
    27
        CheckAccount clId clUid clNick _ -> do
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    28
                statement <- prepare dbConn dbQueryAccount
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    29
                execute statement [SqlByteString clNick]
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    30
                passAndRole <- fetchRow statement
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    31
                finish statement
2919
70244c730ea0 Now really fix build
unc0rr
parents: 2918
diff changeset
    32
                let response = 
70244c730ea0 Now really fix build
unc0rr
parents: 2918
diff changeset
    33
                        if isJust passAndRole then
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    34
                        (
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
    35
                            clId,
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    36
                            clUid,
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    37
                            HasAccount
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    38
                                (fromSql . head . fromJust $ passAndRole)
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    39
                                (fromSql (last . fromJust $ passAndRole) == Just (3 :: Int))
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    40
                        )
2919
70244c730ea0 Now really fix build
unc0rr
parents: 2918
diff changeset
    41
                        else
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
    42
                        (clId, clUid, Guest)
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    43
                print response
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    44
                hFlush stdout
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    45
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    46
        SendStats clients rooms ->
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    47
                run dbConn dbQueryStats [SqlInt32 $ fromIntegral clients, SqlInt32 $ fromIntegral rooms] >> return ()
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2117
diff changeset
    48
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    49
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    50
dbConnectionLoop mySQLConnectionInfo =
4906
22cc9c2b5ae5 Fix even more
unc0rr
parents: 4568
diff changeset
    51
    Control.Exception.handle (\(e :: IOException) -> hPutStrLn stderr $ show e) $ handleSqlError $
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    52
        bracket
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    53
            (connectMySQL mySQLConnectionInfo)
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    54
            disconnect
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    55
            dbInteractionLoop
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    56
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    57
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
    58
--processRequest :: DBQuery -> IO String
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
    59
--processRequest (CheckAccount clId clUid clNick clHost) = return $ show (clclId, clUid, Guest)
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    60
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    61
main = do
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    62
        dbHost <- getLine
4982
3572eaf14340 Add dbName parameter to .ini file, fix some warnings
unc0rr
parents: 4932
diff changeset
    63
        dbName <- getLine
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    64
        dbLogin <- getLine
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    65
        dbPassword <- getLine
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    66
4982
3572eaf14340 Add dbName parameter to .ini file, fix some warnings
unc0rr
parents: 4932
diff changeset
    67
        let mySQLConnectInfo = defaultMySQLConnectInfo {mysqlHost = dbHost, mysqlDatabase = dbName, mysqlUser = dbLogin, mysqlPassword = dbPassword}
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    68
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    69
        dbConnectionLoop mySQLConnectInfo