11380
|
1 |
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
|
11358
|
2 |
module Main where
|
|
3 |
|
11380
|
4 |
import Data.Maybe
|
|
5 |
import Data.TConfig
|
|
6 |
import qualified Data.ByteString.Char8 as B
|
|
7 |
import Database.MySQL.Simple
|
|
8 |
import Database.MySQL.Simple.QueryResults
|
|
9 |
import Database.MySQL.Simple.Result
|
|
10 |
import Control.Monad
|
|
11 |
import Control.Exception
|
|
12 |
import System.IO
|
|
13 |
import qualified Data.Map as Map
|
11381
|
14 |
import Data.Time.Clock
|
11380
|
15 |
------
|
|
16 |
import OfficialServer.Glicko2
|
|
17 |
|
11358
|
18 |
|
11380
|
19 |
queryEpochDates = "SELECT epoch, todatetime, todatetime + INTERVAL 1 week FROM rating_epochs WHERE epoch = (SELECT MAX(epoch) FROM rating_epochs)"
|
|
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))"
|
|
21 |
queryGameResults =
|
|
22 |
"SELECT \
|
|
23 |
\ p.userid \
|
|
24 |
\ , p.place \
|
|
25 |
\ , COALESCE(vp.rating, 1500) \
|
|
26 |
\ , COALESCE(vp.rd, 350) \
|
|
27 |
\ , COALESCE(vp.volatility, 0.06) \
|
|
28 |
\ , COALESCE(vo.rating, 1500) \
|
|
29 |
\ , COALESCE(vo.rd, 350) \
|
|
30 |
\ , COALESCE(vo.volatility, 0.06) \
|
|
31 |
\ FROM \
|
|
32 |
\ (SELECT epoch, todatetime FROM rating_epochs WHERE epoch = (SELECT MAX(epoch) FROM rating_epochs)) as e \
|
|
33 |
\ JOIN rating_games as g ON (g.time BETWEEN e.todatetime AND e.todatetime + INTERVAL 1 WEEK - INTERVAL 1 SECOND) \
|
|
34 |
\ JOIN rating_players as p ON (p.gameid = g.id) \
|
|
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))) \
|
|
36 |
\ LEFT OUTER JOIN rating_values as vp ON (vp.epoch = e.epoch AND vp.userid = p.userid) \
|
|
37 |
\ LEFT OUTER JOIN rating_values as vo ON (vo.epoch = e.epoch AND vo.userid = o.userid) \
|
|
38 |
\ GROUP BY p.userid, p.gameid, p.place \
|
|
39 |
\ ORDER BY p.userid"
|
11381
|
40 |
insertNewRatings = "INSERT INTO rating_values (userid, epoch, rating, rd, volatility) VALUES (?, ?, ?, ?, ?)"
|
|
41 |
insertNewEpoch = "INSERT INTO rating_epochs (epoch, todatetime) VALUES (?, ?)"
|
11380
|
42 |
|
11381
|
43 |
mergeRatingData :: Map.Map Int (RatingData, [GameData]) -> [(Int, (RatingData, [GameData]))] -> Map.Map Int (RatingData, [GameData])
|
|
44 |
mergeRatingData m s = foldr (unc0rry (Map.insertWith mf)) m s
|
|
45 |
where
|
|
46 |
mf (rd, gds) (_, gds2) = (rd, gds ++ gds2)
|
|
47 |
unc0rry f (a, b) c = f a b c
|
|
48 |
|
11380
|
49 |
calculateRatings dbConn = do
|
11381
|
50 |
[(epochNum :: Int, fromDate :: UTCTime, toDate :: UTCTime)] <- query_ dbConn queryEpochDates
|
11380
|
51 |
initRatingData <- (Map.fromList . map fromDBrating) `fmap` query_ dbConn queryPreviousRatings
|
11381
|
52 |
gameData <- map fromGameResult `fmap` query_ dbConn queryGameResults
|
|
53 |
let mData = map getNewRating . Map.toList $ mergeRatingData initRatingData gameData
|
|
54 |
executeMany dbConn insertNewRatings $ map (toInsert epochNum) mData
|
|
55 |
execute dbConn insertNewEpoch (epochNum + 1, toDate)
|
11380
|
56 |
return ()
|
|
57 |
where
|
11381
|
58 |
toInsert e (i, RatingData r rd v) = (i, e + 1, r, rd, v)
|
|
59 |
getNewRating (a, d) = (a, uncurry calcNewRating d)
|
|
60 |
convPlace :: Int -> Double
|
|
61 |
convPlace 0 = 0.5
|
|
62 |
convPlace 1 = 1.0
|
|
63 |
convPlace 2 = 0.0
|
|
64 |
convPlace _ = error "Incorrect place value"
|
11380
|
65 |
fromDBrating (a, b, c, d) = (a, (RatingData b c d, []))
|
11381
|
66 |
fromGameResult (pid, place, prating, pRD, pvol, orating, oRD, ovol) =
|
|
67 |
(pid,
|
|
68 |
(RatingData prating pRD pvol
|
|
69 |
, [GameData (RatingData orating oRD ovol) $ convPlace place]))
|
11380
|
70 |
|
|
71 |
|
|
72 |
data DBConnectInfo = DBConnectInfo {
|
|
73 |
dbHost
|
|
74 |
, dbName
|
|
75 |
, dbLogin
|
|
76 |
, dbPassword :: B.ByteString
|
11358
|
77 |
}
|
|
78 |
|
11380
|
79 |
cfgFileName :: String
|
|
80 |
cfgFileName = "hedgewars-server.ini"
|
11358
|
81 |
|
|
82 |
|
11380
|
83 |
readServerConfig :: ConnectInfo -> IO ConnectInfo
|
|
84 |
readServerConfig ci = do
|
|
85 |
cfg <- readConfig cfgFileName
|
|
86 |
return $ ci{
|
|
87 |
connectHost = value "dbHost" cfg
|
|
88 |
, connectDatabase = value "dbName" cfg
|
|
89 |
, connectUser = value "dbLogin" cfg
|
|
90 |
, connectPassword = value "dbPassword" cfg
|
|
91 |
}
|
11358
|
92 |
where
|
11380
|
93 |
value n c = fromJust2 n $ getValue n c
|
|
94 |
fromJust2 n Nothing = error $ "Missing config entry " ++ n
|
|
95 |
fromJust2 _ (Just a) = a
|
11358
|
96 |
|
11380
|
97 |
dbConnectionLoop mySQLConnectionInfo =
|
|
98 |
Control.Exception.handle (\(e :: SomeException) -> hPutStrLn stderr $ show e) $
|
|
99 |
bracket
|
|
100 |
(connect mySQLConnectionInfo)
|
|
101 |
close
|
|
102 |
calculateRatings
|
11358
|
103 |
|
11380
|
104 |
main = readServerConfig defaultConnectInfo >>= dbConnectionLoop
|