gameServer/OfficialServer/DBInteraction.hs
author unc0rr
Sun, 19 Apr 2009 11:40:41 +0000
changeset 2004 f7944d5adc5f
parent 1979 912e450d4db2
child 2116 dec7ead2d178
permissions -rw-r--r--
Some work to try prevent stack memory leak
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
1979
912e450d4db2 - Add gameServer to build system
unc0rr
parents: 1970
diff changeset
     1
{-# LANGUAGE CPP #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
module OfficialServer.DBInteraction
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
(
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
     4
	startDBConnection
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
) where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
1979
912e450d4db2 - Add gameServer to build system
unc0rr
parents: 1970
diff changeset
     7
#if defined(OFFICIAL_SERVER)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import Database.HDBC
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     9
import Database.HDBC.MySQL
1979
912e450d4db2 - Add gameServer to build system
unc0rr
parents: 1970
diff changeset
    10
#endif
912e450d4db2 - Add gameServer to build system
unc0rr
parents: 1970
diff changeset
    11
912e450d4db2 - Add gameServer to build system
unc0rr
parents: 1970
diff changeset
    12
import Prelude hiding (catch);
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import System.IO
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
import Control.Concurrent
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
import Control.Exception
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    16
import Monad
1834
71cb978dc85f Add working check for www account existance
unc0rr
parents: 1833
diff changeset
    17
import Maybe
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    18
import System.Log.Logger
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    19
------------------------
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    20
import CoreTypes
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
1921
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1857
diff changeset
    22
localAddressList = ["127.0.0.1", "0:0:0:0:0:0:0:1", "0:0:0:0:0:ffff:7f00:1"]
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    23
1857
b835395659e2 Fake database connection with routine which marks all users as guests, when no database host was specified
unc0rr
parents: 1847
diff changeset
    24
fakeDbConnection serverInfo = do
b835395659e2 Fake database connection with routine which marks all users as guests, when no database host was specified
unc0rr
parents: 1847
diff changeset
    25
	q <- readChan $ dbQueries serverInfo
b835395659e2 Fake database connection with routine which marks all users as guests, when no database host was specified
unc0rr
parents: 1847
diff changeset
    26
	case q of
1921
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1857
diff changeset
    27
		CheckAccount client -> do
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1857
diff changeset
    28
			writeChan (coreChan serverInfo) $ ClientAccountInfo (clientUID client) $
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1857
diff changeset
    29
				if host client `elem` localAddressList then Admin else Guest
1857
b835395659e2 Fake database connection with routine which marks all users as guests, when no database host was specified
unc0rr
parents: 1847
diff changeset
    30
b835395659e2 Fake database connection with routine which marks all users as guests, when no database host was specified
unc0rr
parents: 1847
diff changeset
    31
	fakeDbConnection serverInfo
b835395659e2 Fake database connection with routine which marks all users as guests, when no database host was specified
unc0rr
parents: 1847
diff changeset
    32
b835395659e2 Fake database connection with routine which marks all users as guests, when no database host was specified
unc0rr
parents: 1847
diff changeset
    33
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    34
-------------------------------------------------------------------
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    35
-- borrowed from base 4.0.0 ---------------------------------------
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    36
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
    37
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
    38
                                          throw (e :: Exception) --
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    39
-- to be deleted --------------------------------------------------
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    40
-------------------------------------------------------------------
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    41
1979
912e450d4db2 - Add gameServer to build system
unc0rr
parents: 1970
diff changeset
    42
#if defined(OFFICIAL_SERVER)
1847
2178c0fc838c Set admin flag and send admin notification to users with rid equal to 3
unc0rr
parents: 1841
diff changeset
    43
dbQueryString =
1963
58c29439225d Better SQL statement, allows NULL rid
unc0rr
parents: 1921
diff changeset
    44
	"select users.pass, users_roles.rid from users left join users_roles on users.uid = users_roles.uid where users.name = ?"
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    45
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    46
dbInteractionLoop queries coreChan dbConn = do
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    47
	q <- readChan queries
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    48
	case q of
1921
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1857
diff changeset
    49
		CheckAccount client -> do
1847
2178c0fc838c Set admin flag and send admin notification to users with rid equal to 3
unc0rr
parents: 1841
diff changeset
    50
				statement <- prepare dbConn dbQueryString
1921
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1857
diff changeset
    51
				execute statement [SqlString $ nick client]
1847
2178c0fc838c Set admin flag and send admin notification to users with rid equal to 3
unc0rr
parents: 1841
diff changeset
    52
				passAndRole <- fetchRow statement
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    53
				finish statement
1847
2178c0fc838c Set admin flag and send admin notification to users with rid equal to 3
unc0rr
parents: 1841
diff changeset
    54
				if isJust passAndRole then
2178c0fc838c Set admin flag and send admin notification to users with rid equal to 3
unc0rr
parents: 1841
diff changeset
    55
					writeChan coreChan $
1921
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1857
diff changeset
    56
							ClientAccountInfo (clientUID client) $
1847
2178c0fc838c Set admin flag and send admin notification to users with rid equal to 3
unc0rr
parents: 1841
diff changeset
    57
								HasAccount
2178c0fc838c Set admin flag and send admin notification to users with rid equal to 3
unc0rr
parents: 1841
diff changeset
    58
									(fromSql $ head $ fromJust $ passAndRole)
1970
130e7805d49c Prevent server from crashing when get SqlNull value
unc0rr
parents: 1963
diff changeset
    59
									((fromSql $ last $ fromJust $ passAndRole) == (Just (3 :: Int)))
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    60
					else
1921
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1857
diff changeset
    61
					writeChan coreChan $ ClientAccountInfo (clientUID client) Guest
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    62
			`onException`
1921
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1857
diff changeset
    63
				(unGetChan queries q)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    64
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    65
	dbInteractionLoop queries coreChan dbConn
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    66
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    67
dbConnectionLoop serverInfo = do
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    68
	Control.Exception.handle (\e -> infoM "Database" $ show e) $ handleSqlError $
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    69
		bracket
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    70
			(connectMySQL defaultMySQLConnectInfo {mysqlHost = dbHost serverInfo, mysqlDatabase = "hedge_main", mysqlUser = dbLogin serverInfo, mysqlPassword = dbPassword serverInfo })
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    71
			(disconnect)
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    72
			(dbInteractionLoop (dbQueries serverInfo) (coreChan serverInfo))
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    73
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    74
	threadDelay (5 * 10^6)
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    75
	dbConnectionLoop serverInfo
1979
912e450d4db2 - Add gameServer to build system
unc0rr
parents: 1970
diff changeset
    76
#else
912e450d4db2 - Add gameServer to build system
unc0rr
parents: 1970
diff changeset
    77
dbConnectionLoop = fakeDbConnection
912e450d4db2 - Add gameServer to build system
unc0rr
parents: 1970
diff changeset
    78
#endif
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    79
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    80
startDBConnection serverInfo =
1857
b835395659e2 Fake database connection with routine which marks all users as guests, when no database host was specified
unc0rr
parents: 1847
diff changeset
    81
	if (not . null $ dbHost serverInfo) then
b835395659e2 Fake database connection with routine which marks all users as guests, when no database host was specified
unc0rr
parents: 1847
diff changeset
    82
		forkIO $ dbConnectionLoop serverInfo
b835395659e2 Fake database connection with routine which marks all users as guests, when no database host was specified
unc0rr
parents: 1847
diff changeset
    83
		else
b835395659e2 Fake database connection with routine which marks all users as guests, when no database host was specified
unc0rr
parents: 1847
diff changeset
    84
		forkIO $ fakeDbConnection serverInfo