gameServer/stresstest.hs
author koda
Fri, 09 Nov 2012 23:11:53 +0100
branchwebgl
changeset 8006 7ca007615b88
parent 6805 097289be7200
child 10460 8dcea9087d75
permissions -rw-r--r--
no globs, sources not yet generated
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
6805
097289be7200 Add more strictness in hope it will help with space leak
unc0rr
parents: 5119
diff changeset
    17
session 0 nick room = ["NICK", nick, "", "PROTO", "42", "", "PING", "", "CHAT", "lobby 1", "", "PONG", "", "CREATE_ROOM", room, "", "CHAT", "room 1", "", "QUIT", "creator", ""]
097289be7200 Add more strictness in hope it will help with space leak
unc0rr
parents: 5119
diff changeset
    18
session 1 nick room = ["NICK", nick, "", "PROTO", "42", "", "LIST", "", "JOIN_ROOM", room, "", "PONG", "", "CHAT", "room 2", "", "PART", "", "CHAT", "lobby after part", "", "QUIT", "part-quit", ""]
097289be7200 Add more strictness in hope it will help with space leak
unc0rr
parents: 5119
diff changeset
    19
session 2 nick room = ["NICK", nick, "", "PROTO", "42", "", "LIST", "", "JOIN_ROOM", room, "", "PONG", "", "CHAT", "room 2", "", "QUIT", "quit", ""]
097289be7200 Add more strictness in hope it will help with space leak
unc0rr
parents: 5119
diff changeset
    20
session 3 nick room = ["NICK", nick, "", "PROTO", "42", "", "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