make-probes.tcl

   1 #!/usr/bin/tclsh
   2
   3 # core packet generator for vinegar-ip
   4 #
   5 # This file is part of vinegar-ip, tools for IP transparency testing.
   6 # vinegar-ip is Copyright (C) 2002 Ian Jackson
   7 #
   8 # This program is free software; you can redistribute it and/or modify
   9 # it under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 2, or (at your option)
  11 # any later version.
  12 #
  13 # This program is distributed in the hope that it will be useful,
  14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public License
  19 # along with this program; if not, write to the Free Software Foundation,
  20 # Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  21 #
  22 # $Id$
  23
  24 proc debug {level str} {
  25     global debug_level
  26     if {$level <= $debug_level} { puts stderr "debug\[$level] $str" }
  27 }
  28
  29 proc manyset {list args} {
  30     foreach val $list var $args {
  31         upvar 1 $var my
  32         set my $val
  33     }
  34 }
  35
  36
  37 proc start_gen {seed} {
  38     global getlog_log
  39     random-bytes-init $seed
  40     set getlog_log {}
  41 }
  42
  43 proc packet-len {p} { expr {[string length $p]/2} }
  44
  45 proc packet-csum-ip {packet} {
  46     set cs 0
  47     append packet 00
  48     while {[regexp {^([0-9a-f]{4})(.*)$} $packet dummy this packet]} {
  49         set cs [expr "\$cs + 0x$this"]
  50         debug 7 [format "0x%s 0x%08x" $this $cs]
  51     }
  52     while {$cs > 0xffff} {
  53         set cs [expr {($cs & 0xffff) + (($cs >> 16) & 0xffff)}]
  54     }
  55     return [expr {$cs ^ 0xffff}]
  56 }
  57
  58 proc packet-fromstring {s} {
  59     binary scan $s H* y
  60     return $y
  61 }
  62
  63 namespace eval Random-Bytes {
  64     namespace export random-bytes random-bytes-init
  65
  66     proc random-bytes-init {seed} {
  67         variable fh
  68         catch { set h $fh; unset fh; close $h }
  69         set fh [open |[list openssl bf-ofb < /dev/zero -e -k " $seed"] r]
  70         fconfigure $fh -translation binary
  71     }
  72     proc random-bytes {n} {
  73         variable fh
  74         set x [read $fh $n]
  75         if {[string length $x] != $n} {
  76             set h $fh; unset fh; close $h
  77             error "openssl bf-ofb exited unexpectedly"
  78         }
  79         set y [packet-fromstring $x]
  80         return $y
  81     }
  82 }
  83
  84 namespace import Random-Bytes::*
  85
  86 proc choice-int {min max} {
  87     set rv 0x[random-bytes 3]
  88     return [expr {
  89         int( double($rv) / double(0x1000000) * double($max+1-$min) )
  90         + $min
  91     }]
  92 }
  93
  94 proc choice-prob {cv def} {
  95     set prob [config $cv $def]
  96     set rv 0x[random-bytes 3]
  97     set rv [expr {$rv < double($prob)*0x1000000}]
  98     debug 2 "choice-prob $rv <- $prob ($cv)"
  99     return $rv
 100 }
 101
 102 proc choice-mult {args} {
 103     if {!([llength $args] % 2)} { error "choice-mult must have default" }
 104     set h 0x[random-bytes 3]
 105     set x [expr { double($h) / double(0x1000000) }]
 106     set cump 0.0
 107     set def [lindex $args end]
 108     set args [lreplace $args end end]
 109     foreach {val p} $args {
 110         set cump [expr {$cump + double($p)}]
 111         if {$x < $cump} {
 112  debug 2 "choice-mult $val <= [concat $args [list $def]]"
 113             return $val
 114         }
 115     }
 116  debug 2 "choice-mult $def <- [concat $args [list $def]]"
 117     return $def
 118 }
 119
 120 proc getlog {msg} {
 121     upvar #0 getlog_log log
 122     append log " $msg"
 123     debug 2 "getlog $msg"
 124 }
 125
 126 proc config {cv def} {
 127     upvar #0 config/$cv v
 128     if {[info exists v]} { return $v }
 129     return $def
 130 }
 131
 132
 133 proc define {enum val mult name argnames body} {
 134     # mult may be:
 135     #   *    full share of `known' enum values
 136     #   ?    only as often as `random' enum values
 137     # Or *<pct> or ?<pct> meaning <pct>/100 times as often as * or ?.
 138
 139     upvar #0 enum/val2name/$enum v2n
 140     upvar #0 enum/val2mult/$enum v2m
 141     upvar #0 enum/name2val/$enum n2v
 142     foreach kind {? *} {
 143         upvar #0 enum/total$kind/$enum total$kind
 144         if {![info exists total$kind]} { set total$kind 0 }
 145     }
 146
 147     regsub {^[?*]$} $mult {&100} mult
 148     if {![regexp {^([?*])([0-9]+)$} $mult dummy kind times]} {
 149         error "invalid mult $mult"
 150     }
 151
 152     set v2n($val) $name
 153     set v2m($val) [list $kind $times]
 154     set n2v($name) $val
 155     incr total$kind $times
 156
 157     proc enum/val/$enum/$val $argnames $body
 158 }
 159
 160 proc depending-on {scope enum_and_var mtu mtuadjust args} {
 161     upvar 1 $enum_and_var val
 162     set mtu [expr {$mtu + $mtuadjust}]
 163     set procname enum/val/$scope-$enum_and_var/[format %d $val]
 164     if {[choice-prob $enum_and_var-unstruct 0.1] ||
 165             [catch { info body $procname }]} {
 166         getlog (junk)
 167         get-for $scope-fill
 168         get data rand 0 $mtu 1
 169         return $data
 170     } else {
 171         uplevel 1 [list $procname] $mtu $args
 172     }
 173 }
 174
 175
 176 proc get-for {scope} {
 177     upvar 1 get/scope ns
 178     set ns $scope
 179 }
 180
 181 proc get {variable kind args} {
 182     upvar 1 get/scope scope
 183     upvar 1 $variable var
 184     set var [eval [list get/$kind $scope $variable] $args]
 185 }
 186
 187 proc get-config/number {val min max} { return $val }
 188 proc get-config/v4addr {val} {
 189     if {![regexp {^(\d+)\.(\d+)\.(\d+)\.(\d+)$} $val dummy a b c d]} {
 190         error "bad v4addr ?$val?"
 191     }
 192     return [format 0x%02x%02x%02x%02x $a $b $c $d]
 193 }
 194 proc get-config/linkaddr {val} {
 195     return $val
 196 }
 197
 198 proc get-config {variable def kind args} {
 199     # args currently ignored
 200     upvar 1 get/scope scope
 201     upvar 1 $variable var
 202     set val [config $scope-$variable $def]
 203     set var [eval [list get-config/$kind $val] $args]
 204 }
 205
 206 proc get-enum-got {s v rv} {
 207     upvar #0 enum/val2name/$s-$v v2n
 208     if {[info exists v2n($rv)]} {
 209         getlog "$v=$v2n($rv)\[$rv]"
 210     } else {
 211         getlog "$v=$rv"
 212     }
 213     return $rv
 214 }
 215
 216 proc get/enum-rand {s v min max} {
 217     set rv [choice-int $min $max]
 218     return [get-enum-got $s $v $rv]
 219 }
 220
 221 proc enum-prepare-choice-list {s v nvalues prand} {
 222     upvar #0 "enum/choice-list/$s-${v}($nvalues $prand)" cl
 223     upvar #0 enum/val2mult/$s-$v v2m
 224     upvar #0 enum/total*/$s-$v total*org
 225     upvar #0 enum/total?/$s-$v total?
 226
 227     set total* ${total*org}
 228     if {!${total*}} { set total* [expr {double(${total*org}) + 0.001}] }
 229
 230     set pr $prand
 231     if {!${total?}} { set pr 0.0 }
 232     set pm? [expr {$pr / (100.0*double($nvalues))}]
 233     set pm* [expr {(1.0 - $pr) / double(${total*})}]
 234     debug 1 "epcl $s-$v $nvalues $prand: pr $pr  ? pm ${pm?} total ${total?}  * pm ${pm*} total ${total*}"
 235
 236     set cl {}
 237     foreach rv [lsort [array names v2m]] {
 238         manyset $v2m($rv) kind times
 239         set p [expr { double($times) * [set pm$kind] }]
 240         debug 1 "epcl $s-$v $nvalues $prand:   $rv $kind$times := $p"
 241         lappend cl $rv $p
 242     }
 243     if {${total*org}} {
 244         set cl [lreplace $cl end end]
 245     } else {
 246         lappend cl *
 247     }
 248 }
 249
 250 proc get/enum-def {s v min max prand} {
 251     set nvalues [expr {$max-$min+1}]
 252     upvar #0 "enum/choice-list/$s-${v}($nvalues $prand)" cl
 253     if {![info exists cl]} { enum-prepare-choice-list $s $v $nvalues $prand }
 254     set rv [eval choice-mult $cl]
 255     if {"$rv" == "*"} { set rv [choice-int $min $max] }
 256     return [get-enum-got $s $v $rv]
 257 }
 258
 259 proc get/enum {s v min max prand} {
 260     set any [choice-prob $s-$v-any $prand]
 261     if {$any} {
 262         return [get/enum-rand $s $v $min $max]
 263     } else {
 264         return [get/enum-def $s $v $min $max $prand]
 265     }
 266 }
 267
 268 proc get/number {s v min max} {
 269     set rv [choice-int $min $max]
 270     getlog "$v=$rv"
 271     return $rv
 272 }
 273
 274 proc get/hex {s v min max} {
 275     set rv [choice-int $min $max]
 276     getlog [format %s=0x%x $v $rv]
 277     return $rv
 278 }
 279
 280 proc get/hex32 {s v} {
 281     set rv [random-bytes 4]
 282     getlog "$v=0x$rv"
 283     return 0x$rv
 284 }
 285
 286 proc get/flag {s v defprob} {
 287     set rv [choice-prob $s-$v $defprob]
 288     if {$rv} { getlog "$v" } else { getlog "!$v" }
 289     return $rv
 290 }
 291
 292 proc get/choice {s v defprob} {
 293     set rv [choice-prob $s-$v $defprob]
 294     if {$rv} { getlog "($v)" } else { getlog "(!$v)" }
 295     return $rv
 296 }
 297
 298 proc get/rand {s v minlen maxlen blockbytes} {
 299     get-for $s-$v
 300     if {$maxlen<0} { getlog (full!); return {} }
 301     get l number [expr {$minlen/$blockbytes}] [expr {$maxlen/$blockbytes}]
 302     return [random-bytes [expr {$l*$blockbytes}]]
 303 }
 304
 305 proc get/ip-timestamp {s v} {
 306     set rv 0xbc000000
 307     incr rv [choice-int 100 10000]
 308     getlog "$v=[format %x $rv]"
 309     return $rv
 310 }
 311
 312 proc get/v4addr {s v} {
 313     set rv 0x
 314     set p {}
 315     set d {}
 316     for {set i 0} {$i<4} {incr i} {
 317         set b [random-bytes 1]
 318         append rv $b
 319         append p $d [format %d 0x$b]
 320         set d .
 321     }
 322     getlog "$v=$p"
 323     return $rv
 324 }
 325
 326 proc get/choice-mult {s v args} {
 327     set rv [eval choice-mult $args]
 328     getlog "($rv)"
 329     return $rv
 330 }
 331
 332 proc get/string {s v minlen maxlen first rest} {
 333     set o {}
 334     set now $first
 335     for {set l [choice-int $minlen $maxlen]} {$l>0} {incr l -1} {
 336         set cn [choice-int 0 [expr {[string length $now]-1}]]
 337         append o [string index $now $cn]
 338         set now $rest
 339     }
 340     getlog "$v=\"$o\""
 341     return [packet-fromstring $o]
 342 }
 343
 344 proc get/ntstring {s v minlen maxlen first rest} {
 345     set s [get/string $s $v $minlen $maxlen $first $rest]
 346     append s 00
 347     append s [random-bytes $maxlen]
 348     return [string range $s 0 [expr {$maxlen*2-1}]]
 349 }
 350
 351 namespace eval Assembler {
 352     namespace export assemble assembly-overwrite
 353
 354     proc assemble {outvarname format} {
 355         # format should look like those RFC diagrams.  +-+-+ stuff and
 356         # good formatting is mandatory.  You can have a single data
 357         # item at the end ending in ..., which means append that data
 358         # item.
 359         #
 360         # Field names are converted to lowercase; internal spaces
 361         # are replaced with _.  They are then assumed to be
 362         # variable names in the caller's scope.  The packet is
 363         # assembled from those values (which must all be set)
 364         # and stored in $varname in the caller's scope.
 365         #
 366         # Variables ?_whatever will be *set* with the location of the
 367         # field in the string (in internal format); the corresponding
 368         # `whatever' (with the ?_ stripped) will be read when assembling.
 369         #
 370         # Field names starting with digits are literal values instead.
 371
 372         variable cache
 373         upvar 1 $outvarname out
 374         if {[catch { set parsed $cache($format) }]} {
 375             set parsed [parse $format]
 376             set cache($format) $parsed
 377         }
 378
 379         manyset $parsed outbytes lout
 380         set out [string repeat 00 $outbytes]
 381         foreach {?_location varname locvarname} $lout {
 382             if {[regexp {^[0-9]} $varname]} {
 383                 set value $varname
 384             } else {
 385                 set value [uplevel 1 [list set $varname]]
 386             }
 387             if {[string length $locvarname]} {
 388                 upvar 1 $locvarname lv
 389                 set lv ${?_location}
 390             }
 391             if {[catch {
 392                 assembly-overwrite out location $value
 393             } emsg]} {
 394                 global errorInfo errorCode
 395                 error $emsg \
 396                         "$errorInfo\n    setting\n$varname at ${?_location}" \
 397                         $errorCode
 398             }
 399         }
 400     }
 401
 402     proc parse {format} {
 403         set lno 0
 404         set outbytes 0
 405         set atend 0
 406         debug 7 "ASSEMBLY $format"
 407         set format [exec expand << $format]
 408         foreach l [split $format "\n"] {
 409             incr lno
 410             if {[regexp -nocase {^ *\| +\| *$} $l]} {
 411                 if {![info exists wordbits]} {
 412                     error "vspace not in data @$lno\n?$l?"
 413                 }
 414                 incr words
 415             } elseif {[regexp -nocase {^ *[|? a-z0-9.]+$} $l]} {
 416                 if {[info exists words]} {
 417                     error "data without delimline @$lno\n?$l?"
 418                 }
 419                 set words 1
 420                 set cue $l
 421             } elseif {[regexp {^ *[-+]+ *$} $l]} {
 422                 set wordbits 0
 423                 set newlineform {}
 424                 while {[regexp {^([-= ]+)\+(.*)$} $l dummy before after]} {
 425                     set atpos([string length $before]) $wordbits
 426                     incr wordbits
 427                     set l "$before=$after"
 428                     append newlineform "@[string length $before]:$wordbits "
 429                 }
 430                 incr wordbits -1
 431                 append newlineform $wordbits
 432                 if {[info exists lineform]} {
 433                     if {"$newlineform" != "$lineform"} {
 434  error "format change @$lno\n?$l?\n$wordformat != $oldwordformat"
 435                     }
 436                     if {![info exists words] || $words<0} {
 437                         error "consecutive delimlines @$lno\n?$l?"
 438                     }
 439                     incr outbytes [expr {$words*$wordbits/8}]
 440                     set l $cue
 441                     while {[regexp -nocase \
 442                             {^([ =]*)\|( *[? a-z0-9]*[a-z0-9] *\.* *)\|(.*)$} \
 443                             $l dummy before midpart after]} {
 444                         debug 7 "RWORKG ?$l?"
 445                         if {$atend} {
 446                             error "two things at end @$lno\n?$l?"
 447                         }
 448                         set varname [string tolower [string trim $midpart]]
 449                         if {[regexp {(.*[a-z0-9])\s*\.\.\.$} $varname \
 450                                 dummy realvarname]} {
 451                             set varname $realvarname
 452                             set atend 1
 453                         }
 454                         set varname [string map {{ } _} $varname]
 455                         set p1 [string length $before]
 456                         set p2 [expr {
 457                             [string length $before] +
 458                             [string length $midpart] + 1
 459                         }]
 460                         if {![info exists atpos($p1)] ||
 461                             ![info exists atpos($p2)]} {
 462  error "vdelims not found @$lno $varname $p1 $p2 -- $lineform ?$cue?"
 463                         }
 464                         set bit1 [expr {
 465                             $outbytes*8
 466                             - $words*$wordbits
 467                             + $atpos($p1)
 468                         }]
 469                         set bitlen [expr {
 470                             $atpos($p2) - $atpos($p1) + ($words-1)*$wordbits
 471                         }]
 472                         if {$atend} {
 473                             if {$bit1 % 8} {
 474                                 error "atend not at byte @$lno\n?$l?"
 475                             }
 476                             set outbytes [expr {$bit1/8}]
 477                             set location [list $bit1 0 $varname]
 478                         } else {
 479                             set location [list $bit1 $bitlen $varname]
 480                         }
 481                         if {[regexp {^\?_(.*)} $varname dummy realvarname]} {
 482                             debug 7 "LOCATING $varname $location"
 483                             set locvarname $varname
 484                             set varname $realvarname
 485                         } else {
 486                             set locvarname {}
 487                         }
 488                         lappend lout $location $varname $locvarname
 489                         set l "$before="
 490                         append l [string repeat = [string length $midpart]]
 491                         append l |$after
 492                     }
 493                     debug 7 "REMAIN ?$l?"
 494                     if {![regexp {^[ =]*\|? *$} $l]} {
 495                         error "unclear @$lno\n?$l?"
 496                     }
 497                 } else {
 498                     if {$wordbits % 8 || $wordbits >32} {
 499                         error "bad wordbits $wordbits @$lno ?$l? $newlineform"
 500                     }
 501                     set lineform $newlineform
 502                 }
 503                 catch { unset words }
 504             } elseif {[regexp {^ *$} $l]} {
 505             } else {
 506                 error "huh? @$lno ?$l?"
 507             }
 508         }
 509         debug 7 "ASSEMBLY\n$outbytes\n$lout\n"
 510         return [list $outbytes $lout]
 511     }
 512
 513     proc assembly-overwrite {outvarname locvarnameex value} {
 514         upvar 1 $outvarname out
 515         upvar 1 ?_$locvarnameex location
 516         manyset $location bit1 bitlen diag
 517         if {$bitlen > 0 && $bitlen != 32 && $value >= (1<<$bitlen)} {
 518             error "$diag $value >= 2**$bitlen"
 519         }
 520         if {!($bit1 % 8) && !($bitlen % 8)} {
 521             set char0no [expr {$bit1/4}]
 522             set charlen [expr {$bitlen/4}]
 523             set chareno [expr {$char0no + $charlen -1}]
 524             if {$bitlen > 0} {
 525  debug 8 "ASSEMBLY $diag == $value == 0x[format %x $value] (@$bit1+$bitlen)"
 526                 set repl [format %0${charlen}x $value]
 527                 set out [string replace $out $char0no $chareno $repl]
 528             } else {
 529  debug 8 "ASSEMBLY-ADD $diag (@$bit1)"
 530                 # bitlen==0 => append
 531                 set out [string range $out 0 $chareno]
 532                 append out $value
 533             }
 534         } else {
 535             while {$bitlen > 0} {
 536                 set byteno [expr {$bit1 / 8}]
 537                 set char0no [expr {$byteno*2}]
 538                 set char1no [expr {$char0no+1}]
 539                 set bytebit [expr {128>>($bit1 % 8)}]
 540                 set byte 0x[string range $out $char0no $char1no]
 541                 debug 7 "< $bit1+$bitlen $byteno $char0no $bytebit $byte $out"
 542                 set byte [expr {
 543                     ($value & (1<<($bitlen-1)))
 544                     ? ($byte | $bytebit)
 545                     : ($byte & ~$bytebit)
 546                 }]
 547                 set out [string replace $out $char0no $char1no \
 548                         [format %02x $byte]]
 549  debug 8 "> $bit1+$bitlen $byteno $char0no $bytebit 0x[format %02x $byte] $out"
 550                 incr bitlen -1
 551                 incr bit1
 552             }
 553         }
 554     }
 555 }
 556 namespace import Assembler::*
 557
 558 proc gen_1_ip {mtu source_spec dest_spec} {
 559     # RFC791
 560     upvar #0 ip_proto proto
 561     upvar #0 ip_source source
 562     upvar #0 ip_dest dest
 563
 564     set source $source_spec
 565     set dest $dest_spec
 566
 567     get-for ip
 568     set version 4
 569     get tos hex 0x00 0xff
 570     get id number 0x0000 0xffff
 571     get df flag 0.5
 572     if {$df || ![choice-prob ip-midfrag 0.05]} {
 573         set mf 0
 574         set frag 0
 575     } {
 576         get mf flag 0.5
 577         get frag number 0 0x1fff
 578     }
 579     get-config ttl 255 number 0 255
 580     get proto enum 0 255 0.2
 581     set flags [expr {$df*2 + $mf}]
 582
 583     set header_checksum 0
 584     set ihl 0
 585     set total_length 0
 586     assemble ip {
 587    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 588    |Version| ? IHL |TOS            |       ? Total Length          |
 589    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 590    |         Id                    |Flags|      Frag               |
 591    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 592    |  TTL          |    Proto      |      ? Header Checksum        |
 593    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 594    |                       Source                                  |
 595    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 596    |                    Dest                                       |
 597    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 598     }
 599     # we don't do any IP options
 600
 601     set ihl [packet-len $ip]
 602     if {$ihl % 4} { error "ihl not mult of 4 bytes" }
 603     assembly-overwrite ip ihl [expr {$ihl / 4}]
 604
 605     set body [depending-on ip proto $mtu -$ihl]
 606     set total_length [expr {[packet-len $ip] + [packet-len $body]}]
 607
 608     assembly-overwrite ip total_length $total_length
 609     assembly-overwrite ip header_checksum [packet-csum-ip $ip]
 610
 611     append ip $body
 612     return $ip
 613 }
 614
 615 define ip-proto 1 *50 icmp {mtu} {
 616     # RFC792
 617     get-for icmp
 618     get type enum 0 255 0.2
 619     manyset [depending-on icmp type $mtu -4] body code
 620     if {![string length $code]} { get code number 0 255 }
 621     set checksum 0
 622     assemble icmp {
 623    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 624    |     Type      |     Code      |        ? Checksum             |
 625    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 626    |     Body ...                                                  |
 627    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 628     }
 629     assembly-overwrite icmp checksum [packet-csum-ip $icmp]
 630     return $icmp
 631 }
 632
 633 proc define-icmp-type-vanilla {num name} {
 634     define icmp-type $num * $name {mbl} "icmp-vanilla \$mbl [list $name]"
 635 }
 636 proc icmp-vanilla {mbl typename} {
 637     get-for icmp-$typename
 638     get code enum 0 255 0.4
 639     get body rand 0 $mbl 1
 640     return [list $body $code]
 641 }
 642
 643 define-icmp-type-vanilla 3 unreach
 644 define icmp-unreach-code 0 * net {} {}
 645 define icmp-unreach-code 1 * host {} {}
 646 define icmp-unreach-code 2 * proto {} {}
 647 define icmp-unreach-code 3 * port {} {}
 648 define icmp-unreach-code 4 * fragneeded {} {}
 649 define icmp-unreach-code 5 * sourceroutefail {} {}
 650
 651 define-icmp-type-vanilla 11 timeout
 652 define icmp-timeout-code 0 * intransit {} {}
 653 define icmp-timeout-code 1 * fragment {} {}
 654
 655 define-icmp-type-vanilla 12 parameters
 656 define icmp-parameters-code 0 * seepointer {} {}
 657
 658 define-icmp-type-vanilla 4 sourcequench
 659 define icmp-sourcequench-code 0 * quench {} {}
 660
 661 define icmp-type 5 * redirect {mbl} {
 662     get-for icmp-redirect
 663     get code enum 0 255 0.4
 664     get gateway v4addr
 665     get data rand 0 [expr {$mbl-4}] 1
 666     assemble body {
 667    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 668    |                 Gateway                                       |
 669    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 670    |     Data ...                                                  |
 671    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 672     }
 673     return [list $body $code]
 674 }
 675
 676 define icmp-redirect-code 0 * net {} {}
 677 define icmp-redirect-code 1 * host {} {}
 678 define icmp-redirect-code 2 * net+tos {} {}
 679 define icmp-redirect-code 3 * host+tos {} {}
 680
 681 define icmp-type 8 * ping {mbl} { icmp-echo $mbl }
 682 define icmp-type 0 * pong {mbl} { icmp-echo $mbl }
 683 proc icmp-echo {mbl} {
 684     get-for icmp-echo
 685     get code enum 0 255 0.4
 686     get id hex 0 0xffff
 687     get seq hex 0 0xffff
 688     get data rand 0 [expr {$mbl-8}] 1
 689     assemble body {
 690    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 691    |       Id                      |        Seq                    |
 692    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 693    |     Data ...                                                  |
 694    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 695     }
 696     return [list $body $code]
 697 }
 698 define icmp-echo-code 0 * echo {} {}
 699
 700 define icmp-type 13 * timestamp {mbl} { icmp-timestamp }
 701 define icmp-type 14 * timestampreply {mbl} { icmp-timestamp }
 702 proc icmp-timestamp {} {
 703     get-for icmp-timestamp
 704     get code enum 0 255 0.4
 705     get id hex 0 0xffff
 706     get seq hex 0 0xffff
 707     get originate ip-timestamp
 708     get receive ip-timestamp
 709     get transmit ip-timestamp
 710     assemble body {
 711    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 712    |           Id                  |        Seq                    |
 713    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 714    |     Originate                                                 |
 715    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 716    |     Receive                                                   |
 717    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 718    |     Transmit                                                  |
 719    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 720     }
 721     return [list $body $code]
 722 }
 723 define icmp-timestamp-code 0 * timestamp {} {}
 724
 725 define icmp-type 15 * inforequest {mbl} { icmp-inforeq }
 726 define icmp-type 16 * inforeply {mbl} { icmp-inforeq }
 727 proc icmp-inforeq {} {
 728     get-for icmp-inforeq
 729     get code enum 0 255 0.4
 730     get id hex 0 0xffff
 731     get seq hex 0 0xffff
 732     assemble body {
 733    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 734    |           Id                  |        Seq                    |
 735    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 736     }
 737     return [list $body $code]
 738 }
 739 define icmp-inforeq-code 0 * timestamp {} {}
 740
 741 # MAYADD ICMP traceroute RFC1393
 742 # MAYADD ICMP router discovery RFC1256
 743
 744
 745 define ip-proto 4 * ip {mtu} {
 746     # RFC2003
 747     get-for ip-ip
 748     get source v4addr
 749     get dest v4addr
 750     gen_1_ip $mtu $source $dest
 751 }
 752
 753
 754 define ip-proto 2 ? igmp {mtu} {
 755     get-for igmp
 756     get type enum 0 255 0.5
 757     get timeout number 0 255
 758     get group v4addr
 759     set checksum 0
 760     set extra {}
 761     assemble igmp {
 762    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 763    |      Type     |   Timeout     |         ? Checksum            |
 764    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 765    |                         Group                                 |
 766    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 767    |                       ? Extra ...                             |
 768    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 769     }
 770
 771     if {[choice-prob igmp-extra 0.3]} {
 772         get extra rand 1 [expr {$mtu - [packet-len $igmp]}] 1
 773         assembly-overwrite igmp extra $extra
 774     }
 775
 776     assembly-overwrite igmp checksum [packet-csum-ip $igmp]
 777     return $igmp
 778 }
 779
 780 define igmp-type 17 * membquery {} {}
 781 define igmp-type 16 * membreport {} {}
 782 define igmp-type 23 * leavegroup {} {}
 783 define igmp-type 18 * membreport {} {}
 784
 785
 786 define ip-proto 51 ? ah {mtu} {
 787     # RFC1826
 788     get-for ah
 789     get next number 0 255
 790     get reserved hex 0 0xffff
 791     get spi hex32
 792     get auth_data rand 0 [expr {$mtu-8 > 50 ? 50 : $mtu-8}] 4
 793     set length [packet-len $auth_data]
 794     assemble ah {
 795      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 796      | Next          |   Length      |           RESERVED            |
 797      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 798      |                    SPI                                        |
 799      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 800      |                 Auth Data ...                                 |
 801      +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 802     }
 803     get payload rand 0 [expr {$mtu - [packet-len $ah]}] 1
 804     append ah $payload
 805     return $ah
 806 }
 807
 808 proc udp-rport {} {
 809     get-for udp
 810     get port enum-rand 0 0xffff
 811     return $port
 812 }
 813
 814 define ip-proto 17 * udp {mtu} {
 815     # RFC768
 816     get-for udp
 817
 818     set csum_mode [choice-mult \
 819             checksum_bad 0.10 \
 820             checksum_none 0.20 \
 821             checksum_good]
 822
 823     set prand 0.50
 824     get style choice-mult \
 825             random $prand \
 826             request 0.15 \
 827             reply 0.15 \
 828             servers
 829
 830     if {"$style" != "random"} {
 831         get port enum-def 0 255 $prand
 832         set def_port $port
 833     } else {
 834         set def_port x
 835     }
 836     switch -exact $style {
 837         random  { set source_port [udp-rport]; set dest_port [udp-rport] }
 838         request { set source_port [udp-rport]; set dest_port $def_port   }
 839         reply   { set source_port $def_port;   set dest_port [udp-rport] }
 840         servers { set source_port $def_port;   set dest_port $def_port   }
 841     }
 842
 843     if {"$style" != "random"} {
 844         set port $def_port
 845         set data [depending-on udp port $mtu -8 $style]
 846     } else {
 847         get data rand 0 [expr {$mtu-8}] 1
 848     }
 849
 850     set length 0
 851     set checksum 0
 852     assemble udp {
 853    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 854    |       Source Port             |        Dest Port              |
 855    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 856    |       ? Length                |      ? Checksum               |
 857    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 858    |     Data ...                                                  |
 859    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 860     }
 861     set udp_length [packet-len $udp]
 862     assembly-overwrite udp length $udp_length
 863
 864     if {"$csum_mode" == "checksum_none"} {
 865         set checksum 0
 866         getlog (nocsum)
 867     } else {
 868         global ip_source ip_dest ip_proto
 869         assemble pseudo {
 870    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 871    |       IP Source                                               |
 872    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 873    |       IP Dest                                                 |
 874    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 875    |       0       | IP Proto      |        UDP length             |
 876    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 877         }
 878         set checksum [packet-csum-ip "$pseudo$udp"]
 879         if {!$checksum} { set checksum 0xffff }
 880         if {"$csum_mode" == "checksum_bad"} {
 881             get csumerror hex 1 0xffff
 882             set checksum [expr {$checksum ^ $csumerror}]
 883         }
 884     }
 885     assembly-overwrite udp checksum $checksum
 886     return $udp
 887 }
 888
 889 define udp-port 50 ?200 remailck {mtu style} {
 890     # RFC1339
 891     get-for remailck
 892     if {"$style" == "request"} {
 893         get what choice-mult \
 894                 req-baduser 0.15 \
 895                 req-auth 0.15 \
 896                 resp-ok 0.15 \
 897                 resp-auth 0.15 \
 898                 req-user
 899     } else {
 900         get what choice-mult \
 901                 req-baduser 0.15 \
 902                 req-auth 0.15 \
 903                 resp-auth 0.15 \
 904                 req-user 0.15 \
 905                 resp-ok
 906     }
 907     switch -exact $what {
 908         req-user {
 909             set auth 0
 910             get user string 1 8 \
 911                     abcdefghijklmnopqrustuvwxyz \
 912                     abcdefghijklmnopqrustuvwxyz-0123456789_
 913         }
 914         req-baduser {
 915             set auth 0
 916             get user rand 0 [expr {$mtu - 4}] 1
 917         }
 918         req-auth {
 919             get auth enum 0 31 0.5
 920             set user [depending-on remailck auth $mtu -4]
 921         }
 922         resp-auth {
 923             get auth hex 0 0xffff
 924             set modified 0
 925             set read 0
 926         }
 927         resp-ok {
 928             get mail choice-mult \
 929                     newmail 0.15 \
 930                     oldmail 0.15 \
 931                     nomail 0.20 \
 932                     times
 933             set auth 0
 934             switch -exact $mail {
 935                 newmail {
 936                     set modified 0
 937                     set read 1
 938                 }
 939                 oldmail {
 940                     set modified 1
 941                     set read 0
 942                 }
 943                 nomail {
 944                     set modified 0
 945                     set read 0
 946                 }
 947                 times {
 948                     get modified number 1 600
 949                     get read number 1 600
 950                 }
 951                 default { error "mail? $mail" }
 952             }
 953         }
 954         default { error "what? $what" }
 955     }
 956     switch -glob $what {
 957         req-* {
 958             assemble payload {
 959    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 960    |         Auth                                                  |
 961    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 962    |     User ...                                                  |
 963    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 964             }
 965         }
 966         resp-* {
 967             assemble payload {
 968    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 969    |         Auth                                                  |
 970    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 971    |         Modified                                              |
 972    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 973    |         Read                                                  |
 974    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 975             }
 976         }
 977         default { error "what?? $what" }
 978     }
 979     return $payload
 980 }
 981
 982 define remailck-auth 31 * passwd {mtu} {
 983     get-for remailck-passwd
 984     get passwd string 6 8 \
 985             0123456789abcdefghijklmnopqrstuvxwyz \
 986             0123456789abcdefghijklmnopqrstuvxwyz
 987     return $passwd
 988 }
 989
 990 define udp-port 67 ? dhcpserv {mtu style} { return [dhcp $mtu] }
 991 define udp-port 68 ? dhcpclient {mtu style} { return [dhcp $mtu] }
 992 proc dhcp {mtu} {
 993     get-for dhcp
 994     get op enum 0 255 0.2
 995     get htype enum 0 255 0.2
 996     set hlen 6
 997     get hops number 0 255
 998     get xid hex32
 999     get secs number 0 300
1000     get flags hex 0 255
1001     get ciaddr v4addr
1002     get yiaddr v4addr
1003     get siaddr v4addr
1004     get giaddr v4addr
1005     set chaddr [random-bytes 16]
1006     get sname ntstring 0 64 \
1007             0123456789abcdefghijklmnopqrstuvwxyz \
1008             0123456789abcdefghijklmnopqrstuvwxyz.-+
1009     get file ntstring 0 128 / \
1010             0123456789abcdefghijklmnopqrstuvwxyz.-+/_
1011
1012     assemble dhcp {
1013    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1014    |     op        |   htype       |   hlen        |   hops        |
1015    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1016    |                            xid                                |
1017    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1018    |           secs                |           flags               |
1019    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1020    |                          ciaddr                               |
1021    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1022    |                          yiaddr                               |
1023    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1024    |                          siaddr                               |
1025    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1026    |                          giaddr                               |
1027    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1028     }
1029     append dhcp $chaddr $sname $file
1030
1031     return $dhcp
1032 }
1033 define dhcp-op 1 * request {} {}
1034 define dhcp-op 2 * reply {} {}
1035 define dhcp-htype 1 * ethernet {} {}
1036
1037
1038 define ip-proto 6 * tcp {mtu} {
1039     # RFC793
1040     get-for tcp
1041
1042     get source_port number 0 65535
1043     get dest_port number 0 65535
1044     get event choice-mult \
1045             connect 0.15 \
1046             accept 0.15 \
1047             close 0.15 \
1048             reset 0.15 \
1049             weird 0.15 \
1050             data
1051     set s 0
1052     set a 1
1053     set f 0
1054     set r 0
1055     switch -exact $event {
1056         connect { set s 1; set a 0 }
1057         accept { set s 1 }
1058         close { set f 1 }
1059         reset { set a 0; set r 1 }
1060         data { }
1061         weird {
1062             get s flag 0.5
1063             get a flag 0.5
1064             get f flag 0.5
1065             get r flag 0.5
1066         }
1067         default { error "event? $event" }
1068     }
1069     get seq hex32
1070     get ack hex32
1071     if {[choice-prob tcp-smallwindow 0.7]} {
1072         get window number 0 1
1073     } else {
1074         get window hex 0 0xffff
1075     }
1076     get p flag 0.5
1077     get u flag 0.3
1078     get urg hex 0 0xffff
1079
1080     set options {}
1081     get optmode choice-mult badopt 0.3 opt 0.3 noopt
1082     switch -exact $optmode {
1083         noopt { }
1084         badopt {
1085             get options rand 1 60 1
1086         }
1087         opt {
1088             set nooi 1
1089             while {$nooi || [choice-prob tcp-opts-more 0.4]} {
1090                 set nooi 0
1091                 get opt enum 1 255 0.5
1092                 if {$opt == 1} {
1093                     assemble option {
1094    +-+-+-+-+-+-+-+-+
1095    |  Opt          |
1096    +-+-+-+-+-+-+-+-+
1097                     }
1098                 } else {
1099                     set data [depending-on tcp opt 6 0]
1100                     set option_len 0
1101                     assemble option {
1102    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1103    |  Opt          | ? Option Len  |
1104    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1105    |      Data ...                 |
1106    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1107                     }
1108                     assembly-overwrite option option_len [packet-len $option]
1109                 }
1110                 append options $option
1111             }
1112         }
1113     }
1114
1115     if {[choice-prob reserved-nonzero 0.25]} {
1116         get reserved hex 0 0x3f
1117     } else {
1118         set reserved 0
1119     }
1120
1121     if {[packet-len $options] % 4 || [get optxpad choice 0.15]} {
1122         if {"$optmode" != "badopt"} { append options 00 }
1123         set padlen [expr {3 - ([packet-len $options] + 3) % 4}]
1124         append options [random-bytes $padlen]
1125     }
1126
1127     set d_off 0
1128     set checksum 0
1129     assemble packet {
1130    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1131    |          Source Port          |       Dest Port               |
1132    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1133    |                        Seq                                    |
1134    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1135    |                    Ack                                        |
1136    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1137    |? D Off| Reserved  |U|A|P|R|S|F|            Window             |
1138    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1139    |         ? Checksum            |         Urg                   |
1140    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1141    |                    Options     ...                            |
1142    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1143     }
1144
1145     set d_off [expr {([packet-len $packet]/4) & 0x0f}]
1146     assembly-overwrite packet d_off $d_off
1147
1148     if {!($s || $r) || [get unexpdata flag 0.2]} {
1149         get data rand 0 [expr {$mtu - [packet-len $packet]}] 1
1150         append packet $data
1151     }
1152     set tcp_length [packet-len $packet]
1153
1154     global ip_source ip_dest ip_proto
1155     assemble pseudo {
1156    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1157    |       IP Source                                               |
1158    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1159    |       IP Dest                                                 |
1160    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1161    |       0       | IP Proto      |        TCP length             |
1162    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1163     }
1164
1165     set csum [packet-csum-ip "$pseudo$packet"]
1166     if {[choice-prob tcp-badcsum 0.1]} {
1167         get csumerror hex 1 0xffff
1168         set csum [expr {$csum ^ $csumerror}]
1169     }
1170     assembly-overwrite packet checksum $csum
1171     return $packet
1172 }
1173
1174 define tcp-opt 2 * mss {mdl} {
1175     get-for tcp-opt
1176     get mss hex 0 0xffff
1177     assemble od {
1178    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1179    |        MSS                    |
1180    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
1181     }
1182     return $od
1183 }
1184
1185
1186 namespace eval PCap {
1187     namespace export pcap_open pcap_write pcap_write_raw pcap_close
1188
1189     proc pcap_open {fn} {
1190         variable fh
1191         catch { close $fh }
1192         set fh [open $fn w]
1193         fconfigure $fh -translation binary
1194     }
1195
1196     proc pcap_close {} {
1197         variable fh
1198         if {![info exists fh]} return
1199         close $fh
1200         unset fh
1201     }
1202
1203     proc pcap_write_raw {packet} {
1204         variable fh
1205         if {![info exists fh]} return
1206         puts -nonewline $fh [binary format H* $packet]
1207     }
1208
1209     proc pcap_write {valdeflist} {
1210         foreach {kind valvar} $valdeflist {
1211             if {![regexp {^([usx])([0-9]+)} $kind dummy mode bits]} {
1212                 error "unknown kind $kind for $valvar"
1213             }
1214             set value [uplevel 1 [list set $valvar]]
1215             if {$bits % 8} { error "bits must be mult 8 in $kind for $valvar" }
1216             if {"$mode" != "x"} {
1217                 set v {}
1218                 set ov $value
1219                 for {set i 0} {$i<$bits/8} {incr i} {
1220                     append v [format %02x [expr {$value & 0xff}]]
1221                     set value [expr {$value >> 8}]
1222                 }
1223                 if {$value != 0 && $value != -1} {
1224                     error "value $ov more than $bits bits (residue=$value)"
1225                 }
1226                 set value $v
1227             }
1228             if {[string length $value] != $bits/4} {
1229                 error "$valvar value $value wrong length, not $bits bits"
1230             }
1231             pcap_write_raw $value
1232         }
1233     }
1234 }
1235 namespace import PCap::*
1236
1237 proc emit {seed} {
1238     global getlog_log errorInfo mtu fake_time_t
1239     global minframelen linktypename errors_continue
1240
1241     get-for ip
1242     get-config source 127.0.0.1 v4addr
1243     get-config dest 127.0.0.1 v4addr
1244
1245     if {[catch {
1246         start_gen $seed
1247         set packet [gen_1_ip $mtu $source $dest]
1248         puts stdout "[format %6s $seed] $getlog_log\n       $packet"
1249     } emsg]} {
1250         puts stderr "\nERROR\n$seed\n\n$emsg\n\n$errorInfo\n\n"
1251         puts stdout "[format %6s $seed] error"
1252         if {!$errors_continue} {
1253             error "internal error generating packet - consult author"
1254         }
1255     } else {
1256         set ts_sec [incr fake_time_t]
1257         set ts_usec 0
1258
1259         set l [packet-len $packet]
1260         if {$l < $minframelen} {
1261             append packet [string repeat 00 [expr {$minframelen - $l}]]
1262         }
1263
1264         set llpkt [link/$linktypename/linkencap $packet]
1265
1266         set len [packet-len "$llpkt"]
1267         pcap_write {
1268             u32 ts_sec
1269             u32 ts_usec
1270             u32 len
1271             u32 len
1272         }
1273         pcap_write_raw $llpkt
1274     }
1275 }
1276
1277
1278 # link/ether - RFC894
1279 proc link/ether/linkparams {} { return {1 46} }
1280 proc link/ether/defaddr {} { return 00:00:00:00:00:00 }
1281 proc link/ether/procaddr {input sd} {
1282     set v [string tolower $input]
1283     if {[regexp {^([0-9a-f]{1,2}\:){6}$} $v:]} {
1284         set o {}
1285         foreach b [split $v :] { append o [format %02x 0x$b] }
1286         set v $o
1287     }
1288     if {![regexp -nocase {^[0-9a-f]{12}$} $v]} {
1289         error "invalid $sd ethernet addr $input ($v)"
1290     }
1291     return $v
1292 }
1293 proc link/ether/linkencap {packet} {
1294     global link_source link_dest
1295     set llpkt {}
1296     append llpkt $link_dest $link_source 0800
1297     append llpkt $packet
1298     return $llpkt
1299 }
1300
1301
1302 proc nextarg {} {
1303     global argv
1304     if {![llength $argv]} { error "need another arg" }
1305     set a [lindex $argv 0]
1306     set argv [lrange $argv 1 end]
1307     return $a
1308 }
1309
1310 proc nextarg_num {} { return [expr {[nextarg] + 0}] }
1311 proc nextarg_il {} {
1312     set a [nextarg]
1313     if {![regexp -nocase {^([0-9.]+)/(.+)$} $a dummy i l]} {
1314         error "--source/--dest needs <ip-addr>/<link-addr>"
1315     }
1316     return [list $i $l]
1317 }
1318
1319 set debug_level 0
1320 set errors_continue 0
1321 set mtu 100
1322 set upto {}
1323 set xseed {}
1324 set linktypename ether
1325 while {[regexp {^\-\-} [lindex $argv 0]]} {
1326     set o [nextarg]
1327     switch -exact -- $o {
1328         --infinite { set upto -1 }
1329         --debug { set debug_level [nextarg_num] }
1330         --upto { set upto [nextarg_num] }
1331         --write { pcap_open [nextarg] }
1332         --mtu { set mtu [nextarg_num] }
1333         --xseed { set xseed [nextarg] }
1334         --errors-continue { set errors_continue 1 }
1335         --linktype { set linktypename [nextarg] }
1336         --source { manyset [nextarg_il] config/ip-source config/link-source }
1337         --dest { manyset [nextarg_il] config/ip-dest config/link-dest }
1338         default { error "bad option $o" }
1339     }
1340 }
1341
1342 proc process_linkaddr {sd} {
1343     global linktypename
1344     upvar #0 link_$sd l
1345     get-for link
1346     get-config $sd [link/$linktypename/defaddr] linkaddr
1347     set l [link/$linktypename/procaddr [set $sd] $sd]
1348 }
1349
1350 manyset [link/$linktypename/linkparams] linktype minframelen
1351 process_linkaddr source
1352 process_linkaddr dest
1353
1354 set magic d4c3b2a1
1355 set version_major 2
1356 set version_minor 4
1357 set thiszone 0
1358 set sigfigs 0
1359 set snaplen 131073
1360
1361 pcap_write {
1362     x32 magic
1363     u16 version_major
1364     u16 version_minor
1365     s32 thiszone
1366     s32 sigfigs
1367     s32 snaplen
1368     s32 linktype
1369 }
1370
1371 set fake_time_t 1000000000
1372
1373 start_gen TEST
1374 random-bytes 100
1375
1376 if {[llength $argv]} {
1377     foreach count $argv { emit "$xseed$count" }
1378 } else {
1379     if {![string length $upto]} { set upto 100 }
1380     for {set count 1} {$upto<0 || $count<=$upto} {incr count} {
1381         emit "$xseed$count"
1382     }
1383 }
1384
1385 pcap_close