gameServer/OfficialServer/updateRating.hs
author Wuzzy <Wuzzy2@mail.ru>
Sat, 10 Feb 2018 19:30:51 +0100
changeset 12963 544c4302efe4
parent 11390 36e1bbb6ecea
permissions -rw-r--r--
Racer, TechRacer: Change waypoint opacity on victory or failure
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
     1
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
11358
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
     2
module Main where
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
     3
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
     4
import Data.Maybe
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
     5
import Data.TConfig
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
     6
import qualified Data.ByteString.Char8 as B
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
     7
import Database.MySQL.Simple
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
     8
import Database.MySQL.Simple.QueryResults
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
     9
import Database.MySQL.Simple.Result
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    10
import Control.Monad
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    11
import Control.Exception
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    12
import System.IO
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    13
import qualified  Data.Map as Map
11381
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    14
import Data.Time.Clock
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    15
------
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    16
import OfficialServer.Glicko2
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    17
11358
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    18
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    19
queryEpochDates = "SELECT epoch, todatetime, todatetime + INTERVAL 1 week FROM rating_epochs WHERE epoch = (SELECT MAX(epoch) FROM rating_epochs)"
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    20
queryPreviousRatings = "SELECT v.userid, v.rating, v.rd, v.volatility FROM rating_values as v WHERE (v.epoch = (SELECT MAX(epoch) FROM rating_epochs))"
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    21
queryGameResults =
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    22
        "SELECT \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    23
        \     p.userid \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    24
        \     , p.place \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    25
        \     , COALESCE(vp.rating, 1500) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    26
        \     , COALESCE(vp.rd, 350) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    27
        \     , COALESCE(vp.volatility, 0.06) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    28
        \     , COALESCE(vo.rating, 1500) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    29
        \     , COALESCE(vo.rd, 350) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    30
        \     , COALESCE(vo.volatility, 0.06) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    31
        \ FROM \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    32
        \     (SELECT epoch, todatetime FROM rating_epochs WHERE epoch = (SELECT MAX(epoch) FROM rating_epochs)) as e \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    33
        \     JOIN rating_games as g ON (g.time BETWEEN e.todatetime AND e.todatetime + INTERVAL 1 WEEK - INTERVAL 1 SECOND) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    34
        \     JOIN rating_players as p ON (p.gameid = g.id) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    35
        \     JOIN rating_players as o ON (p.gameid = o.gameid AND p.userid <> o.userid AND (p.place = 0 OR (p.place <> o.place))) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    36
        \     LEFT OUTER JOIN rating_values as vp ON (vp.epoch = e.epoch AND vp.userid = p.userid) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    37
        \     LEFT OUTER JOIN rating_values as vo ON (vo.epoch = e.epoch AND vo.userid = o.userid) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    38
        \ GROUP BY p.userid, p.gameid, p.place \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    39
        \ ORDER BY p.userid"
11390
36e1bbb6ecea - Reduce tau value, as suggested in gecko2 paper
unc0rr
parents: 11381
diff changeset
    40
insertNewRatings = "INSERT INTO rating_values (userid, epoch, rating, rd, volatility, games) VALUES (?, ?, ?, ?, ?, ?)"
11381
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    41
insertNewEpoch = "INSERT INTO rating_epochs (epoch, todatetime) VALUES (?, ?)"
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    42
11381
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    43
mergeRatingData :: Map.Map Int (RatingData, [GameData]) -> [(Int, (RatingData, [GameData]))] -> Map.Map Int (RatingData, [GameData])
11390
36e1bbb6ecea - Reduce tau value, as suggested in gecko2 paper
unc0rr
parents: 11381
diff changeset
    44
mergeRatingData m s = foldr (uncurry (Map.insertWith mf)) m s
11381
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    45
    where
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    46
        mf (rd, gds) (_, gds2) = (rd, gds ++ gds2)
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    47
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    48
calculateRatings dbConn = do
11381
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    49
    [(epochNum :: Int, fromDate :: UTCTime, toDate :: UTCTime)] <- query_ dbConn queryEpochDates
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    50
    initRatingData <- (Map.fromList . map fromDBrating) `fmap` query_ dbConn queryPreviousRatings
11381
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    51
    gameData <- map fromGameResult `fmap` query_ dbConn queryGameResults
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    52
    let mData = map getNewRating . Map.toList $ mergeRatingData initRatingData gameData
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    53
    executeMany dbConn insertNewRatings $ map (toInsert epochNum) mData
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    54
    execute dbConn insertNewEpoch (epochNum + 1, toDate)
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    55
    return ()
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    56
    where
11390
36e1bbb6ecea - Reduce tau value, as suggested in gecko2 paper
unc0rr
parents: 11381
diff changeset
    57
        toInsert e (i, (g, RatingData r rd v)) = (i, e + 1, r, rd, v, g)
11381
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    58
        getNewRating (a, d) = (a, uncurry calcNewRating d)
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    59
        convPlace :: Int -> Double
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    60
        convPlace 0 = 0.5
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    61
        convPlace 1 = 1.0
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    62
        convPlace 2 = 0.0
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    63
        convPlace _ = error "Incorrect place value"
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    64
        fromDBrating (a, b, c, d) = (a, (RatingData b c d, []))
11381
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    65
        fromGameResult (pid, place, prating, pRD, pvol, orating, oRD, ovol) =
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    66
            (pid,
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    67
                (RatingData prating pRD pvol
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11380
diff changeset
    68
                , [GameData (RatingData orating oRD ovol) $ convPlace place]))
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    69
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    70
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    71
data DBConnectInfo = DBConnectInfo {
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    72
    dbHost
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    73
    , dbName
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    74
    , dbLogin
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    75
    , dbPassword :: B.ByteString
11358
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    76
    }
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    77
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    78
cfgFileName :: String
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    79
cfgFileName = "hedgewars-server.ini"
11358
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    80
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    81
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    82
readServerConfig :: ConnectInfo -> IO ConnectInfo
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    83
readServerConfig ci = do
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    84
    cfg <- readConfig cfgFileName
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    85
    return $ ci{
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    86
        connectHost = value "dbHost" cfg
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    87
        , connectDatabase = value "dbName" cfg
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    88
        , connectUser = value "dbLogin" cfg
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    89
        , connectPassword = value "dbPassword" cfg
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    90
    }
11358
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    91
    where
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    92
        value n c = fromJust2 n $ getValue n c
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    93
        fromJust2 n Nothing = error $ "Missing config entry " ++ n
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    94
        fromJust2 _ (Just a) = a
11358
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    95
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    96
dbConnectionLoop mySQLConnectionInfo =
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    97
    Control.Exception.handle (\(e :: SomeException) -> hPutStrLn stderr $ show e) $
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    98
        bracket
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
    99
            (connect mySQLConnectionInfo)
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
   100
            close
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
   101
            calculateRatings
11358
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
   102
11380
ff0fa38bdb18 Some WIP
unc0rr
parents: 11359
diff changeset
   103
main = readServerConfig defaultConnectInfo >>= dbConnectionLoop