--- a/gameServer/OfficialServer/DBInteraction.hs Sat Feb 05 15:45:44 2011 +0100
+++ b/gameServer/OfficialServer/DBInteraction.hs Sat Feb 05 23:15:22 2011 +0300
@@ -6,7 +6,7 @@
import Prelude hiding (catch);
import System.Process
-import System.IO
+import System.IO as SIO
import Control.Concurrent
import qualified Control.Exception as Exception
import Control.Monad
@@ -14,6 +14,8 @@
import Data.Maybe
import System.Log.Logger
import Data.Time
+import Data.ByteString.Char8 as B
+import Data.List as L
------------------------
import CoreTypes
import Utils
@@ -24,7 +26,7 @@
q <- readChan $ dbQueries serverInfo
case q of
CheckAccount clId clUid _ clHost -> do
- writeChan (coreChan serverInfo) $ ClientAccountInfo clId clUid (if clHost `elem` localAddressList then Admin else Guest)
+ writeChan (coreChan serverInfo) $ ClientAccountInfo clId clUid (if clHost `L.elem` localAddressList then Admin else Guest)
ClearCache -> return ()
SendStats {} -> return ()
@@ -35,29 +37,29 @@
do
q <- readChan queries
updatedCache <- case q of
- CheckAccount clId clNick _ -> do
+ CheckAccount clId 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
+ SIO.hPutStrLn hIn $ show q
hFlush hIn
- (clId', accountInfo) <- hGetLine hOut >>= (maybeException . maybeRead)
+ (clId', clUid', accountInfo) <- SIO.hGetLine hOut >>= (maybeException . maybeRead)
- writeChan coreChan $ ClientAccountInfo (clId', accountInfo)
+ writeChan coreChan $ ClientAccountInfo clId' clUid' accountInfo
return $ Map.insert clNick (currentTime, accountInfo) accountsCache
`Exception.onException`
(unGetChan queries q)
else
do
- writeChan coreChan $ ClientAccountInfo (clId, snd $ fromJust cacheEntry)
+ writeChan coreChan $ ClientAccountInfo clId clUid (snd $ fromJust cacheEntry)
return accountsCache
ClearCache -> return Map.empty
SendStats {} -> (
- (hPutStrLn hIn $ show q) >>
+ (SIO.hPutStrLn hIn $ show q) >>
hFlush hIn >>
return accountsCache)
`Exception.onException`
@@ -69,7 +71,7 @@
maybeException Nothing = ioError (userError "Can't read")
-pipeDbConnection accountsCache serverInfo = do
+pipeDbConnection accountsCache si = do
updatedCache <-
Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return accountsCache) $ do
(Just hIn, Just hOut, _, _) <- createProcess (proc "./OfficialServer/extdbinterface" [])
@@ -78,19 +80,19 @@
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
+ B.hPutStrLn hIn $ dbHost si
+ B.hPutStrLn hIn $ dbLogin si
+ B.hPutStrLn hIn $ dbPassword si
+ pipeDbConnectionLoop (dbQueries si) (coreChan si) hIn hOut accountsCache
threadDelay (3 * 10^6)
- pipeDbConnection updatedCache serverInfo
+ pipeDbConnection updatedCache si
-dbConnectionLoop serverInfo =
- if (not . null $ dbHost serverInfo) then
- pipeDbConnection Map.empty serverInfo
+dbConnectionLoop si =
+ if (not . B.null $ dbHost si) then
+ pipeDbConnection Map.empty si
else
- fakeDbConnection serverInfo
+ fakeDbConnection si
#else
dbConnectionLoop = fakeDbConnection
#endif
--- a/gameServer/OfficialServer/extdbinterface.hs Sat Feb 05 15:45:44 2011 +0100
+++ b/gameServer/OfficialServer/extdbinterface.hs Sat Feb 05 23:15:22 2011 +0300
@@ -22,9 +22,9 @@
dbInteractionLoop dbConn = forever $ do
q <- (getLine >>= return . read)
hPutStrLn stderr $ show q
-
+
case q of
- CheckAccount clUid clNick _ -> do
+ CheckAccount clId clUid clNick _ -> do
statement <- prepare dbConn dbQueryAccount
execute statement [SqlByteString $ clNick]
passAndRole <- fetchRow statement
@@ -32,13 +32,14 @@
let response =
if isJust passAndRole then
(
+ clId,
clUid,
HasAccount
(fromSql $ head $ fromJust $ passAndRole)
((fromSql $ last $ fromJust $ passAndRole) == (Just (3 :: Int)))
)
else
- (clUid, Guest)
+ (clId, clUid, Guest)
putStrLn (show response)
hFlush stdout
@@ -54,8 +55,8 @@
(dbInteractionLoop)
-processRequest :: DBQuery -> IO String
-processRequest (CheckAccount clUid clNick clHost) = return $ show (clUid, Guest)
+--processRequest :: DBQuery -> IO String
+--processRequest (CheckAccount clId clUid clNick clHost) = return $ show (clclId, clUid, Guest)
main = do
dbHost <- getLine
--- a/gameServer/Utils.hs Sat Feb 05 15:45:44 2011 +0100
+++ b/gameServer/Utils.hs Sat Feb 05 23:15:22 2011 +0300
@@ -107,11 +107,11 @@
(37, "0.9.15"),
(38, "0.9.16-dev")]
-askFromConsole :: String -> IO String
+askFromConsole :: B.ByteString -> IO B.ByteString
askFromConsole msg = do
- putStr msg
+ B.putStr msg
hFlush stdout
- getLine
+ B.getLine
unfoldrE :: (b -> Either b (a, b)) -> b -> ([a], b)
--- a/gameServer/hedgewars-server.hs Sat Feb 05 15:45:44 2011 +0100
+++ b/gameServer/hedgewars-server.hs Sat Feb 05 23:15:22 2011 +0300
@@ -1,4 +1,4 @@
-{-# LANGUAGE CPP, ScopedTypeVariables #-}
+{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings #-}
module Main where
@@ -12,6 +12,9 @@
import Opts
import CoreTypes
import ServerCore
+#if defined(OFFICIAL_SERVER)
+import Utils
+#endif
#if !defined(mingw32_HOST_OS)