author | unc0rr |
Sat, 05 Feb 2011 23:15:22 +0300 | |
changeset 4921 | 2efad3acbb74 |
parent 4918 | c6d3aec73f93 |
child 4932 | f11d80bac7ed |
permissions | -rw-r--r-- |
4906 | 1 |
{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings #-} |
1804 | 2 |
module OfficialServer.DBInteraction |
3 |
( |
|
2869 | 4 |
startDBConnection |
1804 | 5 |
) where |
6 |
||
1979 | 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 |
4921 | 9 |
import System.IO as SIO |
1804 | 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 | 16 |
import Data.Time |
4921 | 17 |
import Data.ByteString.Char8 as B |
18 |
import Data.List as L |
|
1833 | 19 |
------------------------ |
20 |
import CoreTypes |
|
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
1979
diff
changeset
|
21 |
import Utils |
1804 | 22 |
|
1921 | 23 |
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
|
24 |
|
4906 | 25 |
fakeDbConnection serverInfo = forever $ do |
2869 | 26 |
q <- readChan $ dbQueries serverInfo |
27 |
case q of |
|
4918
c6d3aec73f93
Add Unique field to Client structure, and use it to check for matching recieved account status with client
unc0rr
parents:
4906
diff
changeset
|
28 |
CheckAccount clId clUid _ clHost -> do |
4921 | 29 |
writeChan (coreChan serverInfo) $ ClientAccountInfo clId clUid (if clHost `L.elem` localAddressList then Admin else Guest) |
2869 | 30 |
ClearCache -> return () |
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 |
|
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) |
2184 | 35 |
pipeDbConnectionLoop queries coreChan hIn hOut accountsCache = |
2869 | 36 |
Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return accountsCache) $ |
37 |
do |
|
38 |
q <- readChan queries |
|
39 |
updatedCache <- case q of |
|
4921 | 40 |
CheckAccount clId clUid clNick _ -> do |
2869 | 41 |
let cacheEntry = clNick `Map.lookup` accountsCache |
42 |
currentTime <- getCurrentTime |
|
43 |
if (isNothing cacheEntry) || (currentTime `diffUTCTime` (fst . fromJust) cacheEntry > 2 * 24 * 60 * 60) then |
|
44 |
do |
|
4921 | 45 |
SIO.hPutStrLn hIn $ show q |
2869 | 46 |
hFlush hIn |
2117
1ac0e10e546f
Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents:
2116
diff
changeset
|
47 |
|
4921 | 48 |
(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
|
49 |
|
4921 | 50 |
writeChan coreChan $ ClientAccountInfo clId' clUid' accountInfo |
2117
1ac0e10e546f
Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents:
2116
diff
changeset
|
51 |
|
2869 | 52 |
return $ Map.insert clNick (currentTime, accountInfo) accountsCache |
53 |
`Exception.onException` |
|
54 |
(unGetChan queries q) |
|
55 |
else |
|
56 |
do |
|
4921 | 57 |
writeChan coreChan $ ClientAccountInfo clId clUid (snd $ fromJust cacheEntry) |
2869 | 58 |
return accountsCache |
2155
d897222d3339
Implement ability for server admin to clear accounts cache
unc0rr
parents:
2129
diff
changeset
|
59 |
|
2869 | 60 |
ClearCache -> return Map.empty |
61 |
SendStats {} -> ( |
|
4921 | 62 |
(SIO.hPutStrLn hIn $ show q) >> |
2869 | 63 |
hFlush hIn >> |
64 |
return accountsCache) |
|
65 |
`Exception.onException` |
|
66 |
(unGetChan queries q) |
|
2184 | 67 |
|
2869 | 68 |
pipeDbConnectionLoop queries coreChan hIn hOut updatedCache |
69 |
where |
|
70 |
maybeException (Just a) = return a |
|
71 |
maybeException Nothing = ioError (userError "Can't read") |
|
1804 | 72 |
|
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
1979
diff
changeset
|
73 |
|
4921 | 74 |
pipeDbConnection accountsCache si = do |
2869 | 75 |
updatedCache <- |
76 |
Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return accountsCache) $ do |
|
77 |
(Just hIn, Just hOut, _, _) <- createProcess (proc "./OfficialServer/extdbinterface" []) |
|
78 |
{std_in = CreatePipe, |
|
79 |
std_out = CreatePipe} |
|
80 |
hSetBuffering hIn LineBuffering |
|
81 |
hSetBuffering hOut LineBuffering |
|
1804 | 82 |
|
4921 | 83 |
B.hPutStrLn hIn $ dbHost si |
84 |
B.hPutStrLn hIn $ dbLogin si |
|
85 |
B.hPutStrLn hIn $ dbPassword si |
|
86 |
pipeDbConnectionLoop (dbQueries si) (coreChan si) hIn hOut accountsCache |
|
2184 | 87 |
|
2869 | 88 |
threadDelay (3 * 10^6) |
4921 | 89 |
pipeDbConnection updatedCache si |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
1979
diff
changeset
|
90 |
|
4921 | 91 |
dbConnectionLoop si = |
92 |
if (not . B.null $ dbHost si) then |
|
93 |
pipeDbConnection Map.empty si |
|
2869 | 94 |
else |
4921 | 95 |
fakeDbConnection si |
1979 | 96 |
#else |
97 |
dbConnectionLoop = fakeDbConnection |
|
98 |
#endif |
|
1804 | 99 |
|
1833 | 100 |
startDBConnection serverInfo = |
2869 | 101 |
forkIO $ dbConnectionLoop serverInfo |