gameServer/OfficialServer/extdbinterface.hs
author nemo
Fri, 05 Nov 2010 18:56:12 -0400
changeset 4140 1563b216f243
parent 3901 124b4755914b
child 4242 5e3c5fe2cb14
permissions -rw-r--r--
revert attempts to block switching weapon while targetting in infinite attack mode. just getting too messy. probably best to allow any weapon to be targetted, and store the target in the gear and draw it there instead of uworld, but I'm leaving this alone
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
3901
124b4755914b Show database errors in stderr
unc0rr
parents: 2919
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
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    25
    
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    26
    case q of
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    27
        CheckAccount clUid clNick _ -> do
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    28
                statement <- prepare dbConn dbQueryAccount
3901
124b4755914b Show database errors in stderr
unc0rr
parents: 2919
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
                        (
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    35
                            clUid,
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    36
                            HasAccount
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    37
                                (fromSql $ head $ fromJust $ passAndRole)
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    38
                                ((fromSql $ last $ fromJust $ passAndRole) == (Just (3 :: Int)))
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    39
                        )
2919
70244c730ea0 Now really fix build
unc0rr
parents: 2918
diff changeset
    40
                        else
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    41
                        (clUid, Guest)
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    42
                putStrLn (show response)
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    43
                hFlush stdout
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    44
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    45
        SendStats clients rooms ->
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    46
                run dbConn dbQueryStats [SqlInt32 $ fromIntegral clients, SqlInt32 $ fromIntegral rooms] >> return ()
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2117
diff changeset
    47
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    48
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    49
dbConnectionLoop mySQLConnectionInfo =
3901
124b4755914b Show database errors in stderr
unc0rr
parents: 2919
diff changeset
    50
    Control.Exception.handle (\(e :: IOException) -> hPutStrLn stderr $ show e) $ handleSqlError $
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    51
        bracket
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    52
            (connectMySQL mySQLConnectionInfo)
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    53
            (disconnect)
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    54
            (dbInteractionLoop)
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    55
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
processRequest :: DBQuery -> IO String
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    58
processRequest (CheckAccount clUid clNick clHost) = return $ show (clUid, Guest)
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    59
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    60
main = do
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    61
        dbHost <- getLine
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    62
        dbLogin <- getLine
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    63
        dbPassword <- getLine
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    64
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    65
        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
    66
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    67
        dbConnectionLoop mySQLConnectInfo