gameServer/OfficialServer/DBInteraction.hs
author unc0rr
Wed, 16 Feb 2011 13:07:00 +0300
changeset 4944 e43a3da2fc22
parent 4943 21d6b2b79cfe
child 4975 31da8979e5b1
permissions -rw-r--r--
More robust login system when db server goes away
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
4906
22cc9c2b5ae5 Fix even more
unc0rr
parents: 4568
diff changeset
     1
{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings #-}
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);
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
     8
import Control.Concurrent
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
     9
import Control.Monad
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    10
import Data.List as L
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    11
import Data.ByteString.Char8 as B
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    12
#if defined(OFFICIAL_SERVER)
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    13
import System.Process
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4918
diff changeset
    14
import System.IO as SIO
2296
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2245
diff changeset
    15
import qualified Control.Exception as Exception
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    16
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
    17
import Data.Maybe
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    18
import Data.Time
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1834
diff changeset
    19
import System.Log.Logger
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    20
#endif
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    21
------------------------
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    22
import CoreTypes
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    23
#if defined(OFFICIAL_SERVER)
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    24
import Utils
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    25
#endif
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    26
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    27
localAddressList :: [B.ByteString]
1921
2a09f7f786a0 - User from localhost is server admin
unc0rr
parents: 1857
diff changeset
    28
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
    29
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    30
fakeDbConnection :: forall b. ServerInfo -> IO b
4943
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    31
fakeDbConnection si = forever $ do
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    32
    q <- readChan $ dbQueries si
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    33
    case q of
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    34
        CheckAccount clId clUid _ clHost ->
4943
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    35
            writeChan (coreChan si) $ ClientAccountInfo clId clUid (if clHost `L.elem` localAddressList then Admin else Guest)
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    36
        ClearCache -> return ()
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    37
        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
    38
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    39
dbConnectionLoop :: forall b. ServerInfo -> IO b
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
    40
#if defined(OFFICIAL_SERVER)
4943
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    41
flushRequests :: ServerInfo -> IO ()
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    42
flushRequests si = do
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    43
    e <- isEmptyChan $ dbQueries si
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    44
    unless e $ do
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    45
        q <- readChan $ dbQueries si
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    46
        case q of
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    47
            CheckAccount clId clUid _ clHost ->
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    48
                writeChan (coreChan si) $ ClientAccountInfo clId clUid (if clHost `L.elem` localAddressList then Admin else Guest)
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    49
            ClearCache -> return ()
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    50
            SendStats {} -> return ()
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    51
        flushRequests si
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    52
4944
e43a3da2fc22 More robust login system when db server goes away
unc0rr
parents: 4943
diff changeset
    53
pipeDbConnectionLoop :: Chan DBQuery -> Chan CoreMessage -> Handle -> Handle -> Map.Map ByteString (UTCTime, AccountInfo) -> Int -> IO (Map.Map ByteString (UTCTime, AccountInfo), Int)
e43a3da2fc22 More robust login system when db server goes away
unc0rr
parents: 4943
diff changeset
    54
pipeDbConnectionLoop queries cChan hIn hOut accountsCache req =
e43a3da2fc22 More robust login system when db server goes away
unc0rr
parents: 4943
diff changeset
    55
    Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return (accountsCache, req)) $
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    56
    do
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    57
    q <- readChan queries
4944
e43a3da2fc22 More robust login system when db server goes away
unc0rr
parents: 4943
diff changeset
    58
    (updatedCache, newReq) <- case q of
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4918
diff changeset
    59
        CheckAccount clId clUid clNick _ -> do
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    60
            let cacheEntry = clNick `Map.lookup` accountsCache
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    61
            currentTime <- getCurrentTime
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    62
            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
    63
                do
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4918
diff changeset
    64
                    SIO.hPutStrLn hIn $ show q
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    65
                    hFlush hIn
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    66
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4918
diff changeset
    67
                    (clId', clUid', accountInfo) <- SIO.hGetLine hOut >>= (maybeException . maybeRead)
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    68
4943
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    69
                    writeChan cChan $ ClientAccountInfo clId' clUid' accountInfo
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
    70
4944
e43a3da2fc22 More robust login system when db server goes away
unc0rr
parents: 4943
diff changeset
    71
                    return $ (Map.insert clNick (currentTime, accountInfo) accountsCache, req + 1)
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    72
                `Exception.onException`
