author | Wuzzy <Wuzzy2@mail.ru> |
Sun, 05 May 2019 02:04:12 +0200 | |
changeset 14900 | 002f7d41f5ce |
parent 11046 | 47a8c19ecb60 |
permissions | -rw-r--r-- |
10460
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
9661
diff
changeset
|
1 |
{- |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
9661
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:
9661
diff
changeset
|
4 |
* |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
9661
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:
9661
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:
9661
diff
changeset
|
7 |
* the Free Software Foundation; version 2 of the License |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
9661
diff
changeset
|
8 |
* |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
9661
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:
9661
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:
9661
diff
changeset
|
11 |
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
9661
diff
changeset
|
12 |
* GNU General Public License for more details. |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
9661
diff
changeset
|
13 |
* |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
9661
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:
9661
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:
9661
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:
9661
diff
changeset
|
17 |
\-} |
8dcea9087d75
Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents:
9661
diff
changeset
|
18 |
|
4906 | 19 |
{-# LANGUAGE CPP, ScopedTypeVariables, OverloadedStrings #-} |
1804 | 20 |
module OfficialServer.DBInteraction |
21 |
( |
|
2869 | 22 |
startDBConnection |
1804 | 23 |
) where |
24 |
||
1979 | 25 |
import Prelude hiding (catch); |
4932 | 26 |
import Control.Concurrent |
27 |
import Control.Monad |
|
28 |
import Data.List as L |
|
29 |
import Data.ByteString.Char8 as B |
|
30 |
#if defined(OFFICIAL_SERVER) |
|
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
1979
diff
changeset
|
31 |
import System.Process |
4921 | 32 |
import System.IO as SIO |
2296
19f2f76dc346
Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents:
2245
diff
changeset
|
33 |
import qualified Control.Exception as Exception |
2117
1ac0e10e546f
Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents:
2116
diff
changeset
|
34 |
import qualified Data.Map as Map |
4295
1f5604cd99be
This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents:
4242
diff
changeset
|
35 |
import Data.Maybe |
4932 | 36 |
import Data.Time |
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1834
diff
changeset
|
37 |
import System.Log.Logger |
4932 | 38 |
#endif |
1833 | 39 |
------------------------ |
40 |
import CoreTypes |
|
4932 | 41 |
#if defined(OFFICIAL_SERVER) |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
1979
diff
changeset
|
42 |
import Utils |
4932 | 43 |
#endif |
1804 | 44 |
|
4932 | 45 |
localAddressList :: [B.ByteString] |
1921 | 46 |
localAddressList = ["127.0.0.1", "0:0:0:0:0:0:0:1", "0:0:0:0:0:ffff:7f00:1"] |
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1834
diff
changeset
|
47 |
|
4989 | 48 |
fakeDbConnection :: forall b. ServerInfo -> IO b |
4943
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
49 |
fakeDbConnection si = forever $ do |
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
50 |
q <- readChan $ dbQueries si |
2869 | 51 |
case q of |
4932 | 52 |
CheckAccount clId clUid _ clHost -> |
4943
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
53 |
writeChan (coreChan si) $ ClientAccountInfo clId clUid (if clHost `L.elem` localAddressList then Admin else Guest) |
2869 | 54 |
ClearCache -> return () |
55 |
SendStats {} -> return () |
|
1857
b835395659e2
Fake database connection with routine which marks all users as guests, when no database host was specified
unc0rr
parents:
1847
diff
changeset
|
56 |
|
4996
76ef3d8bd78e
Fix crash (accessing already deleted client record) by reverting to old client removing handling + throwTo
unc0rr
parents:
4992
diff
changeset
|
57 |
dbConnectionLoop :: ServerInfo -> IO () |
76ef3d8bd78e
Fix crash (accessing already deleted client record) by reverting to old client removing handling + throwTo
unc0rr
parents:
4992
diff
changeset
|
58 |
|
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
1979
diff
changeset
|
59 |
#if defined(OFFICIAL_SERVER) |
4989 | 60 |
flushRequests :: ServerInfo -> IO () |
4943
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
61 |
flushRequests si = do |
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
62 |
e <- isEmptyChan $ dbQueries si |
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
63 |
unless e $ do |
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
64 |
q <- readChan $ dbQueries si |
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
65 |
case q of |
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
66 |
CheckAccount clId clUid _ clHost -> |
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
67 |
writeChan (coreChan si) $ ClientAccountInfo clId clUid (if clHost `L.elem` localAddressList then Admin else Guest) |
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
68 |
ClearCache -> return () |
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
69 |
SendStats {} -> return () |
9661 | 70 |
GetReplayName {} -> return () |
71 |
StoreAchievements {} -> return () |
|
4943
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
72 |
flushRequests si |
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
73 |
|
4944 | 74 |
pipeDbConnectionLoop :: Chan DBQuery -> Chan CoreMessage -> Handle -> Handle -> Map.Map ByteString (UTCTime, AccountInfo) -> Int -> IO (Map.Map ByteString (UTCTime, AccountInfo), Int) |
75 |
pipeDbConnectionLoop queries cChan hIn hOut accountsCache req = |
|
76 |
Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return (accountsCache, req)) $ |
|
2869 | 77 |
do |
78 |
q <- readChan queries |
|
4944 | 79 |
(updatedCache, newReq) <- case q of |
4921 | 80 |
CheckAccount clId clUid clNick _ -> do |
2869 | 81 |
let cacheEntry = clNick `Map.lookup` accountsCache |
82 |
currentTime <- getCurrentTime |
|
7331
0e50456d652c
Well, since we have database on the same computer as game server, could remove caching, but I just set expiration time to 10 minutes
unc0rr
parents:
4996
diff
changeset
|
83 |
if (isNothing cacheEntry) || (currentTime `diffUTCTime` (fst . fromJust) cacheEntry > 10 * 60) then |
2869 | 84 |
do |
4921 | 85 |
SIO.hPutStrLn hIn $ show q |
2869 | 86 |
hFlush hIn |
2117
1ac0e10e546f
Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents:
2116
diff
changeset
|
87 |
|
4921 | 88 |
(clId', clUid', accountInfo) <- SIO.hGetLine hOut >>= (maybeException . maybeRead) |
2117
1ac0e10e546f
Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents:
2116
diff
changeset
|
89 |
|
4943
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
90 |
writeChan cChan $ ClientAccountInfo clId' clUid' accountInfo |
2117
1ac0e10e546f
Add caching for accounts information (entries are stored in memory forever)
unc0rr
parents:
2116
diff
changeset
|
91 |
|
4944 | 92 |
return $ (Map.insert clNick (currentTime, accountInfo) accountsCache, req + 1) |
2869 | 93 |
`Exception.onException` |
4944 | 94 |
(unGetChan queries q) |
2869 | 95 |
else |
96 |
do |
|
4943
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
97 |
writeChan cChan $ ClientAccountInfo clId clUid (snd $ fromJust cacheEntry) |
4944 | 98 |
return (accountsCache, req) |
2155
d897222d3339
Implement ability for server admin to clear accounts cache
unc0rr
parents:
2129
diff
changeset
|
99 |
|
9446 | 100 |
GetReplayName {} -> do |
101 |
SIO.hPutStrLn hIn $ show q |
|
102 |
hFlush hIn |
|
103 |
||
104 |
(clId', clUid', accountInfo) <- SIO.hGetLine hOut >>= (maybeException . maybeRead) |
|
105 |
||
106 |
writeChan cChan $ ClientAccountInfo clId' clUid' accountInfo |
|
9450 | 107 |
return (accountsCache, req) |
9446 | 108 |
|
4944 | 109 |
ClearCache -> return (Map.empty, req) |
9399 | 110 |
StoreAchievements {} -> ( |
111 |
(SIO.hPutStrLn hIn $ show q) >> |
|
112 |
hFlush hIn >> |
|
113 |
return (accountsCache, req)) |
|
114 |
`Exception.onException` |
|
115 |
(unGetChan queries q) |
|
2869 | 116 |
SendStats {} -> ( |
4921 | 117 |
(SIO.hPutStrLn hIn $ show q) >> |
2869 | 118 |
hFlush hIn >> |
4944 | 119 |
return (accountsCache, req)) |
2869 | 120 |
`Exception.onException` |
121 |
(unGetChan queries q) |
|
2184 | 122 |
|
4944 | 123 |
pipeDbConnectionLoop queries cChan hIn hOut updatedCache newReq |
2869 | 124 |
where |
125 |
maybeException (Just a) = return a |
|
126 |
maybeException Nothing = ioError (userError "Can't read") |
|
1804 | 127 |
|
4992 | 128 |
pipeDbConnection :: |
4982
3572eaf14340
Add dbName parameter to .ini file, fix some warnings
unc0rr
parents:
4975
diff
changeset
|
129 |
Map.Map ByteString (UTCTime, AccountInfo) |
4989 | 130 |
-> ServerInfo |
4992 | 131 |
-> Int |
132 |
-> IO () |
|
4982
3572eaf14340
Add dbName parameter to .ini file, fix some warnings
unc0rr
parents:
4975
diff
changeset
|
133 |
|
4943
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
134 |
pipeDbConnection accountsCache si errNum = do |
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
135 |
(updatedCache, newErrNum) <- |
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
136 |
Exception.handle (\(e :: Exception.IOException) -> warningM "Database" (show e) >> return (accountsCache, errNum + 1)) $ do |
2869 | 137 |
(Just hIn, Just hOut, _, _) <- createProcess (proc "./OfficialServer/extdbinterface" []) |
138 |
{std_in = CreatePipe, |
|
139 |
std_out = CreatePipe} |
|
140 |
hSetBuffering hIn LineBuffering |
|
141 |
hSetBuffering hOut LineBuffering |
|
1804 | 142 |
|
4921 | 143 |
B.hPutStrLn hIn $ dbHost si |
4982
3572eaf14340
Add dbName parameter to .ini file, fix some warnings
unc0rr
parents:
4975
diff
changeset
|
144 |
B.hPutStrLn hIn $ dbName si |
4921 | 145 |
B.hPutStrLn hIn $ dbLogin si |
146 |
B.hPutStrLn hIn $ dbPassword si |
|
4944 | 147 |
(c, r) <- pipeDbConnectionLoop (dbQueries si) (coreChan si) hIn hOut accountsCache 0 |
148 |
return (c, if r > 0 then 0 else errNum + 1) |
|
2184 | 149 |
|
4943
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
150 |
when (newErrNum > 1) $ flushRequests si |
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
151 |
threadDelay (3000000) |
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
152 |
pipeDbConnection updatedCache si newErrNum |
2116
dec7ead2d178
Bring back authentication to official server, now using separate process to perform database interaction
unc0rr
parents:
1979
diff
changeset
|
153 |
|
4921 | 154 |
dbConnectionLoop si = |
155 |
if (not . B.null $ dbHost si) then |
|
4943
21d6b2b79cfe
Allow users to join official server even when there's no db connection
unc0rr
parents:
4932
diff
changeset
|
156 |
pipeDbConnection Map.empty si 0 |
2869 | 157 |
else |
4921 | 158 |
fakeDbConnection si |
1979 | 159 |
#else |
160 |
dbConnectionLoop = fakeDbConnection |
|
161 |
#endif |
|
1804 | 162 |
|
4989 | 163 |
startDBConnection :: ServerInfo -> IO () |
1833 | 164 |
startDBConnection serverInfo = |
4932 | 165 |
forkIO (dbConnectionLoop serverInfo) >> return () |