author | nemo |
Mon, 11 Oct 2010 14:55:13 -0400 | |
changeset 3965 | 09eea558ba83 |
parent 3947 | 709fdb89f76c |
child 4242 | 5e3c5fe2cb14 |
permissions | -rw-r--r-- |
1804 | 1 |
module ServerCore where |
2 |
||
3 |
import Network |
|
4 |
import Control.Concurrent |
|
5 |
import Control.Concurrent.Chan |
|
6 |
import Control.Monad |
|
7 |
import qualified Data.IntMap as IntMap |
|
8 |
import System.Log.Logger |
|
3435 | 9 |
import Control.Monad.Reader |
3741
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
10 |
import Control.Monad.State.Strict |
3566 | 11 |
import Data.Set as Set |
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
12 |
import qualified Data.ByteString.Char8 as B |
1804 | 13 |
-------------------------------------- |
14 |
import CoreTypes |
|
15 |
import NetRoutines |
|
16 |
import HWProtoCore |
|
17 |
import Actions |
|
1833 | 18 |
import OfficialServer.DBInteraction |
3458 | 19 |
import ServerState |
1804 | 20 |
|
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
21 |
|
3741
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
22 |
timerLoop :: Int -> Chan CoreMessage -> IO () |
2349 | 23 |
timerLoop tick messagesChan = threadDelay (30 * 10^6) >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan |
1927
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
24 |
|
1839
5dd4cb7fd7e5
Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents:
1833
diff
changeset
|
25 |
|
3500
af8390d807d6
Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents:
3458
diff
changeset
|
26 |
reactCmd :: [B.ByteString] -> StateT ServerState IO () |
3451
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3435
diff
changeset
|
27 |
reactCmd cmd = do |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3435
diff
changeset
|
28 |
(Just ci) <- gets clientIndex |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3435
diff
changeset
|
29 |
rnc <- gets roomsClients |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3435
diff
changeset
|
30 |
actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc)) |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3435
diff
changeset
|
31 |
forM_ actions processAction |
1804 | 32 |
|
3458 | 33 |
mainLoop :: StateT ServerState IO () |
3451
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3435
diff
changeset
|
34 |
mainLoop = forever $ do |
3947
709fdb89f76c
Some screwing around in try to fix space leak. No luck yet.
unc0rr
parents:
3741
diff
changeset
|
35 |
get >>= \s -> put $! s |
709fdb89f76c
Some screwing around in try to fix space leak. No luck yet.
unc0rr
parents:
3741
diff
changeset
|
36 |
|
3451
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3435
diff
changeset
|
37 |
si <- gets serverInfo |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3435
diff
changeset
|
38 |
r <- liftIO $ readChan $ coreChan si |
3425 | 39 |
|
3435 | 40 |
case r of |
3566 | 41 |
Accept ci -> processAction (AddClient ci) |
1804 | 42 |
|
3451
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3435
diff
changeset
|
43 |
ClientMessage (ci, cmd) -> do |
62089ccec75c
Uses StateT monad instead of manually maintaining the state
unc0rr
parents:
3435
diff
changeset
|
44 |
liftIO $ debugM "Clients" $ (show ci) ++ ": " ++ (show cmd) |
3566 | 45 |
|
46 |
removed <- gets removedClients |
|
47 |
when (not $ ci `Set.member` removed) $ do |
|
3947
709fdb89f76c
Some screwing around in try to fix space leak. No luck yet.
unc0rr
parents:
3741
diff
changeset
|
48 |
as <- get |
709fdb89f76c
Some screwing around in try to fix space leak. No luck yet.
unc0rr
parents:
3741
diff
changeset
|
49 |
put $! as{clientIndex = Just ci} |
3566 | 50 |
reactCmd cmd |
51 |
||
3673
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
52 |
Remove ci -> do |
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
53 |
liftIO $ debugM "Clients" $ "DeleteClient: " ++ show ci |
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
54 |
processAction (DeleteClient ci) |
3566 | 55 |
|
3435 | 56 |
--else |
57 |
--do |
|
58 |
--debugM "Clients" "Message from dead client" |
|
59 |
--return (serverInfo, rnc) |
|
1804 | 60 |
|
3566 | 61 |
ClientAccountInfo (ci, info) -> do |
3741
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
62 |
rnc <- gets roomsClients |
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
63 |
exists <- liftIO $ clientExists rnc ci |
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
64 |
when (exists) $ do |
3947
709fdb89f76c
Some screwing around in try to fix space leak. No luck yet.
unc0rr
parents:
3741
diff
changeset
|
65 |
as <- get |
709fdb89f76c
Some screwing around in try to fix space leak. No luck yet.
unc0rr
parents:
3741
diff
changeset
|
66 |
put $! as{clientIndex = Just ci} |
3741
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
67 |
processAction (ProcessAccountInfo info) |
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
68 |
return () |
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
69 |
|
3435 | 70 |
TimerAction tick -> |
3657 | 71 |
mapM_ processAction $ |
72 |
PingAll : [StatsAction | even tick] |
|
1804 | 73 |
|
3458 | 74 |
|
1927
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
75 |
startServer :: ServerInfo -> Socket -> IO () |
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset
|
76 |
startServer serverInfo serverSocket = do |
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
77 |
putStrLn $ "Listening on port " ++ show (listenPort serverInfo) |
1804 | 78 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
79 |
forkIO $ |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
80 |
acceptLoop |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
81 |
serverSocket |
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
82 |
(coreChan serverInfo) |
1804 | 83 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
84 |
return () |
3435 | 85 |
|
3671
a94d1dc4a8d9
- burp's patch cleaning up module dependancies + cabal file
unc0rr
parents:
3657
diff
changeset
|
86 |
--forkIO $ timerLoop 0 $ coreChan serverInfo |
1804 | 87 |
|
2867
9be6693c78cb
- Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents:
2349
diff
changeset
|
88 |
startDBConnection serverInfo |
1804 | 89 |
|
3435 | 90 |
rnc <- newRoomsAndClients newRoom |
91 |
||
3566 | 92 |
forkIO $ evalStateT mainLoop (ServerState Nothing serverInfo Set.empty rnc) |
2184 | 93 |
|
3671
a94d1dc4a8d9
- burp's patch cleaning up module dependancies + cabal file
unc0rr
parents:
3657
diff
changeset
|
94 |
forever $ threadDelay (60 * 60 * 10^6) |