gameServer/stresstest3.hs
author Wuzzy <Wuzzy2@mail.ru>
Thu, 26 Jul 2018 18:01:32 +0200
changeset 13558 af92481415ef
parent 11046 47a8c19ecb60
permissions -rw-r--r--
TechRacer: Fix gears not spawning on turn start when player pressed control right at start The activationStage was horribly programmed and heavily relied on timer. There was a sweet spot at turn start that if you managed to push a key right at the start of turn, you skip the Ready phase and the activationStage would advance, causing the gear spawning code to be skipped. This fix greatly simplies the spawning phase.
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
10460
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
     1
{-
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
     2
 * Hedgewars, a free turn based strategy game
11046
47a8c19ecb60 more copyright fixes
sheepluva
parents: 10460
diff changeset
     3
 * Copyright (c) 2004-2015 Andrey Korotaev <unC0Rr@gmail.com>
10460
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
     4
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
     5
 * This program is free software; you can redistribute it and/or modify
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
     6
 * it under the terms of the GNU General Public License as published by
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
     7
 * the Free Software Foundation; version 2 of the License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
     8
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
     9
 * This program is distributed in the hope that it will be useful,
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
    10
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
    11
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
    12
 * GNU General Public License for more details.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
    13
 *
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
    14
 * You should have received a copy of the GNU General Public License
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
    15
 * along with this program; if not, write to the Free Software
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
    16
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
    17
 \-}
8dcea9087d75 Added copyrights to gameServer directory
Gianfranco Costamagna <costamagnagianfranco@yahoo.it>
parents: 7751
diff changeset
    18
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    19
{-# LANGUAGE CPP #-}
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    20
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    21
module Main where
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    22
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    23
import System.IO
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4905
diff changeset
    24
import System.IO.Error
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    25
import Control.Concurrent
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    26
import Network
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    27
import Control.OldException
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    28
import Control.Monad
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    29
import System.Random
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    30
import Control.Monad.State
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    31
import Data.List
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    32
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    33
#if !defined(mingw32_HOST_OS)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    34
import System.Posix
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    35
#endif
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    36
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    37
type SState = Handle
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    38
io = liftIO
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    39
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    40
readPacket :: StateT SState IO [String]
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    41
readPacket = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    42
    h <- get
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4905
diff changeset
    43
    io $ hGetPacket h []
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    44
    where
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    45
    hGetPacket h buf = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    46
        l <- hGetLine h
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4905
diff changeset
    47
        if not $ null l then hGetPacket h (buf ++ [l]) else return buf
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    48
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    49
waitPacket :: String -> StateT SState IO Bool
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    50
waitPacket s = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    51
    p <- readPacket
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    52
    return $ head p == s
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    53
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    54
sendPacket :: [String] -> StateT SState IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    55
sendPacket s = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    56
    h <- get
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    57
    io $ do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    58
        mapM_ (hPutStrLn h) s
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    59
        hPutStrLn h ""
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    60
        hFlush h
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    61
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    62
emulateSession :: StateT SState IO ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    63
emulateSession = do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    64
    n <- io $ randomRIO (100000::Int, 100100)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    65
    waitPacket "CONNECTED"
4932
f11d80bac7ed - Take into account hlint suggestions
unc0rr
parents: 4905
diff changeset
    66
    sendPacket ["NICK", "test" ++ show n]
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    67
    waitPacket "NICK"
7751
8c7f5c43ea5e Switch to vector library for arrays
unc0rr
parents: 5058
diff changeset
    68
    sendPacket ["PROTO", "41"]
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    69
    waitPacket "PROTO"
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    70
    b <- waitPacket "LOBBY:JOINED"
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    71
    --io $ print b
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    72
    sendPacket ["QUIT", "BYE"]
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    73
    return ()
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    74
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    75
testing = Control.OldException.handle print $ do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    76
    putStr "+"
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    77
    sock <- connectTo "127.0.0.1" (PortNumber 46631)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    78
    evalStateT emulateSession sock
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    79
    --hClose sock
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    80
    putStr "-"
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    81
    hFlush stdout
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    82
5058
4229507909d6 Some improvements in test programs
unc0rr
parents: 4932
diff changeset
    83
forks = forever $ do
4229507909d6 Some improvements in test programs
unc0rr
parents: 4932
diff changeset
    84
    delay <- randomRIO (0::Int, 80000)
4905
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    85
    threadDelay delay
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    86
    forkIO testing
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    87
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    88
main = withSocketsDo $ do
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    89
#if !defined(mingw32_HOST_OS)
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    90
    installHandler sigPIPE Ignore Nothing;
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    91
#endif
7842d085acf4 Fix merge :D
unc0rr
parents:
diff changeset
    92
    forks