1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
|
#!/usr/bin/tclsh
#
# Run this script, giving the url of a Fossil server instances as the
# argument, and this script will start sending HTTP requests into the
# that server instance as fast as it can, as a stress test for the
# server implementation.
#
set nthread 10
for {set i 0} {$i<[llength $argv]} {incr i} {
set x [lindex $argv $i]
if {[regexp {^--[a-z]} $x]} {
set x [string range $x 1 end]
}
if {$x=="-threads"} {
incr i
set nthread [lindex $argv $i]
} elseif {[string index $x 0]=="-"} {
error "unknown option \"$x\""
} elseif {[info exists url]} {
error "unknown argument \"$x\""
} else {
set url $x
}
}
if {![info exists url]} {
error "Usage: $argv0 [-threads N] URL"
}
if {![regexp {^https?://([^/:]+)(:\d+)?(/.*)$} $url all domain port path]} {
error "could not parse the URL [list $url] -- should be of the\
form \"http://domain/path\""
}
set useragent {Mozilla/5.0 (fossil-stress.tcl) Gecko/20100101 Firefox/57.0}
set path [string trimright $path /]
set port [string trimleft $port :]
if {$port==""} {set port 80}
proc send_one_request {tid domain port path} {
while {[catch {
set x [socket $domain $port]
fconfigure $x -translation binary -blocking 0
puts $x "GET $path HTTP/1.0\r"
if {$port==80} {
puts $x "Host: $domain\r"
} else {
puts $x "Host: $domain:$port\r"
}
puts $x "User-Agent: $::useragent\r"
puts $x "Accept: text/html,q=0.9,*/*;q=0.8\r"
puts $x "Accept-Language: en-US,en;q=0.5\r"
puts $x "Connection: close\r"
puts $x "\r"
} msg]} {
puts "ERROR: $msg"
after 1000
}
global cnt stime threadid
set cnt($x) 0
set stime($x) [clock seconds]
set threadid($x) $tid
flush $x
fileevent $x readable [list get_reply $tid $path $x]
}
proc close_connection {x} {
global cnt stime tid
close $x
unset -nocomplain cnt($x)
unset -nocomplain stime($x)
unset -nocomplain threadid($x)
}
proc get_reply {tid info x} {
global cnt
if {[eof $x]} {
puts "[format %3d: $tid] $info ($cnt($x) bytes)"
flush stdout
close_connection $x
start_another_request $tid
} else {
incr cnt($x) [string length [read $x]]
}
}
set pages {
/timeline?n=20
/timeline?n=20&a=1970-01-01
/home
/brlist
/info/trunk
/info/2015-01-01
/vdiff?from=2015-01-01&to=trunk&diff=0
/wcontent
/fileage
/dir
/tree
/uvlist
/stat
/test-env
/sitemap
/hash-collisions
/artifact_stats
/bloblist
/bigbloblist
/wiki_rules
/md_rules
/help
/test-all-help
/timewarps
/taglist
}
set pageidx 0
proc start_another_request {tid} {
global pages pageidx domain port path
set p [lindex $pages $pageidx]
incr pageidx
if {$pageidx>=[llength $pages]} {set pageidx 0}
send_one_request $tid $domain $port $path$p
}
proc unhang_stalled_threads {} {
global stime threadid
set now [clock seconds]
# puts "checking for stalled threads...."
foreach x [array names stime] {
# puts -nonewline " $threadid($x)=[expr {$now-$stime($x)}]"
if {$stime($x)+0<$now-10} {
set t $threadid($x)
puts "RESTART thread $t"
flush stdout
close_connection $x
start_another_request $t
}
}
# puts ""
flush stdout
after 10000 unhang_stalled_threads
}
unhang_stalled_threads
for {set i 1} {$i<=$nthread} {incr i} {
start_another_request $i
}
vwait forever
|
