gameServer/ServerCore.hs
author szczur
Sat, 07 Aug 2010 23:04:43 -0400
changeset 3719 9b38c2c99c48
parent 3673 45778b16b224
child 3741 73246d25dfe1
permissions -rw-r--r--
Polish translation update
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     1
module ServerCore where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
import Network
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     4
import Control.Concurrent
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
import Control.Concurrent.Chan
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
import Control.Monad
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
import qualified Data.IntMap as IntMap
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import System.Log.Logger
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
     9
import Control.Monad.Reader
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    10
import Control.Monad.State
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    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
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
import NetRoutines
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
import HWProtoCore
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
import Actions
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    18
import OfficialServer.DBInteraction
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    19
import ServerState
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    21
2173
98cde8645e21 Send stats every minute
unc0rr
parents: 2172
diff changeset
    22
timerLoop :: Int -> Chan CoreMessage -> IO()
2349
ba7a0813c532 Some fixes suggested by hlint
unc0rr
parents: 2184
diff changeset
    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
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    32
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    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
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    35
    si <- gets serverInfo
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    36
    r <- liftIO $ readChan $ coreChan si
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents: 2948
diff changeset
    37
3673
45778b16b224 Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents: 3671
diff changeset
    38
    liftIO $ putStrLn $ "Core msg: " ++ show r
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    39
    case r of
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    40
        Accept ci -> processAction (AddClient ci)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    41
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    42
        ClientMessage (ci, cmd) -> do
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    43
            liftIO $ debugM "Clients" $ (show ci) ++ ": " ++ (show cmd)
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    44
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    45
            removed <- gets removedClients
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    46
            when (not $ ci `Set.member` removed) $ do
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    47
                modify (\as -> as{clientIndex = Just ci})
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    48
                reactCmd cmd
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    49
3673
45778b16b224 Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents: 3671
diff changeset
    50
        Remove ci -> do
45778b16b224 Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents: 3671
diff changeset
    51
            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
    52
            processAction (DeleteClient ci)
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    53
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    54
                --else
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    55
                --do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    56
                --debugM "Clients" "Message from dead client"
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    57
                --return (serverInfo, rnc)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    58
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    59
        ClientAccountInfo (ci, info) -> do
3673
45778b16b224 Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents: 3671
diff changeset
    60
            --should instead check ci exists and has same nick/hostname
45778b16b224 Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents: 3671
diff changeset
    61
            --removed <- gets removedClients
45778b16b224 Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents: 3671
diff changeset
    62
            --when (not $ ci `Set.member` removed) $ do
45778b16b224 Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents: 3671
diff changeset
    63
            --    modify (\as -> as{clientIndex = Just ci})
45778b16b224 Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents: 3671
diff changeset
    64
            --    processAction (ProcessAccountInfo info)
45778b16b224 Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents: 3671
diff changeset
    65
            return ()
45778b16b224 Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents: 3671
diff changeset
    66
            
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    67
        TimerAction tick ->
3657
fa3bf50d0338 Run core timer
unc0rr
parents: 3566
diff changeset
    68
                mapM_ processAction $
fa3bf50d0338 Run core timer
unc0rr
parents: 3566
diff changeset
    69
                    PingAll : [StatsAction | even tick]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    70
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    71
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    72
startServer :: ServerInfo -> Socket -> IO ()
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    73
startServer serverInfo serverSocket = do
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    74
    putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    75
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    76
    forkIO $
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    77
        acceptLoop
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    78
            serverSocket
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    79
            (coreChan serverInfo)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    80
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    81
    return ()
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    82
3671
a94d1dc4a8d9 - burp's patch cleaning up module dependancies + cabal file
unc0rr
parents: 3657
diff changeset
    83
    --forkIO $ timerLoop 0 $ coreChan serverInfo
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    84
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    85
    startDBConnection serverInfo
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    86
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    87
    rnc <- newRoomsAndClients newRoom
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    88
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    89
    forkIO $ evalStateT mainLoop (ServerState Nothing serverInfo Set.empty rnc)
2184
f59f80e034b1 Oops, fix database process interaction
unc0rr
parents: 2173
diff changeset
    90
3671
a94d1dc4a8d9 - burp's patch cleaning up module dependancies + cabal file
unc0rr
parents: 3657
diff changeset
    91
    forever $ threadDelay (60 * 60 * 10^6)