2 module OfficialServer.DBInteraction |
2 module OfficialServer.DBInteraction |
3 ( |
3 ( |
4 startDBConnection |
4 startDBConnection |
5 ) where |
5 ) where |
6 |
6 |
7 #if defined(OFFICIAL_SERVER) |
|
8 import Database.HDBC |
|
9 import Database.HDBC.MySQL |
|
10 #endif |
|
11 |
|
12 import Prelude hiding (catch); |
7 import Prelude hiding (catch); |
|
8 import System.Process |
13 import System.IO |
9 import System.IO |
14 import Control.Concurrent |
10 import Control.Concurrent |
15 import Control.Exception |
11 import Control.Exception |
|
12 import Control.Monad |
16 import Monad |
13 import Monad |
17 import Maybe |
14 import Maybe |
18 import System.Log.Logger |
15 import System.Log.Logger |
19 ------------------------ |
16 ------------------------ |
20 import CoreTypes |
17 import CoreTypes |
|
18 import Utils |
21 |
19 |
22 localAddressList = ["127.0.0.1", "0:0:0:0:0:0:0:1", "0:0:0:0:0:ffff:7f00:1"] |
20 localAddressList = ["127.0.0.1", "0:0:0:0:0:0:0:1", "0:0:0:0:0:ffff:7f00:1"] |
23 |
21 |
24 fakeDbConnection serverInfo = do |
22 fakeDbConnection serverInfo = do |
25 q <- readChan $ dbQueries serverInfo |
23 q <- readChan $ dbQueries serverInfo |
26 case q of |
24 case q of |
27 CheckAccount client -> do |
25 CheckAccount clUid _ clHost -> do |
28 writeChan (coreChan serverInfo) $ ClientAccountInfo (clientUID client) $ |
26 writeChan (coreChan serverInfo) $ ClientAccountInfo (clUid, |
29 if host client `elem` localAddressList then Admin else Guest |
27 if clHost `elem` localAddressList then Admin else Guest) |
30 |
28 |
31 fakeDbConnection serverInfo |
29 fakeDbConnection serverInfo |
32 |
30 |
33 |
31 |
|
32 #if defined(OFFICIAL_SERVER) |
34 ------------------------------------------------------------------- |
33 ------------------------------------------------------------------- |
35 -- borrowed from base 4.0.0 --------------------------------------- |
34 -- borrowed from base 4.0.0 --------------------------------------- |
36 onException :: IO a -> IO b -> IO a -- |
35 onException :: IO a -> IO b -> IO a -- |
37 onException io what = io `catch` \e -> do what -- |
36 onException io what = io `catch` \e -> do what -- |
38 throw (e :: Exception) -- |
37 throw (e :: Exception) -- |
39 -- to be deleted -------------------------------------------------- |
38 -- to be deleted -------------------------------------------------- |
40 ------------------------------------------------------------------- |
39 ------------------------------------------------------------------- |
41 |
40 |
42 #if defined(OFFICIAL_SERVER) |
|
43 dbQueryString = |
|
44 "select users.pass, users_roles.rid from users left join users_roles on users.uid = users_roles.uid where users.name = ?" |
|
45 |
41 |
46 dbInteractionLoop queries coreChan dbConn = do |
42 pipeDbConnectionLoop queries coreChan hIn hOut = do |
47 q <- readChan queries |
43 q <- readChan queries |
48 case q of |
44 do |
49 CheckAccount client -> do |
45 hPutStrLn hIn $ show q |
50 statement <- prepare dbConn dbQueryString |
46 hFlush hIn |
51 execute statement [SqlString $ nick client] |
47 |
52 passAndRole <- fetchRow statement |
48 response <- hGetLine hOut >>= (maybeException . maybeRead) |
53 finish statement |
|
54 if isJust passAndRole then |
|
55 writeChan coreChan $ |
|
56 ClientAccountInfo (clientUID client) $ |
|
57 HasAccount |
|
58 (fromSql $ head $ fromJust $ passAndRole) |
|
59 ((fromSql $ last $ fromJust $ passAndRole) == (Just (3 :: Int))) |
|
60 else |
|
61 writeChan coreChan $ ClientAccountInfo (clientUID client) Guest |
|
62 `onException` |
|
63 (unGetChan queries q) |
|
64 |
49 |
65 dbInteractionLoop queries coreChan dbConn |
50 writeChan coreChan $ ClientAccountInfo response |
|
51 `onException` |
|
52 (unGetChan queries q) |
|
53 where |
|
54 maybeException (Just a) = return a |
|
55 maybeException Nothing = ioError (userError "Can't read") |
66 |
56 |
67 dbConnectionLoop serverInfo = do |
57 |
68 Control.Exception.handle (\e -> infoM "Database" $ show e) $ handleSqlError $ |
58 pipeDbConnection serverInfo = forever $ do |
69 bracket |
59 Control.Exception.handle (\e -> warningM "Database" $ show e) $ do |
70 (connectMySQL defaultMySQLConnectInfo {mysqlHost = dbHost serverInfo, mysqlDatabase = "hedge_main", mysqlUser = dbLogin serverInfo, mysqlPassword = dbPassword serverInfo }) |
60 (Just hIn, Just hOut, _, _) <- |
71 (disconnect) |
61 createProcess (proc "./OfficialServer/extdbinterface" []) {std_in = CreatePipe, std_out = CreatePipe } |
72 (dbInteractionLoop (dbQueries serverInfo) (coreChan serverInfo)) |
62 |
|
63 hSetBuffering hIn LineBuffering |
|
64 hSetBuffering hOut LineBuffering |
|
65 |
|
66 hPutStrLn hIn $ dbHost serverInfo |
|
67 hPutStrLn hIn $ dbLogin serverInfo |
|
68 hPutStrLn hIn $ dbPassword serverInfo |
|
69 pipeDbConnectionLoop (dbQueries serverInfo) (coreChan serverInfo) hIn hOut |
73 |
70 |
74 threadDelay (5 * 10^6) |
71 threadDelay (5 * 10^6) |
75 dbConnectionLoop serverInfo |
72 |
|
73 |
|
74 dbConnectionLoop = pipeDbConnection |
76 #else |
75 #else |
77 dbConnectionLoop = fakeDbConnection |
76 dbConnectionLoop = fakeDbConnection |
78 #endif |
77 #endif |
79 |
78 |
80 startDBConnection serverInfo = |
79 startDBConnection serverInfo = |
81 if (not . null $ dbHost serverInfo) then |
80 if (not . null $ dbHost serverInfo) then |
82 forkIO $ dbConnectionLoop serverInfo |
81 forkIO $ dbConnectionLoop serverInfo |
83 else |
82 else |
84 forkIO $ fakeDbConnection serverInfo |
83 --forkIO $ fakeDbConnection serverInfo |
|
84 forkIO $ pipeDbConnection serverInfo |