author | Xeli |
Thu, 14 Jul 2011 16:03:29 +0200 | |
branch | hedgeroid |
changeset 5442 | 7c1e5a5f7f34 |
parent 5209 | f7a610e2ef5f |
child 7529 | 058fcb451b37 |
permissions | -rw-r--r-- |
1804 | 1 |
module ServerCore where |
2 |
||
3 |
import Network |
|
4 |
import Control.Concurrent |
|
5 |
import Control.Monad |
|
6 |
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
|
7 |
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
|
8 |
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
|
9 |
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
|
10 |
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
|
11 |
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
|
12 |
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
|
13 |
import Data.Maybe |
1804 | 14 |
-------------------------------------- |
15 |
import CoreTypes |
|
16 |
import NetRoutines |
|
17 |
import HWProtoCore |
|
18 |
import Actions |
|
1833 | 19 |
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
|
20 |
import ServerState |
1927
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
21 |
|
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
22 |
|
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
|
23 |
timerLoop :: Int -> Chan CoreMessage -> IO () |
4612 | 24 |
timerLoop tick messagesChan = threadDelay 30000000 >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan |
4242 | 25 |
|
26 |
||
4989 | 27 |
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
|
28 |
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
|
29 |
(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
|
30 |
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
|
31 |
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
|
32 |
forM_ (actions `deepseq` actions) processAction |
1804 | 33 |
|
4989 | 34 |
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
|
35 |
mainLoop = forever $ do |
4955 | 36 |
-- 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
|
37 |
|
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 |
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
|
39 |
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
|
40 |
|
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 |
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
|
42 |
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
|
43 |
|
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
|
44 |
ClientMessage (ci, cmd) -> do |
4932 | 45 |
liftIO $ debugM "Clients" $ show ci ++ ": " ++ show cmd |
5093 | 46 |
|
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
|
47 |
removed <- gets removedClients |
4932 | 48 |
unless (ci `Set.member` removed) $ do |
5093 | 49 |
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
|
50 |
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
|
51 |
|
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
|
52 |
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
|
53 |
processAction (DeleteClient ci) |
3566 | 54 |
|
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
|
55 |
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
|
56 |
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
|
57 |
exists <- liftIO $ clientExists rnc ci |
4932 | 58 |
when exists $ do |
5093 | 59 |
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
|
60 |
uid' <- client's clUID |
4932 | 61 |
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
|
62 |
return () |
3741
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
63 |
|
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
|
64 |
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
|
65 |
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
|
66 |
PingAll : [StatsAction | even tick] |
4568 | 67 |
|
3741
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
68 |
|
5209
f7a610e2ef5f
On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents:
5093
diff
changeset
|
69 |
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
|
70 |
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
|
71 |
noticeM "Core" $ "Listening on port " ++ show (listenPort si) |
1804 | 72 |
|
4932 | 73 |
_ <- forkIO $ |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
74 |
acceptLoop |
5209
f7a610e2ef5f
On restart command close server socket and spawn new server, keep running until last client quits
unc0rr
parents:
5093
diff
changeset
|
75 |
(fromJust $ serverSocket si) |
4612 | 76 |
(coreChan si) |
1804 | 77 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
78 |
return () |
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
|
79 |
|
4932 | 80 |
_ <- forkIO $ timerLoop 0 $ coreChan si |
1804 | 81 |
|
4612 | 82 |
startDBConnection si |
1804 | 83 |
|
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
|
84 |
rnc <- newRoomsAndClients newRoom |
1804 | 85 |
|
4955 | 86 |
evalStateT mainLoop (ServerState Nothing si Set.empty rnc) |