gameServer/OfficialServer/DBInteraction.hs
author unc0rr
Wed, 27 May 2009 15:29:30 +0000
changeset 2126 cb249fa8e3da
parent 2123 c49832b4bb38
child 2129 8664554d5547
permissions -rw-r--r--
- Prevent server from producing zombies - Some tweaks
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
import Prelude hiding (catch);
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
     8
import System.Process
1804
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
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    12
import Control.Monad
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    13
import qualified Data.Map as Map
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    14
import Monad
1834
71cb978dc85f Add working check for www account existance
unc0rr
parents: 1833
diff changeset
    15
import Maybe
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    16
import System.Log.Logger
2126
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    17
import Data.Time
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    18
------------------------
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    19
import CoreTypes
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    20
import Utils
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
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    27
		CheckAccount clUid _ clHost -> do
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    28
			writeChan (coreChan serverInfo) $ ClientAccountInfo (clUid,
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    29
				if clHost `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
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    34
#if defined(OFFICIAL_SERVER)
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    35
-------------------------------------------------------------------
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    36
-- borrowed from base 4.0.0 ---------------------------------------
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    37
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
    38
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
    39
                                          throw (e :: Exception) --
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    40
-- to be deleted --------------------------------------------------
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    41
-------------------------------------------------------------------
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    42
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    43
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    44
pipeDbConnectionLoop queries coreChan hIn hOut accountsCache = do
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    45
	q <- readChan queries
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    46
	updatedCache <- case q of
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    47
		CheckAccount clUid clNick _ -> do
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    48
			let cacheEntry = clNick `Map.lookup` accountsCache
2126
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    49
			currentTime <- getCurrentTime
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    50
			if (isNothing cacheEntry) || (currentTime `diffUTCTime` (fst . fromJust) cacheEntry > 2 * 24 * 60 * 60) then
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    51
				do
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    52
					hPutStrLn hIn $ show q
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    53
					hFlush hIn
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    54
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    55
					(clId, accountInfo) <- hGetLine hOut >>= (maybeException . maybeRead)
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    56
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    57
					writeChan coreChan $ ClientAccountInfo (clId, accountInfo)
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    58
2126
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    59
					return $ Map.insert clNick (currentTime, accountInfo) accountsCache
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    60
				`onException`
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    61
					(unGetChan queries q)
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    62
				else
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    63
				do
2126
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    64
					writeChan coreChan $ ClientAccountInfo (clUid, snd $ fromJust cacheEntry)
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    65
					return accountsCache
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    66
	
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    67
	return updatedCache
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    68
	where
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    69
		maybeException (Just a) = return a
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    70
		maybeException Nothing = ioError (userError "Can't read")
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    71
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    72
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    73
pipeDbConnection accountsCache serverInfo = do
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    74
	updatedCache <-
2126
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    75
		Control.Exception.handle (\e -> warningM "Database" (show e) >> return accountsCache) $ 
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    76
			bracket
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    77
				(createProcess (proc "./OfficialServer/extdbinterface" []) {std_in = CreatePipe, std_out = CreatePipe})
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    78
				(\(_, _, _, processHandle) -> getProcessExitCode processHandle >> return (accountsCache))
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    79
				(\(Just hIn, Just hOut, _, _) -> do
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    80
				hSetBuffering hIn LineBuffering
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    81
				hSetBuffering hOut LineBuffering
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    82
	
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    83
				hPutStrLn hIn $ dbHost serverInfo
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    84
				hPutStrLn hIn $ dbLogin serverInfo
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    85
				hPutStrLn hIn $ dbPassword serverInfo
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    86
				pipeDbConnectionLoop (dbQueries serverInfo) (coreChan serverInfo) hIn hOut accountsCache
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    87
				)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    88
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    89
	threadDelay (5 * 10^6)
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    90
	pipeDbConnection updatedCache serverInfo
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    91
2126
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    92
dbConnectionLoop serverInfo =
2123
c49832b4bb38 Fix server compilation
unc0rr
parents: 2117
diff changeset
    93
		if (not . null $ dbHost serverInfo) then
2126
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    94
			pipeDbConnection Map.empty serverInfo
2123
c49832b4bb38 Fix server compilation
unc0rr
parents: 2117
diff changeset
    95
		else
2126
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    96
			fakeDbConnection serverInfo
1979
912e450d4db2 - Add gameServer to build system
unc0rr
parents: 1970
diff changeset
    97
#else
912e450d4db2 - Add gameServer to build system
unc0rr
parents: 1970
diff changeset
    98
dbConnectionLoop = fakeDbConnection
912e450d4db2 - Add gameServer to build system
unc0rr
parents: 1970
diff changeset
    99
#endif
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   100
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
   101
startDBConnection serverInfo =
2123
c49832b4bb38 Fix server compilation
unc0rr
parents: 2117
diff changeset
   102
	forkIO $ dbConnectionLoop serverInfo