gameServer/ServerCore.hs
author koda
Thu, 24 Mar 2011 17:28:36 +0100
changeset 5046 fc6639d56799
parent 4998 cdcdf37e5532
child 5093 7eb35faa7f7a
permissions -rw-r--r--
this brings compatibility up with SDL HEAD (5504), but maybe breaks compatibility with sdl 1.2 so please test! still has problems with keyboard input and rendered ttf textures
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.Monad
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
import System.Log.Logger
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
     7
import Control.Monad.Reader
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
     8
import Control.Monad.State.Strict
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
     9
import Data.Set as Set
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    10
import qualified Data.ByteString.Char8 as B
4597
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4295
diff changeset
    11
import Control.DeepSeq
4918
c6d3aec73f93 Add Unique field to Client structure, and use it to check for matching recieved account status with client
unc0rr
parents: 4904
diff changeset
    12
import Data.Unique
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
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    19
import ServerState
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    20
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    21
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    22
timerLoop :: Int -> Chan CoreMessage -> IO ()
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4597
diff changeset
    23
timerLoop tick messagesChan = threadDelay 30000000 >> writeChan messagesChan (TimerAction tick) >> timerLoop (tick + 1) messagesChan
4242
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
    24
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
    25
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4975
diff changeset
    26
reactCmd :: [B.ByteString] -> StateT ServerState IO ()
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    27
reactCmd cmd = do
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    28
    (Just ci) <- gets clientIndex
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    29
    rnc <- gets roomsClients
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    30
    actions <- liftIO $ withRoomsAndClients rnc (\irnc -> runReader (handleCmd cmd) (ci, irnc))
4597
31e042ab870c Finally a solution for excess lazyness when working with unsafeThaw'ed arrays
unc0rr
parents: 4295
diff changeset
    31
    forM_ (actions `deepseq` actions) processAction
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    32
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4975
diff changeset
    33
mainLoop :: StateT ServerState IO ()
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    34
mainLoop = forever $ do
4955
84543ecae8c3 Don't forkIO main loop
unc0rr
parents: 4932
diff changeset
    35
    -- get >>= \s -> put $! s
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    36
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    37
    si <- gets serverInfo
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    38
    r <- liftIO $ readChan $ coreChan si
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    39
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    40
    case r of
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    41
        Accept ci -> processAction (AddClient ci)
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    42
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    43
        ClientMessage (ci, cmd) -> do
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    44
            liftIO $ debugM "Clients" $ show ci ++ ": " ++ show cmd
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    45
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    46
            removed <- gets removedClients
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    47
            unless (ci `Set.member` removed) $ do
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    48
                as <- get
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    49
                put $! as{clientIndex = Just ci}
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    50
                reactCmd cmd
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    51
4998
cdcdf37e5532 Send QUIT on exception too. This leads to double QUIT for a usual disconnection, yet is safe. Should fix crashes.
unc0rr
parents: 4989
diff changeset
    52
        Remove ci ->
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    53
            processAction (DeleteClient ci)
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    54
4918
c6d3aec73f93 Add Unique field to Client structure, and use it to check for matching recieved account status with client
unc0rr
parents: 4904
diff changeset
    55
        ClientAccountInfo ci uid info -> do
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    56
            rnc <- gets roomsClients
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    57
            exists <- liftIO $ clientExists rnc ci
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    58
            when exists $ do
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    59
                as <- get
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    60
                put $! as{clientIndex = Just ci}
4918
c6d3aec73f93 Add Unique field to Client structure, and use it to check for matching recieved account status with client
unc0rr
parents: 4904
diff changeset
    61
                uid' <- client's clUID
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    62
                when (uid == hashUnique uid') $ processAction (ProcessAccountInfo info)
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    63
                return ()
3741
73246d25dfe1 Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents: 3673
diff changeset
    64
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    65
        TimerAction tick ->
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    66
                mapM_ processAction $
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    67
                    PingAll : [StatsAction | even tick]
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    68
3741
73246d25dfe1 Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents: 3673
diff changeset
    69
4989
4771fed9272e - Write server config into .ini file on change
unc0rr
parents: 4975
diff changeset
    70
startServer :: ServerInfo -> Socket -> IO ()
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4597
diff changeset
    71
startServer si serverSocket = do
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4597
diff changeset
    72
    putStrLn $ "Listening on port " ++ show (listenPort si)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    73
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    74
    _ <- forkIO $
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    75
        acceptLoop
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    76
            serverSocket
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4597
diff changeset
    77
            (coreChan si)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    78
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    79
    return ()
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    80
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    81
    _ <- forkIO $ timerLoop 0 $ coreChan si
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    82
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4597
diff changeset
    83
    startDBConnection si
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    84
4295
1f5604cd99be This revision should, in theory, correctly merge 0.9.14 and tip, so that future merges of 0.9.14 should work properly
nemo
parents: 4242
diff changeset
    85
    rnc <- newRoomsAndClients newRoom
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    86
4955
84543ecae8c3 Don't forkIO main loop
unc0rr
parents: 4932
diff changeset
    87
    evalStateT mainLoop (ServerState Nothing si Set.empty rnc)