gameServer/OfficialServer/extdbinterface.hs
author Wuzzy <almikes@aol.com>
Sun, 08 Oct 2017 20:24:58 +0200
changeset 12681 2e6dcd97f085
parent 11584 d389ea7ca66f
permissions -rw-r--r--
No longer jiggle sticky mines if using portable portal device This fixes the sticky mine sound playing when using portal gun while any sticky mine is placed on ground. We decided that placed sticky mines can't be teleported.
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
11584
d389ea7ca66f Don't compare time value with itself
unc0rr
parents: 11580
diff changeset
    67
dbQueryBestTime = "SELECT MIN(value) FROM achievements WHERE location = ? AND id <> (SELECT MAX(id) FROM achievements)"
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
11580
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11578
diff changeset
   143
        (location, time) <- get
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11578
diff changeset
   144
        res <- io $ query dbConn dbQueryBestTime $ Only location
11578
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
11580
db7743e2fad1 More work on best time ghost feature
unc0rr
parents: 11578
diff changeset
   149
            io $ writeFile (B.unpack $ "ghosts/" `B.append` sanitizeName location) $ show (map readInt_ $ take (2 * pointsNum) bs)
11578
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