gameServer/stresstest3.hs
author sheepluva
Sun, 06 Feb 2011 11:39:11 +0100
changeset 4929 3dca560e6510
parent 4905 7842d085acf4
child 4932 f11d80bac7ed
permissions -rw-r--r--
I need this export in order to not have the wrapper.c fail to find Game() on linux From this point on compilation and usage of library should work on linux, at least does for me :P
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