--- 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