author | nemo |
Wed, 13 Apr 2016 20:02:14 -0400 | |
changeset 11651 | e5c101a6fb8d |
parent 11579 | d389ea7ca66f |
permissions | -rw-r--r-- |
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 | 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 | 19 |
{-# LANGUAGE ScopedTypeVariables, OverloadedStrings #-} |
2348 | 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 |
11573
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
26 |
import Control.Monad.State |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
27 |
import System.IO |
4932 | 28 |
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
|
29 |
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
|
30 |
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
|
31 |
import Database.MySQL.Simple.Result |
11268
096811aa3c55
Let's try to store games info necessary for ratings
unc0rr
parents:
11246
diff
changeset
|
32 |
import Data.List (lookup, elem) |
9409 | 33 |
import qualified Data.ByteString.Char8 as B |
9884 | 34 |
import Data.Word |
11268
096811aa3c55
Let's try to store games info necessary for ratings
unc0rr
parents:
11246
diff
changeset
|
35 |
import Data.Int |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
36 |
-------------------------- |
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
37 |
import CoreTypes |
9409 | 38 |
import Utils |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
39 |
|
11573
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
40 |
io = liftIO |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
41 |
|
2172 | 42 |
dbQueryAccount = |
11053
a009cc19a639
Don't accept any password from players banned on the website
unC0Rr
parents:
11046
diff
changeset
|
43 |
"SELECT CASE WHEN users.status = 1 THEN users.pass ELSE '' END, \ |
9435 | 44 |
\ (SELECT COUNT(users_roles.rid) FROM users_roles WHERE users.uid = users_roles.uid AND users_roles.rid = 3), \ |
45 |
\ (SELECT COUNT(users_roles.rid) FROM users_roles WHERE users.uid = users_roles.uid AND users_roles.rid = 13) \ |
|
46 |
\ 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
|
47 |
|
2172 | 48 |
dbQueryStats = |
6040 | 49 |
"INSERT INTO gameserver_stats (players, rooms, last_update) VALUES (?, ?, UNIX_TIMESTAMP())" |
2172 | 50 |
|
9409 | 51 |
dbQueryAchievement = |
9868 | 52 |
"INSERT INTO achievements (time, typeid, userid, value, filename, location, protocol) \ |
9427 | 53 |
\ VALUES (?, (SELECT id FROM achievement_types WHERE name = ?), (SELECT uid FROM users WHERE name = ?), \ |
9868 | 54 |
\ ?, ?, ?, ?)" |
9409 | 55 |
|
11246
09a2d3988569
Also pass script information alongwith winner/achievements info, so that we could potentially have per mode ratings
unc0rr
parents:
11053
diff
changeset
|
56 |
dbQueryGamesHistory = |
11320
556eafd1443a
Store some more details on game config in the database
unc0rr
parents:
11275
diff
changeset
|
57 |
"INSERT INTO rating_games (script, protocol, filename, time, vamp, ropes, infattacks) \ |
556eafd1443a
Store some more details on game config in the database
unc0rr
parents:
11275
diff
changeset
|
58 |
\ VALUES (?, ?, ?, ?, ?, ?, ?)" |
11268
096811aa3c55
Let's try to store games info necessary for ratings
unc0rr
parents:
11246
diff
changeset
|
59 |
|
11275
13ce106c8836
Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents:
11268
diff
changeset
|
60 |
dbQueryGameId = "SELECT LAST_INSERT_ID()" |
13ce106c8836
Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents:
11268
diff
changeset
|
61 |
|
11268
096811aa3c55
Let's try to store games info necessary for ratings
unc0rr
parents:
11246
diff
changeset
|
62 |
dbQueryGamesHistoryPlaces = "INSERT INTO rating_players (userid, gameid, place) \ |
11275
13ce106c8836
Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents:
11268
diff
changeset
|
63 |
\ VALUES ((SELECT uid FROM users WHERE name = ?), ?, ?)" |
11246
09a2d3988569
Also pass script information alongwith winner/achievements info, so that we could potentially have per mode ratings
unc0rr
parents:
11053
diff
changeset
|
64 |
|
9446 | 65 |
dbQueryReplayFilename = "SELECT filename FROM achievements WHERE id = ?" |
66 |
||
11579 | 67 |
dbQueryBestTime = "SELECT MIN(value) FROM achievements WHERE location = ? AND id <> (SELECT MAX(id) FROM achievements)" |
9446 | 68 |
|
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
69 |
dbInteractionLoop dbConn = forever $ do |
4932 | 70 |
q <- liftM read getLine |
2869 | 71 |
hPutStrLn stderr $ show q |
4921 | 72 |
|
2869 | 73 |
case q of |
4921 | 74 |
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
|
75 |
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
|
76 |
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
|
77 |
[(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
|
78 |
( |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
79 |
clId, |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
80 |
clUid, |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
81 |
HasAccount |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
82 |
(pass) |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
83 |
(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
|
84 |
(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
|
85 |
) |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
86 |
_ -> |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
87 |
(clId, clUid, Guest) |
4932 | 88 |
print response |
2869 | 89 |
hFlush stdout |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
90 |
|
9446 | 91 |
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
|
92 |
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
|
93 |
let fn = if null results then "" else fromOnly $ head results |
9446 | 94 |
print (clId, clUid, ReplayName fn) |
95 |
hFlush stdout |
|
96 |
||
2869 | 97 |
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
|
98 |
void $ execute dbConn dbQueryStats (clients, rooms) |
11320
556eafd1443a
Store some more details on game config in the database
unc0rr
parents:
11275
diff
changeset
|
99 |
StoreAchievements p fileName teams g info -> |
11573
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
100 |
parseStats dbConn p fileName teams g info |
2172 | 101 |
|
9446 | 102 |
|
10991 | 103 |
--readTime = read . B.unpack . B.take 19 . B.drop 8 |
104 |
readTime = B.take 19 . B.drop 8 |
|
9446 | 105 |
|
10907
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
106 |
parseStats :: |
11268
096811aa3c55
Let's try to store games info necessary for ratings
unc0rr
parents:
11246
diff
changeset
|
107 |
Connection |
096811aa3c55
Let's try to store games info necessary for ratings
unc0rr
parents:
11246
diff
changeset
|
108 |
-> Word16 |
10907
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
109 |
-> B.ByteString |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
110 |
-> [(B.ByteString, B.ByteString)] |
11320
556eafd1443a
Store some more details on game config in the database
unc0rr
parents:
11275
diff
changeset
|
111 |
-> GameDetails |
11246
09a2d3988569
Also pass script information alongwith winner/achievements info, so that we could potentially have per mode ratings
unc0rr
parents:
11053
diff
changeset
|
112 |
-> [B.ByteString] |
11573
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
113 |
-> IO () |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
114 |
parseStats dbConn p fileName teams (GameDetails script infRopes vamp infAttacks) d = evalStateT (ps d) ("", maxBound) |
9409 | 115 |
where |
9425
49eb707b9367
Extract time from file name, assuming it is stored in 'replay' folder
unc0rr
parents:
9421
diff
changeset
|
116 |
time = readTime fileName |
11573
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
117 |
ps :: [B.ByteString] -> StateT (B.ByteString, Int) IO () |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
118 |
ps [] = return () |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
119 |
ps ("DRAW" : bs) = do |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
120 |
io $ execute dbConn dbQueryGamesHistory (script, (fromIntegral p) :: Int, fileName, time, vamp, infRopes, infAttacks) |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
121 |
io $ places (map drawParams teams) |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
122 |
ps bs |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
123 |
ps ("WINNERS" : n : bs) = do |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
124 |
let winNum = readInt_ n |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
125 |
io $ execute dbConn dbQueryGamesHistory (script, (fromIntegral p) :: Int, fileName, time, vamp, infRopes, infAttacks) |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
126 |
io $ places (map (placeParams (take winNum bs)) teams) |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
127 |
ps (drop winNum bs) |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
128 |
ps ("ACHIEVEMENT" : typ : teamname : location : value : bs) = do |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
129 |
let result = readInt_ value |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
130 |
io $ execute dbConn dbQueryAchievement |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
131 |
( time |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
132 |
, typ |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
133 |
, fromMaybe "" (lookup teamname teams) |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
134 |
, result |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
135 |
, fileName |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
136 |
, location |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
137 |
, (fromIntegral p) :: Int |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
138 |
) |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
139 |
modify $ \st@(l, s) -> if result < s then (location, result) else st |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
140 |
ps bs |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
141 |
ps ("GHOST_POINTS" : n : bs) = do |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
142 |
let pointsNum = readInt_ n |
11575 | 143 |
(location, time) <- get |
144 |
res <- io $ query dbConn dbQueryBestTime $ Only location |
|
11573
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
145 |
let bestTime = case res of |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
146 |
[Only a] -> a |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
147 |
_ -> maxBound :: Int |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
148 |
when (time < bestTime) $ do |
11575 | 149 |
io $ writeFile (B.unpack $ "ghosts/" `B.append` sanitizeName location) $ show (map readInt_ $ take (2 * pointsNum) bs) |
11573
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
150 |
return () |
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
151 |
ps (drop (2 * pointsNum) bs) |
9421 | 152 |
ps (b:bs) = ps bs |
11573
8fd1808b12ed
Recognize ghost points in db interaction tool (no storing yet)
unc0rr
parents:
11320
diff
changeset
|
153 |
|
11268
096811aa3c55
Let's try to store games info necessary for ratings
unc0rr
parents:
11246
diff
changeset
|
154 |
drawParams t = (snd t, 0 :: Int) |
096811aa3c55
Let's try to store games info necessary for ratings
unc0rr
parents:
11246
diff
changeset
|
155 |
placeParams winners t = (snd t, if (fst t) `elem` winners then 1 else 2 :: Int) |
11275
13ce106c8836
Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents:
11268
diff
changeset
|
156 |
places :: [(B.ByteString, Int)] -> IO Int64 |
13ce106c8836
Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents:
11268
diff
changeset
|
157 |
places params = do |
13ce106c8836
Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents:
11268
diff
changeset
|
158 |
res <- query_ dbConn dbQueryGameId |
13ce106c8836
Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents:
11268
diff
changeset
|
159 |
let gameId = case res of |
13ce106c8836
Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents:
11268
diff
changeset
|
160 |
[Only a] -> a |
13ce106c8836
Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents:
11268
diff
changeset
|
161 |
_ -> 0 |
13ce106c8836
Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents:
11268
diff
changeset
|
162 |
mapM_ (execute dbConn dbQueryGamesHistoryPlaces . midInsert gameId) params |
13ce106c8836
Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents:
11268
diff
changeset
|
163 |
return 0 |
13ce106c8836
Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents:
11268
diff
changeset
|
164 |
midInsert :: Int -> (a, b) -> (a, Int, b) |
13ce106c8836
Workaround mysql-simple library stupiness regarding executeMany
unc0rr
parents:
11268
diff
changeset
|
165 |
midInsert g (a, b) = (a, g, b) |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
166 |
|
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
167 |
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
|
168 |
Control.Exception.handle (\(e :: SomeException) -> hPutStrLn stderr $ show e) $ |
2869 | 169 |
bracket |
10907
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
170 |
(connect mySQLConnectionInfo) |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
171 |
close |
4932 | 172 |
dbInteractionLoop |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
173 |
|
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
174 |
|
4921 | 175 |
--processRequest :: DBQuery -> IO String |
176 |
--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
|
177 |
|
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
178 |
main = do |
2869 | 179 |
dbHost <- getLine |
4982
3572eaf14340
Add dbName parameter to .ini file, fix some warnings
unc0rr
parents:
4932
diff
changeset
|
180 |
dbName <- getLine |
2869 | 181 |
dbLogin <- getLine |
182 |
dbPassword <- getLine |
|
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
183 |
|
10907
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
184 |
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
|
185 |
connectHost = dbHost |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
186 |
, connectDatabase = dbName |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
187 |
, connectUser = dbLogin |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
188 |
, connectPassword = dbPassword |
9b8e9813c6f8
Switch to mysql-simple, as hdbc package seems to be abandoned and anyway never satisfied me
unc0rr
parents:
10460
diff
changeset
|
189 |
} |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
diff
changeset
|
190 |
|
2869 | 191 |
dbConnectionLoop mySQLConnectInfo |