gameServer/OfficialServer/DBInteraction.hs
author unc0rr
Thu, 11 Nov 2010 22:17:54 +0300
branch0.9.14
changeset 4242 5e3c5fe2cb14
parent 3671 a94d1dc4a8d9
child 4295 1f5604cd99be
child 4334 82cfbbab73da
permissions -rw-r--r--
Revert to old server in branch 0.9.14
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
4242
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3671
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
4242
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3671
diff changeset
    14
import Monad
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3671
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
4242
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3671
diff changeset
    24
fakeDbConnection serverInfo = do
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    25
    q <- readChan $ dbQueries serverInfo
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    26
    case q of
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    27
        CheckAccount clUid _ clHost -> do
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    28
            writeChan (coreChan serverInfo) $ ClientAccountInfo (clUid,
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    29
                if clHost `elem` localAddressList then Admin else Guest)
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    30
        ClearCache -> return ()
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    31
        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
    32
4242
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3671
diff changeset
    33
    fakeDbConnection serverInfo
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3671
diff changeset
    34
1857
b835395659e2 Fake database connection with routine which marks all users as guests, when no database host was specified
unc0rr
parents: 1847
diff changeset
    35
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    36
#if defined(OFFICIAL_SERVER)
2184
f59f80e034b1 Oops, fix database process interaction
unc0rr
parents: 2172
diff changeset
    37
pipeDbConnectionLoop queries coreChan hIn hOut accountsCache =
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    38
    Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return accountsCache) $
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    39
    do
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    40
    q <- readChan queries
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    41
    updatedCache <- case q of
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    42
        CheckAccount clUid clNick _ -> do
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    43
            let cacheEntry = clNick `Map.lookup` accountsCache
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    44
            currentTime <- getCurrentTime
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    45
            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
    46
                do
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    47
                    hPutStrLn hIn $ show q
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    48
                    hFlush hIn
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    49
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    50
                    (clId, accountInfo) <- hGetLine hOut >>= (maybeException . maybeRead)
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    51
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    52
                    writeChan coreChan $ ClientAccountInfo (clId, accountInfo)
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    53
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    54
                    return $ Map.insert clNick (currentTime, accountInfo) accountsCache
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    55
                `Exception.onException`
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    56
                    (unGetChan queries q)
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    57
                else
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    58
                do
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    59
                    writeChan coreChan $ ClientAccountInfo (clUid, snd $ fromJust cacheEntry)
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    60
                    return accountsCache
2155
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2129
diff changeset
    61
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    62
        ClearCache -> return Map.empty
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    63
        SendStats {} -> (
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    64
                (hPutStrLn hIn $ show q) >>
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    65
                hFlush hIn >>
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    66
                return accountsCache)
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    67
                `Exception.onException`
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    68
                (unGetChan queries q)
2184
f59f80e034b1 Oops, fix database process interaction
unc0rr
parents: 2172
diff changeset
    69
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    70
    pipeDbConnectionLoop queries coreChan hIn hOut updatedCache
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    71
    where
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    72
        maybeException (Just a) = return a
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    73
        maybeException Nothing = ioError (userError "Can't read")
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    74
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    75
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    76
pipeDbConnection accountsCache serverInfo = do
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    77
    updatedCache <-
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    78
        Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return accountsCache) $ do
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    79
            (Just hIn, Just hOut, _, _) <- createProcess (proc "./OfficialServer/extdbinterface" [])
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    80
                    {std_in = CreatePipe,
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    81
                    std_out = CreatePipe}
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    82
            hSetBuffering hIn LineBuffering
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    83
            hSetBuffering hOut LineBuffering
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    84
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    85
            hPutStrLn hIn $ dbHost serverInfo
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    86
            hPutStrLn hIn $ dbLogin serverInfo
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    87
            hPutStrLn hIn $ dbPassword serverInfo
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    88
            pipeDbConnectionLoop (dbQueries serverInfo) (coreChan serverInfo) hIn hOut accountsCache
2184
f59f80e034b1 Oops, fix database process interaction
unc0rr
parents: 2172
diff changeset
    89
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    90
    threadDelay (3 * 10^6)
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    91
    pipeDbConnection updatedCache serverInfo
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    92
2126
cb249fa8e3da - Prevent server from producing zombies
unc0rr
parents: 2123
diff changeset
    93
dbConnectionLoop serverInfo =
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    94
        if (not . null $ dbHost serverInfo) then
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    95
            pipeDbConnection Map.empty serverInfo
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    96
        else
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    97
            fakeDbConnection serverInfo
1979
912e450d4db2 - Add gameServer to build system
unc0rr
parents: 1970
diff changeset
    98
#else
912e450d4db2 - Add gameServer to build system
unc0rr
parents: 1970
diff changeset
    99
dbConnectionLoop = fakeDbConnection
912e450d4db2 - Add gameServer to build system
unc0rr
parents: 1970
diff changeset
   100
#endif
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   101
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
   102
startDBConnection serverInfo =
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
   103
    forkIO $ dbConnectionLoop serverInfo