gameServer/OfficialServer/DBInteraction.hs
author nemo
Sun, 19 Dec 2010 13:31:55 -0500
changeset 4568 f85243bf890e
parent 4337 85e02b1a8e8f
child 4906 22cc9c2b5ae5
permissions -rw-r--r--
Ok. This should pull 0.9.14.1 server into default
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
     1
{-# LANGUAGE CPP, ScopedTypeVariables #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
module OfficialServer.DBInteraction
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
(
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
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
2296
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2245
diff changeset
    11
import qualified Control.Exception as 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
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    14
import Data.Maybe
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    15
import System.Log.Logger
2126
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    16
import Data.Time
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    17
------------------------
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    18
import CoreTypes
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    19
import Utils
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
1921
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1857
diff changeset
    21
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
    22
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    23
fakeDbConnection serverInfo = do
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    24
    q <- readChan $ dbQueries serverInfo
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    25
    case q of
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    26
        CheckAccount clUid _ clHost -> do
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    27
            writeChan (coreChan serverInfo) $ ClientAccountInfo (clUid,
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    28
                if clHost `elem` localAddressList then Admin else Guest)
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    29
        ClearCache -> return ()
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    30
        SendStats {} -> return ()
1857
b835395659e2 Fake database connection with routine which marks all users as guests, when no database host was specified
unc0rr
parents: 1847
diff changeset
    31
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    32
    fakeDbConnection serverInfo
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4337
diff changeset
    33
1857
b835395659e2 Fake database connection with routine which marks all users as guests, when no database host was specified
unc0rr
parents: 1847
diff changeset
    34
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    35
#if defined(OFFICIAL_SERVER)
2184
f59f80e034b1 Oops, fix database process interaction
unc0rr
parents: 2172
diff changeset
    36
pipeDbConnectionLoop queries coreChan hIn hOut accountsCache =
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    37
    Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return accountsCache) $
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    38
    do
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    39
    q <- readChan queries
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    40
    updatedCache <- case q of
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    41
        CheckAccount clUid clNick _ -> do
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    42
            let cacheEntry = clNick `Map.lookup` accountsCache
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    43
            currentTime <- getCurrentTime
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    44
            if (isNothing cacheEntry) || (currentTime `diffUTCTime` (fst . fromJust) cacheEntry > 2 * 24 * 60 * 60) then
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    45
                do
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    46
                    hPutStrLn hIn $ show q
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    47
                    hFlush hIn
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    48
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    49
                    (clId, accountInfo) <- hGetLine hOut >>= (maybeException . maybeRead)
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    50
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    51
                    writeChan coreChan $ ClientAccountInfo (clId, accountInfo)
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    52
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    53
                    return $ Map.insert clNick (currentTime, accountInfo) accountsCache
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    54
                `Exception.onException`
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    55
                    (unGetChan queries q)
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    56
                else
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    57
                do
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    58
                    writeChan coreChan $ ClientAccountInfo (clUid, snd $ fromJust cacheEntry)
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    59
                    return accountsCache
2155
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2129
diff changeset
    60
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    61
        ClearCache -> return Map.empty
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    62
        SendStats {} -> (
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    63
                (hPutStrLn hIn $ show q) >>
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    64
                hFlush hIn >>
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    65
                return accountsCache)
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    66
                `Exception.onException`
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    67
                (unGetChan queries q)
2184
f59f80e034b1 Oops, fix database process interaction
unc0rr
parents: 2172
diff changeset
    68
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    69
    pipeDbConnectionLoop queries coreChan hIn hOut updatedCache
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    70
    where
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    71
        maybeException (Just a) = return a
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    72
        maybeException Nothing = ioError (userError "Can't read")
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    73
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    74
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    75
pipeDbConnection accountsCache serverInfo = do
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    76
    updatedCache <-
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    77
        Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return accountsCache) $ do
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    78
            (Just hIn, Just hOut, _, _) <- createProcess (proc "./OfficialServer/extdbinterface" [])
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    79
                    {std_in = CreatePipe,
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    80
                    std_out = CreatePipe}
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    81
            hSetBuffering hIn LineBuffering
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    82
            hSetBuffering hOut LineBuffering
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    83
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    84
            hPutStrLn hIn $ dbHost serverInfo
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    85
            hPutStrLn hIn $ dbLogin serverInfo
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    86
            hPutStrLn hIn $ dbPassword serverInfo
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    87
            pipeDbConnectionLoop (dbQueries serverInfo) (coreChan serverInfo) hIn hOut accountsCache
2184
f59f80e034b1 Oops, fix database process interaction
unc0rr
parents: 2172
diff changeset
    88
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    89
    threadDelay (3 * 10^6)
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
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 =
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    93
        if (not . null $ dbHost serverInfo) then
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    94
            pipeDbConnection Map.empty serverInfo
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    95
        else
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
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 =
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
   102
    forkIO $ dbConnectionLoop serverInfo