{-# LANGUAGE CPP, ScopedTypeVariables #-}
module OfficialServer.DBInteraction
(
startDBConnection
) where
import Prelude hiding (catch);
import System.Process
import System.IO
import Control.Concurrent
import qualified Control.Exception as Exception
import Control.Monad
import qualified Data.Map as Map
import Monad
import Maybe
import System.Log.Logger
import Data.Time
------------------------
import CoreTypes
import Utils
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 ()
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
(clId, accountInfo) <- hGetLine hOut >>= (maybeException . maybeRead)
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
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")
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
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
dbConnectionLoop serverInfo =
if (not . null $ dbHost serverInfo) then
pipeDbConnection Map.empty serverInfo
else
fakeDbConnection serverInfo
#else
dbConnectionLoop = fakeDbConnection
#endif
startDBConnection serverInfo =
forkIO $ dbConnectionLoop serverInfo