4944
e43a3da2fc22 More robust login system when db server goes away
unc0rr
parents: 4943
diff changeset
    73
                    (unGetChan queries q)
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    74
                else
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    75
                do
4943
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    76
                    writeChan cChan $ ClientAccountInfo clId clUid (snd $ fromJust cacheEntry)
4944
e43a3da2fc22 More robust login system when db server goes away
unc0rr
parents: 4943
diff changeset
    77
                    return (accountsCache, req)
2155
d897222d3339 Implement ability for server admin to clear accounts cache
unc0rr
parents: 2129
diff changeset
    78
4944
e43a3da2fc22 More robust login system when db server goes away
unc0rr
parents: 4943
diff changeset
    79
        ClearCache -> return (Map.empty, req)
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    80
        SendStats {} -> (
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4918
diff changeset
    81
                (SIO.hPutStrLn hIn $ show q) >>
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    82
                hFlush hIn >>
4944
e43a3da2fc22 More robust login system when db server goes away
unc0rr
parents: 4943
diff changeset
    83
                return (accountsCache, req))
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    84
                `Exception.onException`
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    85
                (unGetChan queries q)
2184
f59f80e034b1 Oops, fix database process interaction
unc0rr
parents: 2172
diff changeset
    86
4944
e43a3da2fc22 More robust login system when db server goes away
unc0rr
parents: 4943
diff changeset
    87
    pipeDbConnectionLoop queries cChan hIn hOut updatedCache newReq
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    88
    where
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    89
        maybeException (Just a) = return a
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    90
        maybeException Nothing = ioError (userError "Can't read")
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    91
4943
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    92
pipeDbConnection :: forall b. Map.Map ByteString (UTCTime, AccountInfo) -> ServerInfo -> Int -> IO b
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    93
pipeDbConnection accountsCache si errNum = do
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    94
    (updatedCache, newErrNum) <-
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
    95
        Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return (accountsCache, errNum + 1)) $ do
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    96
            (Just hIn, Just hOut, _, _) <- createProcess (proc "./OfficialServer/extdbinterface" [])
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    97
                    {std_in = CreatePipe,
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    98
                    std_out = CreatePipe}
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
    99
            hSetBuffering hIn LineBuffering
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
   100
            hSetBuffering hOut LineBuffering
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   101
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4918
diff changeset
   102
            B.hPutStrLn hIn $ dbHost si
2efad3acbb74 Fix build of official server
unc0rr
parents: 4918
diff changeset
   103
            B.hPutStrLn hIn $ dbLogin si
2efad3acbb74 Fix build of official server
unc0rr
parents: 4918
diff changeset
   104
            B.hPutStrLn hIn $ dbPassword si
4944
e43a3da2fc22 More robust login system when db server goes away
unc0rr
parents: 4943
diff changeset
   105
            (c, r) <- pipeDbConnectionLoop (dbQueries si) (coreChan si) hIn hOut accountsCache 0
e43a3da2fc22 More robust login system when db server goes away
unc0rr
parents: 4943
diff changeset
   106
            return (c, if r > 0 then 0 else errNum + 1)
2184
f59f80e034b1 Oops, fix database process interaction
unc0rr
parents: 2172
diff changeset
   107
4943
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
   108
    when (newErrNum > 1) $ flushRequests si
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
   109
    threadDelay (3000000)
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
   110
    pipeDbConnection updatedCache si newErrNum
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents: 1979
diff changeset
   111
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4918
diff changeset
   112
dbConnectionLoop si =
2efad3acbb74 Fix build of official server
unc0rr
parents: 4918
diff changeset
   113
        if (not . B.null $ dbHost si) then
4943
21d6b2b79cfe Allow users to join official server even when there's no db connection
unc0rr
parents: 4932
diff changeset
   114
            pipeDbConnection Map.empty si 0
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2387
diff changeset
   115
        else
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4918
diff changeset
   116
            fakeDbConnection si
1979
912e450d4db2 - Add gameServer to build system
unc0rr
parents: 1970
diff changeset
   117
#else
912e450d4db2 - Add gameServer to build system
unc0rr
parents: 1970
diff changeset
   118
dbConnectionLoop = fakeDbConnection
912e450d4db2 - Add gameServer to build system
unc0rr
parents: 1970
diff changeset
   119
#endif
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
   120
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
   121
startDBConnection :: ServerInfo -> IO ()
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
   122
startDBConnection serverInfo =
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
   123
    forkIO (dbConnectionLoop serverInfo) >> return ()