author | sheepluva |
Thu, 12 Jun 2014 05:40:58 +0200 | |
changeset 10281 | dedc8f23e35e |
parent 10017 | de822cd3df3a |
child 10460 | 8dcea9087d75 |
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 |
9409 | 12 |
import Data.List (lookup) |
13 |
import qualified Data.ByteString.Char8 as B |
|
9884 | 14 |
import Data.Word |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
15 |
-------------------------- |
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
16 |
import CoreTypes |
9409 | 17 |
import Utils |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
18 |
|
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
19 |
|
2172 | 20 |
dbQueryAccount = |
10017 | 21 |
"SELECT users.pass, \ |
9435 | 22 |
\ (SELECT COUNT(users_roles.rid) FROM users_roles WHERE users.uid = users_roles.uid AND users_roles.rid = 3), \ |
23 |
\ (SELECT COUNT(users_roles.rid) FROM users_roles WHERE users.uid = users_roles.uid AND users_roles.rid = 13) \ |
|
24 |
\ FROM users WHERE users.name = ?" |
|
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
25 |
|
2172 | 26 |
dbQueryStats = |
6040 | 27 |
"INSERT INTO gameserver_stats (players, rooms, last_update) VALUES (?, ?, UNIX_TIMESTAMP())" |
2172 | 28 |
|
9409 | 29 |
dbQueryAchievement = |
9868 | 30 |
"INSERT INTO achievements (time, typeid, userid, value, filename, location, protocol) \ |
9427 | 31 |
\ VALUES (?, (SELECT id FROM achievement_types WHERE name = ?), (SELECT uid FROM users WHERE name = ?), \ |
9868 | 32 |
\ ?, ?, ?, ?)" |
9409 | 33 |
|
9446 | 34 |
dbQueryReplayFilename = "SELECT filename FROM achievements WHERE id = ?" |
35 |
||
36 |
||
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
37 |
dbInteractionLoop dbConn = forever $ do |
4932 | 38 |
q <- liftM read getLine |
2869 | 39 |
hPutStrLn stderr $ show q |
4921 | 40 |
|
2869 | 41 |
case q of |
4921 | 42 |
CheckAccount clId clUid clNick _ -> do |
2869 | 43 |
statement <- prepare dbConn dbQueryAccount |
4932 | 44 |
execute statement [SqlByteString clNick] |
9435 | 45 |
result <- fetchRow statement |
2869 | 46 |
finish statement |
8924 | 47 |
let response = |
9437 | 48 |
if isJust result then let [pass, adm, contr] = fromJust result in |
2869 | 49 |
( |
4921 | 50 |
clId, |
2869 | 51 |
clUid, |
52 |
HasAccount |
|
9435 | 53 |
(fromSql pass) |
54 |
(fromSql adm == Just (1 :: Int)) |
|
55 |
(fromSql contr == Just (1 :: Int)) |
|
2869 | 56 |
) |
2919 | 57 |
else |
4921 | 58 |
(clId, clUid, Guest) |
4932 | 59 |
print response |
2869 | 60 |
hFlush stdout |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
61 |
|
9446 | 62 |
GetReplayName clId clUid fileId -> do |
63 |
statement <- prepare dbConn dbQueryReplayFilename |
|
64 |
execute statement [SqlByteString fileId] |
|
65 |
result <- fetchRow statement |
|
66 |
finish statement |
|
9450 | 67 |
let fn = if (isJust result) then fromJust . fromSql . head . fromJust $ result else "" |
9446 | 68 |
print (clId, clUid, ReplayName fn) |
69 |
hFlush stdout |
|
70 |
||
2869 | 71 |
SendStats clients rooms -> |
72 |
run dbConn dbQueryStats [SqlInt32 $ fromIntegral clients, SqlInt32 $ fromIntegral rooms] >> return () |
|
9409 | 73 |
--StoreAchievements (B.pack fileName) (map toPair teams) info |
10017 | 74 |
StoreAchievements p fileName teams info -> |
9868 | 75 |
mapM_ (run dbConn dbQueryAchievement) $ (parseStats p fileName teams) info |
2172 | 76 |
|
9446 | 77 |
|
9425
49eb707b9367
Extract time from file name, assuming it is stored in 'replay' folder
unc0rr
parents:
9421
diff
changeset
|
78 |
readTime = read . B.unpack . B.take 19 . B.drop 8 |
49eb707b9367
Extract time from file name, assuming it is stored in 'replay' folder
unc0rr
parents:
9421
diff
changeset
|
79 |
|
9446 | 80 |
|
9868 | 81 |
parseStats :: Word16 -> B.ByteString -> [(B.ByteString, B.ByteString)] -> [B.ByteString] -> [[SqlValue]] |
82 |
parseStats p fileName teams = ps |
|
9409 | 83 |
where |
9425
49eb707b9367
Extract time from file name, assuming it is stored in 'replay' folder
unc0rr
parents:
9421
diff
changeset
|
84 |
time = readTime fileName |
9421 | 85 |
ps [] = [] |
9409 | 86 |
ps ("DRAW" : bs) = ps bs |
87 |
ps ("WINNERS" : n : bs) = ps $ drop (readInt_ n) bs |
|
88 |
ps ("ACHIEVEMENT" : typ : teamname : location : value : bs) = |
|
9425
49eb707b9367
Extract time from file name, assuming it is stored in 'replay' folder
unc0rr
parents:
9421
diff
changeset
|
89 |
[ SqlUTCTime time |
49eb707b9367
Extract time from file name, assuming it is stored in 'replay' folder
unc0rr
parents:
9421
diff
changeset
|
90 |
, SqlByteString typ |
9409 | 91 |
, SqlByteString $ fromMaybe "" (lookup teamname teams) |
92 |
, SqlInt32 (readInt_ value) |
|
93 |
, SqlByteString fileName |
|
94 |
, SqlByteString location |
|
9884 | 95 |
, SqlInt32 $ fromIntegral p |
9409 | 96 |
] : ps bs |
9421 | 97 |
ps (b:bs) = ps bs |
98 |
||
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
99 |
|
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
100 |
dbConnectionLoop mySQLConnectionInfo = |
4906 | 101 |
Control.Exception.handle (\(e :: IOException) -> hPutStrLn stderr $ show e) $ handleSqlError $ |
2869 | 102 |
bracket |
103 |
(connectMySQL mySQLConnectionInfo) |
|
4932 | 104 |
disconnect |
105 |
dbInteractionLoop |
|
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
106 |
|
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
107 |
|
4921 | 108 |
--processRequest :: DBQuery -> IO String |
109 |
--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
|
110 |
|
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
111 |
main = do |
2869 | 112 |
dbHost <- getLine |
4982
3572eaf14340
Add dbName parameter to .ini file, fix some warnings
unc0rr
parents:
4932
diff
changeset
|
113 |
dbName <- getLine |
2869 | 114 |
dbLogin <- getLine |
115 |
dbPassword <- getLine |
|
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
116 |
|
4982
3572eaf14340
Add dbName parameter to .ini file, fix some warnings
unc0rr
parents:
4932
diff
changeset
|
117 |
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
|
118 |
|
2869 | 119 |
dbConnectionLoop mySQLConnectInfo |