|
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 |
|
26 import Control.Monad.State |
8 import System.IO |
27 import System.IO |
9 import Data.Maybe |
28 import Data.Maybe |
10 import Database.HDBC |
29 import Database.MySQL.Simple |
11 import Database.HDBC.MySQL |
30 import Database.MySQL.Simple.QueryResults |
|
31 import Database.MySQL.Simple.Result |
|
32 import Data.List (lookup, elem) |
|
33 import qualified Data.ByteString.Char8 as B |
|
34 import Data.Word |
|
35 import Data.Int |
12 -------------------------- |
36 -------------------------- |
13 import CoreTypes |
37 import CoreTypes |
|
38 import Utils |
14 |
39 |
|
40 io = liftIO |
15 |
41 |
16 dbQueryAccount = |
42 dbQueryAccount = |
17 "SELECT users.pass, users_roles.rid FROM users LEFT JOIN users_roles ON users.uid = users_roles.uid WHERE users.name = ?" |
43 "SELECT CASE WHEN users.status = 1 THEN users.pass ELSE '' END, \ |
|
44 \ (SELECT COUNT(users_roles.rid) FROM users_roles WHERE users.uid = users_roles.uid AND users_roles.rid = 3), \ |
|
45 \ (SELECT COUNT(users_roles.rid) FROM users_roles WHERE users.uid = users_roles.uid AND users_roles.rid = 13) \ |
|
46 \ FROM users WHERE users.name = ?" |
18 |
47 |
19 dbQueryStats = |
48 dbQueryStats = |
20 "INSERT INTO gameserver_stats (players, rooms, last_update) VALUES (?, ?, UNIX_TIMESTAMP())" |
49 "INSERT INTO gameserver_stats (players, rooms, last_update) VALUES (?, ?, UNIX_TIMESTAMP())" |
|
50 |
|
51 dbQueryAchievement = |
|
52 "INSERT INTO achievements (time, typeid, userid, value, filename, location, protocol) \ |
|
53 \ VALUES (?, (SELECT id FROM achievement_types WHERE name = ?), (SELECT uid FROM users WHERE name = ?), \ |
|
54 \ ?, ?, ?, ?)" |
|
55 |
|
56 dbQueryGamesHistory = |
|
57 "INSERT INTO rating_games (script, protocol, filename, time, vamp, ropes, infattacks) \ |
|
58 \ VALUES (?, ?, ?, ?, ?, ?, ?)" |
|
59 |
|
60 dbQueryGameId = "SELECT LAST_INSERT_ID()" |
|
61 |
|
62 dbQueryGamesHistoryPlaces = "INSERT INTO rating_players (userid, gameid, place) \ |
|
63 \ VALUES ((SELECT uid FROM users WHERE name = ?), ?, ?)" |
|
64 |
|
65 dbQueryReplayFilename = "SELECT filename FROM achievements WHERE id = ?" |
|
66 |
|
67 dbQueryBestTime = "SELECT MIN(value) FROM achievements WHERE location = ? AND id <> (SELECT MAX(id) FROM achievements)" |
21 |
68 |
22 dbInteractionLoop dbConn = forever $ do |
69 dbInteractionLoop dbConn = forever $ do |
23 q <- liftM read getLine |
70 q <- liftM read getLine |
24 hPutStrLn stderr $ show q |
71 hPutStrLn stderr $ show q |
25 |
72 |
26 case q of |
73 case q of |
27 CheckAccount clId clUid clNick _ -> do |
74 CheckAccount clId clUid clNick _ -> do |
28 statement <- prepare dbConn dbQueryAccount |
75 results <- query dbConn dbQueryAccount $ Only clNick |
29 execute statement [SqlByteString clNick] |
76 let response = case results of |
30 passAndRole <- fetchRow statement |
77 [(pass, adm, contr)] -> |
31 finish statement |
78 ( |
32 let response = |
79 clId, |
33 if isJust passAndRole then |
80 clUid, |
34 ( |
81 HasAccount |
35 clId, |
82 (pass) |
36 clUid, |
83 (adm == Just (1 :: Int)) |
37 HasAccount |
84 (contr == Just (1 :: Int)) |
38 (fromSql . head . fromJust $ passAndRole) |
85 ) |
39 (fromSql (last . fromJust $ passAndRole) == Just (3 :: Int)) |
86 _ -> |
40 ) |
87 (clId, clUid, Guest) |
41 else |
|
42 (clId, clUid, Guest) |
|
43 print response |
88 print response |
44 hFlush stdout |
89 hFlush stdout |
45 |
90 |
|
91 GetReplayName clId clUid fileId -> do |
|
92 results <- query dbConn dbQueryReplayFilename $ Only fileId |
|
93 let fn = if null results then "" else fromOnly $ head results |
|
94 print (clId, clUid, ReplayName fn) |
|
95 hFlush stdout |
|
96 |
46 SendStats clients rooms -> |
97 SendStats clients rooms -> |
47 run dbConn dbQueryStats [SqlInt32 $ fromIntegral clients, SqlInt32 $ fromIntegral rooms] >> return () |
98 void $ execute dbConn dbQueryStats (clients, rooms) |
|
99 StoreAchievements p fileName teams g info -> |
|
100 parseStats dbConn p fileName teams g info |
48 |
101 |
49 |
102 |
|
103 --readTime = read . B.unpack . B.take 19 . B.drop 8 |
|
104 readTime = B.take 19 . B.drop 8 |
|
105 |
|
106 parseStats :: |
|
107 Connection |
|
108 -> Word16 |
|
109 -> B.ByteString |
|
110 -> [(B.ByteString, B.ByteString)] |
|
111 -> GameDetails |
|
112 -> [B.ByteString] |
|
113 -> IO () |
|
114 parseStats dbConn p fileName teams (GameDetails script infRopes vamp infAttacks) d = evalStateT (ps d) ("", maxBound) |
|
115 where |
|
116 time = readTime fileName |
|
117 ps :: [B.ByteString] -> StateT (B.ByteString, Int) IO () |
|
118 ps [] = return () |
|
119 ps ("DRAW" : bs) = do |
|
120 io $ execute dbConn dbQueryGamesHistory (script, (fromIntegral p) :: Int, fileName, time, vamp, infRopes, infAttacks) |
|
121 io $ places (map drawParams teams) |
|
122 ps bs |
|
123 ps ("WINNERS" : n : bs) = do |
|
124 let winNum = readInt_ n |
|
125 io $ execute dbConn dbQueryGamesHistory (script, (fromIntegral p) :: Int, fileName, time, vamp, infRopes, infAttacks) |
|
126 io $ places (map (placeParams (take winNum bs)) teams) |
|
127 ps (drop winNum bs) |
|
128 ps ("ACHIEVEMENT" : typ : teamname : location : value : bs) = do |
|
129 let result = readInt_ value |
|
130 io $ execute dbConn dbQueryAchievement |
|
131 ( time |
|
132 , typ |
|
133 , fromMaybe "" (lookup teamname teams) |
|
134 , result |
|
135 , fileName |
|
136 , location |
|
137 , (fromIntegral p) :: Int |
|
138 ) |
|
139 modify $ \st@(l, s) -> if result < s then (location, result) else st |
|
140 ps bs |
|
141 ps ("GHOST_POINTS" : n : bs) = do |
|
142 let pointsNum = readInt_ n |
|
143 (location, time) <- get |
|
144 res <- io $ query dbConn dbQueryBestTime $ Only location |
|
145 let bestTime = case res of |
|
146 [Only a] -> a |
|
147 _ -> maxBound :: Int |
|
148 when (time < bestTime) $ do |
|
149 io $ writeFile (B.unpack $ "ghosts/" `B.append` sanitizeName location) $ show (map readInt_ $ take (2 * pointsNum) bs) |
|
150 return () |
|
151 ps (drop (2 * pointsNum) bs) |
|
152 ps (b:bs) = ps bs |
|
153 |
|
154 drawParams t = (snd t, 0 :: Int) |
|
155 placeParams winners t = (snd t, if (fst t) `elem` winners then 1 else 2 :: Int) |
|
156 places :: [(B.ByteString, Int)] -> IO Int64 |
|
157 places params = do |
|
158 res <- query_ dbConn dbQueryGameId |
|
159 let gameId = case res of |
|
160 [Only a] -> a |
|
161 _ -> 0 |
|
162 mapM_ (execute dbConn dbQueryGamesHistoryPlaces . midInsert gameId) params |
|
163 return 0 |
|
164 midInsert :: Int -> (a, b) -> (a, Int, b) |
|
165 midInsert g (a, b) = (a, g, b) |
|
166 |
50 dbConnectionLoop mySQLConnectionInfo = |
167 dbConnectionLoop mySQLConnectionInfo = |
51 Control.Exception.handle (\(e :: IOException) -> hPutStrLn stderr $ show e) $ handleSqlError $ |
168 Control.Exception.handle (\(e :: SomeException) -> hPutStrLn stderr $ show e) $ |
52 bracket |
169 bracket |
53 (connectMySQL mySQLConnectionInfo) |
170 (connect mySQLConnectionInfo) |
54 disconnect |
171 close |
55 dbInteractionLoop |
172 dbInteractionLoop |
56 |
173 |
57 |
174 |
58 --processRequest :: DBQuery -> IO String |
175 --processRequest :: DBQuery -> IO String |
59 --processRequest (CheckAccount clId clUid clNick clHost) = return $ show (clclId, clUid, Guest) |
176 --processRequest (CheckAccount clId clUid clNick clHost) = return $ show (clclId, clUid, Guest) |