gameServer/stresstest3.hs
author szczur
Sun, 12 Sep 2010 17:38:14 -0400
changeset 3850 df6ecca1894f
parent 3741 73246d25dfe1
child 3947 709fdb89f76c
permissions -rw-r--r--
This change allows computers limited to 512 texture size like szczur's card to run Hedgewars, so long as reduce quality is set to eliminate background textures. It makes Ammo menu and Hats multicolumn, 512 high.
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
a94d1dc4a8d9 - burp's patch cleaning up module dependancies + cabal file
unc0rr
parents: 3665
diff changeset
    55
    return ()
3665
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    56
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    57
testing = Control.OldException.handle print $ do
3671
a94d1dc4a8d9 - burp's patch cleaning up module dependancies + cabal file
unc0rr
parents: 3665
diff changeset
    58
    putStr "+"
3665
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    59
    sock <- connectTo "127.0.0.1" (PortNumber 46631)
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    60
    evalStateT emulateSession sock
3671
a94d1dc4a8d9 - burp's patch cleaning up module dependancies + cabal file
unc0rr
parents: 3665
diff changeset
    61
    --hClose sock
a94d1dc4a8d9 - burp's patch cleaning up module dependancies + cabal file
unc0rr
parents: 3665
diff changeset
    62
    putStr "-"
a94d1dc4a8d9 - burp's patch cleaning up module dependancies + cabal file
unc0rr
parents: 3665
diff changeset
    63
    hFlush stdout
3665
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    64
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    65
forks = forever $ do
3673
45778b16b224 Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents: 3671
diff changeset
    66
    delay <- randomRIO (10000::Int, 30000)
3665
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    67
    threadDelay delay
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    68
    forkIO testing
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    69
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    70
main = withSocketsDo $ do
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    71
#if !defined(mingw32_HOST_OS)
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    72
    installHandler sigPIPE Ignore Nothing;
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    73
#endif
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    74
    forks