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