gameServer/ServerCore.hs
author koda
Sat, 19 Feb 2011 04:04:34 +0100
changeset 4952 df752b69a142
parent 4932 f11d80bac7ed
child 4955 84543ecae8c3
permissions -rw-r--r--
Added tag Hedgewars-iOS-1.2.3 for changeset ae0c6c35414d
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
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
    26
reactCmd :: [B.ByteString] -> StateT ServerState IO ()
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
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
    33
mainLoop :: StateT ServerState IO ()
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
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
    35
    get >>= \s -> put $! s
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
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
    52
        Remove ci -> 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
    53
            liftIO $ debugM "Clients"  $ "DeleteClient: " ++ show 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
    54
            processAction (DeleteClient ci)
3566
772a46ef8288 Properly handle client exit
unc0rr
parents: 3500
diff changeset
    55
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
                --else
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
                --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
    58
                --debugM "Clients" "Message from dead client"
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
                --return (serverInfo, rnc)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    60
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
        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
    62
            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
    63
            exists <- liftIO $ clientExists rnc ci
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    64
            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
    65
                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
    66
                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
    67
                uid' <- client's clUID
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    68
                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
    69
                return ()
3741
73246d25dfe1 Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents: 3673
diff changeset
    70
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
    71
        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
    72
                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
    73
                    PingAll : [StatsAction | even tick]
4568
f85243bf890e Ok. This should pull 0.9.14.1 server into default
nemo
parents: 4295
diff changeset
    74
3741
73246d25dfe1 Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents: 3673
diff changeset
    75
1927
e2031906a347 Ping clients every 30 seconds. Disconnection due to ping timeout to be implemented.
unc0rr
parents: 1926
diff changeset
    76
startServer :: ServerInfo -> Socket -> IO ()
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4597
diff changeset
    77
startServer si serverSocket = do
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4597
diff changeset
    78
    putStrLn $ "Listening on port " ++ show (listenPort si)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    79
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    80
    _ <- forkIO $
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    81
        acceptLoop
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    82
            serverSocket
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4597
diff changeset
    83
            (coreChan si)
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
    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
    86
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    87
    _ <- forkIO $ timerLoop 0 $ coreChan si
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    88
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4597
diff changeset
    89
    startDBConnection si
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    90
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
    91
    rnc <- newRoomsAndClients newRoom
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    92
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4918
diff changeset
    93
    _ <- forkIO $ evalStateT mainLoop (ServerState Nothing si Set.empty rnc)
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    94
4612
e82758d6f924 - Reactivate pings timer, reimplement PING handler
unc0rr
parents: 4597
diff changeset
    95
    forever $ threadDelay 3600000000 -- one hour