author | Periklis Ntanasis <pntanasis@gmail.com> |
Thu, 12 Sep 2013 18:26:06 +0300 | |
branch | spacecampaign |
changeset 9616 | df14425d9e4c |
parent 8924 | 13ac59499066 |
child 9138 | 9e94a9bc8c7e |
child 9399 | 1767c92eff37 |
permissions | -rw-r--r-- |
4906 | 1 |
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} |
2348 | 2 |
|
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
3 |
module Main where |
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
4 |
|
2117
1ac0e10e546f
Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents:
2116
diff
changeset
|
5 |
import Prelude hiding (catch) |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
6 |
import Control.Monad |
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
7 |
import Control.Exception |
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
8 |
import System.IO |
4932 | 9 |
import Data.Maybe |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
10 |
import Database.HDBC |
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
11 |
import Database.HDBC.MySQL |
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
12 |
-------------------------- |
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
13 |
import CoreTypes |
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
14 |
|
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
15 |
|
2172 | 16 |
dbQueryAccount = |
8909 | 17 |
"SELECT users.pass, users_roles.rid FROM users LEFT JOIN users_roles ON (users.uid = users_roles.uid AND users_roles.rid = 3) WHERE users.name = ?" |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
18 |
|
2172 | 19 |
dbQueryStats = |
6040 | 20 |
"INSERT INTO gameserver_stats (players, rooms, last_update) VALUES (?, ?, UNIX_TIMESTAMP())" |
2172 | 21 |
|
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
22 |
dbInteractionLoop dbConn = forever $ do |
4932 | 23 |
q <- liftM read getLine |
2869 | 24 |
hPutStrLn stderr $ show q |
4921 | 25 |
|
2869 | 26 |
case q of |
4921 | 27 |
CheckAccount clId clUid clNick _ -> do |
2869 | 28 |
statement <- prepare dbConn dbQueryAccount |
4932 | 29 |
execute statement [SqlByteString clNick] |
2869 | 30 |
passAndRole <- fetchRow statement |
31 |
finish statement |
|
8924 | 32 |
let response = |
2919 | 33 |
if isJust passAndRole then |
2869 | 34 |
( |
4921 | 35 |
clId, |
2869 | 36 |
clUid, |
37 |
HasAccount |
|
4932 | 38 |
(fromSql . head . fromJust $ passAndRole) |
39 |
(fromSql (last . fromJust $ passAndRole) == Just (3 :: Int)) |
|
2869 | 40 |
) |
2919 | 41 |
else |
4921 | 42 |
(clId, clUid, Guest) |
4932 | 43 |
print response |
2869 | 44 |
hFlush stdout |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
45 |
|
2869 | 46 |
SendStats clients rooms -> |
47 |
run dbConn dbQueryStats [SqlInt32 $ fromIntegral clients, SqlInt32 $ fromIntegral rooms] >> return () |
|
2172 | 48 |
|
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
49 |
|
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
50 |
dbConnectionLoop mySQLConnectionInfo = |
4906 | 51 |
Control.Exception.handle (\(e :: IOException) -> hPutStrLn stderr $ show e) $ handleSqlError $ |
2869 | 52 |
bracket |
53 |
(connectMySQL mySQLConnectionInfo) |
|
4932 | 54 |
disconnect |
55 |
dbInteractionLoop |
|
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
56 |
|
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
57 |
|
4921 | 58 |
--processRequest :: DBQuery -> IO String |
59 |
--processRequest (CheckAccount clId clUid clNick clHost) = return $ show (clclId, clUid, Guest) |
|
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
60 |
|
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
61 |
main = do |
2869 | 62 |
dbHost <- getLine |
4982
3572eaf14340
Add dbName parameter to .ini file, fix some warnings
unc0rr
parents:
4932
diff
changeset
|
63 |
dbName <- getLine |
2869 | 64 |
dbLogin <- getLine |
65 |
dbPassword <- getLine |
|
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
66 |
|
4982
3572eaf14340
Add dbName parameter to .ini file, fix some warnings
unc0rr
parents:
4932
diff
changeset
|
67 |
let mySQLConnectInfo = defaultMySQLConnectInfo {mysqlHost = dbHost, mysqlDatabase = dbName, mysqlUser = dbLogin, mysqlPassword = dbPassword} |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
68 |
|
2869 | 69 |
dbConnectionLoop mySQLConnectInfo |