author | unC0Rr |
Thu, 27 Aug 2015 14:47:38 +0300 | |
changeset 11053 | a009cc19a639 |
parent 11046 | 47a8c19ecb60 |
child 11246 | 09a2d3988569 |
permissions | -rw-r--r-- |
10460
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10017
diff
changeset
|
1 |
{- |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10017
diff
changeset
|
2 |
* Hedgewars, a free turn based strategy game |
11046 | 3 |
* Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com> |
10460
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10017
diff
changeset
|
4 |
* |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10017
diff
changeset
|
5 |
* This program is free software; you can redistribute it and/or modify |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10017
diff
changeset
|
6 |
* it under the terms of the GNU General Public License as published by |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10017
diff
changeset
|
7 |
* the Free Software Foundation; version 2 of the License |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10017
diff
changeset
|
8 |
* |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10017
diff
changeset
|
9 |
* This program is distributed in the hope that it will be useful, |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10017
diff
changeset
|
10 |
* but WITHOUT ANY WARRANTY; without even the implied warranty of |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10017
diff
changeset
|
11 |
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10017
diff
changeset
|
12 |
* GNU General Public License for more details. |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10017
diff
changeset
|
13 |
* |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10017
diff
changeset
|
14 |
* You should have received a copy of the GNU General Public License |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10017
diff
changeset
|
15 |
* along with this program; if not, write to the Free Software |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10017
diff
changeset
|
16 |
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10017
diff
changeset
|
17 |
\-} |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
10017
diff
changeset
|
18 |
|
4906 | 19 |
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} |
2348 | 20 |
|
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
21 |
module Main where |
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
22 |
|
2117
1ac0e10e546f
Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents:
2116
diff
changeset
|
23 |
import Prelude hiding (catch) |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
24 |
import Control.Monad |
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
25 |
import Control.Exception |
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
26 |
import System.IO |
4932 | 27 |
import Data.Maybe |
10907
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
28 |
import Database.MySQL.Simple |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
29 |
import Database.MySQL.Simple.QueryResults |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
30 |
import Database.MySQL.Simple.Result |
9409 | 31 |
import Data.List (lookup) |
32 |
import qualified Data.ByteString.Char8 as B |
|
9884 | 33 |
import Data.Word |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
34 |
-------------------------- |
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
35 |
import CoreTypes |
9409 | 36 |
import Utils |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
37 |
|
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
38 |
|
2172 | 39 |
dbQueryAccount = |
11053
a009cc19a639
Don't accept any password from players banned on the website
unC0Rr
parents:
11046
diff
changeset
|
40 |
"SELECT CASE WHEN users.status = 1 THEN users.pass ELSE '' END, \ |
9435 | 41 |
\ (SELECT COUNT(users_roles.rid) FROM users_roles WHERE users.uid = users_roles.uid AND users_roles.rid = 3), \ |
42 |
\ (SELECT COUNT(users_roles.rid) FROM users_roles WHERE users.uid = users_roles.uid AND users_roles.rid = 13) \ |
|
43 |
\ 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
|
44 |
|
2172 | 45 |
dbQueryStats = |
6040 | 46 |
"INSERT INTO gameserver_stats (players, rooms, last_update) VALUES (?, ?, UNIX_TIMESTAMP())" |
2172 | 47 |
|
9409 | 48 |
dbQueryAchievement = |
9868 | 49 |
"INSERT INTO achievements (time, typeid, userid, value, filename, location, protocol) \ |
9427 | 50 |
\ VALUES (?, (SELECT id FROM achievement_types WHERE name = ?), (SELECT uid FROM users WHERE name = ?), \ |
9868 | 51 |
\ ?, ?, ?, ?)" |
9409 | 52 |
|
9446 | 53 |
dbQueryReplayFilename = "SELECT filename FROM achievements WHERE id = ?" |
54 |
||
55 |
||
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
56 |
dbInteractionLoop dbConn = forever $ do |
4932 | 57 |
q <- liftM read getLine |
2869 | 58 |
hPutStrLn stderr $ show q |
4921 | 59 |
|
2869 | 60 |
case q of |
4921 | 61 |
CheckAccount clId clUid clNick _ -> do |
10907
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
62 |
results <- query dbConn dbQueryAccount $ Only clNick |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
63 |
let response = case results of |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
64 |
[(pass, adm, contr)] -> |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
65 |
( |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
66 |
clId, |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
67 |
clUid, |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
68 |
HasAccount |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
69 |
(pass) |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
70 |
(adm == Just (1 :: Int)) |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
71 |
(contr == Just (1 :: Int)) |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
72 |
) |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
73 |
_ -> |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
74 |
(clId, clUid, Guest) |
4932 | 75 |
print response |
2869 | 76 |
hFlush stdout |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
77 |
|
9446 | 78 |
GetReplayName clId clUid fileId -> do |
10907
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
79 |
results <- query dbConn dbQueryReplayFilename $ Only fileId |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
80 |
let fn = if null results then "" else fromOnly $ head results |
9446 | 81 |
print (clId, clUid, ReplayName fn) |
82 |
hFlush stdout |
|
83 |
||
2869 | 84 |
SendStats clients rooms -> |
10907
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
85 |
void $ execute dbConn dbQueryStats (clients, rooms) |
10017 | 86 |
StoreAchievements p fileName teams info -> |
10990 | 87 |
mapM_ (execute dbConn dbQueryAchievement) $ (parseStats p fileName teams) info |
2172 | 88 |
|
9446 | 89 |
|
10991 | 90 |
--readTime = read . B.unpack . B.take 19 . B.drop 8 |
91 |
readTime = B.take 19 . B.drop 8 |
|
9446 | 92 |
|
10907
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
93 |
parseStats :: |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
94 |
Word16 |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
95 |
-> B.ByteString |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
96 |
-> [(B.ByteString, B.ByteString)] |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
97 |
-> [B.ByteString] |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
98 |
-> [(B.ByteString, B.ByteString, B.ByteString, Int, B.ByteString, B.ByteString, Int)] |
9868 | 99 |
parseStats p fileName teams = ps |
9409 | 100 |
where |
9425
49eb707b9367
Extract time from file name, assuming it is stored in 'replay' folder
unc0rr
parents:
9421
diff
changeset
|
101 |
time = readTime fileName |
9421 | 102 |
ps [] = [] |
9409 | 103 |
ps ("DRAW" : bs) = ps bs |
104 |
ps ("WINNERS" : n : bs) = ps $ drop (readInt_ n) bs |
|
105 |
ps ("ACHIEVEMENT" : typ : teamname : location : value : bs) = |
|
10907
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
106 |
( time |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
107 |
, typ |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
108 |
, fromMaybe "" (lookup teamname teams) |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
109 |
, readInt_ value |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
110 |
, fileName |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
111 |
, location |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
112 |
, fromIntegral p |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
113 |
) : ps bs |
9421 | 114 |
ps (b:bs) = ps bs |
115 |
||
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
116 |
|
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
117 |
dbConnectionLoop mySQLConnectionInfo = |
10907
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
118 |
Control.Exception.handle (\(e :: SomeException) -> hPutStrLn stderr $ show e) $ |
2869 | 119 |
bracket |
10907
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
120 |
(connect mySQLConnectionInfo) |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
121 |
close |
4932 | 122 |
dbInteractionLoop |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
123 |
|
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
124 |
|
4921 | 125 |
--processRequest :: DBQuery -> IO String |
126 |
--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
|
127 |
|
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
128 |
main = do |
2869 | 129 |
dbHost <- getLine |
4982
3572eaf14340
Add dbName parameter to .ini file, fix some warnings
unc0rr
parents:
4932
diff
changeset
|
130 |
dbName <- getLine |
2869 | 131 |
dbLogin <- getLine |
132 |
dbPassword <- getLine |
|
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
133 |
|
10907
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
134 |
let mySQLConnectInfo = defaultConnectInfo { |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
135 |
connectHost = dbHost |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
136 |
, connectDatabase = dbName |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
137 |
, connectUser = dbLogin |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
138 |
, connectPassword = dbPassword |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
139 |
} |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
140 |
|
2869 | 141 |
dbConnectionLoop mySQLConnectInfo |