gameServer/OfficialServer/updateRating.hs
author nemo
Wed, 09 Aug 2017 12:46:52 -0400
changeset 12451 48ee3777e42e
parent 11395 36e1bbb6ecea
permissions -rw-r--r--
trying to eliminate that annoying impact sound for gears that are well under the water and not even exiting it. sheepluva might want to look this over since this is modifying his code and should perhaps be part of the addSplashForGear checks, but hadn't had much luck getting him to examine it past year or so
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
11385
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
     1
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
11375
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
11385
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
     4
import Data.Maybe
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
     5
import Data.TConfig
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
     6
import qualified Data.ByteString.Char8 as B
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
     7
import Database.MySQL.Simple
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
     8
import Database.MySQL.Simple.QueryResults
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
     9
import Database.MySQL.Simple.Result
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    10
import Control.Monad
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    11
import Control.Exception
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    12
import System.IO
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    13
import qualified  Data.Map as Map
11386
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    14
import Data.Time.Clock
11385
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    15
------
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    16
import OfficialServer.Glicko2
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    17
11375
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    18
11385
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
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: 11376
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: 11376
diff changeset
    21
queryGameResults =
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    22
        "SELECT \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    23
        \     p.userid \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    24
        \     , p.place \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    25
        \     , COALESCE(vp.rating, 1500) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    26
        \     , COALESCE(vp.rd, 350) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    27
        \     , COALESCE(vp.volatility, 0.06) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    28
        \     , COALESCE(vo.rating, 1500) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    29
        \     , COALESCE(vo.rd, 350) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    30
        \     , COALESCE(vo.volatility, 0.06) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    31
        \ FROM \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    32
        \     (SELECT epoch, todatetime FROM rating_epochs WHERE epoch = (SELECT MAX(epoch) FROM rating_epochs)) as e \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
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: 11376
diff changeset
    34
        \     JOIN rating_players as p ON (p.gameid = g.id) \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
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: 11376
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: 11376
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: 11376
diff changeset
    38
        \ GROUP BY p.userid, p.gameid, p.place \
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    39
        \ ORDER BY p.userid"
11395
36e1bbb6ecea - Reduce tau value, as suggested in gecko2 paper
unc0rr
parents: 11386
diff changeset
    40
insertNewRatings = "INSERT INTO rating_values (userid, epoch, rating, rd, volatility, games) VALUES (?, ?, ?, ?, ?, ?)"
11386
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    41
insertNewEpoch = "INSERT INTO rating_epochs (epoch, todatetime) VALUES (?, ?)"
11385
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    42
11386
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    43
mergeRatingData :: Map.Map Int (RatingData, [GameData]) -> [(Int, (RatingData, [GameData]))] -> Map.Map Int (RatingData, [GameData])
11395
36e1bbb6ecea - Reduce tau value, as suggested in gecko2 paper
unc0rr
parents: 11386
diff changeset
    44
mergeRatingData m s = foldr (uncurry (Map.insertWith mf)) m s
11386
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    45
    where
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    46
        mf (rd, gds) (_, gds2) = (rd, gds ++ gds2)
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    47
11385
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    48
calculateRatings dbConn = do
11386
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    49
    [(epochNum :: Int, fromDate :: UTCTime, toDate :: UTCTime)] <- query_ dbConn queryEpochDates
11385
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    50
    initRatingData <- (Map.fromList . map fromDBrating) `fmap` query_ dbConn queryPreviousRatings
11386
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    51
    gameData <- map fromGameResult `fmap` query_ dbConn queryGameResults
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    52
    let mData = map getNewRating . Map.toList $ mergeRatingData initRatingData gameData
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    53
    executeMany dbConn insertNewRatings $ map (toInsert epochNum) mData
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    54
    execute dbConn insertNewEpoch (epochNum + 1, toDate)
11385
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    55
    return ()
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    56
    where
11395
36e1bbb6ecea - Reduce tau value, as suggested in gecko2 paper
unc0rr
parents: 11386
diff changeset
    57
        toInsert e (i, (g, RatingData r rd v)) = (i, e + 1, r, rd, v, g)
11386
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    58
        getNewRating (a, d) = (a, uncurry calcNewRating d)
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    59
        convPlace :: Int -> Double
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    60
        convPlace 0 = 0.5
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    61
        convPlace 1 = 1.0
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    62
        convPlace 2 = 0.0
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    63
        convPlace _ = error "Incorrect place value"
11385
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    64
        fromDBrating (a, b, c, d) = (a, (RatingData b c d, []))
11386
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    65
        fromGameResult (pid, place, prating, pRD, pvol, orating, oRD, ovol) =
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    66
            (pid,
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    67
                (RatingData prating pRD pvol
437a60995fe1 Rating updater, alpha version
unc0rr
parents: 11385
diff changeset
    68
                , [GameData (RatingData orating oRD ovol) $ convPlace place]))
11385
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    69
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    70
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    71
data DBConnectInfo = DBConnectInfo {
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    72
    dbHost
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    73
    , dbName
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    74
    , dbLogin
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    75
    , dbPassword :: B.ByteString
11375
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    76
    }
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    77
11385
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    78
cfgFileName :: String
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    79
cfgFileName = "hedgewars-server.ini"
11375
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    80
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    81
11385
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    82
readServerConfig :: ConnectInfo -> IO ConnectInfo
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    83
readServerConfig ci = do
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    84
    cfg <- readConfig cfgFileName
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    85
    return $ ci{
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    86
        connectHost = value "dbHost" cfg
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    87
        , connectDatabase = value "dbName" cfg
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    88
        , connectUser = value "dbLogin" cfg
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    89
        , connectPassword = value "dbPassword" cfg
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    90
    }
11375
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    91
    where
11385
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    92
        value n c = fromJust2 n $ getValue n c
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    93
        fromJust2 n Nothing = error $ "Missing config entry " ++ n
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    94
        fromJust2 _ (Just a) = a
11375
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
    95
11385
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    96
dbConnectionLoop mySQLConnectionInfo =
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    97
    Control.Exception.handle (\(e :: SomeException) -> hPutStrLn stderr $ show e) $
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    98
        bracket
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
    99
            (connect mySQLConnectionInfo)
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
   100
            close
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
   101
            calculateRatings
11375
55360683db75 Start work on rating calculator
unc0rr
parents:
diff changeset
   102
11385
ff0fa38bdb18 Some WIP
unc0rr
parents: 11376
diff changeset
   103
main = readServerConfig defaultConnectInfo >>= dbConnectionLoop