gameServer/stresstest3.hs
author koda
Sat, 05 Feb 2011 22:22:16 +0100
changeset 4924 616b618814b5
parent 4905 7842d085acf4
child 4932 f11d80bac7ed
permissions -rw-r--r--
show dual head mode some love
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     1
{-# LANGUAGE CPP #-}
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     2
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     3
module Main where
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     4
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     5
import IO
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     6
import System.IO
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     7
import Control.Concurrent
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     8
import Network
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
     9
import Control.OldException
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    10
import Control.Monad
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    11
import System.Random
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    12
import Control.Monad.State
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    13
import Data.List
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    14
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    15
#if !defined(mingw32_HOST_OS)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    16
import System.Posix
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    17
#endif
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    18
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    19
type SState = Handle
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    20
io = liftIO
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    21
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    22
readPacket :: StateT SState IO [String]
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    23
readPacket = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    24
    h <- get
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    25
    p <- io $ hGetPacket h []
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    26
    return p
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    27
    where
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    28
    hGetPacket h buf = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    29
        l <- hGetLine h
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    30
        if (not $ null l) then hGetPacket h (buf ++ [l]) else return buf
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    31
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    32
waitPacket :: String -> StateT SState IO Bool
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    33
waitPacket s = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    34
    p <- readPacket
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    35
    return $ head p == s
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    36
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    37
sendPacket :: [String] -> StateT SState IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    38
sendPacket s = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    39
    h <- get
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    40
    io $ do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    41
        mapM_ (hPutStrLn h) s
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    42
        hPutStrLn h ""
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    43
        hFlush h
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    44
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    45
emulateSession :: StateT SState IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    46
emulateSession = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    47
    n <- io $ randomRIO (100000::Int, 100100)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    48
    waitPacket "CONNECTED"
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    49
    sendPacket ["NICK", "test" ++ (show n)]
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    50
    waitPacket "NICK"
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    51
    sendPacket ["PROTO", "31"]
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    52
    waitPacket "PROTO"
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    53
    b <- waitPacket "LOBBY:JOINED"
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    54
    --io $ print b
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    55
    sendPacket ["QUIT", "BYE"]
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    56
    return ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    57
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    58
testing = Control.OldException.handle print $ do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    59
    putStr "+"
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    60
    sock <- connectTo "127.0.0.1" (PortNumber 46631)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    61
    evalStateT emulateSession sock
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    62
    --hClose sock
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    63
    putStr "-"
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    64
    hFlush stdout
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    65
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    66
forks = forM_ [1..100] $ const $ do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    67
    delay <- randomRIO (10000::Int, 30000)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    68
    threadDelay delay
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    69
    forkIO testing
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    70
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    71
main = withSocketsDo $ do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    72
#if !defined(mingw32_HOST_OS)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    73
    installHandler sigPIPE Ignore Nothing;
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    74
#endif
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    75
    forks