gameServer/OfficialServer/DBInteraction.hs
author unc0rr
Wed, 25 Feb 2009 17:12:32 +0000
changeset 1841 fba7210b438b
parent 1839 5dd4cb7fd7e5
child 1847 2178c0fc838c
permissions -rw-r--r--
Retrieve client password from web database and ask for it
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     1
module OfficialServer.DBInteraction
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
(
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
     3
	startDBConnection
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     4
) where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
     6
import Prelude hiding (catch);
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
import Database.HDBC
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import Database.HDBC.MySQL
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     9
import System.IO
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
import Control.Concurrent
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
import Control.Exception
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    12
import Monad
1834
71cb978dc85f Add working check for www account existance
unc0rr
parents: 1833
diff changeset
    13
import Maybe
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    14
import System.Log.Logger
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    15
------------------------
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    16
import CoreTypes
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    18
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    19
-------------------------------------------------------------------
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    20
-- borrowed from base 4.0.0 ---------------------------------------
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    21
onException :: IO a -> IO b -> IO a                              --
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    22
onException io what = io `catch` \e -> do what                   --
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    23
                                          throw (e :: Exception) --
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    24
-- to be deleted --------------------------------------------------
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    25
-------------------------------------------------------------------
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    26
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    27
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    28
dbInteractionLoop queries coreChan dbConn = do
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    29
	q <- readChan queries
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
	case q of
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    31
		CheckAccount clID name -> do
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
    32
				statement <- prepare dbConn "SELECT pass FROM users WHERE name=?"
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    33
				execute statement [SqlString name]
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
    34
				pass <- fetchRow statement
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    35
				finish statement
1841
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
    36
				if isJust pass then
fba7210b438b Retrieve client password from web database and ask for it
unc0rr
parents: 1839
diff changeset
    37
					writeChan coreChan $ ClientAccountInfo clID (HasAccount $ fromSql $ head $ fromJust $ pass)
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    38
					else
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    39
					writeChan coreChan $ ClientAccountInfo clID Guest
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    40
			`onException`
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    41
				(unGetChan queries $ CheckAccount clID name)
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    42
		
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    43
		CheckPassword queryStr -> putStrLn queryStr
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    44
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    45
	dbInteractionLoop queries coreChan dbConn
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    46
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    47
dbConnectionLoop serverInfo = do
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    48
	Control.Exception.handle (\e -> infoM "Database" $ show e) $ handleSqlError $
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    49
		bracket
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    50
			(connectMySQL defaultMySQLConnectInfo {mysqlHost = dbHost serverInfo, mysqlDatabase = "hedge_main", mysqlUser = dbLogin serverInfo, mysqlPassword = dbPassword serverInfo })
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    51
			(disconnect)
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    52
			(dbInteractionLoop (dbQueries serverInfo) (coreChan serverInfo))
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    53
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    54
	threadDelay (5 * 10^6)
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    55
	dbConnectionLoop serverInfo
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    56
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    57
startDBConnection serverInfo =
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    58
	when (not . null $ dbHost serverInfo) ((forkIO $ dbConnectionLoop serverInfo) >> return ())