Fossil SCM
Improvements to the fossil-stress.tcl script to automaticall restart stalled request threads.
Commit
1fae64de38a02e955e01b018b2432153b87af680bed2d63a6e1817efc717f333
Parent
8d60cd571922d0f…
1 file changed
+35
-7
+35
-7
| --- tools/fossil-stress.tcl | ||
| +++ tools/fossil-stress.tcl | ||
| @@ -27,19 +27,19 @@ | ||
| 27 | 27 | } |
| 28 | 28 | if {![regexp {^https?://([^/:]+)(:\d+)?(/.*)$} $url all domain port path]} { |
| 29 | 29 | error "could not parse the URL [list $url] -- should be of the\ |
| 30 | 30 | form \"http://domain/path\"" |
| 31 | 31 | } |
| 32 | -set useragent {Mozilla/5.0 (X11; Linux x86_64; rv:57.0) Gecko/20100101 Firefox/57.0} | |
| 32 | +set useragent {Mozilla/5.0 (fossil-stress.tcl) Gecko/20100101 Firefox/57.0} | |
| 33 | 33 | set path [string trimright $path /] |
| 34 | 34 | set port [string trimleft $port :] |
| 35 | 35 | if {$port==""} {set port 80} |
| 36 | 36 | |
| 37 | 37 | proc send_one_request {tid domain port path} { |
| 38 | 38 | while {[catch { |
| 39 | 39 | set x [socket $domain $port] |
| 40 | - fconfigure $x -translation binary | |
| 40 | + fconfigure $x -translation binary -blocking 0 | |
| 41 | 41 | puts $x "GET $path HTTP/1.0\r" |
| 42 | 42 | if {$port==80} { |
| 43 | 43 | puts $x "Host: $domain\r" |
| 44 | 44 | } else { |
| 45 | 45 | puts $x "Host: $domain:$port\r" |
| @@ -47,28 +47,36 @@ | ||
| 47 | 47 | puts $x "User-Agent: $::useragent\r" |
| 48 | 48 | puts $x "Accept: text/html,q=0.9,*/*;q=0.8\r" |
| 49 | 49 | puts $x "Accept-Language: en-US,en;q=0.5\r" |
| 50 | 50 | puts $x "Connection: close\r" |
| 51 | 51 | puts $x "\r" |
| 52 | - flush $x | |
| 53 | 52 | } msg]} { |
| 54 | 53 | puts "ERROR: $msg" |
| 55 | 54 | after 1000 |
| 56 | 55 | } |
| 57 | - global cnt | |
| 56 | + global cnt stime threadid | |
| 58 | 57 | set cnt($x) 0 |
| 59 | - fconfigure $x -blocking 0 | |
| 58 | + set stime($x) [clock seconds] | |
| 59 | + set threadid($x) $tid | |
| 60 | + flush $x | |
| 60 | 61 | fileevent $x readable [list get_reply $tid $path $x] |
| 61 | 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 | +} | |
| 62 | 71 | |
| 63 | 72 | proc get_reply {tid info x} { |
| 64 | 73 | global cnt |
| 65 | 74 | if {[eof $x]} { |
| 66 | 75 | puts "[format %3d: $tid] $info ($cnt($x) bytes)" |
| 67 | 76 | flush stdout |
| 68 | - close $x | |
| 69 | - unset cnt($x) | |
| 77 | + close_connection $x | |
| 70 | 78 | start_another_request $tid |
| 71 | 79 | } else { |
| 72 | 80 | incr cnt($x) [string length [read $x]] |
| 73 | 81 | } |
| 74 | 82 | } |
| @@ -108,9 +116,29 @@ | ||
| 108 | 116 | incr pageidx |
| 109 | 117 | if {$pageidx>=[llength $pages]} {set pageidx 0} |
| 110 | 118 | send_one_request $tid $domain $port $path$p |
| 111 | 119 | } |
| 112 | 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 | |
| 113 | 141 | for {set i 1} {$i<=$nthread} {incr i} { |
| 114 | 142 | start_another_request $i |
| 115 | 143 | } |
| 116 | 144 | vwait forever |
| 117 | 145 |
| --- tools/fossil-stress.tcl | |
| +++ tools/fossil-stress.tcl | |
| @@ -27,19 +27,19 @@ | |
| 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 (X11; Linux x86_64; rv:57.0) 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 |
| 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" |
| @@ -47,28 +47,36 @@ | |
| 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 | flush $x |
| 53 | } msg]} { |
| 54 | puts "ERROR: $msg" |
| 55 | after 1000 |
| 56 | } |
| 57 | global cnt |
| 58 | set cnt($x) 0 |
| 59 | fconfigure $x -blocking 0 |
| 60 | fileevent $x readable [list get_reply $tid $path $x] |
| 61 | } |
| 62 | |
| 63 | proc get_reply {tid info x} { |
| 64 | global cnt |
| 65 | if {[eof $x]} { |
| 66 | puts "[format %3d: $tid] $info ($cnt($x) bytes)" |
| 67 | flush stdout |
| 68 | close $x |
| 69 | unset cnt($x) |
| 70 | start_another_request $tid |
| 71 | } else { |
| 72 | incr cnt($x) [string length [read $x]] |
| 73 | } |
| 74 | } |
| @@ -108,9 +116,29 @@ | |
| 108 | incr pageidx |
| 109 | if {$pageidx>=[llength $pages]} {set pageidx 0} |
| 110 | send_one_request $tid $domain $port $path$p |
| 111 | } |
| 112 | |
| 113 | for {set i 1} {$i<=$nthread} {incr i} { |
| 114 | start_another_request $i |
| 115 | } |
| 116 | vwait forever |
| 117 |
| --- tools/fossil-stress.tcl | |
| +++ tools/fossil-stress.tcl | |
| @@ -27,19 +27,19 @@ | |
| 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" |
| @@ -47,28 +47,36 @@ | |
| 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 | } |
| @@ -108,9 +116,29 @@ | |
| 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 |