gameServer/stresstest3.hs
author nemo
Sun, 10 Oct 2010 20:16:17 -0400
changeset 3951 c9a63db3e603
parent 3947 709fdb89f76c
permissions -rw-r--r--
Correct another bug in slot switching, adjust width of theme list, really truly fix reset of weps (I hope) should also fix infinite teleport bug in place hogs mode. Slow update of health to 5s for inf attack mode.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
3665
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
     1
{-# LANGUAGE CPP #-}
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
     2
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
     3
module Main where
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
     4
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
     5
import IO
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
     6
import System.IO
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
     7
import Control.Concurrent
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
     8
import Network
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
     9
import Control.OldException
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    10
import Control.Monad
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    11
import System.Random
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    12
import Control.Monad.State
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    13
import Data.List
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    14
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    15
#if !defined(mingw32_HOST_OS)
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    16
import System.Posix
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    17
#endif
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    18
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    19
type SState = Handle
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    20
io = liftIO
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    21
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    22
readPacket :: StateT SState IO [String]
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    23
readPacket = do
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    24
    h <- get
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    25
    p <- io $ hGetPacket h []
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    26
    return p
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    27
    where
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    28
    hGetPacket h buf = do
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    29
        l <- hGetLine h
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    30
        if (not $ null l) then hGetPacket h (buf ++ [l]) else return buf
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    31
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    32
waitPacket :: String -> StateT SState IO Bool
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    33
waitPacket s = do
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    34
    p <- readPacket
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    35
    return $ head p == s
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    36
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    37
sendPacket :: [String] -> StateT SState IO ()
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    38
sendPacket s = do
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    39
    h <- get
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    40
    io $ do
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    41
        mapM_ (hPutStrLn h) s
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    42
        hPutStrLn h ""
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    43
        hFlush h
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    44
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    45
emulateSession :: StateT SState IO ()
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    46
emulateSession = do
3741
73246d25dfe1 Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents: 3673
diff changeset
    47
    n <- io $ randomRIO (100000::Int, 100100)
3665
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    48
    waitPacket "CONNECTED"
3671
a94d1dc4a8d9 - burp's patch cleaning up module dependancies + cabal file
unc0rr
parents: 3665
diff changeset
    49
    sendPacket ["NICK", "test" ++ (show n)]
3665
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    50
    waitPacket "NICK"
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    51
    sendPacket ["PROTO", "31"]
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    52
    waitPacket "PROTO"
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    53
    b <- waitPacket "LOBBY:JOINED"
3671
a94d1dc4a8d9 - burp's patch cleaning up module dependancies + cabal file
unc0rr
parents: 3665
diff changeset
    54
    --io $ print b
3947
709fdb89f76c Some screwing around in try to fix space leak. No luck yet.
unc0rr
parents: 3741
diff changeset
    55
    sendPacket ["QUIT", "BYE"]
3671
a94d1dc4a8d9 - burp's patch cleaning up module dependancies + cabal file
unc0rr
parents: 3665
diff changeset
    56
    return ()
3665
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    57
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    58
testing = Control.OldException.handle print $ do
3671
a94d1dc4a8d9 - burp's patch cleaning up module dependancies + cabal file
unc0rr
parents: 3665
diff changeset
    59
    putStr "+"
3665
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    60
    sock <- connectTo "127.0.0.1" (PortNumber 46631)
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    61
    evalStateT emulateSession sock
3671
a94d1dc4a8d9 - burp's patch cleaning up module dependancies + cabal file
unc0rr
parents: 3665
diff changeset
    62
    --hClose sock
a94d1dc4a8d9 - burp's patch cleaning up module dependancies + cabal file
unc0rr
parents: 3665
diff changeset
    63
    putStr "-"
a94d1dc4a8d9 - burp's patch cleaning up module dependancies + cabal file
unc0rr
parents: 3665
diff changeset
    64
    hFlush stdout
3665
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    65
3947
709fdb89f76c Some screwing around in try to fix space leak. No luck yet.
unc0rr
parents: 3741
diff changeset
    66
forks = forM_ [1..100] $ const $ do
3673
45778b16b224 Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents: 3671
diff changeset
    67
    delay <- randomRIO (10000::Int, 30000)
3665
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    68
    threadDelay delay
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    69
    forkIO testing
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    70
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    71
main = withSocketsDo $ do
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    72
#if !defined(mingw32_HOST_OS)
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    73
    installHandler sigPIPE Ignore Nothing;
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    74
#endif
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    75
    forks