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