gameServer/stresstest3.hs
author koda
Fri, 26 Oct 2012 14:19:57 +0100
branch0.9.17
changeset 6410 fd08e4052360
parent 5058 4229507909d6
child 7751 8c7f5c43ea5e
permissions -rw-r--r--
close branch
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 System.IO
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4905
diff changeset
     6
import System.IO.Error
4905
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
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4905
diff changeset
    25
    io $ hGetPacket h []
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    26
    where
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    27
    hGetPacket h buf = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    28
        l <- hGetLine h
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4905
diff changeset
    29
        if not $ null l then hGetPacket h (buf ++ [l]) else return buf
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    30
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    31
waitPacket :: String -> StateT SState IO Bool
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    32
waitPacket s = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    33
    p <- readPacket
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    34
    return $ head p == s
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    35
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    36
sendPacket :: [String] -> StateT SState IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    37
sendPacket s = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    38
    h <- get
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    39
    io $ do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    40
        mapM_ (hPutStrLn h) s
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    41
        hPutStrLn h ""
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    42
        hFlush h
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    43
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    44
emulateSession :: StateT SState IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    45
emulateSession = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    46
    n <- io $ randomRIO (100000::Int, 100100)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    47
    waitPacket "CONNECTED"
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4905
diff changeset
    48
    sendPacket ["NICK", "test" ++ show n]
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    49
    waitPacket "NICK"
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    50
    sendPacket ["PROTO", "31"]
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    51
    waitPacket "PROTO"
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    52
    b <- waitPacket "LOBBY:JOINED"
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    53
    --io $ print b
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    54
    sendPacket ["QUIT", "BYE"]
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    55
    return ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    56
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    57
testing = Control.OldException.handle print $ do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    58
    putStr "+"
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    59
    sock <- connectTo "127.0.0.1" (PortNumber 46631)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    60
    evalStateT emulateSession sock
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    61
    --hClose sock
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    62
    putStr "-"
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    63
    hFlush stdout
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    64
5058
4229507909d6 Some improvements in test programs
unc0rr
parents: 4932
diff changeset
    65
forks = forever $ do
4229507909d6 Some improvements in test programs
unc0rr
parents: 4932
diff changeset
    66
    delay <- randomRIO (0::Int, 80000)
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    67
    threadDelay delay
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    68
    forkIO testing
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    69
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    70
main = withSocketsDo $ do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    71
#if !defined(mingw32_HOST_OS)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    72
    installHandler sigPIPE Ignore Nothing;
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    73
#endif
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    74
    forks