gameServer/stresstest3.hs
author koda
Thu, 21 Oct 2010 23:11:49 +0200
changeset 3989 adffb668f06e
parent 3947 709fdb89f76c
permissions -rw-r--r--
add a default description to the new ammomenu
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