author | koda |
Mon, 24 Jun 2013 10:51:43 +0200 | |
changeset 9255 | fd16cfa267aa |
parent 7766 | 98edc0724a28 |
child 9973 | 7589978c9912 |
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 |
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
|
9 |
import qualified Data.ByteString.Char8 as B |
4597
31e042ab870c
Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents:
4295
diff
changeset
|
10 |
import Control.DeepSeq |
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
|
11 |
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
|
12 |
import Data.Maybe |
1804 | 13 |
-------------------------------------- |
14 |
import CoreTypes |
|
15 |
import NetRoutines |
|
16 |
import HWProtoCore |
|
17 |
import Actions |
|
1833 | 18 |
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
|
19 |
import ServerState |
1927
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
20 |
|
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
21 |
|
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
|
22 |
timerLoop :: Int -> Chan CoreMessage -> IO () |
4612 | 23 |
timerLoop tick messagesChan = threadDelay 30000000 >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan |
4242 | 24 |
|
25 |
||
4989 | 26 |
reactCmd :: [B.ByteString] -> 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
|
27 |
reactCmd cmd = do |
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 |
(Just ci) <- gets clientIndex |
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 |
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
|
30 |
actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc)) |
4597
31e042ab870c
Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents:
4295
diff
changeset
|
31 |
forM_ (actions `deepseq` actions) processAction |
1804 | 32 |
|
4989 | 33 |
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
|
34 |
mainLoop = forever $ do |
4955 | 35 |
-- 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
|
36 |
|
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
|
37 |
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
|
38 |
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
|
39 |
|
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 |
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
|
41 |
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
|
42 |
|
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
|
43 |
ClientMessage (ci, cmd) -> do |
4932 | 44 |
liftIO $ debugM "Clients" $ show ci ++ ": " ++ show cmd |
7529
058fcb451b37
Check if 'for' cycle body is executed at least once
unc0rr
parents:
5209
diff
changeset
|
45 |
|
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
|
46 |
removed <- gets removedClients |
4932 | 47 |
unless (ci `Set.member` removed) $ do |
5093 | 48 |
modify (\s -> s{clientIndex = Just 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
|
49 |
reactCmd cmd |
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
|
50 |
|
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
|
51 |
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
|
52 |
processAction (DeleteClient ci) |
3566 | 53 |
|
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
|
54 |
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
|
55 |
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
|
56 |
exists <- liftIO $ clientExists rnc ci |
4932 | 57 |
when exists $ do |
5093 | 58 |
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
|
59 |
uid' <- client's clUID |
4932 | 60 |
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
|
61 |
return () |
3741
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
62 |
|
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
|
63 |
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
|
64 |
mapM_ processAction $ |
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
|
65 |
PingAll : [StatsAction | even tick] |
4568 | 66 |
|
3741
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
67 |
|
5209
f7a610e2ef5f
On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents:
5093
diff
changeset
|
68 |
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
|
69 |
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
|
70 |
noticeM "Core" $ "Listening on port " ++ show (listenPort si) |
1804 | 71 |
|
4932 | 72 |
_ <- forkIO $ |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
73 |
acceptLoop |
5209
f7a610e2ef5f
On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents:
5093
diff
changeset
|
74 |
(fromJust $ serverSocket si) |
4612 | 75 |
(coreChan si) |
1804 | 76 |
|
4932 | 77 |
_ <- forkIO $ timerLoop 0 $ coreChan si |
1804 | 78 |
|
4612 | 79 |
startDBConnection si |
1804 | 80 |
|
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
|
81 |
rnc <- newRoomsAndClients newRoom |
1804 | 82 |
|
4955 | 83 |
evalStateT mainLoop (ServerState Nothing si Set.empty rnc) |