gameServer/hedgewars-server.hs
author nemo
Sat, 13 Nov 2010 15:25:38 -0500
branch0.9.14
changeset 4304 a2041fbe5333
parent 4247 b9fe93f187c4
child 4295 1f5604cd99be
permissions -rw-r--r--
lighten tex to look more sandy
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
2348
b39d826e1ccd Drop support for ghc 6.8, use 6.10 instead
unc0rr
parents: 2296
diff changeset
     1
{-# LANGUAGE CPP, ScopedTypeVariables #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
module Main where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     4
4242
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
     5
import Network.Socket
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
     6
import qualified Network
4247
b9fe93f187c4 Make server listen on ipv4 interface only
unc0rr
parents: 4242
diff changeset
     7
import Network.BSD
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import Control.Concurrent.STM
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     9
import Control.Concurrent.Chan
4242
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
    10
#if defined(NEW_EXCEPTIONS)
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
    11
import qualified Control.OldException as Exception
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
    12
#else
2296
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2129
diff changeset
    13
import qualified Control.Exception as Exception
4242
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
    14
#endif
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
import System.Log.Logger
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
-----------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
import Opts
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
import CoreTypes
4242
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
    19
import OfficialServer.DBInteraction
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
import ServerCore
4242
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
    21
import Utils
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    23
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    24
#if !defined(mingw32_HOST_OS)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    25
import System.Posix
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    26
#endif
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    28
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    29
setupLoggers =
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    30
    updateGlobalLogger "Clients"
3947
709fdb89f76c Some screwing around in try to fix space leak. No luck yet.
unc0rr
parents: 3500
diff changeset
    31
        (setLevel INFO)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    32
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    33
main = withSocketsDo $ do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    34
#if !defined(mingw32_HOST_OS)
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    35
    installHandler sigPIPE Ignore Nothing;
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    36
    installHandler sigCHLD Ignore Nothing;
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    37
#endif
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    38
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    39
    setupLoggers
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    40
4242
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
    41
    stats <- atomically $ newTMVar (StatisticsInfo 0 0)
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    42
    dbQueriesChan <- newChan
4242
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
    43
    coreChan <- newChan
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
    44
    serverInfo' <- getOpts $ newServerInfo stats coreChan dbQueriesChan
5e3c5fe2cb14 Revert to old server in branch 0.9.14
unc0rr
parents: 3947
diff changeset
    45
    
1964
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1927
diff changeset
    46
#if defined(OFFICIAL_SERVER)
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    47
    dbHost' <- askFromConsole "DB host: "
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    48
    dbLogin' <- askFromConsole "login: "
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    49
    dbPassword' <- askFromConsole "password: "
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    50
    let serverInfo = serverInfo'{dbHost = dbHost', dbLogin = dbLogin', dbPassword = dbPassword'}
1964
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1927
diff changeset
    51
#else
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    52
    let serverInfo = serverInfo'
1964
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1927
diff changeset
    53
#endif
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1927
diff changeset
    54
4247
b9fe93f187c4 Make server listen on ipv4 interface only
unc0rr
parents: 4242
diff changeset
    55
b9fe93f187c4 Make server listen on ipv4 interface only
unc0rr
parents: 4242
diff changeset
    56
    proto <- getProtocolNumber "tcp"
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    57
    Exception.bracket
4247
b9fe93f187c4 Make server listen on ipv4 interface only
unc0rr
parents: 4242
diff changeset
    58
        (socket AF_INET Stream proto)
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    59
        sClose
4247
b9fe93f187c4 Make server listen on ipv4 interface only
unc0rr
parents: 4242
diff changeset
    60
        (\sock -> do
b9fe93f187c4 Make server listen on ipv4 interface only
unc0rr
parents: 4242
diff changeset
    61
            setSocketOption sock ReuseAddr 1
b9fe93f187c4 Make server listen on ipv4 interface only
unc0rr
parents: 4242
diff changeset
    62
            bindSocket sock (SockAddrInet (listenPort serverInfo) iNADDR_ANY)
b9fe93f187c4 Make server listen on ipv4 interface only
unc0rr
parents: 4242
diff changeset
    63
            listen sock maxListenQueue
b9fe93f187c4 Make server listen on ipv4 interface only
unc0rr
parents: 4242
diff changeset
    64
            startServer serverInfo sock
b9fe93f187c4 Make server listen on ipv4 interface only
unc0rr
parents: 4242
diff changeset
    65
        )