--- /dev/null
+#!/usr/bin/tclsh8.2
+
+
+set debug_level 1
+
+proc debug {level str} {
+ global debug_level
+ if {$level < $debug_level} { puts stderr "debug\[$level] $str" }
+}
+
+proc manyset {list args} {
+ foreach val $list var $args {
+ upvar 1 $var my
+ set my $val
+ }
+}
+
+
+proc start_gen {use_gen_counter} {
+ global gen_counter rand_counter getlog_log rand_buf
+ set gen_counter $use_gen_counter
+ set rand_counter 0
+ set rand_buf {}
+ set getlog_log {}
+}
+
+proc packet-len {p} { expr {[string length $p]/2} }
+
+proc packet-csum-ip {packet} {
+ set cs 0
+ append packet 00
+ while {[regexp {^([0-9a-f][0-9a-f])(.*)$} $packet dummy this packet]} {
+ incr cs 0x$this
+ }
+ return [expr {$cs & 0xffff}]
+}
+
+set rand_buf {}
+proc random-bytes {n} {
+ global gen_counter rand_counter rand_buf
+ set n [expr {$n*2}]
+ set o {}
+ while {[set w [expr {$n - [string length $o]}]] > 0} {
+ if {![string length $rand_buf]} {
+ set md5 [exec md5sum << "$gen_counter $rand_counter"]
+ regexp {^[0-9a-f]{32}} $md5 rand_buf
+ if {![string length $rand_buf]} { error "?$md5?" }
+ incr rand_counter
+ }
+ append o [string range $rand_buf 0 [expr {$w-1}]]
+ set rand_buf [string range $rand_buf $w end]
+ }
+ return $o
+}
+
+proc choice-int {min max} {
+ set rv 0x[random-bytes 3]
+ return [expr {
+ int( double($rv) / double(0xffffff) * double($max+1-$min) )
+ + $min
+ }]
+}
+
+proc choice-prob {cv def} {
+ set prob [config $cv $def]
+ set rv 0x[random-bytes 3]
+ return [expr {$rv < double($prob)*0x1000000}]
+}
+
+
+proc getlog {msg} {
+ upvar #0 getlog_log log
+ append log " $msg"
+ debug 2 "getlog $msg"
+}
+
+proc config {cv def} {
+ upvar #0 config/$cv v
+ if {[info exists v]} { return $v }
+ return $def
+}
+
+
+proc define {enum val name argnames body} {
+ upvar #0 enum/val2name/$enum v2n
+ upvar #0 enum/name2val/$enum n2v
+ set v2n($val) $name
+ set n2v($name) $val
+ proc enum/val/$enum/$val $argnames $body
+}
+
+proc depending-on {scope enum_and_var mtu mtuadjust args} {
+ upvar 1 $enum_and_var val
+ set mtu [expr {$mtu + $mtuadjust}]
+ set procname enum/val/$scope-$enum_and_var/[format %d $val]
+ if {[choice-prob $enum_and_var-unstruct 0.1] ||
+ [catch { info body $procname }]} {
+ # half the time random
+ getlog (junk)
+ get-for $scope-fill
+ get data randupto $mtu
+ return $data
+ } else {
+ uplevel 1 [list $procname] $mtu $args
+ }
+}
+
+
+proc get-for {scope} {
+ upvar 1 get/scope ns
+ set ns $scope
+}
+
+proc get {variable kind args} {
+ upvar 1 get/scope scope
+ upvar 1 $variable var
+ set var [eval [list get/$kind $scope $variable] $args]
+}
+
+proc get-config/number {val min max} { return $val }
+proc get-config/v4addr {val} {
+ if {![regexp {^(\d+)\.(\d+)\.(\d+)\.(\d+)$} $val dummy a b c d]} {
+ error "bad v4addr ?$val?"
+ }
+ return [format 0x%02x%02x%02x%02x $a $b $c $d]
+}
+
+proc get-config {variable def kind args} {
+ # args currently ignored
+ upvar 1 get/scope scope
+ upvar 1 $variable var
+ set val [config $scope-$variable $def]
+ set var [eval [list get-config/$kind $val] $args]
+}
+
+proc get/enum {s v min max} {
+ if {[choice-prob $s-$v-unknown 0.5]} {
+ set rv [choice-int $min $max]
+ } else {
+ upvar #0 enum/val2name/$s-$v v2n
+ set rv [choice-int 1 [array size v2n]]
+ set rv [lindex [array names v2n] [expr {$rv-1}]]
+ }
+ if {[info exists v2n($rv)]} {
+ getlog "$v=$v2n($rv)\[$rv]"
+ } else {
+ getlog "$v=$rv"
+ }
+ return $rv
+}
+
+proc get/number {s v min max} {
+ set rv [choice-int $min $max]
+ getlog "$v=$rv"
+ return $rv
+}
+
+proc get/flag {s v defprob} {
+ set rv [choice-prob $s-$v $defprob]
+ if {$rv} { getlog "$v" } else { getlog "!$v" }
+ return $rv
+}
+
+proc get/choice {s v defprob} {
+ set rv [choice-prob $s-$v $defprob]
+ if {$rv} { getlog "($v)" } else { getlog "(!$v)" }
+ return $rv
+}
+
+proc get/randupto {s v maxlen} {
+ get-for $s-$v
+ get l number 0 $maxlen
+ return [random-bytes $l]
+}
+
+proc get/ip-timestamp {s v} {
+ set rv [expr {[clock seconds] | 0x80000000}]
+ getlog "$v=[format %x $rv]"
+ return $rv
+}
+
+proc get/v4addr {s v} {
+ set rv 0x
+ set p {}
+ set d {}
+ for {set i 0} {$i<4} {incr i} {
+ set b [random-bytes 1]
+ append rv $b
+ append p $d [format %d $b]
+ set d .
+ }
+ getlog "$v=$p"
+ return $rv
+}
+
+
+proc assemble {outvarname format} {
+ # format should look like those RFC diagrams.
+ # +-+-+ stuff and good formatting is mandatory.
+ # Tabs are forbidden.
+ #
+ # Field names are converted to lowercase; internal spaces
+ # are replaced with _. They are then assumed to be
+ # variable names in the caller's scope. The packet is
+ # assembled from those values (which must all be set)
+ # and stored in $varname in the caller's scope.
+ #
+ # Variables ?_whatever will be *set* with the location of the
+ # field in the string (in internal format); the corresponding
+ # `whatever' (with the ?_ stripped) will be read when assembling.
+ #
+ # Field name `0' means set the field to zero.
+
+ upvar 1 $outvarname out
+ set out {}
+ set lno 0
+ debug 7 "ASSEMBLY $outvarname\n$format"
+ foreach l [split $format "\n"] {
+ incr lno
+ if {[regexp -nocase {^ *\| +\| *$} $l]} {
+ if {![info exists wordbits]} {
+ error "vspace not in data @$lno\n?$l?"
+ }
+ incr words
+ } elseif {[regexp -nocase {^ *[|? a-z0-9]+$} $l]} {
+ if {[info exists words]} {
+ error "data without delimline @$lno\n?$l?"
+ }
+ set words 1
+ set cue $l
+ } elseif {[regexp {^ *[-+]+ *$} $l]} {
+ set wordbits 0
+ set newlineform {}
+ while {[regexp {^([-= ]+)\+(.*)$} $l dummy before after]} {
+ set atpos([string length $before]) $wordbits
+ incr wordbits
+ set l "$before=$after"
+ append newlineform "@[string length $before]:$wordbits "
+ }
+ incr wordbits -1
+ append newlineform $wordbits
+ if {[info exists lineform]} {
+ if {"$newlineform" != "$lineform"} {
+ error "format change @$lno\n?$l?\n$wordformat != $oldwordformat"
+ }
+ if {![info exists words] || $words<0} {
+ error "consecutive delimlines @$lno\n?$l?"
+ }
+ append out [string repeat 00 [expr {$words*$wordbits/8}]]
+ set l $cue
+ while {[regexp -nocase \
+ {^([ =]*)\|( *[? a-z0-9]*[a-z0-9] *)\|(.*)$} \
+ $l dummy before midpart after]} {
+ debug 7 "RWORKG ?$l?"
+ set varname [string tolower [string trim $midpart]]
+ set varname [string map {{ } _} $varname]
+ set p1 [string length $before]
+ set p2 [expr {
+ [string length $before] +
+ [string length $midpart] + 1
+ }]
+ if {![info exists atpos($p1)] ||
+ ![info exists atpos($p2)]} {
+ error "vdelims not found @$lno $varname $p1 $p2 -- $lineform ?$cue?"
+ }
+ set bit1 [expr {
+ [string length $out]*4
+ - $words*$wordbits
+ + $atpos($p1)
+ }]
+ set bitlen [expr {
+ $atpos($p2) - $atpos($p1) + ($words-1)*$wordbits
+ }]
+ set location [list $bit1 $bitlen $outvarname-$varname]
+ if {[regexp {^\?_(.*)} $varname dummy realvarname]} {
+ debug 7 "LOCATING $varname $location"
+ upvar 1 $varname locvarname
+ set locvarname $location
+ set varname $realvarname
+ }
+ if {"$varname" == "0"} {
+ set value 0
+ } else {
+ set value [uplevel 1 [list set $varname]]
+ }
+ assembly-overwrite out $location $value
+ set l "$before="
+ append l [string repeat = [string length $midpart]]
+ append l |$after
+ }
+ debug 7 "REMAIN ?$l?"
+ } else {
+ if {$wordbits % 8 || $wordbits >32} {
+ error "bad wordbits $wordbits @$lno ?$l? $newlineform"
+ }
+ set lineform $newlineform
+ }
+ catch { unset words }
+ } elseif {[regexp {^ *$} $l]} {
+ } else {
+ error "huh? @$lno ?$l?"
+ }
+ }
+ debug 7 "ASSEMBLY\n$out\n"
+ return $out
+}
+
+proc assembly-overwrite {outvarname location value} {
+ upvar 1 $outvarname out
+ manyset $location bit1 bitlen diag
+ debug 8 "ASSEMBLY $diag == $value == 0x[format %x $value] (@$bit1+$bitlen)"
+ if {$bitlen < 32 && $value >= (1<<$bitlen)} {
+ error "$diag $value >= 2**$bitlen"
+ }
+ while {$bitlen > 0} {
+ set byteno [expr {$bit1 / 8}]
+ set char0no [expr {$byteno*2}]
+ set char1no [expr {$char0no+1}]
+ set bytebit [expr {128>>($bit1 % 8)}]
+ set byte 0x[string range $out $char0no $char1no]
+ debug 7 "< $bit1+$bitlen $byteno $char0no $bytebit $byte $out"
+ set byte [expr {
+ ($value & (1<<($bitlen-1)))
+ ? ($byte | $bytebit)
+ : ($byte & ~$bytebit)
+ }]
+ set out [string replace $out $char0no $char1no [format %02x $byte]]
+ debug 8 "> $bit1+$bitlen $byteno $char0no $bytebit 0x[format %02x $byte] $out"
+ incr bitlen -1
+ incr bit1
+ }
+}
+
+
+proc gen_1_ip {mtu} {
+ # RFC791
+ upvar #0 ip_proto proto
+ upvar #0 ip_source source
+ upvar #0 ip_dest dest
+ get-for ip
+ set version 4
+ get tos number 0x00 0xff
+ get id number 0x0000 0xffff
+ get df flag 0.5
+ if {$df} {
+ set mf 0
+ set frag 0
+ } {
+ get mf flag 0.5
+ get frag number 0 0x1fff
+ }
+ get-config ttl 255 number 0 255
+ get proto enum 1 255
+ get-config source 127.0.0.1 v4addr
+ get-config dest 127.0.0.1 v4addr
+ # we don't do any IP options
+ set ihl 5
+ set body [depending-on ip proto $mtu [expr {-4*$ihl}]]
+ set total_length [expr {$ihl + [packet-len $body]}]
+ set header_checksum 0
+ set flags [expr {$df*2 + $mf}]
+ assemble ip {
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ |Version| IHL |TOS | Total Length |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | Id |Flags| Frag |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | TTL | Proto | ? Header Checksum |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | Source |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | Dest |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ }
+ assembly-overwrite ip ${?_header_checksum} [packet-csum-ip $ip]
+ append $ip $body
+ return $ip
+}
+
+define ip-proto 1 icmp {mtu} {
+ # RFC792
+ get-for icmp
+ get type enum 0 255
+ manyset [depending-on icmp type $mtu -4] body code
+ if {![string length $code]} { get code number 0 255 }
+ set checksum 0
+ assemble icmp {
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | Type | Code | ? Checksum |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ }
+ append icmp $body
+ assembly-overwrite icmp ${?_checksum} [packet-csum-ip $icmp]
+ return $icmp
+}
+
+proc define-icmp-type-vanilla {num name} {
+ define icmp-type $num $name {mbl} "icmp-vanilla \$mbl [list $name]"
+}
+proc icmp-vanilla {mbl typename} {
+ get-for icmp-$typename
+ get code enum 0 255
+ get body randupto $mbl
+ return [list $body $code]
+}
+
+define-icmp-type-vanilla 3 unreach
+define icmp-unreach-code 0 net {} {}
+define icmp-unreach-code 1 host {} {}
+define icmp-unreach-code 2 proto {} {}
+define icmp-unreach-code 3 port {} {}
+define icmp-unreach-code 4 fragneeded {} {}
+define icmp-unreach-code 5 sourceroutefail {} {}
+
+define-icmp-type-vanilla 11 timeout
+define icmp-timeout-code 0 intransit {} {}
+define icmp-timeout-code 1 fragment {} {}
+
+define-icmp-type-vanilla 12 parameters
+define icmp-parameters-code 0 seepointer {} {}
+
+define-icmp-type-vanilla 4 sourcequench
+define icmp-sourcequench-code 0 quench {} {}
+
+define icmp-type 5 redirect {mbl} {
+ get-for icmp-redirect
+ get code enum 0 255
+ get gateway v4addr
+ assemble body {
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | Gateway |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ }
+ get data randupto [expr {$mbl-4}]
+ append body $data
+ return [list $body $code]
+}
+
+define icmp-redirect-code 0 net {} {}
+define icmp-redirect-code 1 host {} {}
+define icmp-redirect-code 2 net+tos {} {}
+define icmp-redirect-code 3 host+tos {} {}
+
+define icmp-type 8 ping {mbl} { icmp-echo $mbl }
+define icmp-type 0 pong {mbl} { icmp-echo $mbl }
+proc icmp-echo {mbl} {
+ get-for icmp-echo
+ get code enum 0 255
+ get id number 0 0xffff
+ get seq number 0 0xffff
+ assemble body {
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | Id | Seq |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ }
+ get data randupto [expr {$mbl-8}]
+ append body $data
+ return [list $body $code]
+}
+define icmp-echo-code 0 echo {} {}
+
+define icmp-type 13 timestamp {mbl} { icmp-timestamp }
+define icmp-type 14 timestampreply {mbl} { icmp-timestamp }
+proc icmp-timestamp {} {
+ get-for icmp-timestamp
+ get code enum 0 255
+ get id number 0 0xffff
+ get seq number 0 0xffff
+ get originate ip-timestamp
+ get receive ip-timestamp
+ get transmit ip-timestamp
+ assemble body {
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | Id | Seq |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | Originate |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | Receive |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | Transmit |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ }
+ return [list $body $code]
+}
+define icmp-timestamp-code 0 timestamp {} {}
+
+define icmp-type 15 inforequest {mbl} { icmp-inforeq }
+define icmp-type 16 inforeply {mbl} { icmp-inforeq }
+proc icmp-inforeq {} {
+ get-for icmp-inforeq
+ get code enum 0 255
+ get id number 0 0xffff
+ get seq number 0 0xffff
+ assemble body {
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | Id | Seq |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ }
+ return [list $body $code]
+}
+define icmp-inforeq-code 0 timestamp {} {}
+
+# MAYADD ICMP traceroute RFC1393
+# MAYADD ICMP router discovery RFC1256
+
+define ip-proto 17 udp {mtu} {
+ get-for udp
+ set dest_port 4321
+ get source_port number 0 0xffff
+ get data randupto [expr {$mtu-8}]
+ set length [packet-len $data]
+ set checksum 0
+ assemble udp {
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | Source Port | Dest Port |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ | Length | ? Checksum |
+ +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+ }
+ append udp $data
+ get checksum choice 0.75
+ if {$checksum} {
+ set csum [packet-csum-ip $udp]
+ if {!$csum} { set csum 0xffff }
+ } else {
+ set csum 0
+ }
+ assembly-overwrite udp ${?_checksum} $csum
+}
+
+proc emit {count} {
+ global getlog_log errorInfo
+ if {[catch {
+ start_gen $count
+ set packet [gen_1_ip 576]
+ puts stdout "[format %06d $count] $getlog_log\n $packet"
+ } emsg]} {
+ puts stderr "\nERROR\n$count\n\n$emsg\n\n$errorInfo\n\n"
+ puts stdout "[format %06d $count] error"
+ }
+}
+
+if {![llength $argv]} {
+ for {set count 1} {$count < 100} {incr count} { emit $count }
+} elseif {"$argv" == "--infinite"} {
+ set count 1
+ while 1 { emit $count; incr count }
+} else {
+ foreach count $argv { emit $count }
+}
~ianmdlvl / vinegar-ip.git / commitdiff