gameServer/OfficialServer/extdbinterface.hs
author koda
Sat, 05 Feb 2011 22:22:16 +0100
changeset 4924 616b618814b5
parent 4921 2efad3acbb74
child 4932 f11d80bac7ed
permissions -rw-r--r--
show dual head mode some love
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
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
     9
import Maybe
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 =
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    20
    "UPDATE gameserver_stats SET players = ?, rooms = ?, last_update = 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
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    23
    q <- (getLine >>= return . read)
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
4906
22cc9c2b5ae5 Fix even more
unc0rr
parents: 4568
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
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    38
                                (fromSql $ head $ fromJust $ passAndRole)
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    39
                                ((fromSql $ last $ fromJust $ passAndRole) == (Just (3 :: Int)))
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)
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    43
                putStrLn (show response)
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)
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    54
            (disconnect)
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
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
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    63
        dbLogin <- getLine
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    64
        dbPassword <- getLine
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    65
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    66
        let mySQLConnectInfo = defaultMySQLConnectInfo {mysqlHost = dbHost, mysqlDatabase = "hedge_main", mysqlUser = dbLogin, mysqlPassword = dbPassword}
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    67
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    68
        dbConnectionLoop mySQLConnectInfo