gameServer/OfficialServer/extdbinterface.hs
author unc0rr
Wed, 24 Feb 2016 22:37:03 +0300
changeset 11578 8fd1808b12ed
parent 11320 556eafd1443a
child 11580 db7743e2fad1
permissions -rw-r--r--
Recognize ghost points in db interaction tool (no storing yet)
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
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
47a8c19ecb60 more copyright fixes
sheepluva
parents: 10991
diff changeset
     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
22cc9c2b5ae5 Fix even more
unc0rr
parents: 4568
diff changeset
    19
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
2348
b39d826e1ccd Drop support for ghc 6.8, use 6.10 instead
unc0rr
parents: 2195
diff changeset
    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
11578
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
    26
import Control.Monad.State
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    27
import System.IO
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    28
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
    29
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
    30
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
    31
import Database.MySQL.Simple.Result
11273
096811aa3c55 Let's try to store games info necessary for ratings
unc0rr
parents: 11250
diff changeset
    32
import Data.List (lookup, elem)
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    33
import qualified Data.ByteString.Char8 as B
9884
6e09ca662fa3 Some fixes
unc0rr
parents: 9868
diff changeset
    34
import Data.Word
11273
096811aa3c55 Let's try to store games info necessary for ratings
unc0rr
parents: 11250
diff changeset
    35
import Data.Int
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    36
--------------------------
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    37
import CoreTypes
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    38
import Utils
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    39
11578
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
    40
io = liftIO
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    41
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2117
diff changeset
    42
dbQueryAccount =
11053
a009cc19a639 Don't accept any password from players banned on the website
unC0Rr
parents: 11046
diff changeset
    43
    "SELECT CASE WHEN users.status = 1 THEN users.pass ELSE '' END, \
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9427
diff changeset
    44
    \ (SELECT COUNT(users_roles.rid) FROM users_roles WHERE users.uid = users_roles.uid AND users_roles.rid = 3), \
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9427
diff changeset
    45
    \ (SELECT COUNT(users_roles.rid) FROM users_roles WHERE users.uid = users_roles.uid AND users_roles.rid = 13) \
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9427
diff changeset
    46
    \ 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
    47
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2117
diff changeset
    48
dbQueryStats =
6040
a740069c21e3 - Add unique id to replay file name
unc0rr
parents: 4982
diff changeset
    49
    "INSERT INTO gameserver_stats (players, rooms, last_update) VALUES (?, ?, UNIX_TIMESTAMP())"
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2117
diff changeset
    50
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    51
dbQueryAchievement =
9868
53d1b92db6ce Store protocol number in database for replays
unc0rr
parents: 9450
diff changeset
    52
    "INSERT INTO achievements (time, typeid, userid, value, filename, location, protocol) \
9427
unc0rr
parents: 9425
diff changeset
    53
    \ VALUES (?, (SELECT id FROM achievement_types WHERE name = ?), (SELECT uid FROM users WHERE name = ?), \
9868
53d1b92db6ce Store protocol number in database for replays
unc0rr
parents: 9450
diff changeset
    54
    \ ?, ?, ?, ?)"
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    55
11250
09a2d3988569 Also pass script information alongwith winner/achievements info, so that we could potentially have per mode ratings
unc0rr
parents: 11053
diff changeset
    56
dbQueryGamesHistory =
11320
556eafd1443a Store some more details on game config in the database
unc0rr
parents: 11280
diff changeset
    57
    "INSERT INTO rating_games (script, protocol, filename, time, vamp, ropes, infattacks) \
556eafd1443a Store some more details on game config in the database
unc0rr
parents: 11280
diff changeset
    58
    \ VALUES (?, ?, ?, ?, ?, ?, ?)"
11273
096811aa3c55 Let's try to store games info necessary for ratings
unc0rr
parents: 11250
diff changeset
    59
11280
13ce106c8836 Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents: 11273
diff changeset
    60
dbQueryGameId = "SELECT LAST_INSERT_ID()"
13ce106c8836 Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents: 11273
diff changeset
    61
