gameServer/hedgewars-server.hs
author szczur
Sat, 07 Aug 2010 23:04:43 -0400
changeset 3719 9b38c2c99c48
parent 3500 af8390d807d6
child 3947 709fdb89f76c
permissions -rw-r--r--
Polish translation update
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
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents: 2867
diff changeset
     5
import Network
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
import Control.Concurrent.STM
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
import Control.Concurrent.Chan
2296
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2129
diff changeset
     8
import qualified Control.Exception as Exception
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     9
import System.Log.Logger
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
-----------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
import Opts
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import ServerCore
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
#if !defined(mingw32_HOST_OS)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
import System.Posix
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
#endif
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    19
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    21
setupLoggers :: IO ()
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
setupLoggers =
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    23
    updateGlobalLogger "Clients"
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents: 2867
diff changeset
    24
        (setLevel DEBUG)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    25
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    26
main :: IO ()
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
main = withSocketsDo $ do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    28
#if !defined(mingw32_HOST_OS)
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    29
    installHandler sigPIPE Ignore Nothing;
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    30
    installHandler sigCHLD Ignore Nothing;
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
#endif
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    32
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    33
    setupLoggers
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    34
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents: 2867
diff changeset
    35
    stats' <- atomically $ newTMVar (StatisticsInfo 0 0)
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    36
    dbQueriesChan <- newChan
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents: 2867
diff changeset
    37
    coreChan' <- newChan
ead2ed20dfd4 Start the server refactoring
unc0rr
parents: 2867
diff changeset
    38
    serverInfo' <- getOpts $ newServerInfo stats' coreChan' dbQueriesChan
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    39
1964
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1927
diff changeset
    40
#if defined(OFFICIAL_SERVER)
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    41
    dbHost' <- askFromConsole "DB host: "
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    42
    dbLogin' <- askFromConsole "login: "
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    43
    dbPassword' <- askFromConsole "password: "
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    44
    let serverInfo = serverInfo'{dbHost = dbHost', dbLogin = dbLogin', dbPassword = dbPassword'}
1964
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1927
diff changeset
    45
#else
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    46
    let serverInfo = serverInfo'
1964
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1927
diff changeset
    47
#endif
dc9ea05c9d2f - Another way of defining official server
unc0rr
parents: 1927
diff changeset
    48
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    49
    Exception.bracket
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    50
        (Network.listenOn $ Network.PortNumber $ listenPort serverInfo)
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    51
        sClose
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2349
diff changeset
    52
        (startServer serverInfo)