gameServer/ServerCore.hs
author unc0rr
Thu, 06 May 2010 17:39:08 +0000
changeset 3435 4e4f88a7bdf2
parent 3425 ead2ed20dfd4
child 3451 62089ccec75c
permissions -rw-r--r--
Some more steps in refactoring
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
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
--------------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
import NetRoutines
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import HWProtoCore
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
import Actions
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    15
import OfficialServer.DBInteraction
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    16
import RoomsAndClients
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    18
2173
98cde8645e21 Send stats every minute
unc0rr
parents: 2172
diff changeset
    19
timerLoop :: Int -> Chan CoreMessage -> IO()
2349
ba7a0813c532 Some fixes suggested by hlint
unc0rr
parents: 2184
diff changeset
    20
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
    21
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    22
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    23
reactCmd :: ServerInfo -> ClientIndex -> [String] -> MRnC -> IO ()
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    24
reactCmd sInfo ci cmd rnc = do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    25
    actions <- withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc))
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    26
    forM_ actions (processAction (ci, sInfo, rnc))
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    28
mainLoop :: ServerInfo -> MRnC -> IO ()
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    29
mainLoop serverInfo rnc = forever $ do
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    30
    r <- readChan $ coreChan serverInfo
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents: 2948
diff changeset
    31
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    32
    case r of
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    33
        Accept ci -> do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    34
            processAction
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    35
                (undefined, serverInfo, rnc) (AddClient ci)
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    36
            return ()
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    37
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    38
        ClientMessage (clID, cmd) -> do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    39
            debugM "Clients" $ (show clID) ++ ": " ++ (show cmd)
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    40
            --if clID `IntMap.member` clients then
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    41
            reactCmd serverInfo clID cmd rnc
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    42
            return ()
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    43
                --else
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    44
                --do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    45
                --debugM "Clients" "Message from dead client"
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    46
                --return (serverInfo, rnc)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    47
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    48
        ClientAccountInfo (clID, info) -> do
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    49
            --if clID `IntMap.member` clients then
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    50
            processAction
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    51
                (clID, serverInfo, rnc)
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    52
                (ProcessAccountInfo info)
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    53
            return ()
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" "Got info for dead client"
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    57
                --return (serverInfo, rnc)
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    58
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    59
        TimerAction tick ->
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    60
            return ()
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    61
            --liftM snd $
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    62
            --    foldM processAction (0, serverInfo, rnc) $
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    63
            --        PingAll : [StatsAction | even tick]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    64
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    65
startServer :: ServerInfo -> Socket -> IO ()
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    66
startServer serverInfo serverSocket = do
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    67
    putStrLn $ "Listening on port " ++ show (listenPort serverInfo)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    68
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    69
    forkIO $
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    70
        acceptLoop
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    71
            serverSocket
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    72
            (coreChan serverInfo)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    73
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    74
    return ()
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    75
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    76
    forkIO $ timerLoop 0 $ coreChan serverInfo
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    77
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    78
    startDBConnection serverInfo
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    79
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    80
    rnc <- newRoomsAndClients newRoom
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    81
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    82
    forkIO $ mainLoop serverInfo rnc
2184
f59f80e034b1 Oops, fix database process interaction
unc0rr
parents: 2173
diff changeset
    83
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents: 2948
diff changeset
    84
    forever $ threadDelay (60 * 60 * 10^6) >> putStrLn "***"