| 1 | # ---------------------------------------------------------------------- |
|---|
| 2 | # TEST HARNESS for the P2P infrastructure |
|---|
| 3 | # |
|---|
| 4 | # This script drives the test setup and visualization for the P2P |
|---|
| 5 | # infrastructure. It launches the authority server(s) and various |
|---|
| 6 | # workers, and helps to visualize their interactions. |
|---|
| 7 | # ---------------------------------------------------------------------- |
|---|
| 8 | # Michael McLennan (mmclennan@purdue.edu) |
|---|
| 9 | # ====================================================================== |
|---|
| 10 | # Copyright (c) 2004-2012 HUBzero Foundation, LLC |
|---|
| 11 | # |
|---|
| 12 | # See the file "license.terms" for information on usage and |
|---|
| 13 | # redistribution of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
|---|
| 14 | # ====================================================================== |
|---|
| 15 | package require Itcl |
|---|
| 16 | |
|---|
| 17 | # recognize other library files in this same directory |
|---|
| 18 | set dir [file dirname [info script]] |
|---|
| 19 | lappend auto_path $dir |
|---|
| 20 | |
|---|
| 21 | set time0 [clock seconds] |
|---|
| 22 | set processes "" |
|---|
| 23 | set nodes(all) "" |
|---|
| 24 | set nodeRadius 15 |
|---|
| 25 | |
|---|
| 26 | option add *highlightBackground [. cget -background] |
|---|
| 27 | option add *client*background gray |
|---|
| 28 | option add *client*highlightBackground gray |
|---|
| 29 | option add *client*troughColor darkGray |
|---|
| 30 | |
|---|
| 31 | # ====================================================================== |
|---|
| 32 | # SHAPES |
|---|
| 33 | # ====================================================================== |
|---|
| 34 | itcl::class Shape { |
|---|
| 35 | private variable _canvas "" ;# shape sits on this canvas |
|---|
| 36 | private variable _ranges "" ;# list of time ranges for shape |
|---|
| 37 | private common _shapesOnCanvas ;# maps canvas => list of shapes |
|---|
| 38 | |
|---|
| 39 | public variable command "" ;# command template used to create shape |
|---|
| 40 | |
|---|
| 41 | constructor {canvas args} { |
|---|
| 42 | # add this shape to the list of shapes on this canvas |
|---|
| 43 | lappend _shapesOnCanvas($canvas) $this |
|---|
| 44 | set _canvas $canvas |
|---|
| 45 | eval configure $args |
|---|
| 46 | } |
|---|
| 47 | destructor { |
|---|
| 48 | # remove this shape from the list of shapes on the canvas |
|---|
| 49 | set i [lsearch $_shapesOnCanvas($_canvas) $this] |
|---|
| 50 | if {$i >= 0} { |
|---|
| 51 | set _shapesOnCanvas($_canvas) \ |
|---|
| 52 | [lreplace $_shapesOnCanvas($_canvas) $i $i] |
|---|
| 53 | } |
|---|
| 54 | } |
|---|
| 55 | |
|---|
| 56 | # ------------------------------------------------------------------ |
|---|
| 57 | # METHOD: addRange <time0> <time1> |
|---|
| 58 | # Declares that this shape exists during the given time range |
|---|
| 59 | # between <time0> and <time1>. |
|---|
| 60 | # ------------------------------------------------------------------ |
|---|
| 61 | public method addRange {t0 t1} { |
|---|
| 62 | # see if there's any overlap with existing ranges |
|---|
| 63 | set ri0 -1 |
|---|
| 64 | set ri1 -1 |
|---|
| 65 | for {set i 0} {$i < [llength $_ranges]} {incr i} { |
|---|
| 66 | set pair [lindex $_ranges $i] |
|---|
| 67 | foreach {r0 r1} $pair break |
|---|
| 68 | if {$r0 >= $t0 && $r0 <= $t1} { |
|---|
| 69 | set ri0 $i |
|---|
| 70 | } |
|---|
| 71 | if {$r1 >= $t0 && $r1 <= $t1} { |
|---|
| 72 | set ri1 $i |
|---|
| 73 | } |
|---|
| 74 | incr i |
|---|
| 75 | } |
|---|
| 76 | |
|---|
| 77 | if {$ri0 < 0 && $ri1 < 1} { |
|---|
| 78 | # doesn't overlap with anything -- insert in right place |
|---|
| 79 | for {set i 0} {$i < [llength $_ranges]} {incr i} { |
|---|
| 80 | set pair [lindex $_ranges $i] |
|---|
| 81 | foreach {r0 r1} $pair break |
|---|
| 82 | if {$t0 < $r0} break |
|---|
| 83 | } |
|---|
| 84 | set _ranges [linsert $_ranges $i [list $t0 $t1]] |
|---|
| 85 | } elseif {$ri0 >= 0 && $ri1 >= 0} { |
|---|
| 86 | # overlaps on both limits -- bridge the middle part |
|---|
| 87 | set r0 [lindex [lindex $_ranges $ri0] 0] |
|---|
| 88 | set r1 [lindex [lindex $_ranges $ri1] 1] |
|---|
| 89 | set _ranges [lreplace $_ranges $ri0 $ri1 [list $r0 $r1]] |
|---|
| 90 | } elseif {$ri0 >= 0} { |
|---|
| 91 | # overlaps on the lower limit |
|---|
| 92 | for {set i [expr {[llength $_ranges]-1}]} {$i >= 0} {incr i -1} { |
|---|
| 93 | set pair [lindex $_ranges $i] |
|---|
| 94 | foreach {r0 r1} $pair break |
|---|
| 95 | if {$r0 > $t0 && $r1 < $t1} { |
|---|
| 96 | # remove any ranges completely contained in this one |
|---|
| 97 | set _ranges [lreplace $_ranges $i $i] |
|---|
| 98 | } |
|---|
| 99 | set _ranges [lreplace $_ranges $ri0 $ri1 [list $r0 $r1]] |
|---|
| 100 | } |
|---|
| 101 | set pair [lindex $_ranges $ri0] |
|---|
| 102 | foreach {r0 r1} $pair break |
|---|
| 103 | set _ranges [lreplace $_ranges $ri0 $ri0 [list $r0 $t1]] |
|---|
| 104 | } else { |
|---|
| 105 | # overlaps on the upper limit |
|---|
| 106 | for {set i [expr {[llength $_ranges]-1}]} {$i >= 0} {incr i -1} { |
|---|
| 107 | set pair [lindex $_ranges $i] |
|---|
| 108 | foreach {r0 r1} $pair break |
|---|
| 109 | if {$r0 > $t0 && $r1 < $t1} { |
|---|
| 110 | # remove any ranges completely contained in this one |
|---|
| 111 | set _ranges [lreplace $_ranges $i $i] |
|---|
| 112 | } |
|---|
| 113 | set _ranges [lreplace $_ranges $ri0 $ri1 [list $r0 $r1]] |
|---|
| 114 | } |
|---|
| 115 | set pair [lindex $_ranges $ri1] |
|---|
| 116 | foreach {r0 r1} $pair break |
|---|
| 117 | set _ranges [lreplace $_ranges $ri1 $ri1 [list $t0 $r1]] |
|---|
| 118 | } |
|---|
| 119 | } |
|---|
| 120 | |
|---|
| 121 | # ------------------------------------------------------------------ |
|---|
| 122 | # METHOD: exists <time> |
|---|
| 123 | # Checks to see if this shape exists at the given <time>. |
|---|
| 124 | # Returns 1 if so, and 0 otherwise. |
|---|
| 125 | # ------------------------------------------------------------------ |
|---|
| 126 | public method exists {t} { |
|---|
| 127 | for {set i 0} {$i < [llength $_ranges]} {incr i} { |
|---|
| 128 | set pair [lindex $_ranges $i] |
|---|
| 129 | foreach {r0 r1} $pair break |
|---|
| 130 | if {$t >= $r0 && $t <= $r1} { |
|---|
| 131 | return 1 |
|---|
| 132 | } |
|---|
| 133 | } |
|---|
| 134 | return 0 |
|---|
| 135 | } |
|---|
| 136 | |
|---|
| 137 | # ------------------------------------------------------------------ |
|---|
| 138 | # PROC: draw <canvas> <time> |
|---|
| 139 | # Finds the list of shapes that exist on the given <canvas> at |
|---|
| 140 | # the specified time, and executes all of their associated |
|---|
| 141 | # -command templates, adding them to the canvas. |
|---|
| 142 | # ------------------------------------------------------------------ |
|---|
| 143 | public proc draw {canvas time} { |
|---|
| 144 | global times |
|---|
| 145 | if {[info exists _shapesOnCanvas($canvas)]} { |
|---|
| 146 | set y0 5 |
|---|
| 147 | if {[info exists times($time)]} { |
|---|
| 148 | $canvas create text 5 $y0 -anchor nw -text $times($time) |
|---|
| 149 | incr y0 15 |
|---|
| 150 | } |
|---|
| 151 | $canvas create text 5 $y0 -anchor nw -tags entity |
|---|
| 152 | |
|---|
| 153 | foreach obj $_shapesOnCanvas($canvas) { |
|---|
| 154 | if {[$obj exists $time]} { |
|---|
| 155 | set cmd [$obj cget -command] |
|---|
| 156 | regsub -all %c $cmd $canvas cmd |
|---|
| 157 | eval $cmd |
|---|
| 158 | } |
|---|
| 159 | } |
|---|
| 160 | } |
|---|
| 161 | } |
|---|
| 162 | |
|---|
| 163 | # ------------------------------------------------------------------ |
|---|
| 164 | # PROC: clear <canvas> |
|---|
| 165 | # Removes all shapes associated with the specified <canvas>. |
|---|
| 166 | # ------------------------------------------------------------------ |
|---|
| 167 | public proc clear {canvas} { |
|---|
| 168 | if {[info exists _shapesOnCanvas($canvas)]} { |
|---|
| 169 | eval itcl::delete object $_shapesOnCanvas($canvas) |
|---|
| 170 | } |
|---|
| 171 | } |
|---|
| 172 | } |
|---|
| 173 | |
|---|
| 174 | # ====================================================================== |
|---|
| 175 | # Build the main interface |
|---|
| 176 | # ====================================================================== |
|---|
| 177 | frame .client -borderwidth 8 -relief flat |
|---|
| 178 | pack .client -side right -fill y |
|---|
| 179 | button .client.getbids -text "Get Bids:" -command test_bids |
|---|
| 180 | pack .client.getbids -side top -anchor w |
|---|
| 181 | frame .client.cntls |
|---|
| 182 | pack .client.cntls -side bottom -fill x |
|---|
| 183 | button .client.cntls.run -text "Spend" -command test_spend |
|---|
| 184 | pack .client.cntls.run -side left |
|---|
| 185 | entry .client.cntls.points -width 8 |
|---|
| 186 | pack .client.cntls.points -side left |
|---|
| 187 | label .client.cntls.pointsl -text "points" |
|---|
| 188 | pack .client.cntls.pointsl -side left |
|---|
| 189 | |
|---|
| 190 | frame .client.bids |
|---|
| 191 | pack .client.bids -side bottom -expand yes -fill both |
|---|
| 192 | scrollbar .client.bids.ysbar -orient vertical -command {.client.bids.info yview} |
|---|
| 193 | pack .client.bids.ysbar -side right -fill y |
|---|
| 194 | listbox .client.bids.info -yscrollcommand {.client.bids.ysbar set} |
|---|
| 195 | pack .client.bids.info -side left -expand yes -fill both |
|---|
| 196 | |
|---|
| 197 | frame .cntls |
|---|
| 198 | pack .cntls -fill x |
|---|
| 199 | |
|---|
| 200 | button .cntls.start -text "Start" -command test_start |
|---|
| 201 | pack .cntls.start -side left -padx 4 -pady 2 |
|---|
| 202 | |
|---|
| 203 | button .cntls.stop -text "Stop" -command test_stop -state disabled |
|---|
| 204 | pack .cntls.stop -side left -padx 4 -pady 2 |
|---|
| 205 | |
|---|
| 206 | button .cntls.reload -text "Reload" -command test_reload |
|---|
| 207 | pack .cntls.reload -side left -padx 4 -pady 2 |
|---|
| 208 | |
|---|
| 209 | button .cntls.layout -text "New Layout" -command { |
|---|
| 210 | foreach key [array names nodes *-\[xy\]] { |
|---|
| 211 | unset nodes($key) |
|---|
| 212 | } |
|---|
| 213 | after idle test_reload |
|---|
| 214 | } |
|---|
| 215 | pack .cntls.layout -side left -padx 4 -pady 2 |
|---|
| 216 | |
|---|
| 217 | entry .cntls.workers -width 5 |
|---|
| 218 | pack .cntls.workers -side right -padx {0 4} -pady 2 |
|---|
| 219 | .cntls.workers insert end "3" |
|---|
| 220 | label .cntls.workersl -text "Workers:" |
|---|
| 221 | pack .cntls.workersl -side right -pady 2 |
|---|
| 222 | |
|---|
| 223 | frame .player |
|---|
| 224 | pack .player -side bottom -fill x |
|---|
| 225 | |
|---|
| 226 | button .player.back -text "<" -command {test_frame_go -1 nudge} |
|---|
| 227 | pack .player.back -side left -padx 4 -pady 2 |
|---|
| 228 | |
|---|
| 229 | button .player.fwd -text ">" -command {test_frame_go 1 nudge} |
|---|
| 230 | pack .player.fwd -side left -padx 4 -pady 2 |
|---|
| 231 | |
|---|
| 232 | button .player.err -text "0 errors" -command {wm deiconify .errors; raise .errors} |
|---|
| 233 | pack .player.err -side right -padx 4 -pady 2 |
|---|
| 234 | .player.err configure -state disabled |
|---|
| 235 | |
|---|
| 236 | scale .player.scale -label "Frame" -orient horizontal \ |
|---|
| 237 | -from 0 -to 1 -showvalue 0 -command {test_frame_go 1} |
|---|
| 238 | pack .player.scale -side left -expand yes -fill x -padx 4 -pady 2 |
|---|
| 239 | |
|---|
| 240 | frame .view |
|---|
| 241 | pack .view -side bottom -anchor w |
|---|
| 242 | label .view.show -text "Show:" |
|---|
| 243 | grid .view.show -row 0 -column 0 -sticky e |
|---|
| 244 | radiobutton .view.network -text "P2P Network" -variable view -value network -command test_view_change |
|---|
| 245 | grid .view.network -row 0 -column 1 -sticky w |
|---|
| 246 | radiobutton .view.traffic -text "Network traffic" -variable view -value traffic -command test_view_change |
|---|
| 247 | grid .view.traffic -row 1 -column 1 -sticky w |
|---|
| 248 | |
|---|
| 249 | frame .diagram |
|---|
| 250 | pack .diagram -expand yes -fill both |
|---|
| 251 | canvas .diagram.network -width 500 -height 400 |
|---|
| 252 | canvas .diagram.traffic -width 500 -height 400 |
|---|
| 253 | |
|---|
| 254 | after idle .view.traffic invoke |
|---|
| 255 | |
|---|
| 256 | toplevel .errors |
|---|
| 257 | wm title .errors "Error Messages" |
|---|
| 258 | wm withdraw .errors |
|---|
| 259 | wm protocol .errors WM_DELETE_WINDOW {wm withdraw .errors} |
|---|
| 260 | scrollbar .errors.ysbar -orient vertical -command {.errors.info yview} |
|---|
| 261 | pack .errors.ysbar -side right -fill y |
|---|
| 262 | text .errors.info -yscrollcommand {.errors.ysbar set} -font {Courier 12} |
|---|
| 263 | pack .errors.info -expand yes -fill both |
|---|
| 264 | .errors.info tag configure timecode -foreground gray |
|---|
| 265 | .errors.info tag configure error -foreground red -font {Courier 12 bold} |
|---|
| 266 | |
|---|
| 267 | proc test_stop {} { |
|---|
| 268 | global processes |
|---|
| 269 | |
|---|
| 270 | # kill any existing processes |
|---|
| 271 | foreach job $processes { |
|---|
| 272 | exec kill $job |
|---|
| 273 | } |
|---|
| 274 | set processes "" |
|---|
| 275 | |
|---|
| 276 | .cntls.stop configure -state disabled |
|---|
| 277 | .cntls.start configure -state normal |
|---|
| 278 | |
|---|
| 279 | after idle test_reload |
|---|
| 280 | } |
|---|
| 281 | |
|---|
| 282 | proc test_start {} { |
|---|
| 283 | global processes |
|---|
| 284 | |
|---|
| 285 | # clean up existing log files... |
|---|
| 286 | foreach fname [glob -nocomplain /tmp/log*] { |
|---|
| 287 | file delete $fname |
|---|
| 288 | } |
|---|
| 289 | |
|---|
| 290 | # launch a new authority server |
|---|
| 291 | lappend processes [exec tclsh authority.tcl &] |
|---|
| 292 | |
|---|
| 293 | # launch a series of workers |
|---|
| 294 | for {set i 0} {$i < [.cntls.workers get]} {incr i} { |
|---|
| 295 | lappend processes [exec tclsh worker.tcl &] |
|---|
| 296 | after [expr {int(rand()*5000)}] |
|---|
| 297 | } |
|---|
| 298 | |
|---|
| 299 | .cntls.start configure -state disabled |
|---|
| 300 | .cntls.stop configure -state normal |
|---|
| 301 | } |
|---|
| 302 | |
|---|
| 303 | proc test_reload {} { |
|---|
| 304 | global time0 nodes actions times nodeRadius |
|---|
| 305 | |
|---|
| 306 | array set colors { |
|---|
| 307 | authority blue |
|---|
| 308 | worker gray |
|---|
| 309 | foreman red |
|---|
| 310 | } |
|---|
| 311 | |
|---|
| 312 | Shape::clear .diagram.network |
|---|
| 313 | Shape::clear .diagram.traffic |
|---|
| 314 | .errors.info configure -state normal |
|---|
| 315 | .errors.info delete 1.0 end |
|---|
| 316 | set tmax 0 |
|---|
| 317 | set errs 0 |
|---|
| 318 | |
|---|
| 319 | # |
|---|
| 320 | # Scan through all files and generate positions for all nodes. |
|---|
| 321 | # |
|---|
| 322 | foreach fname [glob -nocomplain /tmp/log*] { |
|---|
| 323 | set fid [open $fname r] |
|---|
| 324 | set info [read $fid] |
|---|
| 325 | close $fid |
|---|
| 326 | |
|---|
| 327 | set lasttime "" |
|---|
| 328 | set t0val ""; set first "" |
|---|
| 329 | set t1val ""; set last "" |
|---|
| 330 | set info [split $info \n] |
|---|
| 331 | foreach line $info { |
|---|
| 332 | if {[regexp {^([0-9]+/[0-9]+/[0-9]+ [0-9]+:[0-9]+:[0-9]+)} $line match tval]} { |
|---|
| 333 | if {"" == $t0val} { |
|---|
| 334 | set first $line |
|---|
| 335 | set t0val [expr {([clock scan $tval]-$time0)*100}] |
|---|
| 336 | } else { |
|---|
| 337 | set last $line |
|---|
| 338 | set t1val [expr {([clock scan $tval]-$time0)*100 + 99}] |
|---|
| 339 | } |
|---|
| 340 | } |
|---|
| 341 | } |
|---|
| 342 | |
|---|
| 343 | if {"" == $t0val || "" == $t1val} { |
|---|
| 344 | # can't find any log statements -- skip this file! |
|---|
| 345 | continue |
|---|
| 346 | } |
|---|
| 347 | |
|---|
| 348 | # get the address for this host |
|---|
| 349 | if {[regexp {started at port ([0-9]+)} $info match port]} { |
|---|
| 350 | if {[regexp {options [^\n]+ ip ([^ ]+)} $info match ip]} { |
|---|
| 351 | set addr $ip:$port |
|---|
| 352 | } else { |
|---|
| 353 | set addr 127.0.0.1:$port |
|---|
| 354 | } |
|---|
| 355 | set shape oval |
|---|
| 356 | regexp {^([0-9]+/[0-9]+/[0-9]+ [0-9]+:[0-9]+:[0-9]+) +(authority|worker)} $first match t0 type |
|---|
| 357 | } elseif {[regexp -- {foreman<-} $info]} { |
|---|
| 358 | set shape rectangle |
|---|
| 359 | set addr "foreman" |
|---|
| 360 | set type "foreman" |
|---|
| 361 | } else { |
|---|
| 362 | # unknown log file -- skip it |
|---|
| 363 | continue |
|---|
| 364 | } |
|---|
| 365 | set margin 20 |
|---|
| 366 | set r $nodeRadius |
|---|
| 367 | |
|---|
| 368 | set nodes($fname) $addr |
|---|
| 369 | set nodes($addr-log) $fname |
|---|
| 370 | set nodes($addr-type) $type |
|---|
| 371 | if {![info exists nodes($addr-x)]} { |
|---|
| 372 | set w [expr {[winfo width .diagram]-2*$margin}] |
|---|
| 373 | set h [expr {[winfo height .diagram]-2*$margin}] |
|---|
| 374 | set nodes($addr-x) [expr {int(rand()*$w) + $margin}] |
|---|
| 375 | set nodes($addr-y) [expr {int(rand()*$h) + $margin}] |
|---|
| 376 | } |
|---|
| 377 | set x $nodes($addr-x) |
|---|
| 378 | set y $nodes($addr-y) |
|---|
| 379 | |
|---|
| 380 | foreach canv {.diagram.traffic .diagram.network} { |
|---|
| 381 | set s [Shape ::#auto $canv -command \ |
|---|
| 382 | [list %c create $shape [expr {$x-$r}] [expr {$y-$r}] \ |
|---|
| 383 | [expr {$x+$r}] [expr {$y+$r}] \ |
|---|
| 384 | -outline black -fill $colors($type) \ |
|---|
| 385 | -tags [list $fname $fname-node]]] |
|---|
| 386 | $s addRange $t0val $t1val |
|---|
| 387 | } |
|---|
| 388 | |
|---|
| 389 | append actions($t0val) "$type $addr online\n" |
|---|
| 390 | append actions($t1val) "$type $addr offline\n" |
|---|
| 391 | |
|---|
| 392 | if {$t1val > $tmax} { set tmax $t1val } |
|---|
| 393 | } |
|---|
| 394 | |
|---|
| 395 | # |
|---|
| 396 | # Scan through files again and generate shapes for all messages |
|---|
| 397 | # |
|---|
| 398 | foreach fname [glob -nocomplain /tmp/log*] { |
|---|
| 399 | set fid [open $fname r] |
|---|
| 400 | set info [read $fid] |
|---|
| 401 | close $fid |
|---|
| 402 | puts "\nscanning $fname" |
|---|
| 403 | |
|---|
| 404 | catch {unset started} |
|---|
| 405 | set peerlist(addrs) "" |
|---|
| 406 | set peerlist(time) 0 |
|---|
| 407 | set lasttime "" |
|---|
| 408 | set counter 0 |
|---|
| 409 | foreach line [split $info \n] { |
|---|
| 410 | if {[regexp {^([0-9]+/[0-9]+/[0-9]+ [0-9]+:[0-9]+:[0-9]+) (.+)$} $line match time mesg]} { |
|---|
| 411 | set tval [expr {([clock scan $time]-$time0)*100}] |
|---|
| 412 | |
|---|
| 413 | if {$time == $lasttime} { |
|---|
| 414 | set tval [expr {$tval + [incr counter]}] |
|---|
| 415 | } |
|---|
| 416 | set lasttime $time |
|---|
| 417 | |
|---|
| 418 | if {$tval > $tmax} { set tmax $tval } |
|---|
| 419 | |
|---|
| 420 | set cid "" |
|---|
| 421 | if {[regexp {accepted: +([^ ]+) +\((.+)\)} $mesg match addr cid]} { |
|---|
| 422 | append actions($tval) $mesg \n |
|---|
| 423 | set started(connect$cid-time) $tval |
|---|
| 424 | set started(connect$cid-addr) ? |
|---|
| 425 | |
|---|
| 426 | } elseif {[regexp {dropped: +([^ ]+) +\((.+)\)} $mesg match addr cid] && [info exists started(connect$cid-time)]} { |
|---|
| 427 | incr tval 99 ;# end of this second |
|---|
| 428 | append actions($tval) $mesg \n |
|---|
| 429 | set from $nodes($fname) |
|---|
| 430 | set x0 $nodes($from-x) |
|---|
| 431 | set y0 $nodes($from-y) |
|---|
| 432 | set x1 $nodes($addr-x) |
|---|
| 433 | set y1 $nodes($addr-y) |
|---|
| 434 | set s [Shape ::#auto .diagram.traffic -command \ |
|---|
| 435 | [list %c create line $x0 $y0 $x1 $y1 -width 3 -fill gray -tags [list $fname $fname-cnx]]] |
|---|
| 436 | $s addRange $started(connect$cid-time) $tval |
|---|
| 437 | |
|---|
| 438 | unset started(connect$cid-time) |
|---|
| 439 | unset started(connect$cid-addr) |
|---|
| 440 | |
|---|
| 441 | } elseif {[regexp {(incoming) message from ([^ ]+) \((sock[0-9]+)\): +(.+) => (.*)} $mesg match which addr cid cmd result] |
|---|
| 442 | || [regexp {(outgoing) message to ([^ ]+): +(.+)} $mesg match which addr cmd]} { |
|---|
| 443 | switch -- $which { |
|---|
| 444 | outgoing { |
|---|
| 445 | set from $addr |
|---|
| 446 | set to $nodes($fname) |
|---|
| 447 | } |
|---|
| 448 | incoming { |
|---|
| 449 | set from $nodes($fname) |
|---|
| 450 | set to $addr |
|---|
| 451 | # show incoming messages later in time |
|---|
| 452 | incr tval 50 |
|---|
| 453 | } |
|---|
| 454 | } |
|---|
| 455 | append actions($tval) $mesg \n |
|---|
| 456 | set x0 $nodes($from-x) |
|---|
| 457 | set y0 $nodes($from-y) |
|---|
| 458 | set x1 $nodes($to-x) |
|---|
| 459 | set y1 $nodes($to-y) |
|---|
| 460 | set w [expr {[winfo width .diagram]/2}] |
|---|
| 461 | |
|---|
| 462 | set s [Shape ::#auto .diagram.traffic -command \ |
|---|
| 463 | [list %c create line [expr $x0-3] [expr $y0-3] [expr $x1-3] [expr $y1-3] -fill black -arrow first -tags transient]] |
|---|
| 464 | $s addRange $tval $tval |
|---|
| 465 | |
|---|
| 466 | set s [Shape ::#auto .diagram.traffic -command \ |
|---|
| 467 | [list %c create text [expr {0.5*($x0+$x1)}] [expr {0.5*($y0+$y1)-1}] -width $w -fill black -anchor s -text $cmd -tags transient]] |
|---|
| 468 | $s addRange $tval $tval |
|---|
| 469 | |
|---|
| 470 | if {$which == "incoming" && "" != [string trim $result]} { |
|---|
| 471 | if {[regexp {^ok:} $result]} { |
|---|
| 472 | set color black |
|---|
| 473 | } else { |
|---|
| 474 | set color red |
|---|
| 475 | } |
|---|
| 476 | set s [Shape ::#auto .diagram.traffic -command \ |
|---|
| 477 | [list %c create line [expr $x0+3] [expr $y0+3] [expr $x1+3] [expr $y1+3] -fill $color -arrow last -tags transient]] |
|---|
| 478 | $s addRange $tval $tval |
|---|
| 479 | |
|---|
| 480 | set s [Shape ::#auto .diagram.traffic -command \ |
|---|
| 481 | [list %c create text [expr {0.5*($x0+$x1)}] [expr {0.5*($y0+$y1)+1}] -width $w -fill $color -anchor n -text $result -tags transient]] |
|---|
| 482 | $s addRange $tval $tval |
|---|
| 483 | } |
|---|
| 484 | |
|---|
| 485 | # no address for this client yet? then save this info |
|---|
| 486 | if {"" != $cid |
|---|
| 487 | && [info exists started(connect$cid-addr)] |
|---|
| 488 | && $started(connect$cid-addr) == "?"} { |
|---|
| 489 | set started(connect$cid-addr) $addr |
|---|
| 490 | } |
|---|
| 491 | |
|---|
| 492 | } elseif {[regexp {connected to peers: (.*)} $mesg match plist]} { |
|---|
| 493 | # draw a highlight ring, indicating that peers have changed |
|---|
| 494 | set from $nodes($fname) |
|---|
| 495 | set x $nodes($from-x) |
|---|
| 496 | set y $nodes($from-y) |
|---|
| 497 | foreach canv {.diagram.traffic .diagram.network} { |
|---|
| 498 | set s [Shape ::#auto $canv -command \ |
|---|
| 499 | [list %c create oval [expr {$x-$r-3}] [expr {$y-$r-3}] [expr {$x+$r+3}] [expr {$y+$r+3}] -outline red -fill "" -tags transient]] |
|---|
| 500 | $s addRange $tval [expr {$tval+20}] |
|---|
| 501 | } |
|---|
| 502 | |
|---|
| 503 | # draw lines from the previous peer list, now that |
|---|
| 504 | # we know it's time range is done. |
|---|
| 505 | foreach addr $peerlist(addrs) { |
|---|
| 506 | set from $nodes($fname) |
|---|
| 507 | set x0 $nodes($from-x) |
|---|
| 508 | set y0 $nodes($from-y) |
|---|
| 509 | set x1 $nodes($addr-x) |
|---|
| 510 | set y1 $nodes($addr-y) |
|---|
| 511 | set s [Shape ::#auto .diagram.network -command \ |
|---|
| 512 | [list %c create line $x0 $y0 $x1 $y1 -width 3 -fill gray -tags [list $fname $fname-cnx]]] |
|---|
| 513 | $s addRange $peerlist(time) $tval |
|---|
| 514 | } |
|---|
| 515 | |
|---|
| 516 | # save the start of this new peer list |
|---|
| 517 | set peerlist(addrs) $plist |
|---|
| 518 | set peerlist(time) $tval |
|---|
| 519 | } elseif {[regexp {ERROR} $mesg match addr]} { |
|---|
| 520 | .errors.info insert end $time timecode $mesg error "\n" |
|---|
| 521 | incr errs |
|---|
| 522 | } |
|---|
| 523 | set times($tval) $time |
|---|
| 524 | } |
|---|
| 525 | } |
|---|
| 526 | |
|---|
| 527 | # any connections hanging out that we haven't drawn? |
|---|
| 528 | foreach key [array names started connect*-addr] { |
|---|
| 529 | regexp {connect([^-]+)-addr} $key match cid |
|---|
| 530 | set from $nodes($fname) |
|---|
| 531 | set addr $started($key) |
|---|
| 532 | |
|---|
| 533 | if {![info exists nodes($addr-x)]} { |
|---|
| 534 | unset started(connect$cid-time) |
|---|
| 535 | unset started(connect$cid-addr) |
|---|
| 536 | continue |
|---|
| 537 | } |
|---|
| 538 | set x0 $nodes($from-x) |
|---|
| 539 | set y0 $nodes($from-y) |
|---|
| 540 | set x1 $nodes($addr-x) |
|---|
| 541 | set y1 $nodes($addr-y) |
|---|
| 542 | set s [Shape ::#auto .diagram.traffic -command \ |
|---|
| 543 | [list %c create line $x0 $y0 $x1 $y1 -width 3 -fill gray -tags [list $fname $fname-cnx]]] |
|---|
| 544 | $s addRange $started(connect$cid-time) $tval |
|---|
| 545 | |
|---|
| 546 | unset started(connect$cid-time) |
|---|
| 547 | unset started(connect$cid-addr) |
|---|
| 548 | } |
|---|
| 549 | |
|---|
| 550 | .diagram.traffic bind $fname <Enter> " |
|---|
| 551 | %W itemconfigure $fname-node -outline red |
|---|
| 552 | %W itemconfigure $fname-cnx -fill red |
|---|
| 553 | %W raise $fname-cnx |
|---|
| 554 | %W itemconfigure entity -text {$nodes($fname)} |
|---|
| 555 | " |
|---|
| 556 | .diagram.traffic bind $fname <Leave> " |
|---|
| 557 | %W itemconfigure $fname-node -outline black |
|---|
| 558 | %W itemconfigure $fname-cnx -fill gray |
|---|
| 559 | %W raise transient |
|---|
| 560 | %W itemconfigure entity -text {} |
|---|
| 561 | " |
|---|
| 562 | |
|---|
| 563 | foreach canv {.diagram.network .diagram.traffic} { |
|---|
| 564 | $canv bind $fname-node <ButtonPress-1> \ |
|---|
| 565 | [list worker_node_click %W $fname %x %y] |
|---|
| 566 | $canv bind $fname-node <B1-Motion> \ |
|---|
| 567 | [list worker_node_drag %W $fname %x %y] |
|---|
| 568 | $canv bind $fname-node <ButtonRelease-1> \ |
|---|
| 569 | [list worker_node_release %W $fname %x %y] |
|---|
| 570 | } |
|---|
| 571 | |
|---|
| 572 | # any peer connections that we haven't drawn? then do it now |
|---|
| 573 | foreach addr $peerlist(addrs) { |
|---|
| 574 | set from $nodes($fname) |
|---|
| 575 | set x0 $nodes($from-x) |
|---|
| 576 | set y0 $nodes($from-y) |
|---|
| 577 | set x1 $nodes($addr-x) |
|---|
| 578 | set y1 $nodes($addr-y) |
|---|
| 579 | set s [Shape ::#auto .diagram.network -command \ |
|---|
| 580 | [list %c create line $x0 $y0 $x1 $y1 -width 3 -fill gray -tags [list $fname $fname-cnx]]] |
|---|
| 581 | $s addRange $peerlist(time) $tmax |
|---|
| 582 | } |
|---|
| 583 | |
|---|
| 584 | .diagram.network bind $fname <Enter> " |
|---|
| 585 | %W itemconfigure $fname-node -outline red |
|---|
| 586 | %W itemconfigure $fname-cnx -fill red |
|---|
| 587 | %W raise $fname-cnx |
|---|
| 588 | " |
|---|
| 589 | .diagram.network bind $fname <Leave> " |
|---|
| 590 | %W itemconfigure $fname-node -outline black |
|---|
| 591 | %W itemconfigure $fname-cnx -fill gray |
|---|
| 592 | %W raise transient |
|---|
| 593 | " |
|---|
| 594 | } |
|---|
| 595 | .player.scale configure -to $tmax |
|---|
| 596 | .errors.info configure -state disabled |
|---|
| 597 | if {$errs == 0} { |
|---|
| 598 | .player.err configure -state normal -text "0 errors" |
|---|
| 599 | .player.err configure -state disabled |
|---|
| 600 | } else { |
|---|
| 601 | .player.err configure -state normal -text "$errs error[expr {($errs == 1) ? {} : {s}}]" |
|---|
| 602 | } |
|---|
| 603 | |
|---|
| 604 | after cancel test_visualize |
|---|
| 605 | after idle test_visualize |
|---|
| 606 | } |
|---|
| 607 | |
|---|
| 608 | proc worker_node_click {canv fname x y} { |
|---|
| 609 | $canv itemconfigure $fname-node -stipple gray50 |
|---|
| 610 | } |
|---|
| 611 | |
|---|
| 612 | proc worker_node_drag {canv fname x y} { |
|---|
| 613 | global nodeRadius |
|---|
| 614 | $canv itemconfigure $fname-node -stipple "" |
|---|
| 615 | $canv coords $fname-node [expr {$x-$nodeRadius}] [expr {$y-$nodeRadius}] [expr {$x+$nodeRadius}] [expr {$y+$nodeRadius}] |
|---|
| 616 | } |
|---|
| 617 | |
|---|
| 618 | proc worker_node_release {canv fname x y} { |
|---|
| 619 | global move nodes |
|---|
| 620 | |
|---|
| 621 | worker_node_drag $canv $fname $x $y |
|---|
| 622 | $canv itemconfigure $fname-node -stipple "" |
|---|
| 623 | |
|---|
| 624 | set addr $nodes($fname) |
|---|
| 625 | set nodes($addr-x) $x |
|---|
| 626 | set nodes($addr-y) $y |
|---|
| 627 | after idle test_reload |
|---|
| 628 | } |
|---|
| 629 | |
|---|
| 630 | proc test_frame_go {dir position} { |
|---|
| 631 | global actions times |
|---|
| 632 | |
|---|
| 633 | set tmax [.player.scale cget -to] |
|---|
| 634 | if {"nudge" == $position} { |
|---|
| 635 | set nframe [.player.scale get] |
|---|
| 636 | incr nframe $dir |
|---|
| 637 | } else { |
|---|
| 638 | set nframe $position |
|---|
| 639 | } |
|---|
| 640 | |
|---|
| 641 | while {![info exists actions($nframe)] && $nframe > 0 && $nframe < $tmax} { |
|---|
| 642 | incr nframe $dir |
|---|
| 643 | } |
|---|
| 644 | |
|---|
| 645 | # set the scale to this new position |
|---|
| 646 | .player.scale configure -command "" |
|---|
| 647 | .player.scale set $nframe |
|---|
| 648 | .player.scale configure -command {test_frame_go 1} |
|---|
| 649 | |
|---|
| 650 | after cancel test_visualize |
|---|
| 651 | after idle test_visualize |
|---|
| 652 | } |
|---|
| 653 | |
|---|
| 654 | proc test_visualize {} { |
|---|
| 655 | .diagram.traffic delete all |
|---|
| 656 | Shape::draw .diagram.traffic [.player.scale get] |
|---|
| 657 | .diagram.traffic raise transient |
|---|
| 658 | |
|---|
| 659 | .diagram.network delete all |
|---|
| 660 | Shape::draw .diagram.network [.player.scale get] |
|---|
| 661 | .diagram.network raise transient |
|---|
| 662 | } |
|---|
| 663 | |
|---|
| 664 | proc test_view_change {} { |
|---|
| 665 | global view |
|---|
| 666 | foreach widget [pack slaves .diagram] { |
|---|
| 667 | catch {pack forget $widget} |
|---|
| 668 | } |
|---|
| 669 | pack .diagram.$view -expand yes -fill both |
|---|
| 670 | } |
|---|
| 671 | |
|---|
| 672 | proc test_bids {} { |
|---|
| 673 | set info [Rappture::foreman::bids] |
|---|
| 674 | .client.bids.info delete 0 end |
|---|
| 675 | eval .client.bids.info insert end $info |
|---|
| 676 | } |
|---|
