gameServer/OfficialServer/extdbinterface.hs
author unc0rr
Thu, 03 Sep 2015 20:59:48 +0300
branchqmlfrontend
changeset 11071 3851ce4f2061
parent 11053 a009cc19a639
child 11250 09a2d3988569
permissions -rw-r--r--
Merge default
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
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    26
import System.IO
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    27
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
    28
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
    29
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
    30
import Database.MySQL.Simple.Result
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    31
import Data.List (lookup)
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    32
import qualified Data.ByteString.Char8 as B
9884
6e09ca662fa3 Some fixes
unc0rr
parents: 9868
diff changeset
    33
import Data.Word
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    34
--------------------------
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    35
import CoreTypes
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    36
import Utils
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    37
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    38
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2117
diff changeset
    39
dbQueryAccount =
11053
a009cc19a639 Don't accept any password from players banned on the website
unC0Rr
parents: 11046
diff changeset
    40
    "SELECT CASE WHEN users.status = 1 THEN users.pass ELSE '' END, \
9435
59eec19cb31a 'c' flag for contributors
unc0rr
parents: 9427
diff changeset
    41
    \ (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
    42
    \ (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
    43
    \ 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
    44
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2117
diff changeset
    45
dbQueryStats =
6040
a740069c21e3 - Add unique id to replay file name
unc0rr
parents: 4982
diff changeset
    46
    "INSERT INTO gameserver_stats (players, rooms, last_update) VALUES (?, ?, UNIX_TIMESTAMP())"
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2117
diff changeset
    47
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    48
dbQueryAchievement =
9868
53d1b92db6ce Store protocol number in database for replays
unc0rr
parents: 9450
diff changeset
    49
    "INSERT INTO achievements (time, typeid, userid, value, filename, location, protocol) \
9427
unc0rr
parents: 9425
diff changeset
    50
    \ 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
    51
    \ ?, ?, ?, ?)"
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
    52
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    53
dbQueryReplayFilename = "SELECT filename FROM achievements WHERE id = ?"
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    54
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    55
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    56
dbInteractionLoop dbConn = forever $ do
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    57
    q <- liftM read getLine
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    58
    hPutStrLn stderr $ show q
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
    59
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    60
    case q of
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
    61
        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
    62
                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
    63
                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
    64
                        [(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
    65
                            (
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    66
                                clId,
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    67
                                clUid,
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    68
                                HasAccount
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    69
                                    (pass)
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    70
                                    (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
    71
                                    (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
    72
                            )
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    73
                        _ ->
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    74
                            (clId, clUid, Guest)
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
    75
                print response
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    76
                hFlush stdout
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
    77
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    78
        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
    79
                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
    80
                let fn = if null results then "" else fromOnly $ head results
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    81
                print (clId, clUid, ReplayName fn)
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    82
                hFlush stdout
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    83
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
    84
        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
    85
                void $ execute dbConn dbQueryStats (clients, rooms)
10017
de822cd3df3a fixwhitespace and dos2unix
koda
parents: 9884
diff changeset
    86
        StoreAchievements p fileName teams info ->
10990
c99385e4654d Buggy executeMany?
unc0rr
parents: 10907
diff changeset
    87
            mapM_ (execute dbConn dbQueryAchievement) $ (parseStats p fileName teams) info
2172
80d34c0b9dfe Implement sending gameserver stats to webserver
unc0rr
parents: 2117
diff changeset
    88
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    89
10991
189b2370353d Time is stored in bytestring now
unc0rr
parents: 10990
diff changeset
    90
--readTime = read . B.unpack . B.take 19 . B.drop 8
189b2370353d Time is stored in bytestring now
unc0rr
parents: 10990
diff changeset
    91
readTime = B.take 19 . B.drop 8
9446
4fd5df03deb8 Start support of achievement replay query:
unc0rr
parents: 9437
diff changeset
    92
10907
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    93
parseStats :: 
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    94
    Word16 
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    95
    -> B.ByteString 
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    96
    -> [(B.ByteString, B.ByteString)] 
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    97
    -> [B.ByteString] 
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
    98
    -> [(B.ByteString, B.ByteString, B.ByteString, Int, B.ByteString, B.ByteString, Int)]
9868
53d1b92db6ce Store protocol number in database for replays
unc0rr
parents: 9450
diff changeset
    99
parseStats p fileName teams = ps
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
   100
    where
9425
49eb707b9367 Extract time from file name, assuming it is stored in 'replay' folder
unc0rr
parents: 9421
diff changeset
   101
    time = readTime fileName
9421
90fe753b3654 Fix 'non-exhaustive pattern' crash
unc0rr
parents: 9409
diff changeset
   102
    ps [] = []
9409
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
   103
    ps ("DRAW" : bs) = ps bs
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
   104
    ps ("WINNERS" : n : bs) = ps $ drop (readInt_ n) bs
6564baf7dedf Store TrophyRace records in database
unc0rr
parents: 9401
diff changeset
   105
    ps ("ACHIEVEMENT" : typ : teamname : location : value : bs) =
10907
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   106
        ( time
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   107
        , typ
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   108
        , fromMaybe "" (lookup teamname teams)
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   109
        , readInt_ value
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   110
        , fileName
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   111
        , location
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   112
        , fromIntegral p
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   113
        ) : ps bs
9421
90fe753b3654 Fix 'non-exhaustive pattern' crash
unc0rr
parents: 9409
diff changeset
   114
    ps (b:bs) = ps bs
90fe753b3654 Fix 'non-exhaustive pattern' crash
unc0rr
parents: 9409
diff changeset
   115
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   117
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
   118
    Control.Exception.handle (\(e :: SomeException) -> hPutStrLn stderr $ show e) $
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
   119
        bracket
10907
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   120
            (connect mySQLConnectionInfo)
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   121
            close
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4921
diff changeset
   122
            dbInteractionLoop
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   123
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   124
4921
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
   125
--processRequest :: DBQuery -> IO String
2efad3acbb74 Fix build of official server
unc0rr
parents: 4906
diff changeset
   126
--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
   127
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   128
main = do
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
   129
        dbHost <- getLine
4982
3572eaf14340 Add dbName parameter to .ini file, fix some warnings
unc0rr
parents: 4932
diff changeset
   130
        dbName <- getLine
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
   131
        dbLogin <- getLine
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
   132
        dbPassword <- getLine
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   133
10907
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   134
        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
   135
            connectHost = dbHost
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   136
            , connectDatabase = dbName
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   137
            , connectUser = dbLogin
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   138
            , connectPassword = dbPassword
9b8e9813c6f8 Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents: 10460
diff changeset
   139
            }
2116
dec7ead2d178 Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff changeset
   140
2869
93cc73dcc421 Replace tabs with spaces here too
unc0rr
parents: 2348
diff changeset
   141
        dbConnectionLoop mySQLConnectInfo