gameServer/stresstest3.hs
author unc0rr
Fri, 23 Jul 2010 22:14:56 +0400
changeset 3665 bc06dd09cb21
child 3671 a94d1dc4a8d9
permissions -rw-r--r--
New stress testing app with advanced features (not complete yet)
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
        
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    23
readPacket :: StateT SState IO [String]
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    24
readPacket = do
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    25
    h <- get
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    26
    p <- io $ hGetPacket h []
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    27
    return p
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    28
    where
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    29
    hGetPacket h buf = do
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    30
        l <- hGetLine h
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    31
        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
    32
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    33
waitPacket :: String -> StateT SState IO Bool
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    34
waitPacket s = do
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    35
    p <- readPacket
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    36
    return $ head p == s
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    37
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    38
sendPacket :: [String] -> StateT SState IO ()
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    39
sendPacket s = do
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    40
    h <- get
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    41
    io $ do
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    42
        mapM_ (hPutStrLn h) s
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    43
        hPutStrLn h ""
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    44
        hFlush h
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    45
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    46
emulateSession :: StateT SState IO ()
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    47
emulateSession = do
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    48
    waitPacket "CONNECTED"
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    49
    sendPacket ["NICK", "test"]
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"
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    54
    io $ print b
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    55
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    56
testing = Control.OldException.handle print $ do
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    57
    putStrLn "Start"
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    58
    sock <- connectTo "127.0.0.1" (PortNumber 46631)
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    59
    evalStateT emulateSession sock
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    60
    putStrLn "Finish"
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    61
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    62
forks = forever $ do
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    63
    delay <- randomRIO (400000::Int, 600000)
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    64
    threadDelay delay
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    65
    forkIO testing
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    66
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    67
main = withSocketsDo $ do
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    68
#if !defined(mingw32_HOST_OS)
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    69
    installHandler sigPIPE Ignore Nothing;
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    70
#endif
bc06dd09cb21 New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff changeset
    71
    forks