gameServer/ServerCore.hs
author nemo
Fri, 09 Jul 2010 20:09:46 -0400
changeset 3633 130c24d74043
parent 3566 772a46ef8288
child 3657 fa3bf50d0338
permissions -rw-r--r--
Updated Island theme.
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
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    38
    case r of
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    39
        Accept ci -> processAction (AddClient ci)
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)
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    43
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    44
            removed <- gets removedClients
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    45
            when (not $ ci `Set.member` removed) $ do
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    46
                modify (\as -> as{clientIndex = Just ci})
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    47
                reactCmd cmd
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    48
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    49
        Remove ci -> processAction (DeleteClient ci)
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    50
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    51
                --else
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    52
                --do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    53
                --debugM "Clients" "Message from dead client"
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    54
                --return (serverInfo, rnc)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    55
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    56
        ClientAccountInfo (ci, info) -> do
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    57
            removed <- gets removedClients
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    58
            when (not $ ci `Set.member` removed) $
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    59
                processAction (ProcessAccountInfo info)
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
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    68
startServer :: ServerInfo -> Socket -> IO ()
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    69
startServer serverInfo serverSocket = do
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    70
    putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    71
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    72
    forkIO $
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    73
        acceptLoop
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    74
            serverSocket
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    75
            (coreChan 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
    return ()
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    78
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    79
    forkIO $ timerLoop 0 $ 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
    startDBConnection serverInfo
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    82
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    83
    rnc <- newRoomsAndClients newRoom
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    84
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    85
    forkIO $ evalStateT mainLoop (ServerState Nothing serverInfo Set.empty rnc)
2184
f59f80e034b1 Oops, fix database process interaction
unc0rr
parents: 2173
diff changeset
    86
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents: 2948
diff changeset
    87
    forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***"