gameServer/stresstest.hs
author Xeli
Fri, 17 Feb 2012 21:34:33 +0100
changeset 6701 58a43c2064ad
parent 5119 f475e10c4081
child 6805 097289be7200
permissions -rw-r--r--
the onScreenwidgets are multitouch now, frequently (alternating) tapping left and right still causes it to bug though, but you have to try hard to duplicate it, works ok for now
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     1
{-# LANGUAGE CPP #-}
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 System.IO
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4905
diff changeset
     6
import System.IO.Error
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     7
import Control.Concurrent
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
     8
import Network
4905
7842d085acf4 Fix merge :D
unc0rr
parents: 4568
diff changeset
     9
import Control.OldException
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    10
import Control.Monad
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    11
import System.Random
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    12
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    13
#if !defined(mingw32_HOST_OS)
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    14
import System.Posix
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    15
#endif
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    16
5119
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5077
diff changeset
    17
session 0 nick room = ["NICK", nick, "", "PROTO", "38", "", "PING", "", "CHAT", "lobby 1", "", "PONG", "", "CREATE_ROOM", room, "", "CHAT", "room 1", "", "QUIT", "creator", ""]
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5077
diff changeset
    18
session 1 nick room = ["NICK", nick, "", "PROTO", "38", "", "LIST", "", "JOIN_ROOM", room, "", "PONG", "", "CHAT", "room 2", "", "PART", "", "CHAT", "lobby after part", "", "QUIT", "part-quit", ""]
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5077
diff changeset
    19
session 2 nick room = ["NICK", nick, "", "PROTO", "38", "", "LIST", "", "JOIN_ROOM", room, "", "PONG", "", "CHAT", "room 2", "", "QUIT", "quit", ""]
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5077
diff changeset
    20
session 3 nick room = ["NICK", nick, "", "PROTO", "38", "", "CHAT", "lobby 1", "", "CREATE_ROOM", room, "", "", "PONG", "CHAT", "room 1", "", "PART", "creator", "", "QUIT", "part-quit", ""]
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    21
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    22
emulateSession sock s = do
5119
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5077
diff changeset
    23
    mapM_ (\x -> hPutStrLn sock x >> hFlush sock >> randomRIO (100000::Int, 600000) >>= threadDelay) s
2948
3f21a9dc93d0 Replace tabs with spaces using 'expand -t 4' command
unc0rr
parents: 2352
diff changeset
    24
    hFlush sock
3f21a9dc93d0 Replace tabs with spaces using 'expand -t 4' command
unc0rr
parents: 2352
diff changeset
    25
    threadDelay 225000
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    26
4905
7842d085acf4 Fix merge :D
unc0rr
parents: 4568
diff changeset
    27
testing = Control.OldException.handle print $ do
2948
3f21a9dc93d0 Replace tabs with spaces using 'expand -t 4' command
unc0rr
parents: 2352
diff changeset
    28
    putStrLn "Start"
3f21a9dc93d0 Replace tabs with spaces using 'expand -t 4' command
unc0rr
parents: 2352
diff changeset
    29
    sock <- connectTo "127.0.0.1" (PortNumber 46631)
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    30
5119
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5077
diff changeset
    31
    num1 <- randomRIO (100000::Int, 101000)
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5077
diff changeset
    32
    num2 <- randomRIO (0::Int, 3)
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5077
diff changeset
    33
    num3 <- randomRIO (0::Int, 1000)
4905
7842d085acf4 Fix merge :D
unc0rr
parents: 4568
diff changeset
    34
    let nick1 = 'n' : show num1
5119
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5077
diff changeset
    35
    let room1 = 'r' : show num3
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5077
diff changeset
    36
    emulateSession sock $ session num2 nick1 room1
2948
3f21a9dc93d0 Replace tabs with spaces using 'expand -t 4' command
unc0rr
parents: 2352
diff changeset
    37
    hClose sock
3f21a9dc93d0 Replace tabs with spaces using 'expand -t 4' command
unc0rr
parents: 2352
diff changeset
    38
    putStrLn "Finish"
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    39
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    40
forks = forever $ do
5119
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5077
diff changeset
    41
    delays <- randomRIO (0::Int, 2)
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5077
diff changeset
    42
    replicateM 200 $
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5077
diff changeset
    43
        do
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5077
diff changeset
    44
        delay <- randomRIO (delays * 20000::Int, delays * 20000 + 50000)
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5077
diff changeset
    45
        threadDelay delay
f475e10c4081 Fix crash in server (accessing deleted room)
unc0rr
parents: 5077
diff changeset
    46
        forkIO testing
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    47
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    48
main = withSocketsDo $ do
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    49
#if !defined(mingw32_HOST_OS)
2948
3f21a9dc93d0 Replace tabs with spaces using 'expand -t 4' command
unc0rr
parents: 2352
diff changeset
    50
    installHandler sigPIPE Ignore Nothing;
1804
4e78ad846fb6 New game server:
unc0rr
parents:
diff changeset
    51
#endif
2948
3f21a9dc93d0 Replace tabs with spaces using 'expand -t 4' command
unc0rr
parents: 2352
diff changeset
    52
    forks