gameServer/ServerCore.hs
author nemo
Sun, 20 Jun 2010 19:31:15 -0400
changeset 3524 8d0783d2a0ff
parent 3500 af8390d807d6
child 3566 772a46ef8288
permissions -rw-r--r--
This reduces CheckLand ~5.5% on average over prior making the overall reduction ~77.4% instead of ~81.9%. It does skip centre pixel in odd w/h, but that really shouldn't matter much in this case. Can alter if any objects are noticeably off.
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
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    11
import qualified Data.ByteString.Char8 as B
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
import NetRoutines
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
import HWProtoCore
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
import Actions
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    17
import OfficialServer.DBInteraction
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    18
import ServerState
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    19
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    20
2173
98cde8645e21 Send stats every minute
unc0rr
parents: 2172
diff changeset
    21
timerLoop :: Int -> Chan CoreMessage -> IO()
2349
ba7a0813c532 Some fixes suggested by hlint
unc0rr
parents: 2184
diff changeset
    22
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
    23
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    24
3500
af8390d807d6 Use sockets instead of handles, use bytestrings instead of strings
unc0rr
parents: 3458
diff changeset
    25
reactCmd :: [B.ByteString] -> StateT ServerState IO ()
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    26
reactCmd cmd = do
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    27
    (Just ci) <- gets clientIndex
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    28
    rnc <- gets roomsClients
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    29
    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
    30
    forM_ actions processAction
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    32
mainLoop :: StateT ServerState IO ()
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    33
mainLoop = forever $ do
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    34
    si <- gets serverInfo
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    35
    r <- liftIO $ readChan $ coreChan si
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents: 2948
diff changeset
    36
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    37
    case r of
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    38
        Accept ci -> do
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    39
            processAction (AddClient ci)
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    40
            return ()
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)
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    44
            modify (\as -> as{clientIndex = Just ci})
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    45
            --if clID `IntMap.member` clients then
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    46
            reactCmd cmd
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    47
            return ()
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    48
                --else
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    49
                --do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    50
                --debugM "Clients" "Message from dead client"
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    51
                --return (serverInfo, rnc)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    52
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    53
        ClientAccountInfo (clID, info) -> do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    54
            --if clID `IntMap.member` clients then
3451
62089ccec75c Uses StateT monad instead of manually maintaining the state
unc0rr
parents: 3435
diff changeset
    55
            processAction (ProcessAccountInfo info)
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    56
            return ()
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    57
                --else
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    58
                --do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    59
                --debugM "Clients" "Got info for dead client"
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    60
                --return (serverInfo, rnc)
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    61
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    62
        TimerAction tick ->
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    63
            return ()
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    64
            --liftM snd $
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    65
            --    foldM processAction (0, serverInfo, rnc) $
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    66
            --        PingAll : [StatsAction | even tick]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    67
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    68
        FreeClient ci -> do
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    69
            rnc <- gets roomsClients
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    70
            liftIO $ removeClient rnc ci
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    71
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    72
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    73
startServer :: ServerInfo -> Socket -> IO ()
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    74
startServer serverInfo serverSocket = do
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    75
    putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    76
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    77
    forkIO $
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    78
        acceptLoop
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    79
            serverSocket
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    80
            (coreChan serverInfo)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    81
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    82
    return ()
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    83
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    84
    forkIO $ timerLoop 0 $ coreChan serverInfo
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    85
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    86
    startDBConnection serverInfo
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    87
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    88
    rnc <- newRoomsAndClients newRoom
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    89
3458
11cd56019f00 Make some more protocol commands work
unc0rr
parents: 3451
diff changeset
    90
    forkIO $ evalStateT mainLoop (ServerState Nothing serverInfo rnc)
2184
f59f80e034b1 Oops, fix database process interaction
unc0rr
parents: 2173
diff changeset
    91
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents: 2948
diff changeset
    92
    forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***"