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 19{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} 20 21module Main where 22 23import Prelude hiding (catch) 24import Control.Monad 25import Control.Exception 26import Control.Monad.State 27import System.IO 28import Data.Maybe 29import Database.MySQL.Simple 30import Database.MySQL.Simple.QueryResults 31import Database.MySQL.Simple.Result 32import Data.List (lookup, elem) 33import qualified Data.ByteString.Char8 as B 34import Data.Word 35import Data.Int 36-------------------------- 37import CoreTypes 38import Utils 39 40io = liftIO 41 42dbQueryAccount = 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 = ?" 47 48dbQueryStats = 49 "INSERT INTO gameserver_stats (players, rooms, last_update) VALUES (?, ?, UNIX_TIMESTAMP())" 50 51dbQueryAchievement = 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 56dbQueryGamesHistory = 57 "INSERT INTO rating_games (script, protocol, filename, time, vamp, ropes, infattacks) \ 58 \ VALUES (?, ?, ?, ?, ?, ?, ?)" 59 60dbQueryGameId = "SELECT LAST_INSERT_ID()" 61 62dbQueryGamesHistoryPlaces = "INSERT INTO rating_players (userid, gameid, place) \ 63 \ VALUES ((SELECT uid FROM users WHERE name = ?), ?, ?)" 64 65dbQueryReplayFilename = "SELECT filename FROM achievements WHERE id = ?" 66 67dbQueryBestTime = "SELECT MIN(value) FROM achievements WHERE location = ? AND id <> (SELECT MAX(id) FROM achievements)" 68 69dbInteractionLoop dbConn = forever $ do 70 q <- liftM read getLine 71 hPutStrLn stderr $ show q 72 73 case q of 74 CheckAccount clId clUid clNick _ -> do 75 results <- query dbConn dbQueryAccount $ Only clNick 76 let response = case results of 77 [(pass, adm, contr)] -> 78 ( 79 clId, 80 clUid, 81 HasAccount 82 (pass) 83 (adm == Just (1 :: Int)) 84 (contr == Just (1 :: Int)) 85 ) 86 _ -> 87 (clId, clUid, Guest) 88 print response 89 hFlush stdout 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 97 SendStats clients rooms -> 98 void $ execute dbConn dbQueryStats (clients, rooms) 99 StoreAchievements p fileName teams g info -> 100 parseStats dbConn p fileName teams g info 101 102 103--readTime = read . B.unpack . B.take 19 . B.drop 8 104readTime = B.take 19 . B.drop 8 105 106parseStats :: 107 Connection 108 -> Word16 109 -> B.ByteString 110 -> [(B.ByteString, B.ByteString)] 111 -> GameDetails 112 -> [B.ByteString] 113 -> IO () 114parseStats 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 167dbConnectionLoop mySQLConnectionInfo = 168 Control.Exception.handle (\(e :: SomeException) -> hPutStrLn stderr $ show e) $ 169 bracket 170 (connect mySQLConnectionInfo) 171 close 172 dbInteractionLoop 173 174 175--processRequest :: DBQuery -> IO String 176--processRequest (CheckAccount clId clUid clNick clHost) = return $ show (clclId, clUid, Guest) 177 178main = do 179 dbHost <- getLine 180 dbName <- getLine 181 dbLogin <- getLine 182 dbPassword <- getLine 183 184 let mySQLConnectInfo = defaultConnectInfo { 185 connectHost = dbHost 186 , connectDatabase = dbName 187 , connectUser = dbLogin 188 , connectPassword = dbPassword 189 } 190 191 dbConnectionLoop mySQLConnectInfo 192