gameServer/stresstest3.hs
author koda
Sat, 09 Mar 2013 00:57:09 +0100
changeset 8702 a28966180a29
parent 7751 8c7f5c43ea5e
child 10460 8dcea9087d75
permissions -rw-r--r--
have fpc work in the right directory instead of passing the full path of the main module (avoids having full paths in debug build backtraces for the first module only)
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"
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 5058
diff changeset
    50
    sendPacket ["PROTO", "41"]
4905
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