# HG changeset patch # User unc0rr # Date 1235504389 0 # Node ID 5dd4cb7fd7e59f9adb06e7f4478bf3e7cb41d244 # Parent 00a5fc50aa438196205f10ed84ac38d64e661465 Server now send ASKPASSWORD command to frontend when user has web account diff -r 00a5fc50aa43 -r 5dd4cb7fd7e5 gameServer/Actions.hs --- 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) diff -r 00a5fc50aa43 -r 5dd4cb7fd7e5 gameServer/CoreTypes.hs --- 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 diff -r 00a5fc50aa43 -r 5dd4cb7fd7e5 gameServer/NetRoutines.hs --- 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 diff -r 00a5fc50aa43 -r 5dd4cb7fd7e5 gameServer/OfficialServer/DBInteraction.hs --- 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 = diff -r 00a5fc50aa43 -r 5dd4cb7fd7e5 gameServer/ServerCore.hs --- 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) diff -r 00a5fc50aa43 -r 5dd4cb7fd7e5 gameServer/hedgewars-server.hs --- 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)