4 startDBConnection |
4 startDBConnection |
5 ) where |
5 ) where |
6 |
6 |
7 import Prelude hiding (catch); |
7 import Prelude hiding (catch); |
8 import System.Process |
8 import System.Process |
9 import System.IO |
9 import System.IO as SIO |
10 import Control.Concurrent |
10 import Control.Concurrent |
11 import qualified Control.Exception as Exception |
11 import qualified Control.Exception as Exception |
12 import Control.Monad |
12 import Control.Monad |
13 import qualified Data.Map as Map |
13 import qualified Data.Map as Map |
14 import Data.Maybe |
14 import Data.Maybe |
15 import System.Log.Logger |
15 import System.Log.Logger |
16 import Data.Time |
16 import Data.Time |
|
17 import Data.ByteString.Char8 as B |
|
18 import Data.List as L |
17 ------------------------ |
19 ------------------------ |
18 import CoreTypes |
20 import CoreTypes |
19 import Utils |
21 import Utils |
20 |
22 |
21 localAddressList = ["127.0.0.1", "0:0:0:0:0:0:0:1", "0:0:0:0:0:ffff:7f00:1"] |
23 localAddressList = ["127.0.0.1", "0:0:0:0:0:0:0:1", "0:0:0:0:0:ffff:7f00:1"] |
22 |
24 |
23 fakeDbConnection serverInfo = forever $ do |
25 fakeDbConnection serverInfo = forever $ do |
24 q <- readChan $ dbQueries serverInfo |
26 q <- readChan $ dbQueries serverInfo |
25 case q of |
27 case q of |
26 CheckAccount clId clUid _ clHost -> do |
28 CheckAccount clId clUid _ clHost -> do |
27 writeChan (coreChan serverInfo) $ ClientAccountInfo clId clUid (if clHost `elem` localAddressList then Admin else Guest) |
29 writeChan (coreChan serverInfo) $ ClientAccountInfo clId clUid (if clHost `L.elem` localAddressList then Admin else Guest) |
28 ClearCache -> return () |
30 ClearCache -> return () |
29 SendStats {} -> return () |
31 SendStats {} -> return () |
30 |
32 |
31 |
33 |
32 #if defined(OFFICIAL_SERVER) |
34 #if defined(OFFICIAL_SERVER) |
33 pipeDbConnectionLoop queries coreChan hIn hOut accountsCache = |
35 pipeDbConnectionLoop queries coreChan hIn hOut accountsCache = |
34 Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return accountsCache) $ |
36 Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return accountsCache) $ |
35 do |
37 do |
36 q <- readChan queries |
38 q <- readChan queries |
37 updatedCache <- case q of |
39 updatedCache <- case q of |
38 CheckAccount clId clNick _ -> do |
40 CheckAccount clId clUid clNick _ -> do |
39 let cacheEntry = clNick `Map.lookup` accountsCache |
41 let cacheEntry = clNick `Map.lookup` accountsCache |
40 currentTime <- getCurrentTime |
42 currentTime <- getCurrentTime |
41 if (isNothing cacheEntry) || (currentTime `diffUTCTime` (fst . fromJust) cacheEntry > 2 * 24 * 60 * 60) then |
43 if (isNothing cacheEntry) || (currentTime `diffUTCTime` (fst . fromJust) cacheEntry > 2 * 24 * 60 * 60) then |
42 do |
44 do |
43 hPutStrLn hIn $ show q |
45 SIO.hPutStrLn hIn $ show q |
44 hFlush hIn |
46 hFlush hIn |
45 |
47 |
46 (clId', accountInfo) <- hGetLine hOut >>= (maybeException . maybeRead) |
48 (clId', clUid', accountInfo) <- SIO.hGetLine hOut >>= (maybeException . maybeRead) |
47 |
49 |
48 writeChan coreChan $ ClientAccountInfo (clId', accountInfo) |
50 writeChan coreChan $ ClientAccountInfo clId' clUid' accountInfo |
49 |
51 |
50 return $ Map.insert clNick (currentTime, accountInfo) accountsCache |
52 return $ Map.insert clNick (currentTime, accountInfo) accountsCache |
51 `Exception.onException` |
53 `Exception.onException` |
52 (unGetChan queries q) |
54 (unGetChan queries q) |
53 else |
55 else |
54 do |
56 do |
55 writeChan coreChan $ ClientAccountInfo (clId, snd $ fromJust cacheEntry) |
57 writeChan coreChan $ ClientAccountInfo clId clUid (snd $ fromJust cacheEntry) |
56 return accountsCache |
58 return accountsCache |
57 |
59 |
58 ClearCache -> return Map.empty |
60 ClearCache -> return Map.empty |
59 SendStats {} -> ( |
61 SendStats {} -> ( |
60 (hPutStrLn hIn $ show q) >> |
62 (SIO.hPutStrLn hIn $ show q) >> |
61 hFlush hIn >> |
63 hFlush hIn >> |
62 return accountsCache) |
64 return accountsCache) |
63 `Exception.onException` |
65 `Exception.onException` |
64 (unGetChan queries q) |
66 (unGetChan queries q) |
65 |
67 |
67 where |
69 where |
68 maybeException (Just a) = return a |
70 maybeException (Just a) = return a |
69 maybeException Nothing = ioError (userError "Can't read") |
71 maybeException Nothing = ioError (userError "Can't read") |
70 |
72 |
71 |
73 |
72 pipeDbConnection accountsCache serverInfo = do |
74 pipeDbConnection accountsCache si = do |
73 updatedCache <- |
75 updatedCache <- |
74 Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return accountsCache) $ do |
76 Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return accountsCache) $ do |
75 (Just hIn, Just hOut, _, _) <- createProcess (proc "./OfficialServer/extdbinterface" []) |
77 (Just hIn, Just hOut, _, _) <- createProcess (proc "./OfficialServer/extdbinterface" []) |
76 {std_in = CreatePipe, |
78 {std_in = CreatePipe, |
77 std_out = CreatePipe} |
79 std_out = CreatePipe} |
78 hSetBuffering hIn LineBuffering |
80 hSetBuffering hIn LineBuffering |
79 hSetBuffering hOut LineBuffering |
81 hSetBuffering hOut LineBuffering |
80 |
82 |
81 hPutStrLn hIn $ dbHost serverInfo |
83 B.hPutStrLn hIn $ dbHost si |
82 hPutStrLn hIn $ dbLogin serverInfo |
84 B.hPutStrLn hIn $ dbLogin si |
83 hPutStrLn hIn $ dbPassword serverInfo |
85 B.hPutStrLn hIn $ dbPassword si |
84 pipeDbConnectionLoop (dbQueries serverInfo) (coreChan serverInfo) hIn hOut accountsCache |
86 pipeDbConnectionLoop (dbQueries si) (coreChan si) hIn hOut accountsCache |
85 |
87 |
86 threadDelay (3 * 10^6) |
88 threadDelay (3 * 10^6) |
87 pipeDbConnection updatedCache serverInfo |
89 pipeDbConnection updatedCache si |
88 |
90 |
89 dbConnectionLoop serverInfo = |
91 dbConnectionLoop si = |
90 if (not . null $ dbHost serverInfo) then |
92 if (not . B.null $ dbHost si) then |
91 pipeDbConnection Map.empty serverInfo |
93 pipeDbConnection Map.empty si |
92 else |
94 else |
93 fakeDbConnection serverInfo |
95 fakeDbConnection si |
94 #else |
96 #else |
95 dbConnectionLoop = fakeDbConnection |
97 dbConnectionLoop = fakeDbConnection |
96 #endif |
98 #endif |
97 |
99 |
98 startDBConnection serverInfo = |
100 startDBConnection serverInfo = |