author | koda |
Mon, 15 Nov 2010 12:37:39 +0100 | |
branch | experimental3D |
changeset 4343 | 19cbea33e4d2 |
parent 3947 | 709fdb89f76c |
permissions | -rw-r--r-- |
3665
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
1 |
{-# LANGUAGE CPP #-} |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
2 |
|
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
3 |
module Main where |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
4 |
|
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
5 |
import IO |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
6 |
import System.IO |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
7 |
import Control.Concurrent |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
8 |
import Network |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
9 |
import Control.OldException |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
10 |
import Control.Monad |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
11 |
import System.Random |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
12 |
import Control.Monad.State |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
13 |
import Data.List |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
14 |
|
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
15 |
#if !defined(mingw32_HOST_OS) |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
16 |
import System.Posix |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
17 |
#endif |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
18 |
|
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
19 |
type SState = Handle |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
20 |
io = liftIO |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
21 |
|
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
22 |
readPacket :: StateT SState IO [String] |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
23 |
readPacket = do |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
24 |
h <- get |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
25 |
p <- io $ hGetPacket h [] |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
26 |
return p |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
27 |
where |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
28 |
hGetPacket h buf = do |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
29 |
l <- hGetLine h |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
30 |
if (not $ null l) then hGetPacket h (buf ++ [l]) else return buf |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
31 |
|
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
32 |
waitPacket :: String -> StateT SState IO Bool |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
33 |
waitPacket s = do |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
34 |
p <- readPacket |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
35 |
return $ head p == s |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
36 |
|
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
37 |
sendPacket :: [String] -> StateT SState IO () |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
38 |
sendPacket s = do |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
39 |
h <- get |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
40 |
io $ do |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
41 |
mapM_ (hPutStrLn h) s |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
42 |
hPutStrLn h "" |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
43 |
hFlush h |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
44 |
|
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
45 |
emulateSession :: StateT SState IO () |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
46 |
emulateSession = do |
3741
73246d25dfe1
Add some more strictness, use unsafeThaw and unsafeFreeze functions which work at O(1)
unc0rr
parents:
3673
diff
changeset
|
47 |
n <- io $ randomRIO (100000::Int, 100100) |
3665
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
48 |
waitPacket "CONNECTED" |
3671
a94d1dc4a8d9
- burp's patch cleaning up module dependancies + cabal file
unc0rr
parents:
3665
diff
changeset
|
49 |
sendPacket ["NICK", "test" ++ (show n)] |
3665
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
50 |
waitPacket "NICK" |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
51 |
sendPacket ["PROTO", "31"] |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
52 |
waitPacket "PROTO" |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
53 |
b <- waitPacket "LOBBY:JOINED" |
3671
a94d1dc4a8d9
- burp's patch cleaning up module dependancies + cabal file
unc0rr
parents:
3665
diff
changeset
|
54 |
--io $ print b |
3947
709fdb89f76c
Some screwing around in try to fix space leak. No luck yet.
unc0rr
parents:
3741
diff
changeset
|
55 |
sendPacket ["QUIT", "BYE"] |
3671
a94d1dc4a8d9
- burp's patch cleaning up module dependancies + cabal file
unc0rr
parents:
3665
diff
changeset
|
56 |
return () |
3665
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
57 |
|
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
58 |
testing = Control.OldException.handle print $ do |
3671
a94d1dc4a8d9
- burp's patch cleaning up module dependancies + cabal file
unc0rr
parents:
3665
diff
changeset
|
59 |
putStr "+" |
3665
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
60 |
sock <- connectTo "127.0.0.1" (PortNumber 46631) |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
61 |
evalStateT emulateSession sock |
3671
a94d1dc4a8d9
- burp's patch cleaning up module dependancies + cabal file
unc0rr
parents:
3665
diff
changeset
|
62 |
--hClose sock |
a94d1dc4a8d9
- burp's patch cleaning up module dependancies + cabal file
unc0rr
parents:
3665
diff
changeset
|
63 |
putStr "-" |
a94d1dc4a8d9
- burp's patch cleaning up module dependancies + cabal file
unc0rr
parents:
3665
diff
changeset
|
64 |
hFlush stdout |
3665
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
65 |
|
3947
709fdb89f76c
Some screwing around in try to fix space leak. No luck yet.
unc0rr
parents:
3741
diff
changeset
|
66 |
forks = forM_ [1..100] $ const $ do |
3673
45778b16b224
Some comments on the reason of the bug, leave bug not fixed yet
unc0rr
parents:
3671
diff
changeset
|
67 |
delay <- randomRIO (10000::Int, 30000) |
3665
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
68 |
threadDelay delay |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
69 |
forkIO testing |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
70 |
|
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
71 |
main = withSocketsDo $ do |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
72 |
#if !defined(mingw32_HOST_OS) |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
73 |
installHandler sigPIPE Ignore Nothing; |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
74 |
#endif |
bc06dd09cb21
New stress testing app with advanced features (not complete yet)
unc0rr
parents:
diff
changeset
|
75 |
forks |