make-probes.tcl

   1 #!/usr/bin/tclsh8.2
   2
   3
   4 set debug_level 1
   5
   6 proc debug {level str} {
   7     global debug_level
   8     if {$level < $debug_level} { puts stderr "debug\[$level] $str" }
   9 }
  10
  11 proc manyset {list args} {
  12     foreach val $list var $args {
  13         upvar 1 $var my
  14         set my $val
  15     }
  16 }
  17
  18
  19 proc start_gen {use_gen_counter} {
  20     global gen_counter rand_counter getlog_log rand_buf
  21     random-bytes-init $use_gen_counter
  22     set getlog_log {}
  23 }
  24
  25 proc packet-len {p} { expr {[string length $p]/2} }
  26
  27 proc packet-csum-ip {packet} {
  28     set cs 0
  29     append packet 00
  30     while {[regexp {^([0-9a-f][0-9a-f])(.*)$} $packet dummy this packet]} {
  31         incr cs 0x$this
  32     }
  33     return [expr {$cs & 0xffff}]
  34 }
  35
  36
  37 namespace eval Random-Bytes {
  38     namespace export random-bytes random-bytes-init
  39
  40     proc random-bytes-init {seed} {
  41         variable counter
  42         variable fh
  43         catch { set h $fh; unset fh; close $h }
  44         set counter 0
  45         set fh [open |[list openssl bf-ofb < /dev/zero -e -k " $seed"] r]
  46         fconfigure $fh -translation binary
  47     }
  48     proc random-bytes {n} {
  49         variable fh
  50         set x [read $fh $n]
  51         if {[string length $x] != $n} {
  52             set h $fh; unset fh; close $h
  53             error "openssl bf-ofb exited unexpectedly"
  54         }
  55         binary scan $x H* y
  56         if {[string length $y] != $n*2} { error "binary format failed $n $y" }
  57         return $y
  58     }
  59 }
  60
  61 namespace import Random-Bytes::*
  62
  63 proc choice-int {min max} {
  64     set rv 0x[random-bytes 3]
  65     return [expr {
  66         int( double($rv) / double(0x1000000) * double($max+1-$min) )
  67         + $min
  68     }]
  69 }
  70
  71 proc choice-prob {cv def} {
  72     set prob [config $cv $def]
  73     set rv 0x[random-bytes 3]
  74     return [expr {$rv < double($prob)*0x1000000}]
  75 }
  76
  77 proc choice-mult {args} {
  78     if {!([llength $args] % 2)} { error "choice-mult must have default" }
  79     set x 0x[random-bytes 3]
  80     set x [expr { double($x) / double(0x1000000) }]
  81     set cump 0.0
  82     set def [lindex $args end]
  83     set args [lreplace $args end end]
  84     foreach {val p} $args {
  85         set cump [expr {$cump + double($p)}]
  86         if {$x < $cump} { return $val }
  87     }
  88     return $def
  89 }
  90
  91 proc getlog {msg} {
  92     upvar #0 getlog_log log
  93     append log " $msg"
  94     debug 2 "getlog $msg"
  95 }
  96
  97 proc config {cv def} {
  98     upvar #0 config/$cv v
  99     if {[info exists v]} { return $v }
 100     return $def
 101 }
 102
 103
 104 proc define {enum val name argnames body} {
 105     upvar #0 enum/val2name/$enum v2n
 106     upvar #0 enum/name2val/$enum n2v
 107     set v2n($val) $name
 108     set n2v($name) $val
 109     proc enum/val/$enum/$val $argnames $body
 110 }
 111
 112 proc depending-on {scope enum_and_var mtu mtuadjust args} {
 113     upvar 1 $enum_and_var val
 114     set mtu [expr {$mtu + $mtuadjust}]
 115     set procname enum/val/$scope-$enum_and_var/[format %d $val]
 116     if {[choice-prob $enum_and_var-unstruct 0.1] ||
 117             [catch { info body $procname }]} {
 118         # half the time random
 119         getlog (junk)
 120         get-for $scope-fill
 121         get data rand 0 $mtu
 122         return $data
 123     } else {
 124         uplevel 1 [list $procname] $mtu $args
 125     }
 126 }
 127
 128
 129 proc get-for {scope} {
 130     upvar 1 get/scope ns
 131     set ns $scope
 132 }
 133
 134 proc get {variable kind args} {
 135     upvar 1 get/scope scope
 136     upvar 1 $variable var
 137     set var [eval [list get/$kind $scope $variable] $args]
 138 }
 139
 140 proc get-config/number {val min max} { return $val }
 141 proc get-config/v4addr {val} {
 142     if {![regexp {^(\d+)\.(\d+)\.(\d+)\.(\d+)$} $val dummy a b c d]} {
 143         error "bad v4addr ?$val?"
 144     }
 145     return [format 0x%02x%02x%02x%02x $a $b $c $d]
 146 }
 147
 148 proc get-config {variable def kind args} {
 149     # args currently ignored
 150     upvar 1 get/scope scope
 151     upvar 1 $variable var
 152     set val [config $scope-$variable $def]
 153     set var [eval [list get-config/$kind $val] $args]
 154 }
 155
 156 proc get-enum-got {s v rv} {
 157     upvar #0 enum/val2name/$s-$v v2n
 158     if {[info exists v2n($rv)]} {
 159         getlog "$v=$v2n($rv)\[$rv]"
 160     } else {
 161         getlog "$v=$rv"
 162     }
 163     return $rv
 164 }
 165
 166 proc get/enum-rand {s v min max} {
 167     set rv [choice-int $min $max]
 168     return [get-enum-got $s $v $rv]
 169 }
 170
 171 proc get/enum-def {s v} {
 172     upvar #0 enum/val2name/$s-$v v2n
 173     set rv [choice-int 1 [array size v2n]]
 174     set rv [lindex [array names v2n] [expr {$rv-1}]]
 175     return [get-enum-got $s $v $rv]
 176 }
 177
 178 proc get/enum {s v min max prand} {
 179     get-for $s-$v
 180     get any choice $prand
 181     if {$any} {
 182         return [get/enum-rand $s $v $min $max]
 183     } else {
 184         return [get/enum-def $s $v]
 185     }
 186 }
 187
 188 proc get/number {s v min max} {
 189     set rv [choice-int $min $max]
 190     getlog "$v=$rv"
 191     return $rv
 192 }
 193
 194 proc get/flag {s v defprob} {
 195     set rv [choice-prob $s-$v $defprob]
 196     if {$rv} { getlog "$v" } else { getlog "!$v" }
 197     return $rv
 198 }
 199
 200 proc get/choice {s v defprob} {
 201     set rv [choice-prob $s-$v $defprob]
 202     if {$rv} { getlog "($v)" } else { getlog "(!$v)" }
 203     return $rv
 204 }
 205
 206 proc get/rand {s v minlen maxlen} {
 207     get-for $s-$v
 208     get l number $minlen $maxlen
 209     return [random-bytes $l]
 210 }
 211
 212 proc get/ip-timestamp {s v} {
 213     set rv [expr {[clock seconds] | 0x80000000}]
 214     getlog "$v=[format %x $rv]"
 215     return $rv
 216 }
 217
 218 proc get/v4addr {s v} {
 219     set rv 0x
 220     set p {}
 221     set d {}
 222     for {set i 0} {$i<4} {incr i} {
 223         set b [random-bytes 1]
 224         append rv $b
 225         append p $d [format %d 0x$b]
 226         set d .
 227     }
 228     getlog "$v=$p"
 229     return $rv
 230 }
 231
 232 proc get/choice-mult {s v args} {
 233     set rv [eval choice-mult $args]
 234     getlog "($rv)"
 235     return $rv
 236 }
 237
 238 proc get/string {s v minlen maxlen first rest} {
 239     set o {}
 240     set now $first
 241     for {set l [choice-int $minlen $maxlen]} {$l>0} {incr l -1} {
 242         set cn [choice-int 0 [expr {[string length $now]-1}]]
 243         append o [string index $now $cn]
 244         set now $rest
 245     }
 246     getlog "$v=\"$o\""
 247     return $o
 248 }
 249
 250
 251 proc assemble {outvarname format} {
 252     # format should look like those RFC diagrams.
 253     # +-+-+ stuff and good formatting is mandatory.
 254     # Tabs are forbidden.
 255     #
 256     # Field names are converted to lowercase; internal spaces
 257     # are replaced with _.  They are then assumed to be
 258     # variable names in the caller's scope.  The packet is
 259     # assembled from those values (which must all be set)
 260     # and stored in $varname in the caller's scope.
 261     #
 262     # Variables ?_whatever will be *set* with the location of the
 263     # field in the string (in internal format); the corresponding
 264     # `whatever' (with the ?_ stripped) will be read when assembling.
 265     #
 266     # Field name `0' means set the field to zero.
 267
 268     upvar 1 $outvarname out
 269     set out {}
 270     set lno 0
 271     debug 7 "ASSEMBLY $outvarname\n$format"
 272     foreach l [split $format "\n"] {
 273         incr lno
 274         if {[regexp -nocase {^ *\| +\| *$} $l]} {
 275             if {![info exists wordbits]} {
 276                 error "vspace not in data @$lno\n?$l?"
 277             }
 278             incr words
 279         } elseif {[regexp -nocase {^ *[|? a-z0-9]+$} $l]} {
 280             if {[info exists words]} {
 281                 error "data without delimline @$lno\n?$l?"
 282             }
 283             set words 1
 284             set cue $l
 285         } elseif {[regexp {^ *[-+]+ *$} $l]} {
 286             set wordbits 0
 287             set newlineform {}
 288             while {[regexp {^([-= ]+)\+(.*)$} $l dummy before after]} {
 289                 set atpos([string length $before]) $wordbits
 290                 incr wordbits
 291                 set l "$before=$after"
 292                 append newlineform "@[string length $before]:$wordbits "
 293             }
 294             incr wordbits -1
 295             append newlineform $wordbits
 296             if {[info exists lineform]} {
 297                 if {"$newlineform" != "$lineform"} {
 298  error "format change @$lno\n?$l?\n$wordformat != $oldwordformat"
 299                 }
 300                 if {![info exists words] || $words<0} {
 301                     error "consecutive delimlines @$lno\n?$l?"
 302                 }
 303                 append out [string repeat 00 [expr {$words*$wordbits/8}]]
 304                 set l $cue
 305                 while {[regexp -nocase \
 306                         {^([ =]*)\|( *[? a-z0-9]*[a-z0-9] *)\|(.*)$} \
 307                         $l dummy before midpart after]} {
 308                     debug 7 "RWORKG ?$l?"
 309                     set varname [string tolower [string trim $midpart]]
 310                     set varname [string map {{ } _} $varname]
 311                     set p1 [string length $before]
 312                     set p2 [expr {
 313                         [string length $before] +
 314                         [string length $midpart] + 1
 315                     }]
 316                     if {![info exists atpos($p1)] ||
 317                         ![info exists atpos($p2)]} {
 318  error "vdelims not found @$lno $varname $p1 $p2 -- $lineform ?$cue?"
 319                     }
 320                     set bit1 [expr {
 321                         [string length $out]*4
 322                         - $words*$wordbits
 323                         + $atpos($p1)
 324                     }]
 325                     set bitlen [expr {
 326                         $atpos($p2) - $atpos($p1) + ($words-1)*$wordbits
 327                     }]
 328                     set location [list $bit1 $bitlen $outvarname-$varname]
 329                     if {[regexp {^\?_(.*)} $varname dummy realvarname]} {
 330                         debug 7 "LOCATING $varname $location"
 331                         upvar 1 $varname locvarname
 332                         set locvarname $location
 333                         set varname $realvarname
 334                     }
 335                     if {"$varname" == "0"} {
 336                         set value 0
 337                     } else {
 338                         set value [uplevel 1 [list set $varname]]
 339                     }
 340                     assembly-overwrite out $location $value
 341                     set l "$before="
 342                     append l [string repeat = [string length $midpart]]
 343                     append l |$after
 344                 }
 345                 debug 7 "REMAIN ?$l?"
 346             } else {
 347                 if {$wordbits % 8 || $wordbits >32} {
 348                     error "bad wordbits $wordbits @$lno ?$l? $newlineform"
 349                 }
 350                 set lineform $newlineform
 351             }
 352             catch { unset words }
 353         } elseif {[regexp {^ *$} $l]} {
 354         } else {
 355             error "huh? @$lno ?$l?"
 356         }
 357     }
 358     debug 7 "ASSEMBLY\n$out\n"
 359     return $out
 360 }
 361
 362 proc assembly-overwrite {outvarname location value} {
 363     upvar 1 $outvarname out
 364     manyset $location bit1 bitlen diag
 365     debug 8 "ASSEMBLY $diag == $value == 0x[format %x $value] (@$bit1+$bitlen)"
 366     if {$bitlen < 32 && $value >= (1<<$bitlen)} {
 367         error "$diag $value >= 2**$bitlen"
 368     }
 369     if {!($bit1 % 8) && !($bitlen % 8)} {
 370         set char0no [expr {$bit1/4}]
 371         set charlen [expr {$bitlen/4}]
 372         set chareno [expr {$char0no + $charlen -1}]
 373         set repl [format %0${charlen}x $value]
 374         set out [string replace $out $char0no $chareno $repl]
 375     } else {
 376         while {$bitlen > 0} {
 377             set byteno [expr {$bit1 / 8}]
 378             set char0no [expr {$byteno*2}]
 379             set char1no [expr {$char0no+1}]
 380             set bytebit [expr {128>>($bit1 % 8)}]
 381             set byte 0x[string range $out $char0no $char1no]
 382             debug 7 "< $bit1+$bitlen $byteno $char0no $bytebit $byte $out"
 383             set byte [expr {
 384                 ($value & (1<<($bitlen-1)))
 385                 ? ($byte | $bytebit)
 386                 : ($byte & ~$bytebit)
 387             }]
 388             set out [string replace $out $char0no $char1no [format %02x $byte]]
 389  debug 8 "> $bit1+$bitlen $byteno $char0no $bytebit 0x[format %02x $byte] $out"
 390             incr bitlen -1
 391             incr bit1
 392         }
 393     }
 394 }
 395
 396
 397 proc gen_1_ip {mtu} {
 398     # RFC791
 399     upvar #0 ip_proto proto
 400     upvar #0 ip_source source
 401     upvar #0 ip_dest dest
 402     get-for ip
 403     set version 4
 404     get tos number 0x00 0xff
 405     get id number 0x0000 0xffff
 406     get df flag 0.5
 407     if {$df} {
 408         set mf 0
 409         set frag 0
 410     } {
 411         get mf flag 0.5
 412         get frag number 0 0x1fff
 413     }
 414     get-config ttl 255 number 0 255
 415     get proto enum 1 255 0.05
 416     get-config source 127.0.0.1 v4addr
 417     get-config dest 127.0.0.1 v4addr
 418     # we don't do any IP options
 419     set ihl 5
 420     set body [depending-on ip proto $mtu [expr {-4*$ihl}]]
 421     set total_length [expr {$ihl + [packet-len $body]}]
 422     set header_checksum 0
 423     set flags [expr {$df*2 + $mf}]
 424     assemble ip {
 425    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 426    |Version|  IHL  |TOS            |         Total Length          |
 427    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 428    |         Id                    |Flags|      Frag               |
 429    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 430    |  TTL          |    Proto      |      ? Header Checksum        |
 431    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 432    |                       Source                                  |
 433    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 434    |                    Dest                                       |
 435    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 436     }
 437     assembly-overwrite ip ${?_header_checksum} [packet-csum-ip $ip]
 438     append ip $body
 439     return $ip
 440 }
 441
 442 define ip-proto 1 icmp {mtu} {
 443     # RFC792
 444     get-for icmp
 445     get type enum 0 255 0.2
 446     manyset [depending-on icmp type $mtu -4] body code
 447     if {![string length $code]} { get code number 0 255 }
 448     set checksum 0
 449     assemble icmp {
 450    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 451    |     Type      |     Code      |        ? Checksum             |
 452    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 453     }
 454     append icmp $body
 455     assembly-overwrite icmp ${?_checksum} [packet-csum-ip $icmp]
 456     return $icmp
 457 }
 458
 459 proc define-icmp-type-vanilla {num name} {
 460     define icmp-type $num $name {mbl} "icmp-vanilla \$mbl [list $name]"
 461 }
 462 proc icmp-vanilla {mbl typename} {
 463     get-for icmp-$typename
 464     get code enum 0 255 0.4
 465     get body rand 0 $mbl
 466     return [list $body $code]
 467 }
 468
 469 define-icmp-type-vanilla 3 unreach
 470 define icmp-unreach-code 0 net {} {}
 471 define icmp-unreach-code 1 host {} {}
 472 define icmp-unreach-code 2 proto {} {}
 473 define icmp-unreach-code 3 port {} {}
 474 define icmp-unreach-code 4 fragneeded {} {}
 475 define icmp-unreach-code 5 sourceroutefail {} {}
 476
 477 define-icmp-type-vanilla 11 timeout
 478 define icmp-timeout-code 0 intransit {} {}
 479 define icmp-timeout-code 1 fragment {} {}
 480
 481 define-icmp-type-vanilla 12 parameters
 482 define icmp-parameters-code 0 seepointer {} {}
 483
 484 define-icmp-type-vanilla 4 sourcequench
 485 define icmp-sourcequench-code 0 quench {} {}
 486
 487 define icmp-type 5 redirect {mbl} {
 488     get-for icmp-redirect
 489     get code enum 0 255 0.4
 490     get gateway v4addr
 491     assemble body {
 492    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 493    |                 Gateway                                       |
 494    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 495     }
 496     get data rand 0 [expr {$mbl-4}]
 497     append body $data
 498     return [list $body $code]
 499 }
 500
 501 define icmp-redirect-code 0 net {} {}
 502 define icmp-redirect-code 1 host {} {}
 503 define icmp-redirect-code 2 net+tos {} {}
 504 define icmp-redirect-code 3 host+tos {} {}
 505
 506 define icmp-type 8 ping {mbl} { icmp-echo $mbl }
 507 define icmp-type 0 pong {mbl} { icmp-echo $mbl }
 508 proc icmp-echo {mbl} {
 509     get-for icmp-echo
 510     get code enum 0 255 0.4
 511     get id number 0 0xffff
 512     get seq number 0 0xffff
 513     assemble body {
 514    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 515    |       Id                      |        Seq                    |
 516    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 517     }
 518     get data rand 0 [expr {$mbl-8}]
 519     append body $data
 520     return [list $body $code]
 521 }
 522 define icmp-echo-code 0 echo {} {}
 523
 524 define icmp-type 13 timestamp {mbl} { icmp-timestamp }
 525 define icmp-type 14 timestampreply {mbl} { icmp-timestamp }
 526 proc icmp-timestamp {} {
 527     get-for icmp-timestamp
 528     get code enum 0 255 0.4
 529     get id number 0 0xffff
 530     get seq number 0 0xffff
 531     get originate ip-timestamp
 532     get receive ip-timestamp
 533     get transmit ip-timestamp
 534     assemble body {
 535    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 536    |           Id                  |        Seq                    |
 537    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 538    |     Originate                                                 |
 539    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 540    |     Receive                                                   |
 541    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 542    |     Transmit                                                  |
 543    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 544     }
 545     return [list $body $code]
 546 }
 547 define icmp-timestamp-code 0 timestamp {} {}
 548
 549 define icmp-type 15 inforequest {mbl} { icmp-inforeq }
 550 define icmp-type 16 inforeply {mbl} { icmp-inforeq }
 551 proc icmp-inforeq {} {
 552     get-for icmp-inforeq
 553     get code enum 0 255 0.4
 554     get id number 0 0xffff
 555     get seq number 0 0xffff
 556     assemble body {
 557    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 558    |           Id                  |        Seq                    |
 559    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 560     }
 561     return [list $body $code]
 562 }
 563 define icmp-inforeq-code 0 timestamp {} {}
 564
 565 # MAYADD ICMP traceroute RFC1393
 566 # MAYADD ICMP router discovery RFC1256
 567
 568 proc port_pair_data {scope mtu mtuadjust} {
 569     get-for $scope
 570
 571     get style choice-mult \
 572             request 0.24 \
 573             reply 0.24 \
 574             random 0.16 \
 575             servers
 576
 577     if {"$style" != "random"} {
 578         get port enum-def
 579         set def_port $port
 580     }
 581     if {"$style" != "servers"} {
 582         get port enum-rand 0 0xffff
 583         set rand_port $port
 584     }
 585     switch -exact $style {
 586         random  { set source_port $rand_port; set dest_port $rand_port }
 587         request { set source_port $rand_port; set dest_port $def_port }
 588         reply   { set source_port $def_port;  set dest_port $rand_port }
 589         servers { set source_port $def_port;  set dest_port $def_port }
 590     }
 591     if {"$style" != "random"} {
 592         set port $def_port
 593         set data [depending-on $scope port $mtu $mtuadjust $style]
 594     } else {
 595         get data rand 0 [expr {$mtu + $mtuadjust}]
 596     }
 597     return [list $source_port $dest_port $data]
 598 }
 599
 600 define ip-proto 17 udp {mtu} {
 601     get-for udp
 602     get checksum choice-mult \
 603             checksum_bad 0.20 \
 604             checksum_none 0.20 \
 605             checksum_good
 606     manyset [port_pair_data udp $mtu 8] source_port dest_port data
 607     set length [packet-len $data]
 608     set checksum 0
 609     assemble udp {
 610    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 611    |       Source Port             |        Dest Port              |
 612    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 613    |         Length                |      ? Checksum               |
 614    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 615     }
 616     append udp $data
 617     if {"$checksum" != "none"} {
 618         set csum [packet-csum-ip $udp]
 619         if {!$csum} { set csum 0xffff }
 620         if {"$checksum" == "bad"} {
 621             get error number 1 0xffff
 622             set csum [expr {$csum ^ $error}]
 623         }
 624     } else {
 625         set csum 0
 626     }
 627     assembly-overwrite udp ${?_checksum} $csum
 628 }
 629
 630 define udp-port 50 remailck {mtu style} {
 631     get-for remailck
 632     if {"$style" == "request"} {
 633         get what choice-mult \
 634                 req-baduser 0.15 \
 635                 req-auth 0.15 \
 636                 resp-ok 0.15 \
 637                 resp-auth 0.15 \
 638                 req-user
 639     } else {
 640         get what choice-mult \
 641                 req-baduser 0.15 \
 642                 req-auth 0.15 \
 643                 resp-auth 0.15 \
 644                 req-user 0.15 \
 645                 resp-ok
 646     }
 647     switch -exact $what {
 648         req-user {
 649             set auth 0
 650             get user string 1 8 \
 651                     abcdefghijklmnopqrustuvwxyz \
 652                     abcdefghijklmnopqrustuvwxyz-0123456789_
 653         }
 654         req-baduser {
 655             set auth 0
 656             get user rand 0 [expr {$mtu - 4}]
 657         }
 658         req-auth {
 659             get auth enum 0 31
 660             set user [depending-on auth {$mtu - 4}]
 661         }
 662         resp-auth {
 663             get auth number 0 0xffff
 664             set modified 0
 665             set read 0
 666         }
 667         resp-ok {
 668             get mail choice-mult \
 669                     newmail 0.15 \
 670                     oldmail 0.15 \
 671                     nomail 0.20 \
 672                     times
 673             set auth 0
 674             switch -exact $mail {
 675                 newmail {
 676                     set modified 0
 677                     set read 1
 678                 }
 679                 oldmail {
 680                     set modified 1
 681                     set read 0
 682                 }
 683                 nomail {
 684                     set modified 0
 685                     set read 0
 686                 }
 687                 times {
 688                     get modified number 1 600
 689                     get read number 1 600
 690                 }
 691                 default { error "mail? $mail" }
 692             }
 693         }
 694         default { error "what? $what" }
 695     }
 696     switch -glob $what {
 697         req-* {
 698             assemble packet {
 699    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 700    |         Auth                                                  |
 701    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 702             }
 703             append packet $user
 704         }
 705         resp-* {
 706             assemble packet {
 707    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 708    |         Auth                                                  |
 709    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 710    |         Modified                                              |
 711    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 712    |         Read                                                  |
 713    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 714             }
 715         }
 716         default { error "what?? $what" }
 717     }
 718     return $packet
 719 }
 720
 721 proc emit {count} {
 722     global getlog_log errorInfo
 723     if {[catch {
 724         start_gen $count
 725         set packet [gen_1_ip 576]
 726         puts stdout "[format %06d $count] $getlog_log\n       $packet"
 727     } emsg]} {
 728         puts stderr "\nERROR\n$count\n\n$emsg\n\n$errorInfo\n\n"
 729         puts stdout "[format %06d $count] error"
 730     }
 731 }
 732
 733 if {![llength $argv]} {
 734     for {set count 1} {$count < 100} {incr count} { emit $count }
 735 } elseif {"$argv" == "--infinite"} {
 736     set count 1
 737     while 1 { emit $count; incr count }
 738 } else {
 739     foreach count $argv { emit $count }
 740 }