author  unc0rr 
Wed, 23 Feb 2011 18:34:07 +0300  
changeset 4955  84543ecae8c3 
parent 4932  f11d80bac7ed 
child 4975  31da8979e5b1 
permissions  rwrr 
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 

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 
reactCmd :: [B.ByteString] > StateT ServerState IO () 
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 

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

33 
mainLoop :: StateT ServerState IO () 
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 

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 
Remove ci > 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

53 
liftIO $ debugM "Clients" $ "DeleteClient: " ++ show 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

54 
processAction (DeleteClient ci) 
3566  55 

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

56 
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

57 
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

58 
exists < liftIO $ clientExists rnc ci 
4932  59 
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

60 
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

61 
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

62 
uid' < client's clUID 
4932  63 
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

64 
return () 
3741
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset

65 

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

66 
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

67 
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

68 
PingAll : [StatsAction  even tick] 
4568  69 

3741
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset

70 

1927
e2031906a347
Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents:
1926
diff
changeset

71 
startServer :: ServerInfo > Socket > IO () 
4612  72 
startServer si serverSocket = do 
73 
putStrLn $ "Listening on port " ++ show (listenPort si) 

1804  74 

4932  75 
_ < forkIO $ 
2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2349
diff
changeset

76 
acceptLoop 
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2349
diff
changeset

77 
serverSocket 
4612  78 
(coreChan si) 
1804  79 

2867
9be6693c78cb
 Unbreak support for client versions prior to 0.9.13dev
unc0rr
parents:
2349
diff
changeset

80 
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

81 

4932  82 
_ < forkIO $ timerLoop 0 $ coreChan si 
1804  83 

4612  84 
startDBConnection si 
1804  85 

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

86 
rnc < newRoomsAndClients newRoom 
1804  87 

4955  88 
evalStateT mainLoop (ServerState Nothing si Set.empty rnc) 