make-probes.tcl

   1 #!/usr/bin/tclsh8.2
   2
   3
   4 set debug_level 1
   5
   6 proc debug {level str} {
   7     global debug_level
   8     if {$level < $debug_level} { puts stderr "debug\[$level] $str" }
   9 }
  10
  11 proc manyset {list args} {
  12     foreach val $list var $args {
  13         upvar 1 $var my
  14         set my $val
  15     }
  16 }
  17
  18
  19 proc start_gen {use_gen_counter} {
  20     global gen_counter rand_counter getlog_log rand_buf
  21     random-bytes-init $use_gen_counter
  22     set getlog_log {}
  23 }
  24
  25 proc packet-len {p} { expr {[string length $p]/2} }
  26
  27 proc packet-csum-ip {packet} {
  28     set cs 0
  29     append packet 00
  30     while {[regexp {^([0-9a-f][0-9a-f])(.*)$} $packet dummy this packet]} {
  31         incr cs 0x$this
  32     }
  33     return [expr {$cs & 0xffff}]
  34 }
  35
  36
  37 namespace eval Random-Bytes {
  38     namespace export random-bytes random-bytes-init
  39
  40     proc random-bytes-init {seed} {
  41         variable counter
  42         variable fh
  43         catch { set h $fh; unset fh; close $h }
  44         set counter 0
  45         set fh [open |[list openssl bf-ofb < /dev/zero -e -k " $seed"] r]
  46         fconfigure $fh -translation binary
  47     }
  48     proc random-bytes {n} {
  49         variable fh
  50         set x [read $fh $n]
  51         if {[string length $x] != $n} {
  52             set h $fh; unset fh; close $h
  53             error "openssl bf-ofb exited unexpectedly"
  54         }
  55         binary scan $x H* y
  56         if {[string length $y] != $n*2} { error "binary format failed $n $y" }
  57         return $y
  58     }
  59 }
  60
  61 namespace import Random-Bytes::*
  62
  63 proc choice-int {min max} {
  64     set rv 0x[random-bytes 3]
  65     return [expr {
  66         int( double($rv) / double(0xffffff) * double($max+1-$min) )
  67         + $min
  68     }]
  69 }
  70
  71 proc choice-prob {cv def} {
  72     set prob [config $cv $def]
  73     set rv 0x[random-bytes 3]
  74     return [expr {$rv < double($prob)*0x1000000}]
  75 }
  76
  77
  78 proc getlog {msg} {
  79     upvar #0 getlog_log log
  80     append log " $msg"
  81     debug 2 "getlog $msg"
  82 }
  83
  84 proc config {cv def} {
  85     upvar #0 config/$cv v
  86     if {[info exists v]} { return $v }
  87     return $def
  88 }
  89
  90
  91 proc define {enum val name argnames body} {
  92     upvar #0 enum/val2name/$enum v2n
  93     upvar #0 enum/name2val/$enum n2v
  94     set v2n($val) $name
  95     set n2v($name) $val
  96     proc enum/val/$enum/$val $argnames $body
  97 }
  98
  99 proc depending-on {scope enum_and_var mtu mtuadjust args} {
 100     upvar 1 $enum_and_var val
 101     set mtu [expr {$mtu + $mtuadjust}]
 102     set procname enum/val/$scope-$enum_and_var/[format %d $val]
 103     if {[choice-prob $enum_and_var-unstruct 0.1] ||
 104             [catch { info body $procname }]} {
 105         # half the time random
 106         getlog (junk)
 107         get-for $scope-fill
 108         get data randupto $mtu
 109         return $data
 110     } else {
 111         uplevel 1 [list $procname] $mtu $args
 112     }
 113 }
 114
 115
 116 proc get-for {scope} {
 117     upvar 1 get/scope ns
 118     set ns $scope
 119 }
 120
 121 proc get {variable kind args} {
 122     upvar 1 get/scope scope
 123     upvar 1 $variable var
 124     set var [eval [list get/$kind $scope $variable] $args]
 125 }
 126
 127 proc get-config/number {val min max} { return $val }
 128 proc get-config/v4addr {val} {
 129     if {![regexp {^(\d+)\.(\d+)\.(\d+)\.(\d+)$} $val dummy a b c d]} {
 130         error "bad v4addr ?$val?"
 131     }
 132     return [format 0x%02x%02x%02x%02x $a $b $c $d]
 133 }
 134
 135 proc get-config {variable def kind args} {
 136     # args currently ignored
 137     upvar 1 get/scope scope
 138     upvar 1 $variable var
 139     set val [config $scope-$variable $def]
 140     set var [eval [list get-config/$kind $val] $args]
 141 }
 142
 143 proc get/enum {s v min max} {
 144     if {[choice-prob $s-$v-unknown 0.5]} {
 145         set rv [choice-int $min $max]
 146     } else {
 147         upvar #0 enum/val2name/$s-$v v2n
 148         set rv [choice-int 1 [array size v2n]]
 149         set rv [lindex [array names v2n] [expr {$rv-1}]]
 150     }
 151     if {[info exists v2n($rv)]} {
 152         getlog "$v=$v2n($rv)\[$rv]"
 153     } else {
 154         getlog "$v=$rv"
 155     }
 156     return $rv
 157 }
 158
 159 proc get/number {s v min max} {
 160     set rv [choice-int $min $max]
 161     getlog "$v=$rv"
 162     return $rv
 163 }
 164
 165 proc get/flag {s v defprob} {
 166     set rv [choice-prob $s-$v $defprob]
 167     if {$rv} { getlog "$v" } else { getlog "!$v" }
 168     return $rv
 169 }
 170
 171 proc get/choice {s v defprob} {
 172     set rv [choice-prob $s-$v $defprob]
 173     if {$rv} { getlog "($v)" } else { getlog "(!$v)" }
 174     return $rv
 175 }
 176
 177 proc get/randupto {s v maxlen} {
 178     get-for $s-$v
 179     get l number 0 $maxlen
 180     return [random-bytes $l]
 181 }
 182
 183 proc get/ip-timestamp {s v} {
 184     set rv [expr {[clock seconds] | 0x80000000}]
 185     getlog "$v=[format %x $rv]"
 186     return $rv
 187 }
 188
 189 proc get/v4addr {s v} {
 190     set rv 0x
 191     set p {}
 192     set d {}
 193     for {set i 0} {$i<4} {incr i} {
 194         set b [random-bytes 1]
 195         append rv $b
 196         append p $d [format %d 0x$b]
 197         set d .
 198     }
 199     getlog "$v=$p"
 200     return $rv
 201 }
 202
 203
 204 proc assemble {outvarname format} {
 205     # format should look like those RFC diagrams.
 206     # +-+-+ stuff and good formatting is mandatory.
 207     # Tabs are forbidden.
 208     #
 209     # Field names are converted to lowercase; internal spaces
 210     # are replaced with _.  They are then assumed to be
 211     # variable names in the caller's scope.  The packet is
 212     # assembled from those values (which must all be set)
 213     # and stored in $varname in the caller's scope.
 214     #
 215     # Variables ?_whatever will be *set* with the location of the
 216     # field in the string (in internal format); the corresponding
 217     # `whatever' (with the ?_ stripped) will be read when assembling.
 218     #
 219     # Field name `0' means set the field to zero.
 220
 221     upvar 1 $outvarname out
 222     set out {}
 223     set lno 0
 224     debug 7 "ASSEMBLY $outvarname\n$format"
 225     foreach l [split $format "\n"] {
 226         incr lno
 227         if {[regexp -nocase {^ *\| +\| *$} $l]} {
 228             if {![info exists wordbits]} {
 229                 error "vspace not in data @$lno\n?$l?"
 230             }
 231             incr words
 232         } elseif {[regexp -nocase {^ *[|? a-z0-9]+$} $l]} {
 233             if {[info exists words]} {
 234                 error "data without delimline @$lno\n?$l?"
 235             }
 236             set words 1
 237             set cue $l
 238         } elseif {[regexp {^ *[-+]+ *$} $l]} {
 239             set wordbits 0
 240             set newlineform {}
 241             while {[regexp {^([-= ]+)\+(.*)$} $l dummy before after]} {
 242                 set atpos([string length $before]) $wordbits
 243                 incr wordbits
 244                 set l "$before=$after"
 245                 append newlineform "@[string length $before]:$wordbits "
 246             }
 247             incr wordbits -1
 248             append newlineform $wordbits
 249             if {[info exists lineform]} {
 250                 if {"$newlineform" != "$lineform"} {
 251  error "format change @$lno\n?$l?\n$wordformat != $oldwordformat"
 252                 }
 253                 if {![info exists words] || $words<0} {
 254                     error "consecutive delimlines @$lno\n?$l?"
 255                 }
 256                 append out [string repeat 00 [expr {$words*$wordbits/8}]]
 257                 set l $cue
 258                 while {[regexp -nocase \
 259                         {^([ =]*)\|( *[? a-z0-9]*[a-z0-9] *)\|(.*)$} \
 260                         $l dummy before midpart after]} {
 261                     debug 7 "RWORKG ?$l?"
 262                     set varname [string tolower [string trim $midpart]]
 263                     set varname [string map {{ } _} $varname]
 264                     set p1 [string length $before]
 265                     set p2 [expr {
 266                         [string length $before] +
 267                         [string length $midpart] + 1
 268                     }]
 269                     if {![info exists atpos($p1)] ||
 270                         ![info exists atpos($p2)]} {
 271  error "vdelims not found @$lno $varname $p1 $p2 -- $lineform ?$cue?"
 272                     }
 273                     set bit1 [expr {
 274                         [string length $out]*4
 275                         - $words*$wordbits
 276                         + $atpos($p1)
 277                     }]
 278                     set bitlen [expr {
 279                         $atpos($p2) - $atpos($p1) + ($words-1)*$wordbits
 280                     }]
 281                     set location [list $bit1 $bitlen $outvarname-$varname]
 282                     if {[regexp {^\?_(.*)} $varname dummy realvarname]} {
 283                         debug 7 "LOCATING $varname $location"
 284                         upvar 1 $varname locvarname
 285                         set locvarname $location
 286                         set varname $realvarname
 287                     }
 288                     if {"$varname" == "0"} {
 289                         set value 0
 290                     } else {
 291                         set value [uplevel 1 [list set $varname]]
 292                     }
 293                     assembly-overwrite out $location $value
 294                     set l "$before="
 295                     append l [string repeat = [string length $midpart]]
 296                     append l |$after
 297                 }
 298                 debug 7 "REMAIN ?$l?"
 299             } else {
 300                 if {$wordbits % 8 || $wordbits >32} {
 301                     error "bad wordbits $wordbits @$lno ?$l? $newlineform"
 302                 }
 303                 set lineform $newlineform
 304             }
 305             catch { unset words }
 306         } elseif {[regexp {^ *$} $l]} {
 307         } else {
 308             error "huh? @$lno ?$l?"
 309         }
 310     }
 311     debug 7 "ASSEMBLY\n$out\n"
 312     return $out
 313 }
 314
 315 proc assembly-overwrite {outvarname location value} {
 316     upvar 1 $outvarname out
 317     manyset $location bit1 bitlen diag
 318     debug 8 "ASSEMBLY $diag == $value == 0x[format %x $value] (@$bit1+$bitlen)"
 319     if {$bitlen < 32 && $value >= (1<<$bitlen)} {
 320         error "$diag $value >= 2**$bitlen"
 321     }
 322     if {!($bit1 % 8) && !($bitlen % 8)} {
 323         set char0no [expr {$bit1/4}]
 324         set charlen [expr {$bitlen/4}]
 325         set chareno [expr {$char0no + $charlen -1}]
 326         set repl [format %0${charlen}x $value]
 327         set out [string replace $out $char0no $chareno $repl]
 328     } else {
 329         while {$bitlen > 0} {
 330             set byteno [expr {$bit1 / 8}]
 331             set char0no [expr {$byteno*2}]
 332             set char1no [expr {$char0no+1}]
 333             set bytebit [expr {128>>($bit1 % 8)}]
 334             set byte 0x[string range $out $char0no $char1no]
 335             debug 7 "< $bit1+$bitlen $byteno $char0no $bytebit $byte $out"
 336             set byte [expr {
 337                 ($value & (1<<($bitlen-1)))
 338                 ? ($byte | $bytebit)
 339                 : ($byte & ~$bytebit)
 340             }]
 341             set out [string replace $out $char0no $char1no [format %02x $byte]]
 342  debug 8 "> $bit1+$bitlen $byteno $char0no $bytebit 0x[format %02x $byte] $out"
 343             incr bitlen -1
 344             incr bit1
 345         }
 346     }
 347 }
 348
 349
 350 proc gen_1_ip {mtu} {
 351     # RFC791
 352     upvar #0 ip_proto proto
 353     upvar #0 ip_source source
 354     upvar #0 ip_dest dest
 355     get-for ip
 356     set version 4
 357     get tos number 0x00 0xff
 358     get id number 0x0000 0xffff
 359     get df flag 0.5
 360     if {$df} {
 361         set mf 0
 362         set frag 0
 363     } {
 364         get mf flag 0.5
 365         get frag number 0 0x1fff
 366     }
 367     get-config ttl 255 number 0 255
 368     get proto enum 1 255
 369     get-config source 127.0.0.1 v4addr
 370     get-config dest 127.0.0.1 v4addr
 371     # we don't do any IP options
 372     set ihl 5
 373     set body [depending-on ip proto $mtu [expr {-4*$ihl}]]
 374     set total_length [expr {$ihl + [packet-len $body]}]
 375     set header_checksum 0
 376     set flags [expr {$df*2 + $mf}]
 377     assemble ip {
 378    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 379    |Version|  IHL  |TOS            |         Total Length          |
 380    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 381    |         Id                    |Flags|      Frag               |
 382    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 383    |  TTL          |    Proto      |      ? Header Checksum        |
 384    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 385    |                       Source                                  |
 386    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 387    |                    Dest                                       |
 388    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 389     }
 390     assembly-overwrite ip ${?_header_checksum} [packet-csum-ip $ip]
 391     append ip $body
 392     return $ip
 393 }
 394
 395 define ip-proto 1 icmp {mtu} {
 396     # RFC792
 397     get-for icmp
 398     get type enum 0 255
 399     manyset [depending-on icmp type $mtu -4] body code
 400     if {![string length $code]} { get code number 0 255 }
 401     set checksum 0
 402     assemble icmp {
 403    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 404    |     Type      |     Code      |        ? Checksum             |
 405    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 406     }
 407     append icmp $body
 408     assembly-overwrite icmp ${?_checksum} [packet-csum-ip $icmp]
 409     return $icmp
 410 }
 411
 412 proc define-icmp-type-vanilla {num name} {
 413     define icmp-type $num $name {mbl} "icmp-vanilla \$mbl [list $name]"
 414 }
 415 proc icmp-vanilla {mbl typename} {
 416     get-for icmp-$typename
 417     get code enum 0 255
 418     get body randupto $mbl
 419     return [list $body $code]
 420 }
 421
 422 define-icmp-type-vanilla 3 unreach
 423 define icmp-unreach-code 0 net {} {}
 424 define icmp-unreach-code 1 host {} {}
 425 define icmp-unreach-code 2 proto {} {}
 426 define icmp-unreach-code 3 port {} {}
 427 define icmp-unreach-code 4 fragneeded {} {}
 428 define icmp-unreach-code 5 sourceroutefail {} {}
 429
 430 define-icmp-type-vanilla 11 timeout
 431 define icmp-timeout-code 0 intransit {} {}
 432 define icmp-timeout-code 1 fragment {} {}
 433
 434 define-icmp-type-vanilla 12 parameters
 435 define icmp-parameters-code 0 seepointer {} {}
 436
 437 define-icmp-type-vanilla 4 sourcequench
 438 define icmp-sourcequench-code 0 quench {} {}
 439
 440 define icmp-type 5 redirect {mbl} {
 441     get-for icmp-redirect
 442     get code enum 0 255
 443     get gateway v4addr
 444     assemble body {
 445    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 446    |                 Gateway                                       |
 447    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 448     }
 449     get data randupto [expr {$mbl-4}]
 450     append body $data
 451     return [list $body $code]
 452 }
 453
 454 define icmp-redirect-code 0 net {} {}
 455 define icmp-redirect-code 1 host {} {}
 456 define icmp-redirect-code 2 net+tos {} {}
 457 define icmp-redirect-code 3 host+tos {} {}
 458
 459 define icmp-type 8 ping {mbl} { icmp-echo $mbl }
 460 define icmp-type 0 pong {mbl} { icmp-echo $mbl }
 461 proc icmp-echo {mbl} {
 462     get-for icmp-echo
 463     get code enum 0 255
 464     get id number 0 0xffff
 465     get seq number 0 0xffff
 466     assemble body {
 467    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 468    |       Id                      |        Seq                    |
 469    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 470     }
 471     get data randupto [expr {$mbl-8}]
 472     append body $data
 473     return [list $body $code]
 474 }
 475 define icmp-echo-code 0 echo {} {}
 476
 477 define icmp-type 13 timestamp {mbl} { icmp-timestamp }
 478 define icmp-type 14 timestampreply {mbl} { icmp-timestamp }
 479 proc icmp-timestamp {} {
 480     get-for icmp-timestamp
 481     get code enum 0 255
 482     get id number 0 0xffff
 483     get seq number 0 0xffff
 484     get originate ip-timestamp
 485     get receive ip-timestamp
 486     get transmit ip-timestamp
 487     assemble body {
 488    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 489    |           Id                  |        Seq                    |
 490    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 491    |     Originate                                                 |
 492    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 493    |     Receive                                                   |
 494    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 495    |     Transmit                                                  |
 496    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 497     }
 498     return [list $body $code]
 499 }
 500 define icmp-timestamp-code 0 timestamp {} {}
 501
 502 define icmp-type 15 inforequest {mbl} { icmp-inforeq }
 503 define icmp-type 16 inforeply {mbl} { icmp-inforeq }
 504 proc icmp-inforeq {} {
 505     get-for icmp-inforeq
 506     get code enum 0 255
 507     get id number 0 0xffff
 508     get seq number 0 0xffff
 509     assemble body {
 510    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 511    |           Id                  |        Seq                    |
 512    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 513     }
 514     return [list $body $code]
 515 }
 516 define icmp-inforeq-code 0 timestamp {} {}
 517
 518 # MAYADD ICMP traceroute RFC1393
 519 # MAYADD ICMP router discovery RFC1256
 520
 521 define ip-proto 17 udp {mtu} {
 522     get-for udp
 523     set dest_port 4321
 524     get source_port number 0 0xffff
 525     get data randupto [expr {$mtu-8}]
 526     set length [packet-len $data]
 527     set checksum 0
 528     assemble udp {
 529    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 530    |       Source Port             |        Dest Port              |
 531    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 532    |         Length                |      ? Checksum               |
 533    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
 534     }
 535     append udp $data
 536     get checksum choice 0.75
 537     if {$checksum} {
 538         set csum [packet-csum-ip $udp]
 539         if {!$csum} { set csum 0xffff }
 540     } else {
 541         set csum 0
 542     }
 543     assembly-overwrite udp ${?_checksum} $csum
 544 }
 545
 546
 547
 548
 549
 550 proc emit {count} {
 551     global getlog_log errorInfo
 552     if {[catch {
 553         start_gen $count
 554         set packet [gen_1_ip 576]
 555         puts stdout "[format %06d $count] $getlog_log\n       $packet"
 556     } emsg]} {
 557         puts stderr "\nERROR\n$count\n\n$emsg\n\n$errorInfo\n\n"
 558         puts stdout "[format %06d $count] error"
 559     }
 560 }
 561
 562 if {![llength $argv]} {
 563     for {set count 1} {$count < 100} {incr count} { emit $count }
 564 } elseif {"$argv" == "--infinite"} {
 565     set count 1
 566     while 1 { emit $count; incr count }
 567 } else {
 568     foreach count $argv { emit $count }
 569 }