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