11273
096811aa3c55 Let's try to store games info necessary for ratings
unc0rr
parents: 11250
diff changeset
    62
dbQueryGamesHistoryPlaces = "INSERT INTO rating_players (userid, gameid, place) \
11280
13ce106c8836 Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents: 11273
diff changeset
    63
    \ VALUES ((SELECT uid FROM users WHERE name = ?), ?, ?)"
11250
09a2d3988569 Also pass script information alongwith winner/achievements info, so that we could potentially have per mode ratings
unc0rr
parents: 11053
diff changeset
    64
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    65
dbQueryReplayFilename = "SELECT filename FROM achievements WHERE id = ?"
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    66
11578
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
    67
dbQueryBestTime = "SELECT MIN(value) FROM achievements WHERE location = ?"
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    68
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    69
dbInteractionLoop dbConn = forever $ do
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    70
    q <- liftM read getLine
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    71
    hPutStrLn stderr $ show q
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
    72
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    73
    case q of
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
    74
        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
    75
                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
    76
                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
    77
                        [(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
    78
                            (
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    79
                                clId,
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    80
                                clUid,
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    81
                                HasAccount
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    82
                                    (pass)
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    83
                                    (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
    84
                                    (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
    85
                            )
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    86
                        _ ->
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    87
                            (clId, clUid, Guest)
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    88
                print response
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    89
                hFlush stdout
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    90
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    91
        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
    92
                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
    93
                let fn = if null results then "" else fromOnly $ head results
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    94
                print (clId, clUid, ReplayName fn)
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    95
                hFlush stdout
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    96
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    97
        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
    98
                void $ execute dbConn dbQueryStats (clients, rooms)
11320
556eafd1443a Store some more details on game config in the database
unc0rr
parents: 11280
diff changeset
    99
        StoreAchievements p fileName teams g info ->
11578
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   100
            parseStats dbConn p fileName teams g info
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2117
diff changeset
   101
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
   102
10991
189b2370353d Time is stored in bytestring now
unc0rr
parents: 10990
diff changeset
   103
--readTime = read . B.unpack . B.take 19 . B.drop 8
189b2370353d Time is stored in bytestring now
unc0rr
parents: 10990
diff changeset
   104
readTime = B.take 19 . B.drop 8
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
   105
10907
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   106
parseStats :: 
11273
096811aa3c55 Let's try to store games info necessary for ratings
unc0rr
parents: 11250
diff changeset
   107
    Connection
096811aa3c55 Let's try to store games info necessary for ratings
unc0rr
parents: 11250
diff changeset
   108
    -> Word16 
10907
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   109
    -> B.ByteString 
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   110
    -> [(B.ByteString, B.ByteString)] 
11320
556eafd1443a Store some more details on game config in the database
unc0rr
parents: 11280
diff changeset
   111
    -> GameDetails
11250
09a2d3988569 Also pass script information alongwith winner/achievements info, so that we could potentially have per mode ratings
unc0rr
parents: 11053
diff changeset
   112
    -> [B.ByteString]
11578
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   113
    -> IO ()
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   114
parseStats dbConn p fileName teams (GameDetails script infRopes vamp infAttacks) d = evalStateT (ps d) ("", maxBound)
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
   115
    where
9425
49eb707b9367 Extract time from file name, assuming it is stored in 'replay' folder
unc0rr
parents: 9421
diff changeset
   116
    time = readTime fileName
11578
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   117
    ps :: [B.ByteString] -> StateT (B.ByteString, Int) IO ()
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   118
    ps [] = return ()
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   119
    ps ("DRAW" : bs) = do
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   120
        io $ execute dbConn dbQueryGamesHistory (script, (fromIntegral p) :: Int, fileName, time, vamp, infRopes, infAttacks)
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   121
        io $ places (map drawParams teams)
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   122
        ps bs
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   123
    ps ("WINNERS" : n : bs) = do
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   124
        let winNum = readInt_ n
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   125
        io $ execute dbConn dbQueryGamesHistory (script, (fromIntegral p) :: Int, fileName, time, vamp, infRopes, infAttacks)
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   126
        io $ places (map (placeParams (take winNum bs)) teams)
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   127
        ps (drop winNum bs)
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   128
    ps ("ACHIEVEMENT" : typ : teamname : location : value : bs) = do
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   129
        let result = readInt_ value
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   130
        io $ execute dbConn dbQueryAchievement
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   131
            ( time
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   132
            , typ
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   133
            , fromMaybe "" (lookup teamname teams)
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   134
            , result
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   135
            , fileName
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   136
            , location
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   137
            , (fromIntegral p) :: Int
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   138
            )
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   139
        modify $ \st@(l, s) -> if result < s then (location, result) else st
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   140
        ps bs
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   141
    ps ("GHOST_POINTS" : n : bs) = do
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   142
        let pointsNum = readInt_ n
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   143
        (loc, time) <- get
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   144
        res <- io $ query dbConn dbQueryBestTime $ Only loc
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   145
        let bestTime = case res of
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   146
                [Only a] -> a
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   147
                _ -> maxBound :: Int
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   148
        when (time < bestTime) $ do
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   149
            -- store it
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   150
            return ()
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   151
        ps (drop (2 * pointsNum) bs)
9421
90fe753b3654 Fix 'non-exhaustive pattern' crash
unc0rr
parents: 9409
diff changeset
   152
    ps (b:bs) = ps bs
11578
8fd1808b12ed Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents: 11320
diff changeset
   153
11273
096811aa3c55 Let's try to store games info necessary for ratings
unc0rr
parents: 11250
diff changeset
   154
    drawParams t = (snd t, 0 :: Int)
096811aa3c55 Let's try to store games info necessary for ratings
unc0rr
parents: 11250
diff changeset
   155
    placeParams winners t = (snd t, if (fst t) `elem` winners then 1 else 2 :: Int)
11280
13ce106c8836 Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents: 11273
diff changeset
   156
    places :: [(B.ByteString, Int)] -> IO Int64
13ce106c8836 Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents: 11273
diff changeset
   157
    places params = do
13ce106c8836 Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents: 11273
diff changeset
   158
        res <- query_ dbConn dbQueryGameId
13ce106c8836 Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents: 11273
diff changeset
   159
        let gameId = case res of
13ce106c8836 Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents: 11273
diff changeset
   160
                [Only a] -> a
13ce106c8836 Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents: 11273
diff changeset
   161
                _ -> 0
13ce106c8836 Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents: 11273
diff changeset
   162
        mapM_ (execute dbConn dbQueryGamesHistoryPlaces . midInsert gameId) params
13ce106c8836 Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents: 11273
diff changeset
   163
        return 0
13ce106c8836 Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents: 11273
diff changeset
   164
    midInsert :: Int -> (a, b) -> (a, Int, b)
13ce106c8836 Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents: 11273
diff changeset
   165
    midInsert g (a, b) = (a, g, b)
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   166
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   167
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
   168
    Control.Exception.handle (\(e :: SomeException) -> hPutStrLn stderr $ show e) $
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
   169
        bracket
10907
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   170
            (connect mySQLConnectionInfo)
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   171
            close
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
   172
            dbInteractionLoop
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   173
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   174
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
   175
--processRequest :: DBQuery -> IO String
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
   176
--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
   177
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   178
main = do
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
   179
        dbHost <- getLine
4982
3572eaf14340 Add dbName parameter to .ini file, fix some warnings
unc0rr
parents: 4932
diff changeset
   180
        dbName <- getLine
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
   181
        dbLogin <- getLine
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
   182
        dbPassword <- getLine
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   183
10907
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   184
        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
   185
            connectHost = dbHost
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   186
            , connectDatabase = dbName
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   187
            , connectUser = dbLogin
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   188
            , connectPassword = dbPassword
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   189
            }
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   190
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
   191
        dbConnectionLoop mySQLConnectInfo