gameServer/OfficialServer/extdbinterface.hs
author unc0rr
Fri, 27 Sep 2013 12:58:21 +0400
changeset 9468 3d07fd84c39d
parent 9450 2084b1b7839c
child 9868 53d1b92db6ce
permissions -rw-r--r--
- Actually call uTexture.initModule and .freeModule - Fix texture leaks in teams/hedgehogs structures on application shutdown
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
4906
22cc9c2b5ae5 Fix even more
unc0rr
parents: 4568
diff changeset
     1
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-}
2348
b39d826e1ccd Drop support for ghc 6.8, use 6.10 instead
unc0rr
parents: 2195
diff changeset
     2
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
     3
module Main where
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
     4
2117
1ac0e10e546f Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents: 2116
diff changeset
     5
import Prelude hiding (catch)
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
     6
import Control.Monad
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
     7
import Control.Exception
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
     8
import System.IO
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
     9
import Data.Maybe
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    10
import Database.HDBC
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    11
import Database.HDBC.MySQL
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    12
import Data.List (lookup)
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    13
import qualified Data.ByteString.Char8 as B
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    14
--------------------------
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    15
import CoreTypes
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    16
import Utils
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    17
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    18
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2117
diff changeset
    19
dbQueryAccount =
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9427
diff changeset
    20
    "SELECT users.pass, \ 
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9427
diff changeset
    21
    \ (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
    22
    \ (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
    23
    \ 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
    24
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2117
diff changeset
    25
dbQueryStats =
6040
a740069c21e3 - Add unique id to replay file name
unc0rr
parents: 4982
diff changeset
    26
    "INSERT INTO gameserver_stats (players, rooms, last_update) VALUES (?, ?, UNIX_TIMESTAMP())"
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2117
diff changeset
    27
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    28
dbQueryAchievement =
9425
49eb707b9367 Extract time from file name, assuming it is stored in 'replay' folder
unc0rr
parents: 9421
diff changeset
    29
    "INSERT INTO achievements (time, typeid, userid, value, filename, location) \
9427
unc0rr
parents: 9425
diff changeset
    30
    \ VALUES (?, (SELECT id FROM achievement_types WHERE name = ?), (SELECT uid FROM users WHERE name = ?), \
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    31
    \ ?, ?, ?)"
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    32
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    33
dbQueryReplayFilename = "SELECT filename FROM achievements WHERE id = ?"
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    34
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    35
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    36
dbInteractionLoop dbConn = forever $ do
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    37
    q <- liftM read getLine
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    38
    hPutStrLn stderr $ show q
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
    39
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    40
    case q of
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
    41
        CheckAccount clId clUid clNick _ -> do
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    42
                statement <- prepare dbConn dbQueryAccount
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    43
                execute statement [SqlByteString clNick]
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9427
diff changeset
    44
                result <- fetchRow statement
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    45
                finish statement
8924
13ac59499066 update 0.9.19 with dev branch
koda
parents: 8909
diff changeset
    46
                let response =
9437
8d1e9a9dda8e Fix build
unc0rr
parents: 9435
diff changeset
    47
                        if isJust result then let [pass, adm, contr] = fromJust result in
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    48
                        (
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
    49
                            clId,
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    50
                            clUid,
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    51
                            HasAccount
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9427
diff changeset
    52
                                (fromSql pass)
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9427
diff changeset
    53
                                (fromSql adm == Just (1 :: Int))
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9427
diff changeset
    54
                                (fromSql contr == Just (1 :: Int))
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    55
                        )
2919
70244c730ea0 Now really fix build
unc0rr
parents: 2918
diff changeset
    56
                        else
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
    57
                        (clId, clUid, Guest)
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    58
                print response
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    59
                hFlush stdout
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    60
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    61
        GetReplayName clId clUid fileId -> do
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    62
                statement <- prepare dbConn dbQueryReplayFilename
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    63
                execute statement [SqlByteString fileId]
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    64
                result <- fetchRow statement
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    65
                finish statement
9450
2084b1b7839c Fix official server build
unc0rr
parents: 9446
diff changeset
    66
                let fn = if (isJust result) then fromJust . fromSql . head . fromJust $ result else ""
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    67
                print (clId, clUid, ReplayName fn)
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    68
                hFlush stdout
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    69
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    70
        SendStats clients rooms ->
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    71
                run dbConn dbQueryStats [SqlInt32 $ fromIntegral clients, SqlInt32 $ fromIntegral rooms] >> return ()
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    72
--StoreAchievements (B.pack fileName) (map toPair teams) info
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    73
        StoreAchievements fileName teams info -> 
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    74
            mapM_ (run dbConn dbQueryAchievement) $ (parseStats fileName teams) info
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2117
diff changeset
    75
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    76
9425
49eb707b9367 Extract time from file name, assuming it is stored in 'replay' folder
unc0rr
parents: 9421
diff changeset
    77
readTime = read . B.unpack . B.take 19 . B.drop 8
49eb707b9367 Extract time from file name, assuming it is stored in 'replay' folder
unc0rr
parents: 9421
diff changeset
    78
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    79
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    80
parseStats :: B.ByteString -> [(B.ByteString, B.ByteString)] -> [B.ByteString] -> [[SqlValue]]
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    81
parseStats fileName teams = ps
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    82
    where
9425
49eb707b9367 Extract time from file name, assuming it is stored in 'replay' folder
unc0rr
parents: 9421
diff changeset
    83
    time = readTime fileName
9421
90fe753b3654 Fix 'non-exhaustive pattern' crash
unc0rr
parents: 9409
diff changeset
    84
    ps [] = []
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    85
    ps ("DRAW" : bs) = ps bs
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    86
    ps ("WINNERS" : n : bs) = ps $ drop (readInt_ n) bs
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    87
    ps ("ACHIEVEMENT" : typ : teamname : location : value : bs) =
9425
49eb707b9367 Extract time from file name, assuming it is stored in 'replay' folder
unc0rr
parents: 9421
diff changeset
    88
        [ SqlUTCTime time
49eb707b9367 Extract time from file name, assuming it is stored in 'replay' folder
unc0rr
parents: 9421
diff changeset
    89
        , SqlByteString typ
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    90
        , SqlByteString $ fromMaybe "" (lookup teamname teams)
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    91
        , SqlInt32 (readInt_ value)
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    92
        , SqlByteString fileName
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    93
        , SqlByteString location
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    94
        ] : ps bs
9421
90fe753b3654 Fix 'non-exhaustive pattern' crash
unc0rr
parents: 9409
diff changeset
    95
    ps (b:bs) = ps bs
90fe753b3654 Fix 'non-exhaustive pattern' crash
unc0rr
parents: 9409
diff changeset
    96
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    97
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    98
dbConnectionLoop mySQLConnectionInfo =
4906
22cc9c2b5ae5 Fix even more
unc0rr
parents: 4568
diff changeset
    99
    Control.Exception.handle (\(e :: IOException) -> hPutStrLn stderr $ show e) $ handleSqlError $
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
   100
        bracket
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
   101
            (connectMySQL mySQLConnectionInfo)
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
   102
            disconnect
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
   103
            dbInteractionLoop
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   104
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   105
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
   106
--processRequest :: DBQuery -> IO String
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
   107
--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
   108
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   109
main = do
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
   110
        dbHost <- getLine
4982
3572eaf14340 Add dbName parameter to .ini file, fix some warnings
unc0rr
parents: 4932
diff changeset
   111
        dbName <- getLine
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
   112
        dbLogin <- getLine
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
   113
        dbPassword <- getLine
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   114
4982
3572eaf14340 Add dbName parameter to .ini file, fix some warnings
unc0rr
parents: 4932
diff changeset
   115
        let mySQLConnectInfo = defaultMySQLConnectInfo {mysqlHost = dbHost, mysqlDatabase = dbName, mysqlUser = dbLogin, mysqlPassword = dbPassword}
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   116
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
   117
        dbConnectionLoop mySQLConnectInfo