1 module OfficialServer.DBInteraction |
1 module OfficialServer.DBInteraction |
2 ( |
2 ( |
3 startDBConnection, |
3 startDBConnection |
4 DBQuery(HasRegistered, CheckPassword) |
|
5 ) where |
4 ) where |
6 |
5 |
|
6 import Prelude hiding (catch); |
7 import Database.HDBC |
7 import Database.HDBC |
8 import Database.HDBC.MySQL |
8 import Database.HDBC.MySQL |
9 import System.IO |
9 import System.IO |
10 import Control.Concurrent |
10 import Control.Concurrent |
11 import Control.Exception |
11 import Control.Exception |
12 import Monad |
12 import Monad |
13 import Maybe |
13 import Maybe |
|
14 import System.Log.Logger |
14 ------------------------ |
15 ------------------------ |
15 import CoreTypes |
16 import CoreTypes |
16 |
17 |
17 dbInteractionLoop queries dbConn = do |
18 |
|
19 ------------------------------------------------------------------- |
|
20 -- borrowed from base 4.0.0 --------------------------------------- |
|
21 onException :: IO a -> IO b -> IO a -- |
|
22 onException io what = io `catch` \e -> do what -- |
|
23 throw (e :: Exception) -- |
|
24 -- to be deleted -------------------------------------------------- |
|
25 ------------------------------------------------------------------- |
|
26 |
|
27 |
|
28 dbInteractionLoop queries coreChan dbConn = do |
18 q <- readChan queries |
29 q <- readChan queries |
19 case q of |
30 case q of |
20 HasRegistered name -> do |
31 CheckAccount clID name -> do |
21 statement <- prepare dbConn "SELECT uid FROM users WHERE name=?" |
32 statement <- prepare dbConn "SELECT uid FROM users WHERE name=?" |
22 execute statement [SqlString name] |
33 execute statement [SqlString name] |
23 uid <- fetchRow statement |
34 uid <- fetchRow statement |
24 finish statement |
35 finish statement |
25 putStrLn (show $ isJust uid) |
36 if isJust uid then |
|
37 writeChan coreChan $ ClientAccountInfo clID HasAccount |
|
38 else |
|
39 writeChan coreChan $ ClientAccountInfo clID Guest |
|
40 `onException` |
|
41 (unGetChan queries $ CheckAccount clID name) |
|
42 |
26 CheckPassword queryStr -> putStrLn queryStr |
43 CheckPassword queryStr -> putStrLn queryStr |
27 |
44 |
28 dbInteractionLoop queries dbConn |
45 dbInteractionLoop queries coreChan dbConn |
29 |
46 |
30 dbConnectionLoop serverInfo = do |
47 dbConnectionLoop serverInfo = do |
31 Control.Exception.handle (\e -> print e) $ handleSqlError $ |
48 Control.Exception.handle (\e -> infoM "Database" $ show e) $ handleSqlError $ |
32 bracket |
49 bracket |
33 (connectMySQL defaultMySQLConnectInfo {mysqlHost = dbHost serverInfo, mysqlDatabase = "hedge_main", mysqlUser = dbLogin serverInfo, mysqlPassword = dbPassword serverInfo }) |
50 (connectMySQL defaultMySQLConnectInfo {mysqlHost = dbHost serverInfo, mysqlDatabase = "hedge_main", mysqlUser = dbLogin serverInfo, mysqlPassword = dbPassword serverInfo }) |
34 (disconnect) |
51 (disconnect) |
35 (dbInteractionLoop $ dbQueries serverInfo) |
52 (dbInteractionLoop (dbQueries serverInfo) (coreChan serverInfo)) |
36 |
53 |
37 threadDelay (15 * 10^6) |
54 threadDelay (5 * 10^6) |
38 dbConnectionLoop serverInfo |
55 dbConnectionLoop serverInfo |
39 |
56 |
40 startDBConnection serverInfo = |
57 startDBConnection serverInfo = |
41 when (not . null $ dbHost serverInfo) ((forkIO $ dbConnectionLoop serverInfo) >> return ()) |
58 when (not . null $ dbHost serverInfo) ((forkIO $ dbConnectionLoop serverInfo) >> return ()) |