gameServer/ServerCore.hs
author smxx
Fri, 04 Jun 2010 20:50:24 +0000
changeset 3494 208c5671b202
parent 3458 11cd56019f00
child 3500 af8390d807d6
permissions -rw-r--r--
Frontend: * Avoid overwriting/replacing premade game/weapon schemes
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
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import NetRoutines
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
import HWProtoCore
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
import Actions
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    16
import OfficialServer.DBInteraction
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    17
import ServerState
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    19
2173
98cde8645e21 Send stats every minute
unc0rr
parents: 2172
diff changeset
    20
timerLoop :: Int -> Chan CoreMessage -> IO()
2349
ba7a0813c532 Some fixes suggested by hlint
unc0rr
parents: 2184
diff changeset
    21
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
    22
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    23
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    24
reactCmd :: [String] -> StateT ServerState IO ()
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    25
reactCmd cmd = do
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    26
    (Just ci) <- gets clientIndex
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    27
    rnc <- gets roomsClients
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    28
    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
    29
    forM_ actions processAction
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    31
mainLoop :: StateT ServerState IO ()
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    32
mainLoop = forever $ do
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    33
    si <- gets serverInfo
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    34
    r <- liftIO $ readChan $ coreChan si
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents: 2948
diff changeset
    35
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    36
    case r of
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    37
        Accept ci -> do
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    38
            processAction (AddClient ci)
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    39
            return ()
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    40
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    41
        ClientMessage (ci, cmd) -> do
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    42
            liftIO $ debugM "Clients" $ (show ci) ++ ": " ++ (show cmd)
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    43
            modify (\as -> as{clientIndex = Just ci})
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    44
            --if clID `IntMap.member` clients then
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    45
            reactCmd cmd
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    46
            return ()
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    47
                --else
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    48
                --do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    49
                --debugM "Clients" "Message from dead client"
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    50
                --return (serverInfo, rnc)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    51
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    52
        ClientAccountInfo (clID, info) -> do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    53
            --if clID `IntMap.member` clients then
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    54
            processAction (ProcessAccountInfo info)
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    55
            return ()
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    56
                --else
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    57
                --do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    58
                --debugM "Clients" "Got info for dead client"
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    59
                --return (serverInfo, rnc)
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    60
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    61
        TimerAction tick ->
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    62
            return ()
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    63
            --liftM snd $
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    64
            --    foldM processAction (0, serverInfo, rnc) $
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    65
            --        PingAll : [StatsAction | even tick]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    66
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    67
        FreeClient ci -> do
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    68
            rnc <- gets roomsClients
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    69
            liftIO $ removeClient rnc ci
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    70
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
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
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
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    89
    forkIO $ evalStateT mainLoop (ServerState Nothing serverInfo rnc)
2184
f59f80e034b1 Oops, fix database process interaction
unc0rr
parents: 2173
diff changeset
    90
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents: 2948
diff changeset
    91
    forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***"