make-probes.tcl

   1 #!/usr/bin/tclsh8.2
   2
   3
   4 proc debug {level str} {
   5     global debug_level
   6     if {$level <= $debug_level} { puts stderr "debug\[$level] $str" }
   7 }
   8
   9 proc manyset {list args} {
  10     foreach val $list var $args {
  11         upvar 1 $var my
  12         set my $val
  13     }
  14 }
  15
  16
  17 proc start_gen {use_gen_counter} {
  18     global gen_counter rand_counter getlog_log rand_buf
  19     random-bytes-init $use_gen_counter
  20     set getlog_log {}
  21 }
  22
  23 proc packet-len {p} { expr {[string length $p]/2} }
  24
  25 proc packet-csum-ip {packet} {
  26     set cs 0
  27     append packet 00
  28     while {[regexp {^([0-9a-f]{4})(.*)$} $packet dummy this packet]} {
  29         set cs [expr "\$cs + 0x$this"]
  30         debug 7 [format "0x%s 0x%08x" $this $cs]
  31     }
  32     return [expr {(($cs & 0xffff) + (($cs >> 16) & 0xffff)) ^ 0xffff}]
  33 }
  34
  35 proc packet-fromstring {s} {
  36     binary scan $s H* y
  37     return $y
  38 }
  39
  40 namespace eval Random-Bytes {
  41     namespace export random-bytes random-bytes-init
  42
  43     proc random-bytes-init {seed} {
  44         variable counter
  45         variable fh
  46         catch { set h $fh; unset fh; close $h }
  47         set counter 0
  48         set fh [open |[list openssl bf-ofb < /dev/zero -e -k " $seed"] r]
  49         fconfigure $fh -translation binary
  50     }
  51     proc random-bytes {n} {
  52         variable fh
  53         set x [read $fh $n]
  54         if {[string length $x] != $n} {
  55             set h $fh; unset fh; close $h
  56             error "openssl bf-ofb exited unexpectedly"
  57         }
  58         set y [packet-fromstring $x]
  59         return $y
  60     }
  61 }
  62
  63 namespace import Random-Bytes::*
  64
  65 proc choice-int {min max} {
  66     set rv 0x[random-bytes 3]
  67     return [expr {
  68         int( double($rv) / double(0x1000000) * double($max+1-$min) )
  69         + $min
  70     }]
  71 }
  72
  73 proc choice-prob {cv def} {
  74     set prob [config $cv $def]
  75     set rv 0x[random-bytes 3]
  76     return [expr {$rv < double($prob)*0x1000000}]
  77 }
  78
  79 proc choice-mult {args} {
  80     if {!([llength $args] % 2)} { error "choice-mult must have default" }
  81     set x 0x[random-bytes 3]
  82     set x [expr { double($x) / double(0x1000000) }]
  83     set cump 0.0
  84     set def [lindex $args end]
  85     set args [lreplace $args end end]
  86     foreach {val p} $args {
  87         set cump [expr {$cump + double($p)}]
  88         if {$x < $cump} { return $val }
  89     }
  90     return $def
  91 }
  92
  93 proc getlog {msg} {
  94     upvar #0 getlog_log log
  95     append log " $msg"
  96     debug 2 "getlog $msg"
  97 }
  98
  99 proc config {cv def} {
 100     upvar #0 config/$cv v
 101     if {[info exists v]} { return $v }
 102     return $def
 103 }
 104
 105
 106 proc define {enum val name argnames body} {
 107     upvar #0 enum/val2name/$enum v2n
 108     upvar #0 enum/name2val/$enum n2v
 109     set v2n($val) $name
 110     set n2v($name) $val
 111     proc enum/val/$enum/$val $argnames $body
 112 }
 113
 114 proc depending-on {scope enum_and_var mtu mtuadjust args} {
 115     upvar 1 $enum_and_var val
 116     set mtu [expr {$mtu + $mtuadjust}]
 117     set procname enum/val/$scope-$enum_and_var/[format %d $val]
 118     if {[choice-prob $enum_and_var-unstruct 0.1] ||
 119             [catch { info body $procname }]} {
 120         getlog (junk)
 121         get-for $scope-fill
 122         get data rand 0 $mtu
 123         return $data
 124     } else {
 125         uplevel 1 [list $procname] $mtu $args
 126     }
 127 }
 128
 129
 130 proc get-for {scope} {
 131     upvar 1 get/scope ns
 132     set ns $scope
 133 }
 134
 135 proc get {variable kind args} {
 136     upvar 1 get/scope scope
 137     upvar 1 $variable var
 138     set var [eval [list get/$kind $scope $variable] $args]
 139 }
 140
 141 proc get-config/number {val min max} { return $val }
 142 proc get-config/v4addr {val} {
 143     if {![regexp {^(\d+)\.(\d+)\.(\d+)\.(\d+)$} $val dummy a b c d]} {
 144         error "bad v4addr ?$val?"
 145     }
 146     return [format 0x%02x%02x%02x%02x $a $b $c $d]
 147 }
 148
 149 proc get-config {variable def kind args} {
 150     # args currently ignored
 151     upvar 1 get/scope scope
 152     upvar 1 $variable var
 153     set val [config $scope-$variable $def]
 154     set var [eval [list get-config/$kind $val] $args]
 155 }
 156
 157 proc get-enum-got {s v rv} {
 158     upvar #0 enum/val2name/$s-$v v2n
 159     if {[info exists v2n($rv)]} {
 160         getlog "$v=$v2n($rv)\[$rv]"
 161     } else {
 162         getlog "$v=$rv"
 163     }
 164     return $rv
 165 }
 166
 167 proc get/enum-rand {s v min max} {
 168     set rv [choice-int $min $max]
 169     return [get-enum-got $s $v $rv]
 170 }
 171
 172 proc get/enum-def {s v} {
 173     upvar #0 enum/val2name/$s-$v v2n
 174     set rv [choice-int 1 [array size v2n]]
 175     set rv [lindex [array names v2n] [expr {$rv-1}]]
 176     return [get-enum-got $s $v $rv]
 177 }
 178
 179 proc get/enum {s v min max prand} {
 180     get-for $s-$v
 181     get any choice $prand
 182     if {$any} {
 183         return [get/enum-rand $s $v $min $max]
 184     } else {
 185         return [get/enum-def $s $v]
 186     }
 187 }
 188
 189 proc get/number {s v min max} {
 190     set rv [choice-int $min $max]
 191     getlog "$v=$rv"
 192     return $rv
 193 }
 194
 195 proc get/hex {s v min max} {
 196     set rv [choice-int $min $max]
 197     getlog [format %s=0x%x $v $rv]
 198     return $rv
 199 }
 200
 201 proc get/hex32 {s v} {
 202     set rv [random-bytes 4]
 203     getlog "$v=0x$rv"
 204     return 0x$rv
 205 }
 206
 207 proc get/flag {s v defprob} {
 208     set rv [choice-prob $s-$v $defprob]
 209     if {$rv} { getlog "$v" } else { getlog "!$v" }
 210     return $rv
 211 }
 212
 213 proc get/choice {s v defprob} {
 214     set rv [choice-prob $s-$v $defprob]
 215     if {$rv} { getlog "($v)" } else { getlog "(!$v)" }
 216     return $rv
 217 }
 218
 219 proc get/rand {s v minlen maxlen} {
 220     get-for $s-$v
 221     if {$maxlen<0} { getlog (full!); return {} }
 222     get l number $minlen $maxlen
 223     return [random-bytes $l]
 224 }
 225
 226 proc get/ip-timestamp {s v} {
 227     set rv [expr {[clock seconds] | 0x80000000}]
 228     getlog "$v=[format %x $rv]"
 229     return $rv
 230 }
 231
 232 proc get/v4addr {s v} {
 233     set rv 0x
 234     set p {}
 235     set d {}
 236     for {set i 0} {$i<4} {incr i} {
 237         set b [random-bytes 1]
 238         append rv $b
 239         append p $d [format %d 0x$b]
 240         set d .
 241     }
 242     getlog "$v=$p"
 243     return $rv
 244 }
 245
 246 proc get/choice-mult {s v args} {
 247     set rv [eval choice-mult $args]
 248     getlog "($rv)"
 249     return $rv
 250 }
 251
 252 proc get/string {s v minlen maxlen first rest} {
 253     set o {}
 254     set now $first
 255     for {set l [choice-int $minlen $maxlen]} {$l>0} {incr l -1} {
 256         set cn [choice-int 0 [expr {[string length $now]-1}]]
 257         append o [string index $now $cn]
 258         set now $rest
 259     }
 260     getlog "$v=\"$o\""
 261     return [packet-fromstring $o]
 262 }
 263
 264
 265 namespace eval Assembler {
 266     namespace export assemble assembly-overwrite
 267
 268     proc assemble {outvarname format} {
 269         # format should look like those RFC diagrams.  +-+-+ stuff and
 270         # good formatting is mandatory.  You can have a single data
 271         # item at the end ending in ..., which means append that data
 272         # item.
 273         #
 274         # Field names are converted to lowercase; internal spaces
 275         # are replaced with _.  They are then assumed to be
 276         # variable names in the caller's scope.  The packet is
 277         # assembled from those values (which must all be set)
 278         # and stored in $varname in the caller's scope.
 279         #
 280         # Variables ?_whatever will be *set* with the location of the
 281         # field in the string (in internal format); the corresponding
 282         # `whatever' (with the ?_ stripped) will be read when assembling.
 283         #
 284         # Field names starting with digits are literal values instead.
 285
 286         variable cache
 287         upvar 1 $outvarname out
 288         if {[catch { set parsed $cache($format) }]} {
 289             set parsed [parse $format]
 290             set cache($format) $parsed
 291         }
 292
 293         manyset $parsed outbytes lout
 294         set out [string repeat 00 $outbytes]
 295         foreach {?_location varname locvarname} $lout {
 296             if {[regexp {^[0-9]} $varname]} {
 297                 set value $varname
 298             } else {
 299                 set value [uplevel 1 [list set $varname]]
 300             }
 301             if {[string length $locvarname]} {
 302                 upvar 1 $locvarname lv
 303                 set lv ${?_location}
 304             }
 305             if {[catch {
 306                 assembly-overwrite out location $value
 307             } emsg]} {
 308                 global errorInfo errorCode
 309                 error $emsg \
 310                         "$errorInfo\n    setting\n$varname at ${?_location}" \
 311                         $errorCode
 312             }
 313         }
 314     }
 315
 316     proc parse {format} {
 317         set lno 0
 318         set outbytes 0
 319         set atend 0
 320         debug 7 "ASSEMBLY $format"
 321         set format [exec expand << $format]
 322         foreach l [split $format "\n"] {
 323             incr lno
 324             if {[regexp -nocase {^ *\| +\| *$} $l]} {
 325                 if {![info exists wordbits]} {
 326                     error "vspace not in data @$lno\n?$l?"
 327                 }
 328                 incr words
 329             } elseif {[regexp -nocase {^ *[|? a-z0-9.]+$} $l]} {
 330                 if {[info exists words]} {
 331                     error "data without delimline @$lno\n?$l?"
 332                 }
 333                 set words 1
 334                 set cue $l
 335             } elseif {[regexp {^ *[-+]+ *$} $l]} {
 336                 set wordbits 0
 337                 set newlineform {}
 338                 while {[regexp {^([-= ]+)\+(.*)$} $l dummy before after]} {
 339                     set atpos([string length $before]) $wordbits
 340                     incr wordbits
 341                     set l "$before=$after"
 342                     append newlineform "@[string length $before]:$wordbits "
 343                 }
 344                 incr wordbits -1
 345                 append newlineform $wordbits
 346                 if {[info exists lineform]} {
 347                     if {"$newlineform" != "$lineform"} {
 348  error "format change @$lno\n?$l?\n$wordformat != $oldwordformat"
 349                     }
 350                     if {![info exists words] || $words<0} {
 351                         error "consecutive delimlines @$lno\n?$l?"
 352                     }
 353                     incr outbytes [expr {$words*$wordbits/8}]
 354                     set l $cue
 355                     while {[regexp -nocase \
 356                             {^([ =]*)\|( *[? a-z0-9]*[a-z0-9] *\.* *)\|(.*)$} \
 357                             $l dummy before midpart after]} {
 358                         debug 7 "RWORKG ?$l?"
 359                         if {$atend} {
 360                             error "two things at end @$lno\n?$l?"
 361                         }
 362                         set varname [string tolower [string trim $midpart]]
 363                         if {[regexp {(.*[a-z0-9])\s*\.\.\.$} $varname \
 364                                 dummy realvarname]} {
 365                             set varname $realvarname
 366                             set atend 1
 367                         }
 368                         set varname [string map {{ } _} $varname]
 369                         set p1 [string length $before]
 370                         set p2 [expr {
 371                             [string length $before] +
 372                             [string length $midpart] + 1
 373                         }]
 374                         if {![info exists atpos($p1)] ||
 375                             ![info exists atpos($p2)]} {
 376  error "vdelims not found @$lno $varname $p1 $p2 -- $lineform ?$cue?"
 377                         }
 378                         set bit1 [expr {
 379                             $outbytes*8
 380                             - $words*$wordbits
 381                             + $atpos($p1)
 382                         }]
 383                         set bitlen [expr {
 384                             $atpos($p2) - $atpos($p1) + ($words-1)*$wordbits
 385                         }]
 386                         if {$atend} {
 387                             if {$bit1 % 8} {
 388                                 error "atend not at byte @$lno\n?$l?"
 389                             }
 390                             set outbytes [expr {$bit1/8}]
 391                             set location [list $bit1 0 $varname]
 392                         } else {
 393                             set location [list $bit1 $bitlen $varname]
 394                         }
 395                         if {[regexp {^\?_(.*)} $varname dummy realvarname]} {
 396                             debug 7 "LOCATING $varname $location"
 397                             set locvarname $varname
 398                             set varname $realvarname
 399                         } else {
 400                             set locvarname {}
 401                         }
 402                         lappend lout $location $varname $locvarname
 403                         set l "$before="
 404                         append l [string repeat = [string length $midpart]]
 405                         append l |$after
 406                     }
 407                     debug 7 "REMAIN ?$l?"
 408                     if {![regexp {^[ =]*\|? *$} $l]} {
 409                         error "unclear @$lno\n?$l?"
 410                     }
 411                 } else {
 412                     if {$wordbits % 8 || $wordbits >32} {
 413                         error "bad wordbits $wordbits @$lno ?$l? $newlineform"
 414                     }
 415                     set lineform $newlineform
 416                 }
 417                 catch { unset words }
 418             } elseif {[regexp {^ *$} $l]} {
 419             } else {
 420                 error "huh? @$lno ?$l?"
 421             }
 422         }
 423         debug 7 "ASSEMBLY\n$outbytes\n$lout\n"
 424         return [list $outbytes $lout]
 425     }
 426
 427     proc assembly-overwrite {outvarname locvarnameex value} {
 428         upvar 1 $outvarname out
 429         upvar 1 ?_$locvarnameex location
 430         manyset $location bit1 bitlen diag
 431         if {$bitlen > 0 && $bitlen != 32 && $value >= (1<<$bitlen)} {
 432             error "$diag $value >= 2**$bitlen"
 433         }
 434         if {!($bit1 % 8) && !($bitlen % 8)} {
 435             set char0no [expr {$bit1/4}]
 436             set charlen [expr {$bitlen/4}]
 437             set chareno [expr {$char0no + $charlen -1}]
 438             if {$bitlen > 0} {
 439  debug 8 "ASSEMBLY $diag == $value == 0x[format %x $value] (@$bit1+$bitlen)"
 440                 set repl [format %0${charlen}x $value]
 441                 set out [string replace $out $char0no $chareno $repl]
 442             } else {
 443  debug 8 "ASSEMBLY-ADD $diag (@$bit1)"
 444                 # bitlen==0 => append
 445                 set out [string range $out 0 $chareno]
 446                 append out $value
 447             }
 448         } else {
 449             while {$bitlen > 0} {
 450                 set byteno [expr {$bit1 / 8}]
 451                 set char0no [expr {$byteno*2}]
 452                 set char1no [expr {$char0no+1}]
 453                 set bytebit [expr {128>>($bit1 % 8)}]
 454                 set byte 0x[string range $out $char0no $char1no]
 455                 debug 7 "< $bit1+$bitlen $byteno $char0no $bytebit $byte $out"
 456                 set byte [expr {
 457                     ($value & (1<<($bitlen-1)))
 458                     ? ($byte | $bytebit)
 459                     : ($byte & ~$bytebit)
 460                 }]
 461                 set out [string replace $out $char0no $char1no \
 462                         [format %02x $byte]]
 463  debug 8 "> $bit1+$bitlen $byteno $char0no $bytebit 0x[format %02x $byte] $out"
 464                 incr bitlen -1
 465                 incr bit1
 466             }
 467         }
 468     }
 469 }
 470 namespace import Assembler::*
 471
 472 proc gen_1_ip {mtu} {
 473     # RFC791
 474     upvar #0 ip_proto proto
 475     upvar #0 ip_source source
 476     upvar #0 ip_dest dest
 477     get-for ip
 478     set version 4
 479     get tos hex 0x00 0xff
 480     get id number 0x0000 0xffff
 481     get df flag 0.5
 482     if {$df || ![choice-prob ip-midfrag 0.05]} {
 483         set mf 0
 484         set frag 0
 485     } {
 486         get mf flag 0.5
 487         get frag number 0 0x1fff
 488     }
 489     get-config ttl 255 number 0 255
 490     get proto enum 1 255 0.05
 491     get-config source 127.0.0.1 v4addr
 492     get-config dest 127.0.0.1 v4addr
 493     set flags [expr {$df*2 + $mf}]
 494
 495     set header_checksum 0
 496     set ihl 0
 497     set total_length 0
 498     assemble ip {
 499    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 500    |Version| ? IHL |TOS            |       ? Total Length          |
 501    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 502    |         Id                    |Flags|      Frag               |
 503    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 504    |  TTL          |    Proto      |      ? Header Checksum        |
 505    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 506    |                       Source                                  |
 507    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 508    |                    Dest                                       |
 509    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 510     }
 511     # we don't do any IP options
 512
 513     set ihl [packet-len $ip]
 514     if {$ihl % 4} { error "ihl not mult of 4 bytes" }
 515     assembly-overwrite ip ihl [expr {$ihl / 4}]
 516
 517     set body [depending-on ip proto $mtu -$ihl]
 518     set total_length [expr {[packet-len $ip] + [packet-len $body]}]
 519
 520     assembly-overwrite ip total_length $total_length
 521     assembly-overwrite ip header_checksum [packet-csum-ip $ip]
 522
 523     append ip $body
 524     return $ip
 525 }
 526
 527 define ip-proto 1 icmp {mtu} {
 528     # RFC792
 529     get-for icmp
 530     get type enum 0 255 0.2
 531     manyset [depending-on icmp type $mtu -4] body code
 532     if {![string length $code]} { get code number 0 255 }
 533     set checksum 0
 534     assemble icmp {
 535    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 536    |     Type      |     Code      |        ? Checksum             |
 537    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 538    |     Body ...                                                  |
 539    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 540     }
 541     assembly-overwrite icmp checksum [packet-csum-ip $icmp]
 542     return $icmp
 543 }
 544
 545 proc define-icmp-type-vanilla {num name} {
 546     define icmp-type $num $name {mbl} "icmp-vanilla \$mbl [list $name]"
 547 }
 548 proc icmp-vanilla {mbl typename} {
 549     get-for icmp-$typename
 550     get code enum 0 255 0.4
 551     get body rand 0 $mbl
 552     return [list $body $code]
 553 }
 554
 555 define-icmp-type-vanilla 3 unreach
 556 define icmp-unreach-code 0 net {} {}
 557 define icmp-unreach-code 1 host {} {}
 558 define icmp-unreach-code 2 proto {} {}
 559 define icmp-unreach-code 3 port {} {}
 560 define icmp-unreach-code 4 fragneeded {} {}
 561 define icmp-unreach-code 5 sourceroutefail {} {}
 562
 563 define-icmp-type-vanilla 11 timeout
 564 define icmp-timeout-code 0 intransit {} {}
 565 define icmp-timeout-code 1 fragment {} {}
 566
 567 define-icmp-type-vanilla 12 parameters
 568 define icmp-parameters-code 0 seepointer {} {}
 569
 570 define-icmp-type-vanilla 4 sourcequench
 571 define icmp-sourcequench-code 0 quench {} {}
 572
 573 define icmp-type 5 redirect {mbl} {
 574     get-for icmp-redirect
 575     get code enum 0 255 0.4
 576     get gateway v4addr
 577     get data rand 0 [expr {$mbl-4}]
 578     assemble body {
 579    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 580    |                 Gateway                                       |
 581    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 582    |     Data ...                                                  |
 583    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 584     }
 585     return [list $body $code]
 586 }
 587
 588 define icmp-redirect-code 0 net {} {}
 589 define icmp-redirect-code 1 host {} {}
 590 define icmp-redirect-code 2 net+tos {} {}
 591 define icmp-redirect-code 3 host+tos {} {}
 592
 593 define icmp-type 8 ping {mbl} { icmp-echo $mbl }
 594 define icmp-type 0 pong {mbl} { icmp-echo $mbl }
 595 proc icmp-echo {mbl} {
 596     get-for icmp-echo
 597     get code enum 0 255 0.4
 598     get id hex 0 0xffff
 599     get seq hex 0 0xffff
 600     get data rand 0 [expr {$mbl-8}]
 601     assemble body {
 602    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 603    |       Id                      |        Seq                    |
 604    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 605    |     Data ...                                                  |
 606    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 607     }
 608     return [list $body $code]
 609 }
 610 define icmp-echo-code 0 echo {} {}
 611
 612 define icmp-type 13 timestamp {mbl} { icmp-timestamp }
 613 define icmp-type 14 timestampreply {mbl} { icmp-timestamp }
 614 proc icmp-timestamp {} {
 615     get-for icmp-timestamp
 616     get code enum 0 255 0.4
 617     get id hex 0 0xffff
 618     get seq hex 0 0xffff
 619     get originate ip-timestamp
 620     get receive ip-timestamp
 621     get transmit ip-timestamp
 622     assemble body {
 623    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 624    |           Id                  |        Seq                    |
 625    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 626    |     Originate                                                 |
 627    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 628    |     Receive                                                   |
 629    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 630    |     Transmit                                                  |
 631    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 632     }
 633     return [list $body $code]
 634 }
 635 define icmp-timestamp-code 0 timestamp {} {}
 636
 637 define icmp-type 15 inforequest {mbl} { icmp-inforeq }
 638 define icmp-type 16 inforeply {mbl} { icmp-inforeq }
 639 proc icmp-inforeq {} {
 640     get-for icmp-inforeq
 641     get code enum 0 255 0.4
 642     get id hex 0 0xffff
 643     get seq hex 0 0xffff
 644     assemble body {
 645    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 646    |           Id                  |        Seq                    |
 647    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 648     }
 649     return [list $body $code]
 650 }
 651 define icmp-inforeq-code 0 timestamp {} {}
 652
 653 # MAYADD ICMP traceroute RFC1393
 654 # MAYADD ICMP router discovery RFC1256
 655
 656 proc port-pair {scope} {
 657     get-for $scope
 658
 659     get style choice-mult \
 660             request 0.24 \
 661             reply 0.24 \
 662             random 0.16 \
 663             servers
 664
 665     if {"$style" != "random"} {
 666         get port enum-def
 667         set def_port $port
 668     } else {
 669         set def_port x
 670     }
 671     if {"$style" != "servers"} {
 672         get port enum-rand 0 0xffff
 673         set rand_port $port
 674     }
 675     switch -exact $style {
 676         random  { set source_port $rand_port; set dest_port $rand_port }
 677         request { set source_port $rand_port; set dest_port $def_port }
 678         reply   { set source_port $def_port;  set dest_port $rand_port }
 679         servers { set source_port $def_port;  set dest_port $def_port }
 680     }
 681     return [list $source_port $dest_port $def_port $style]
 682 }
 683
 684 define ip-proto 17 udp {mtu} {
 685     get-for udp
 686
 687     get checksum choice-mult \
 688             checksum_bad 0.10 \
 689             checksum_none 0.20 \
 690             checksum_good
 691     manyset [port-pair udp] source_port dest_port def_port style
 692
 693     if {"$style" != "random"} {
 694         set port $def_port
 695         set data [depending-on udp port $mtu -8 $style]
 696     } else {
 697         get data rand 0 [expr {$mtu-8}]
 698     }
 699
 700     set length 0
 701     set checksum 0
 702     assemble udp {
 703    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 704    |       Source Port             |        Dest Port              |
 705    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 706    |       ? Length                |      ? Checksum               |
 707    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 708    |     Data ...                                                  |
 709    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 710     }
 711     set udp_length [packet-len $udp]
 712     assembly-overwrite udp length $udp_length
 713
 714     if {"$checksum" != "none"} {
 715         global ip_source ip_dest ip_proto
 716         assemble pseudo {
 717    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 718    |       IP Source                                               |
 719    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 720    |       IP Dest                                                 |
 721    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 722    |       0       | IP Proto      |        UDP length             |
 723    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 724         }
 725         set csum [packet-csum-ip "$pseudo$udp"]
 726         if {!$csum} { set csum 0xffff }
 727         if {"$checksum" == "bad"} {
 728             get csumerror hex 1 0xffff
 729             set csum [expr {$csum ^ $csumerror}]
 730         }
 731     } else {
 732         set csum 0
 733     }
 734     assembly-overwrite udp checksum $csum
 735     return $udp
 736 }
 737
 738 define udp-port 50 remailck {mtu style} {
 739     get-for remailck
 740     if {"$style" == "request"} {
 741         get what choice-mult \
 742                 req-baduser 0.15 \
 743                 req-auth 0.15 \
 744                 resp-ok 0.15 \
 745                 resp-auth 0.15 \
 746                 req-user
 747     } else {
 748         get what choice-mult \
 749                 req-baduser 0.15 \
 750                 req-auth 0.15 \
 751                 resp-auth 0.15 \
 752                 req-user 0.15 \
 753                 resp-ok
 754     }
 755     switch -exact $what {
 756         req-user {
 757             set auth 0
 758             get user string 1 8 \
 759                     abcdefghijklmnopqrustuvwxyz \
 760                     abcdefghijklmnopqrustuvwxyz-0123456789_
 761         }
 762         req-baduser {
 763             set auth 0
 764             get user rand 0 [expr {$mtu - 4}]
 765         }
 766         req-auth {
 767             get auth enum 0 31 0.5
 768             set user [depending-on remailck auth $mtu -4]
 769         }
 770         resp-auth {
 771             get auth hex 0 0xffff
 772             set modified 0
 773             set read 0
 774         }
 775         resp-ok {
 776             get mail choice-mult \
 777                     newmail 0.15 \
 778                     oldmail 0.15 \
 779                     nomail 0.20 \
 780                     times
 781             set auth 0
 782             switch -exact $mail {
 783                 newmail {
 784                     set modified 0
 785                     set read 1
 786                 }
 787                 oldmail {
 788                     set modified 1
 789                     set read 0
 790                 }
 791                 nomail {
 792                     set modified 0
 793                     set read 0
 794                 }
 795                 times {
 796                     get modified number 1 600
 797                     get read number 1 600
 798                 }
 799                 default { error "mail? $mail" }
 800             }
 801         }
 802         default { error "what? $what" }
 803     }
 804     switch -glob $what {
 805         req-* {
 806             assemble payload {
 807    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 808    |         Auth                                                  |
 809    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 810    |     User ...                                                  |
 811    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 812             }
 813         }
 814         resp-* {
 815             assemble payload {
 816    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 817    |         Auth                                                  |
 818    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 819    |         Modified                                              |
 820    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 821    |         Read                                                  |
 822    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 823             }
 824         }
 825         default { error "what?? $what" }
 826     }
 827     return $payload
 828 }
 829
 830 define remailck-auth 31 passwd {mtu} {
 831     get-for remailck-passwd
 832     get passwd string 6 8 \
 833             0123456789abcdefghijklmnopqrstuvxwyz \
 834             0123456789abcdefghijklmnopqrstuvxwyz
 835     return $passwd
 836 }
 837
 838 define ip-proto 6 tcp {mtu} {
 839     get-for tcp
 840
 841     get source_port number 0 65535
 842     get dest_port number 0 65535
 843     get event choice-mult \
 844             connect 0.15 \
 845             accept 0.15 \
 846             close 0.15 \
 847             reset 0.15 \
 848             weird 0.15 \
 849             data
 850     set s 0
 851     set a 1
 852     set f 0
 853     set r 0
 854     switch -exact $event {
 855         connect { set s 1; set a 0 }
 856         accept { set s 1 }
 857         close { set f 1 }
 858         reset { set a 0; set r 1 }
 859         data { }
 860         weird {
 861             get s flag 0.5
 862             get a flag 0.5
 863             get f flag 0.5
 864             get r flag 0.5
 865         }
 866         default { error "event? $event" }
 867     }
 868     get seq hex32
 869     get ack hex32
 870     if {[choice-prob tcp-smallwindow 0.7]} {
 871         get window number 0 1
 872     } else {
 873         get window hex 0 0xffff
 874     }
 875     get p flag 0.5
 876     get u flag 0.3
 877     get urg hex 0 0xffff
 878
 879     set options {}
 880     get optmode choice-mult badopt 0.3 opt 0.6 noopt
 881     switch -exact $optmode {
 882         noopt { }
 883         badopt {
 884             get options rand 1 60
 885         }
 886         opt {
 887             while {[choice-prob tcp-opts-more 0.4]} {
 888                 get opt enum 1 255 0.5
 889                 if {$opt == 1} {
 890                     assemble option {
 891    +-+-+-+-+-+-+-+-+
 892    |  Opt          |
 893    +-+-+-+-+-+-+-+-+
 894                     }
 895                 } else {
 896                     set data [depending-on tcp opt 6 0]
 897                     set option_len 0
 898                     assemble option {
 899    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 900    |  Opt          | ? Option Len  |
 901    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 902    |      Data ...                 |
 903    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 904                     }
 905                     assembly-overwrite option option_len [packet-len $option]
 906                 }
 907                 append options $option
 908             }
 909         }
 910     }
 911
 912     if {[choice-prob reserved-nonzero 0.25]} {
 913         get reserved hex 0 0x3f
 914     } else {
 915         set reserved 0
 916     }
 917
 918     if {[packet-len $options] % 4 || [get optxpad choice 0.15]} {
 919         if {"$optmode" != "badopt"} { append options 00 }
 920         set padlen [expr {3 - ([packet-len $options] + 3) % 4}]
 921         append options [random-bytes $padlen]
 922     }
 923
 924     set d_off 0
 925     set checksum 0
 926     assemble packet {
 927    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 928    |          Source Port          |       Dest Port               |
 929    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 930    |                        Seq                                    |
 931    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 932    |                    Ack                                        |
 933    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 934    |? D Off| Reserved  |U|A|P|R|S|F|            Window             |
 935    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 936    |         ? Checksum            |         Urg                   |
 937    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 938    |                    Options     ...                            |
 939    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 940     }
 941
 942     set d_off [expr {([packet-len $packet]/4) & 0x0f}]
 943     assembly-overwrite packet d_off $d_off
 944
 945     if {!($s || $r) || [get unexpdata flag 0.2]} {
 946         get data rand 0 [expr {$mtu - [packet-len $packet]}]
 947         append packet $data
 948     }
 949     set tcp_length [packet-len $packet]
 950
 951     global ip_source ip_dest ip_proto
 952     assemble pseudo {
 953    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 954    |       IP Source                                               |
 955    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 956    |       IP Dest                                                 |
 957    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 958    |       0       | IP Proto      |        TCP length             |
 959    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 960     }
 961
 962     set csum [packet-csum-ip "$pseudo$packet"]
 963     if {[choice-prob tcp-badcsum 0.1]} {
 964         get csumerror hex 1 0xffff
 965         set csum [expr {$csum ^ $csumerror}]
 966     }
 967     assembly-overwrite packet checksum $csum
 968     return $packet
 969 }
 970
 971 define tcp-opt 2 mss {mdl} {
 972     get-for tcp-opt
 973     get mss hex 0 0xffff
 974     assemble od {
 975    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 976    |        MSS                    |
 977    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 978     }
 979     return $od
 980 }
 981
 982
 983 namespace eval PCap {
 984     namespace export pcap_open pcap_write pcap_write_raw pcap_close
 985
 986     proc pcap_open {fn} {
 987         variable fh
 988         catch { close $fh }
 989         set fh [open $fn w]
 990         fconfigure $fh -translation binary
 991     }
 992
 993     proc pcap_close {} {
 994         variable fh
 995         if {![info exists fh]} return
 996         close $fh
 997         unset fh
 998     }
 999
1000     proc pcap_write_raw {packet} {
1001         variable fh
1002         if {![info exists fh]} return
1003         puts -nonewline $fh [binary format H* $packet]
1004     }
1005
1006     proc pcap_write {valdeflist} {
1007         foreach {kind valvar} $valdeflist {
1008             if {![regexp {^([usx])([0-9]+)} $kind dummy mode bits]} {
1009                 error "unknown kind $kind for $valvar"
1010             }
1011             set value [uplevel 1 [list set $valvar]]
1012             if {$bits % 8} { error "bits must be mult 8 in $kind for $valvar" }
1013             if {"$mode" != "x"} {
1014                 set v {}
1015                 set ov $value
1016                 for {set i 0} {$i<$bits/8} {incr i} {
1017                     append v [format %02x [expr {$value & 0xff}]]
1018                     set value [expr {$value >> 8}]
1019                 }
1020                 if {$value != 0 && $value != -1} {
1021                     error "value $ov more than $bits bits (residue=$value)"
1022                 }
1023                 set value $v
1024             }
1025             if {[string length $value] != $bits/4} {
1026                 error "$valvar value $value wrong length, not $bits bits"
1027             }
1028             pcap_write_raw $value
1029         }
1030     }
1031 }
1032 namespace import PCap::*
1033
1034 proc emit {count} {
1035     global getlog_log errorInfo mtu
1036     if {[catch {
1037         start_gen $count
1038         set packet [gen_1_ip $mtu]
1039         puts stdout "[format %6d $count] $getlog_log\n       $packet"
1040     } emsg]} {
1041         puts stderr "\nERROR\n$count\n\n$emsg\n\n$errorInfo\n\n"
1042         puts stdout "[format %06d $count] error"
1043     } else {
1044         set ts_sec [clock seconds]
1045         set ts_usec 0
1046
1047         set llpkt [random-bytes 12] ;# ether addrs
1048         append llpkt 0800 ;# eth ip type
1049         append llpkt $packet
1050
1051         set len [packet-len "$llpkt"]
1052         pcap_write {
1053             u32 ts_sec
1054             u32 ts_usec
1055             u32 len
1056             u32 len
1057         }
1058         pcap_write_raw $llpkt
1059     }
1060 }
1061
1062
1063 proc nextarg {} {
1064     global argv
1065     if {![llength $argv]} { error "need another arg" }
1066     set a [lindex $argv 0]
1067     set argv [lrange $argv 1 end]
1068     return $a
1069 }
1070
1071 proc nextarg_num {} { return [expr {[nextarg] + 0}] }
1072
1073 set debug_level 0
1074 set mtu 576
1075 set upto {}
1076 set xseed {}
1077 while {[regexp {^\-\-} [lindex $argv 0]]} {
1078     set o [nextarg]
1079     switch -exact -- $o {
1080         --infinite { set upto -1 }
1081         --debug { set debug_level [nextarg_num] }
1082         --upto { set upto [nextarg_num] }
1083         --write { pcap_open [nextarg] }
1084         --mtu { set mtu [nextarg_num] }
1085         --xseed { set xseed [nextarg] }
1086         default { error "bad option $o" }
1087     }
1088 }
1089
1090 set magic d4c3b2a1
1091 set version_major 2
1092 set version_minor 4
1093 set thiszone 0
1094 set sigfigs 0
1095 set snaplen 131073
1096 set linktype 1
1097
1098 pcap_write {
1099     x32 magic
1100     u16 version_major
1101     u16 version_minor
1102     s32 thiszone
1103     s32 sigfigs
1104     s32 snaplen
1105     s32 linktype
1106 }
1107
1108 if {[llength $argv] && ![string length $upto]} {
1109     foreach count $argv { emit "$xseed$count" }
1110 } elseif {![llength $argv]} {
1111     if {![string length $upto]} { set upto 100 }
1112     for {set count 1} {$upto<0 || $count<=$upto} {incr count} {
1113         emit "$xseed$count"
1114     }
1115 } else {
1116     error "bad mode"
1117 }
1118
1119 pcap_close