|
1 {- |
|
2 * Hedgewars, a free turn based strategy game |
|
3 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com> |
|
4 * |
|
5 * This program is free software; you can redistribute it and/or modify |
|
6 * it under the terms of the GNU General Public License as published by |
|
7 * the Free Software Foundation; version 2 of the License |
|
8 * |
|
9 * This program is distributed in the hope that it will be useful, |
|
10 * but WITHOUT ANY WARRANTY; without even the implied warranty of |
|
11 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|
12 * GNU General Public License for more details. |
|
13 * |
|
14 * You should have received a copy of the GNU General Public License |
|
15 * along with this program; if not, write to the Free Software |
|
16 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. |
|
17 \-} |
|
18 |
1 {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} |
19 {-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} |
2 |
20 |
3 module Main where |
21 module Main where |
4 |
22 |
5 import Prelude hiding (catch) |
23 import Prelude hiding (catch) |
6 import Control.Monad |
24 import Control.Monad |
7 import Control.Exception |
25 import Control.Exception |
8 import System.IO |
26 import System.IO |
9 import Data.Maybe |
27 import Data.Maybe |
10 import Database.HDBC |
28 import Database.MySQL.Simple |
11 import Database.HDBC.MySQL |
29 import Database.MySQL.Simple.QueryResults |
12 import Data.List (lookup) |
30 import Database.MySQL.Simple.Result |
|
31 import Data.List (lookup, elem) |
13 import qualified Data.ByteString.Char8 as B |
32 import qualified Data.ByteString.Char8 as B |
|
33 import Data.Word |
|
34 import Data.Int |
14 -------------------------- |
35 -------------------------- |
15 import CoreTypes |
36 import CoreTypes |
16 import Utils |
37 import Utils |
17 |
38 |
18 |
39 |
19 dbQueryAccount = |
40 dbQueryAccount = |
20 "SELECT users.pass, \ |
41 "SELECT CASE WHEN users.status = 1 THEN users.pass ELSE '' END, \ |
21 \ (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 = 3), \ |
22 \ (SELECT COUNT(users_roles.rid) FROM users_roles WHERE users.uid = users_roles.uid AND users_roles.rid = 13) \ |
43 \ (SELECT COUNT(users_roles.rid) FROM users_roles WHERE users.uid = users_roles.uid AND users_roles.rid = 13) \ |
23 \ FROM users WHERE users.name = ?" |
44 \ FROM users WHERE users.name = ?" |
24 |
45 |
25 dbQueryStats = |
46 dbQueryStats = |
26 "INSERT INTO gameserver_stats (players, rooms, last_update) VALUES (?, ?, UNIX_TIMESTAMP())" |
47 "INSERT INTO gameserver_stats (players, rooms, last_update) VALUES (?, ?, UNIX_TIMESTAMP())" |
27 |
48 |
28 dbQueryAchievement = |
49 dbQueryAchievement = |
29 "INSERT INTO achievements (time, typeid, userid, value, filename, location) \ |
50 "INSERT INTO achievements (time, typeid, userid, value, filename, location, protocol) \ |
30 \ VALUES (?, (SELECT id FROM achievement_types WHERE name = ?), (SELECT uid FROM users WHERE name = ?), \ |
51 \ VALUES (?, (SELECT id FROM achievement_types WHERE name = ?), (SELECT uid FROM users WHERE name = ?), \ |
31 \ ?, ?, ?)" |
52 \ ?, ?, ?, ?)" |
|
53 |
|
54 dbQueryGamesHistory = |
|
55 "INSERT INTO rating_games (script, protocol, filename, time, vamp, ropes, infattacks) \ |
|
56 \ VALUES (?, ?, ?, ?, ?, ?, ?)" |
|
57 |
|
58 dbQueryGameId = "SELECT LAST_INSERT_ID()" |
|
59 |
|
60 dbQueryGamesHistoryPlaces = "INSERT INTO rating_players (userid, gameid, place) \ |
|
61 \ VALUES ((SELECT uid FROM users WHERE name = ?), ?, ?)" |
32 |
62 |
33 dbQueryReplayFilename = "SELECT filename FROM achievements WHERE id = ?" |
63 dbQueryReplayFilename = "SELECT filename FROM achievements WHERE id = ?" |
34 |
64 |
35 |
65 |
36 dbInteractionLoop dbConn = forever $ do |
66 dbInteractionLoop dbConn = forever $ do |
37 q <- liftM read getLine |
67 q <- liftM read getLine |
38 hPutStrLn stderr $ show q |
68 hPutStrLn stderr $ show q |
39 |
69 |
40 case q of |
70 case q of |
41 CheckAccount clId clUid clNick _ -> do |
71 CheckAccount clId clUid clNick _ -> do |
42 statement <- prepare dbConn dbQueryAccount |
72 results <- query dbConn dbQueryAccount $ Only clNick |
43 execute statement [SqlByteString clNick] |
73 let response = case results of |
44 result <- fetchRow statement |
74 [(pass, adm, contr)] -> |
45 finish statement |
75 ( |
46 let response = |
76 clId, |
47 if isJust result then let [pass, adm, contr] = fromJust result in |
77 clUid, |
48 ( |
78 HasAccount |
49 clId, |
79 (pass) |
50 clUid, |
80 (adm == Just (1 :: Int)) |
51 HasAccount |
81 (contr == Just (1 :: Int)) |
52 (fromSql pass) |
82 ) |
53 (fromSql adm == Just (1 :: Int)) |
83 _ -> |
54 (fromSql contr == Just (1 :: Int)) |
84 (clId, clUid, Guest) |
55 ) |
|
56 else |
|
57 (clId, clUid, Guest) |
|
58 print response |
85 print response |
59 hFlush stdout |
86 hFlush stdout |
60 |
87 |
61 GetReplayName clId clUid fileId -> do |
88 GetReplayName clId clUid fileId -> do |
62 statement <- prepare dbConn dbQueryReplayFilename |
89 results <- query dbConn dbQueryReplayFilename $ Only fileId |
63 execute statement [SqlByteString fileId] |
90 let fn = if null results then "" else fromOnly $ head results |
64 result <- fetchRow statement |
|
65 finish statement |
|
66 let fn = if (isJust result) then fromJust . fromSql . head . fromJust $ result else "" |
|
67 print (clId, clUid, ReplayName fn) |
91 print (clId, clUid, ReplayName fn) |
68 hFlush stdout |
92 hFlush stdout |
69 |
93 |
70 SendStats clients rooms -> |
94 SendStats clients rooms -> |
71 run dbConn dbQueryStats [SqlInt32 $ fromIntegral clients, SqlInt32 $ fromIntegral rooms] >> return () |
95 void $ execute dbConn dbQueryStats (clients, rooms) |
72 --StoreAchievements (B.pack fileName) (map toPair teams) info |
96 StoreAchievements p fileName teams g info -> |
73 StoreAchievements fileName teams info -> |
97 sequence_ $ parseStats dbConn p fileName teams g info |
74 mapM_ (run dbConn dbQueryAchievement) $ (parseStats fileName teams) info |
|
75 |
98 |
76 |
99 |
77 readTime = read . B.unpack . B.take 19 . B.drop 8 |
100 --readTime = read . B.unpack . B.take 19 . B.drop 8 |
|
101 readTime = B.take 19 . B.drop 8 |
78 |
102 |
79 |
103 parseStats :: |
80 parseStats :: B.ByteString -> [(B.ByteString, B.ByteString)] -> [B.ByteString] -> [[SqlValue]] |
104 Connection |
81 parseStats fileName teams = ps |
105 -> Word16 |
|
106 -> B.ByteString |
|
107 -> [(B.ByteString, B.ByteString)] |
|
108 -> GameDetails |
|
109 -> [B.ByteString] |
|
110 -> [IO Int64] |
|
111 parseStats dbConn p fileName teams (GameDetails script infRopes vamp infAttacks) = ps |
82 where |
112 where |
83 time = readTime fileName |
113 time = readTime fileName |
|
114 ps :: [B.ByteString] -> [IO Int64] |
84 ps [] = [] |
115 ps [] = [] |
85 ps ("DRAW" : bs) = ps bs |
116 ps ("DRAW" : bs) = execute dbConn dbQueryGamesHistory (script, (fromIntegral p) :: Int, fileName, time, vamp, infRopes, infAttacks) |
86 ps ("WINNERS" : n : bs) = ps $ drop (readInt_ n) bs |
117 : places (map drawParams teams) |
87 ps ("ACHIEVEMENT" : typ : teamname : location : value : bs) = |
118 : ps bs |
88 [ SqlUTCTime time |
119 ps ("WINNERS" : n : bs) = let winNum = readInt_ n in execute dbConn dbQueryGamesHistory (script, (fromIntegral p) :: Int, fileName, time, vamp, infRopes, infAttacks) |
89 , SqlByteString typ |
120 : places (map (placeParams (take winNum bs)) teams) |
90 , SqlByteString $ fromMaybe "" (lookup teamname teams) |
121 : ps (drop winNum bs) |
91 , SqlInt32 (readInt_ value) |
122 ps ("ACHIEVEMENT" : typ : teamname : location : value : bs) = execute dbConn dbQueryAchievement |
92 , SqlByteString fileName |
123 ( time |
93 , SqlByteString location |
124 , typ |
94 ] : ps bs |
125 , fromMaybe "" (lookup teamname teams) |
|
126 , (readInt_ value) :: Int |
|
127 , fileName |
|
128 , location |
|
129 , (fromIntegral p) :: Int |
|
130 ) : ps bs |
95 ps (b:bs) = ps bs |
131 ps (b:bs) = ps bs |
96 |
132 drawParams t = (snd t, 0 :: Int) |
|
133 placeParams winners t = (snd t, if (fst t) `elem` winners then 1 else 2 :: Int) |
|
134 places :: [(B.ByteString, Int)] -> IO Int64 |
|
135 places params = do |
|
136 res <- query_ dbConn dbQueryGameId |
|
137 let gameId = case res of |
|
138 [Only a] -> a |
|
139 _ -> 0 |
|
140 mapM_ (execute dbConn dbQueryGamesHistoryPlaces . midInsert gameId) params |
|
141 return 0 |
|
142 midInsert :: Int -> (a, b) -> (a, Int, b) |
|
143 midInsert g (a, b) = (a, g, b) |
97 |
144 |
98 dbConnectionLoop mySQLConnectionInfo = |
145 dbConnectionLoop mySQLConnectionInfo = |
99 Control.Exception.handle (\(e :: IOException) -> hPutStrLn stderr $ show e) $ handleSqlError $ |
146 Control.Exception.handle (\(e :: SomeException) -> hPutStrLn stderr $ show e) $ |
100 bracket |
147 bracket |
101 (connectMySQL mySQLConnectionInfo) |
148 (connect mySQLConnectionInfo) |
102 disconnect |
149 close |
103 dbInteractionLoop |
150 dbInteractionLoop |
104 |
151 |
105 |
152 |
106 --processRequest :: DBQuery -> IO String |
153 --processRequest :: DBQuery -> IO String |
107 --processRequest (CheckAccount clId clUid clNick clHost) = return $ show (clclId, clUid, Guest) |
154 --processRequest (CheckAccount clId clUid clNick clHost) = return $ show (clclId, clUid, Guest) |