make-probes.tcl

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