gameServer/hedgewars-server.hs
author unc0rr
Sun, 15 Mar 2009 12:58:23 +0000
changeset 1891 47e832a88cbd
parent 1839 5dd4cb7fd7e5
child 1927 e2031906a347
permissions -rw-r--r--
Fix for rooms list + Qt 4.5 by TheXception
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     1
{-# LANGUAGE CPP, ScopedTypeVariables, PatternSignatures #-}
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
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
import Network.Socket
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
import qualified Network
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
import Control.Concurrent.STM
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import Control.Concurrent.Chan
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     9
import Control.Exception
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
import System.Log.Logger
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
-----------------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
import Opts
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
import CoreTypes
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
import OfficialServer.DBInteraction
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
import ServerCore
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    17
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    18
#if !defined(mingw32_HOST_OS)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    19
import System.Posix
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
#endif
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    23
{-data Messages =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    24
	Accept ClientInfo
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    25
	| ClientMessage ([String], ClientInfo)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    26
	| CoreMessage [String]
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    27
	| TimerTick
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    28
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    29
messagesLoop :: TChan String -> IO()
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
messagesLoop messagesChan = forever $ do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    31
	threadDelay (25 * 10^6) -- 25 seconds
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    32
	atomically $ writeTChan messagesChan "PING"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    33
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    34
timerLoop :: TChan String -> IO()
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    35
timerLoop messagesChan = forever $ do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    36
	threadDelay (60 * 10^6) -- 60 seconds
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    37
	atomically $ writeTChan messagesChan "MINUTELY"-}
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    38
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    39
setupLoggers =
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    40
	updateGlobalLogger "Clients"
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    41
		(setLevel DEBUG)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    42
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    43
main = withSocketsDo $ do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    44
#if !defined(mingw32_HOST_OS)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    45
	installHandler sigPIPE Ignore Nothing;
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    46
#endif
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    47
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    48
	setupLoggers
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    49
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    50
	stats <- atomically $ newTMVar (StatisticsInfo 0 0)
1833
e901ec5644b4 Add options for configuring database access
unc0rr
parents: 1804
diff changeset
    51
	dbQueriesChan <- newChan
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    52
	coreChan <- newChan
1839
5dd4cb7fd7e5 Server now send ASKPASSWORD command to frontend when user has web account
unc0rr
parents: 1833
diff changeset
    53
	serverInfo <- getOpts $ newServerInfo stats coreChan dbQueriesChan
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    54
	
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    55
	bracket
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    56
		(Network.listenOn $ Network.PortNumber $ listenPort serverInfo)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    57
		(sClose)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    58
		(startServer serverInfo coreChan)