--- a/gameServer/OfficialServer/DBInteraction.hs Thu Feb 25 18:34:30 2010 +0000
+++ b/gameServer/OfficialServer/DBInteraction.hs Thu Feb 25 18:34:36 2010 +0000
@@ -1,7 +1,7 @@
{-# LANGUAGE CPP, ScopedTypeVariables #-}
module OfficialServer.DBInteraction
(
- startDBConnection
+ startDBConnection
) where
import Prelude hiding (catch);
@@ -22,82 +22,82 @@
localAddressList = ["127.0.0.1", "0:0:0:0:0:0:0:1", "0:0:0:0:0:ffff:7f00:1"]
fakeDbConnection serverInfo = do
- q <- readChan $ dbQueries serverInfo
- case q of
- CheckAccount clUid _ clHost -> do
- writeChan (coreChan serverInfo) $ ClientAccountInfo (clUid,
- if clHost `elem` localAddressList then Admin else Guest)
- ClearCache -> return ()
- SendStats {} -> return ()
+ q <- readChan $ dbQueries serverInfo
+ case q of
+ CheckAccount clUid _ clHost -> do
+ writeChan (coreChan serverInfo) $ ClientAccountInfo (clUid,
+ if clHost `elem` localAddressList then Admin else Guest)
+ ClearCache -> return ()
+ SendStats {} -> return ()
- fakeDbConnection serverInfo
+ fakeDbConnection serverInfo
#if defined(OFFICIAL_SERVER)
pipeDbConnectionLoop queries coreChan hIn hOut accountsCache =
- Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return accountsCache) $
- do
- q <- readChan queries
- updatedCache <- case q of
- CheckAccount clUid clNick _ -> do
- let cacheEntry = clNick `Map.lookup` accountsCache
- currentTime <- getCurrentTime
- if (isNothing cacheEntry) || (currentTime `diffUTCTime` (fst . fromJust) cacheEntry > 2 * 24 * 60 * 60) then
- do
- hPutStrLn hIn $ show q
- hFlush hIn
+ Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return accountsCache) $
+ do
+ q <- readChan queries
+ updatedCache <- case q of
+ CheckAccount clUid clNick _ -> do
+ let cacheEntry = clNick `Map.lookup` accountsCache
+ currentTime <- getCurrentTime
+ if (isNothing cacheEntry) || (currentTime `diffUTCTime` (fst . fromJust) cacheEntry > 2 * 24 * 60 * 60) then
+ do
+ hPutStrLn hIn $ show q
+ hFlush hIn
- (clId, accountInfo) <- hGetLine hOut >>= (maybeException . maybeRead)
+ (clId, accountInfo) <- hGetLine hOut >>= (maybeException . maybeRead)
- writeChan coreChan $ ClientAccountInfo (clId, accountInfo)
+ writeChan coreChan $ ClientAccountInfo (clId, accountInfo)
- return $ Map.insert clNick (currentTime, accountInfo) accountsCache
- `Exception.onException`
- (unGetChan queries q)
- else
- do
- writeChan coreChan $ ClientAccountInfo (clUid, snd $ fromJust cacheEntry)
- return accountsCache
+ return $ Map.insert clNick (currentTime, accountInfo) accountsCache
+ `Exception.onException`
+ (unGetChan queries q)
+ else
+ do
+ writeChan coreChan $ ClientAccountInfo (clUid, snd $ fromJust cacheEntry)
+ return accountsCache
- ClearCache -> return Map.empty
- SendStats {} -> (
- (hPutStrLn hIn $ show q) >>
- hFlush hIn >>
- return accountsCache)
- `Exception.onException`
- (unGetChan queries q)
+ ClearCache -> return Map.empty
+ SendStats {} -> (
+ (hPutStrLn hIn $ show q) >>
+ hFlush hIn >>
+ return accountsCache)
+ `Exception.onException`
+ (unGetChan queries q)
- pipeDbConnectionLoop queries coreChan hIn hOut updatedCache
- where
- maybeException (Just a) = return a
- maybeException Nothing = ioError (userError "Can't read")
+ pipeDbConnectionLoop queries coreChan hIn hOut updatedCache
+ where
+ maybeException (Just a) = return a
+ maybeException Nothing = ioError (userError "Can't read")
pipeDbConnection accountsCache serverInfo = do
- updatedCache <-
- Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return accountsCache) $ do
- (Just hIn, Just hOut, _, _) <- createProcess (proc "./OfficialServer/extdbinterface" [])
- {std_in = CreatePipe,
- std_out = CreatePipe}
- hSetBuffering hIn LineBuffering
- hSetBuffering hOut LineBuffering
+ updatedCache <-
+ Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return accountsCache) $ do
+ (Just hIn, Just hOut, _, _) <- createProcess (proc "./OfficialServer/extdbinterface" [])
+ {std_in = CreatePipe,
+ std_out = CreatePipe}
+ hSetBuffering hIn LineBuffering
+ hSetBuffering hOut LineBuffering
- hPutStrLn hIn $ dbHost serverInfo
- hPutStrLn hIn $ dbLogin serverInfo
- hPutStrLn hIn $ dbPassword serverInfo
- pipeDbConnectionLoop (dbQueries serverInfo) (coreChan serverInfo) hIn hOut accountsCache
+ hPutStrLn hIn $ dbHost serverInfo
+ hPutStrLn hIn $ dbLogin serverInfo
+ hPutStrLn hIn $ dbPassword serverInfo
+ pipeDbConnectionLoop (dbQueries serverInfo) (coreChan serverInfo) hIn hOut accountsCache
- threadDelay (3 * 10^6)
- pipeDbConnection updatedCache serverInfo
+ threadDelay (3 * 10^6)
+ pipeDbConnection updatedCache serverInfo
dbConnectionLoop serverInfo =
- if (not . null $ dbHost serverInfo) then
- pipeDbConnection Map.empty serverInfo
- else
- fakeDbConnection serverInfo
+ if (not . null $ dbHost serverInfo) then
+ pipeDbConnection Map.empty serverInfo
+ else
+ fakeDbConnection serverInfo
#else
dbConnectionLoop = fakeDbConnection
#endif
startDBConnection serverInfo =
- forkIO $ dbConnectionLoop serverInfo
+ forkIO $ dbConnectionLoop serverInfo
--- a/gameServer/OfficialServer/extdbinterface.hs Thu Feb 25 18:34:30 2010 +0000
+++ b/gameServer/OfficialServer/extdbinterface.hs Thu Feb 25 18:34:36 2010 +0000
@@ -14,54 +14,54 @@
dbQueryAccount =
- "select users.pass, users_roles.rid from users left join users_roles on users.uid = users_roles.uid where users.name = ?"
+ "SELECT users.pass, users_roles.rid FROM users LEFT JOIN users_roles ON users.uid = users_roles.uid WHERE users.name = ?"
dbQueryStats =
- "UPDATE gameserver_stats SET players = ?, rooms = ?, last_update = UNIX_TIMESTAMP()"
+ "UPDATE gameserver_stats SET players = ?, rooms = ?, last_update = UNIX_TIMESTAMP()"
dbInteractionLoop dbConn = forever $ do
- q <- (getLine >>= return . read)
- hPutStrLn stderr $ show q
-
- case q of
- CheckAccount clUid clNick _ -> do
- statement <- prepare dbConn dbQueryAccount
- execute statement [SqlString $ clNick]
- passAndRole <- fetchRow statement
- finish statement
- let response =
- if isJust passAndRole then
- (
- clUid,
- HasAccount
- (fromSql $ head $ fromJust $ passAndRole)
- ((fromSql $ last $ fromJust $ passAndRole) == (Just (3 :: Int)))
- )
- else
- (clUid, Guest)
- putStrLn (show response)
- hFlush stdout
+ q <- (getLine >>= return . read)
+ hPutStrLn stderr $ show q
+
+ case q of
+ CheckAccount clUid clNick _ -> do
+ statement <- prepare dbConn dbQueryAccount
+ execute statement [SqlString $ clNick]
+ passAndRole <- fetchRow statement
+ finish statement
+ let response =
+ if isJust passAndRole then
+ (
+ clUid,
+ HasAccount
+ (fromSql $ head $ fromJust $ passAndRole)
+ ((fromSql $ last $ fromJust $ passAndRole) == (Just (3 :: Int)))
+ )
+ else
+ (clUid, Guest)
+ putStrLn (show response)
+ hFlush stdout
- SendStats clients rooms ->
- run dbConn dbQueryStats [SqlInt32 $ fromIntegral clients, SqlInt32 $ fromIntegral rooms] >> return ()
+ SendStats clients rooms ->
+ run dbConn dbQueryStats [SqlInt32 $ fromIntegral clients, SqlInt32 $ fromIntegral rooms] >> return ()
dbConnectionLoop mySQLConnectionInfo =
- Control.Exception.handle (\(_ :: IOException) -> return ()) $ handleSqlError $
- bracket
- (connectMySQL mySQLConnectionInfo)
- (disconnect)
- (dbInteractionLoop)
+ Control.Exception.handle (\(_ :: IOException) -> return ()) $ handleSqlError $
+ bracket
+ (connectMySQL mySQLConnectionInfo)
+ (disconnect)
+ (dbInteractionLoop)
processRequest :: DBQuery -> IO String
processRequest (CheckAccount clUid clNick clHost) = return $ show (clUid, Guest)
main = do
- dbHost <- getLine
- dbLogin <- getLine
- dbPassword <- getLine
+ dbHost <- getLine
+ dbLogin <- getLine
+ dbPassword <- getLine
- let mySQLConnectInfo = defaultMySQLConnectInfo {mysqlHost = dbHost, mysqlDatabase = "hedge_main", mysqlUser = dbLogin, mysqlPassword = dbPassword}
+ let mySQLConnectInfo = defaultMySQLConnectInfo {mysqlHost = dbHost, mysqlDatabase = "hedge_main", mysqlUser = dbLogin, mysqlPassword = dbPassword}
- dbConnectionLoop mySQLConnectInfo
+ dbConnectionLoop mySQLConnectInfo