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