gameServer/OfficialServer/extdbinterface.hs
author nemo
Tue, 30 Mar 2010 13:33:01 +0000
changeset 3173 909b28b1b61a
parent 2919 70244c730ea0
child 3901 124b4755914b
permissions -rw-r--r--
This map has always been broken. This variant makes it slightly less broken (although something changed on the ceiling might prevent hiding on pixels on the slope). What will finally fix it is either moving nets closer together or adding angle bounce to hedgehogs or some other layout that prevents hiding.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
2348
b39d826e1ccd Drop support for ghc 6.8, use 6.10 instead
unc0rr
parents: 2195
diff changeset
     1
{-# LANGUAGE ScopedTypeVariables #-}
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
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    29
                execute statement [SqlString $ clNick]
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 =
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    50
    Control.Exception.handle (\(_ :: IOException) -> return ()) $ handleSqlError $
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