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