gameServer/stresstest3.hs
author nemo
Fri, 23 Mar 2012 18:20:59 -0400
changeset 6810 5337f554480e
parent 5058 4229507909d6
child 7751 8c7f5c43ea5e
permissions -rw-r--r--
This has bugged me for a while. Since we are missing the source SVGs for this theme, removed the leaves crudely in GIMP. Also added some basic roots. Someone more artistic is encouraged to try and improve it.
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