author | koda |
Thu, 24 Mar 2011 16:06:03 +0100 | |
changeset 5045 | f215eb5d4b75 |
parent 4998 | cdcdf37e5532 |
child 5093 | 7eb35faa7f7a |
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 |
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 |
3566 | 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 |
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
|
48 |
as <- get |
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 |
put $! as{clientIndex = Just 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
|
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 |
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
|
59 |
as <- get |
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
|
60 |
put $! as{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
|
61 |
uid' <- client's clUID |
4932 | 62 |
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
|
63 |
return () |
3741
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
64 |
|
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
|
65 |
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
|
66 |
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
|
67 |
PingAll : [StatsAction | even tick] |
4568 | 68 |
|
3741
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
69 |
|
4989 | 70 |
startServer :: ServerInfo -> Socket -> IO () |
4612 | 71 |
startServer si serverSocket = do |
72 |
putStrLn $ "Listening on port " ++ show (listenPort si) |
|
1804 | 73 |
|
4932 | 74 |
_ <- forkIO $ |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
75 |
acceptLoop |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
76 |
serverSocket |
4612 | 77 |
(coreChan si) |
1804 | 78 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
79 |
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
|
80 |
|
4932 | 81 |
_ <- forkIO $ timerLoop 0 $ coreChan si |
1804 | 82 |
|
4612 | 83 |
startDBConnection si |
1804 | 84 |
|
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
|
85 |
rnc <- newRoomsAndClients newRoom |
1804 | 86 |
|
4955 | 87 |
evalStateT mainLoop (ServerState Nothing si Set.empty rnc) |