author | sheepluva |
Tue, 10 Jun 2014 08:19:59 +0200 | |
changeset 10265 | 7e8d4cd76ce7 |
parent 10215 | 26fc5502ba22 |
child 10460 | 8dcea9087d75 |
permissions | -rw-r--r-- |
1804 | 1 |
module ServerCore where |
2 |
||
3 |
import Control.Concurrent |
|
4 |
import Control.Monad |
|
5 |
import System.Log.Logger |
|
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
|
6 |
import Control.Monad.Reader |
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
|
7 |
import Control.Monad.State.Strict |
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
|
8 |
import Data.Set as Set |
4918
c6d3aec73f93
Add Unique field to Client structure, and use it to check for matching recieved account status with client
unc0rr
parents:
4904
diff
changeset
|
9 |
import Data.Unique |
5209
f7a610e2ef5f
On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents:
5093
diff
changeset
|
10 |
import Data.Maybe |
1804 | 11 |
-------------------------------------- |
12 |
import CoreTypes |
|
13 |
import NetRoutines |
|
14 |
import Actions |
|
1833 | 15 |
import OfficialServer.DBInteraction |
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
|
16 |
import ServerState |
1927
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
17 |
|
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
18 |
|
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
|
19 |
timerLoop :: Int -> Chan CoreMessage -> IO () |
4612 | 20 |
timerLoop tick messagesChan = threadDelay 30000000 >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan |
4242 | 21 |
|
22 |
||
4989 | 23 |
mainLoop :: StateT ServerState IO () |
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
|
24 |
mainLoop = forever $ do |
4955 | 25 |
-- get >>= \s -> put $! s |
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
|
26 |
|
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
|
27 |
si <- gets serverInfo |
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
|
28 |
r <- liftIO $ readChan $ coreChan si |
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
|
29 |
|
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
|
30 |
case r of |
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
|
31 |
Accept ci -> processAction (AddClient ci) |
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
|
32 |
|
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
|
33 |
ClientMessage (ci, cmd) -> do |
4932 | 34 |
liftIO $ debugM "Clients" $ show ci ++ ": " ++ show cmd |
7529
058fcb451b37
Check if 'for' cycle body is executed at least once
unc0rr
parents:
5209
diff
changeset
|
35 |
|
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
|
36 |
removed <- gets removedClients |
4932 | 37 |
unless (ci `Set.member` removed) $ do |
5093 | 38 |
modify (\s -> s{clientIndex = Just ci}) |
10212 | 39 |
processAction $ ReactCmd cmd |
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
|
40 |
|
4998
cdcdf37e5532
Send QUIT on exception too. This leads to double QUIT for a usual disconnection, yet is safe. Should fix crashes.
unc0rr
parents:
4989
diff
changeset
|
41 |
Remove ci -> |
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
|
42 |
processAction (DeleteClient ci) |
3566 | 43 |
|
4918
c6d3aec73f93
Add Unique field to Client structure, and use it to check for matching recieved account status with client
unc0rr
parents:
4904
diff
changeset
|
44 |
ClientAccountInfo ci uid info -> do |
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
|
45 |
rnc <- gets roomsClients |
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
|
46 |
exists <- liftIO $ clientExists rnc ci |
4932 | 47 |
when exists $ do |
5093 | 48 |
modify (\s -> s{clientIndex = Just ci}) |
4918
c6d3aec73f93
Add Unique field to Client structure, and use it to check for matching recieved account status with client
unc0rr
parents:
4904
diff
changeset
|
49 |
uid' <- client's clUID |
4932 | 50 |
when (uid == hashUnique uid') $ processAction (ProcessAccountInfo info) |
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
|
51 |
return () |
3741
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
52 |
|
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
|
53 |
TimerAction tick -> |
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
|
54 |
mapM_ processAction $ |
10017 | 55 |
PingAll |
10215 | 56 |
: CheckVotes |
10017 | 57 |
: [StatsAction | even tick] |
9973
7589978c9912
Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents:
7766
diff
changeset
|
58 |
++ [Cleanup | tick `mod` 100 == 0] |
4568 | 59 |
|
3741
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
60 |
|
5209
f7a610e2ef5f
On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents:
5093
diff
changeset
|
61 |
startServer :: ServerInfo -> IO () |
f7a610e2ef5f
On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents:
5093
diff
changeset
|
62 |
startServer si = do |
f7a610e2ef5f
On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents:
5093
diff
changeset
|
63 |
noticeM "Core" $ "Listening on port " ++ show (listenPort si) |
1804 | 64 |
|
4932 | 65 |
_ <- forkIO $ |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
66 |
acceptLoop |
5209
f7a610e2ef5f
On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents:
5093
diff
changeset
|
67 |
(fromJust $ serverSocket si) |
4612 | 68 |
(coreChan si) |
1804 | 69 |
|
4932 | 70 |
_ <- forkIO $ timerLoop 0 $ coreChan si |
1804 | 71 |
|
4612 | 72 |
startDBConnection si |
1804 | 73 |
|
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
|
74 |
rnc <- newRoomsAndClients newRoom |
9973
7589978c9912
Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents:
7766
diff
changeset
|
75 |
jm <- newJoinMonitor |
1804 | 76 |
|
9973
7589978c9912
Stub for joins monitor which is a replacement to plain ban for 10 seconds system after join
unc0rr
parents:
7766
diff
changeset
|
77 |
evalStateT mainLoop (ServerState Nothing si Set.empty rnc jm) |