--- a/gameServer/Actions.hs Tue Feb 24 19:39:10 2009 +0000
+++ b/gameServer/Actions.hs Tue Feb 24 19:39:49 2009 +0000
@@ -5,6 +5,7 @@
import Data.IntMap
import qualified Data.IntSet as IntSet
import qualified Data.Sequence as Seq
+import System.Log.Logger
import Monad
-----------------------------
import CoreTypes
@@ -29,6 +30,7 @@
| ModifyRoom (RoomInfo -> RoomInfo)
| AddRoom String String
| CheckRegistered
+ | ProcessAccountInfo AccountInfo
| Dump
type CmdHandler = Int -> Clients -> Rooms -> [String] -> [Action]
@@ -243,7 +245,7 @@
processAction (clID, serverInfo, clients, rooms) (CheckRegistered) = do
- writeChan (dbQueries serverInfo) $ HasRegistered $ nick client
+ writeChan (dbQueries serverInfo) $ CheckAccount clID (nick client)
return (clID, serverInfo, clients, rooms)
where
client = clients ! clID
@@ -252,3 +254,13 @@
writeChan (sendChan $ clients ! clID) ["DUMP", show serverInfo, showTree clients, showTree rooms]
return (clID, serverInfo, clients, rooms)
+processAction (clID, serverInfo, clients, rooms) (ProcessAccountInfo info) = do
+ case info of
+ HasAccount -> do
+ infoM "Clients" $ show clID ++ " has account"
+ writeChan (sendChan $ clients ! clID) ["ASKPASSWORD"]
+ LogonPassed -> do
+ infoM "Clients" $ show clID ++ " authenticated"
+ Guest -> do
+ infoM "Clients" $ show clID ++ " is guest"
+ return (clID, serverInfo, clients, rooms)
--- a/gameServer/CoreTypes.hs Tue Feb 24 19:39:10 2009 +0000
+++ b/gameServer/CoreTypes.hs Tue Feb 24 19:39:49 2009 +0000
@@ -117,6 +117,7 @@
dbLogin :: String,
dbPassword :: String,
stats :: TMVar StatisticsInfo,
+ coreChan :: Chan CoreMessage,
dbQueries :: Chan DBQuery
}
@@ -135,14 +136,20 @@
""
)
+data AccountInfo =
+ HasAccount
+ | LogonPassed
+ | Guest
+
data CoreMessage =
Accept ClientInfo
| ClientMessage (Int, [String])
+ | ClientAccountInfo Int AccountInfo
-- | CoreMessage String
-- | TimerTick
data DBQuery =
- HasRegistered String
+ CheckAccount Int String
| CheckPassword String
--- a/gameServer/NetRoutines.hs Tue Feb 24 19:39:10 2009 +0000
+++ b/gameServer/NetRoutines.hs Tue Feb 24 19:39:49 2009 +0000
@@ -29,7 +29,7 @@
clientHost <- sockAddr2String sockAddr
currentTime <- getCurrentTime
- putStrLn $ (show currentTime) ++ " new client id: " ++ (show nextID)
+ --putStrLn $ (show currentTime) ++ " new client id: " ++ (show nextID)
sendChan <- newChan
--- a/gameServer/OfficialServer/DBInteraction.hs Tue Feb 24 19:39:10 2009 +0000
+++ b/gameServer/OfficialServer/DBInteraction.hs Tue Feb 24 19:39:49 2009 +0000
@@ -1,9 +1,9 @@
module OfficialServer.DBInteraction
(
- startDBConnection,
- DBQuery(HasRegistered, CheckPassword)
+ startDBConnection
) where
+import Prelude hiding (catch);
import Database.HDBC
import Database.HDBC.MySQL
import System.IO
@@ -11,30 +11,47 @@
import Control.Exception
import Monad
import Maybe
+import System.Log.Logger
------------------------
import CoreTypes
-dbInteractionLoop queries dbConn = do
+
+-------------------------------------------------------------------
+-- borrowed from base 4.0.0 ---------------------------------------
+onException :: IO a -> IO b -> IO a --
+onException io what = io `catch` \e -> do what --
+ throw (e :: Exception) --
+-- to be deleted --------------------------------------------------
+-------------------------------------------------------------------
+
+
+dbInteractionLoop queries coreChan dbConn = do
q <- readChan queries
case q of
- HasRegistered name -> do
- statement <- prepare dbConn "SELECT uid FROM users WHERE name=?"
- execute statement [SqlString name]
- uid <- fetchRow statement
- finish statement
- putStrLn (show $ isJust uid)
+ CheckAccount clID name -> do
+ statement <- prepare dbConn "SELECT uid FROM users WHERE name=?"
+ execute statement [SqlString name]
+ uid <- fetchRow statement
+ finish statement
+ if isJust uid then
+ writeChan coreChan $ ClientAccountInfo clID HasAccount
+ else
+ writeChan coreChan $ ClientAccountInfo clID Guest
+ `onException`
+ (unGetChan queries $ CheckAccount clID name)
+
CheckPassword queryStr -> putStrLn queryStr
- dbInteractionLoop queries dbConn
+ dbInteractionLoop queries coreChan dbConn
dbConnectionLoop serverInfo = do
- Control.Exception.handle (\e -> print e) $ handleSqlError $
+ Control.Exception.handle (\e -> infoM "Database" $ show e) $ handleSqlError $
bracket
(connectMySQL defaultMySQLConnectInfo {mysqlHost = dbHost serverInfo, mysqlDatabase = "hedge_main", mysqlUser = dbLogin serverInfo, mysqlPassword = dbPassword serverInfo })
(disconnect)
- (dbInteractionLoop $ dbQueries serverInfo)
+ (dbInteractionLoop (dbQueries serverInfo) (coreChan serverInfo))
- threadDelay (15 * 10^6)
+ threadDelay (5 * 10^6)
dbConnectionLoop serverInfo
startDBConnection serverInfo =
--- a/gameServer/ServerCore.hs Tue Feb 24 19:39:10 2009 +0000
+++ b/gameServer/ServerCore.hs Tue Feb 24 19:39:49 2009 +0000
@@ -15,21 +15,24 @@
import Actions
import OfficialServer.DBInteraction
+
+firstAway (_, a, b, c) = (a, b, c)
+
reactCmd :: ServerInfo -> Int -> [String] -> Clients -> Rooms -> IO (ServerInfo, Clients, Rooms)
reactCmd serverInfo clID cmd clients rooms = do
(_ , serverInfo, clients, rooms) <-
foldM processAction (clID, serverInfo, clients, rooms) $ handleCmd clID clients rooms cmd
return (serverInfo, clients, rooms)
-mainLoop :: Chan CoreMessage -> ServerInfo -> Clients -> Rooms -> IO ()
-mainLoop coreChan serverInfo clients rooms = do
- r <- readChan coreChan
+mainLoop :: ServerInfo -> Clients -> Rooms -> IO ()
+mainLoop serverInfo clients rooms = do
+ r <- readChan $ coreChan serverInfo
(newServerInfo, mClients, mRooms) <-
case r of
Accept ci -> do
let updatedClients = IntMap.insert (clientUID ci) ci clients
- --infoM "Clients" ("New client: id " ++ (show $ clientUID ci))
+ infoM "Clients" ("New client: id " ++ (show $ clientUID ci))
processAction
(clientUID ci, serverInfo, updatedClients, rooms)
(AnswerThisClient ["CONNECTED", "Hedgewars server http://www.hedgewars.org/"])
@@ -44,11 +47,22 @@
debugM "Clients" "Message from dead client"
return (serverInfo, clients, rooms)
+ ClientAccountInfo clID info ->
+ if clID `IntMap.member` clients then
+ liftM firstAway $ processAction
+ (clID, serverInfo, clients, rooms)
+ (ProcessAccountInfo info)
+ else
+ do
+ debugM "Clients" "Got info for dead client"
+ return (serverInfo, clients, rooms)
+
+
{- let hadRooms = (not $ null rooms) && (null mrooms)
in unless ((not $ isDedicated serverInfo) && ((null clientsIn) || hadRooms)) $
mainLoop serverInfo acceptChan messagesChan clientsIn mrooms -}
- mainLoop coreChan newServerInfo mClients mRooms
+ mainLoop newServerInfo mClients mRooms
startServer :: ServerInfo -> Chan CoreMessage -> Socket -> IO ()
startServer serverInfo coreChan serverSocket = do
@@ -67,7 +81,7 @@
startDBConnection $ serverInfo
- mainLoop coreChan serverInfo IntMap.empty (IntMap.singleton 0 newRoom)
+ mainLoop serverInfo IntMap.empty (IntMap.singleton 0 newRoom)
--- a/gameServer/hedgewars-server.hs Tue Feb 24 19:39:10 2009 +0000
+++ b/gameServer/hedgewars-server.hs Tue Feb 24 19:39:49 2009 +0000
@@ -50,7 +50,7 @@
stats <- atomically $ newTMVar (StatisticsInfo 0 0)
dbQueriesChan <- newChan
coreChan <- newChan
- serverInfo <- getOpts $ newServerInfo stats dbQueriesChan
+ serverInfo <- getOpts $ newServerInfo stats coreChan dbQueriesChan
bracket
(Network.listenOn $ Network.PortNumber $ listenPort serverInfo)