gameServer/NetRoutines.hs
author unc0rr
Mon, 10 May 2010 17:48:06 +0000
changeset 3458 11cd56019f00
parent 3435 4e4f88a7bdf2
child 3500 af8390d807d6
permissions -rw-r--r--
Make some more protocol commands work
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 ScopedTypeVariables #-}
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     2
module NetRoutines where
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     3
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     4
import Network.Socket
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     5
import System.IO
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     6
import Control.Concurrent.Chan
2296
19f2f76dc346 Patch for compiling with 6.10 (define NEW_EXCEPTIONS to do that)
unc0rr
parents: 2245
diff changeset
     7
import qualified Control.Exception as Exception
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import Data.Time
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
     9
import Control.Monad
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
-----------------------------
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
import CoreTypes
1917
c94045b70142 - Better ip2string implementation
unc0rr
parents: 1847
diff changeset
    12
import Utils
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    14
acceptLoop :: Socket -> Chan CoreMessage -> IO ()
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    15
acceptLoop servSock chan = forever $ do
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    16
    Exception.handle
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    17
        (\(_ :: Exception.IOException) -> putStrLn "exception on connect") $
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    18
        do
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    19
        (sock, sockAddr) <- Network.Socket.accept servSock
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    20
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    21
        cHandle <- socketToHandle sock ReadWriteMode
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    22
        hSetBuffering cHandle LineBuffering
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    23
        clientHost <- sockAddr2String sockAddr
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    24
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    25
        currentTime <- getCurrentTime
3425
ead2ed20dfd4 Start the server refactoring
unc0rr
parents: 2867
diff changeset
    26
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    27
        sendChan' <- newChan
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    28
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    29
        let newClient =
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    30
                (ClientInfo
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    31
                    sendChan'
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    32
                    cHandle
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    33
                    clientHost
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    34
                    currentTime
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    35
                    ""
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    36
                    ""
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    37
                    False
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    38
                    0
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    39
                    0
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    40
                    0
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    41
                    False
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    42
                    False
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    43
                    False
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    44
                    undefined
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    45
                    undefined
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    46
                    )
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    47
3435
4e4f88a7bdf2 Some more steps in refactoring
unc0rr
parents: 3425
diff changeset
    48
        writeChan chan $ Accept newClient
2867
9be6693c78cb - Unbreak support for client versions prior to 0.9.13-dev
unc0rr
parents: 2403
diff changeset
    49
        return ()