[vinegar-ip.git] / make-probes.tcl

#!/usr/bin/tclsh


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 {seed} {
    global getlog_log
    random-bytes-init $seed
    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]{4})(.*)$} $packet dummy this packet]} {
        set cs [expr "\$cs + 0x$this"]
        debug 7 [format "0x%s 0x%08x" $this $cs]
    }
    return [expr {(($cs & 0xffff) + (($cs >> 16) & 0xffff)) ^ 0xffff}]
}

proc packet-fromstring {s} {
    binary scan $s H* y
    return $y
}

namespace eval Random-Bytes {
    namespace export random-bytes random-bytes-init

    proc random-bytes-init {seed} {
        variable fh
        catch { set h $fh; unset fh; close $h }
        set fh [open |[list openssl bf-ofb < /dev/zero -e -k " $seed"] r]
        fconfigure $fh -translation binary
    }
    proc random-bytes {n} {
        variable fh
        set x [read $fh $n]
        if {[string length $x] != $n} {
            set h $fh; unset fh; close $h
            error "openssl bf-ofb exited unexpectedly"
        }
        set y [packet-fromstring $x]
        return $y
    }
}

namespace import Random-Bytes::*

proc choice-int {min max} {
    set rv 0x[random-bytes 3]
    return [expr {
        int( double($rv) / double(0x1000000) * 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 choice-mult {args} {
    if {!([llength $args] % 2)} { error "choice-mult must have default" }
    set h 0x[random-bytes 3]
    set x [expr { double($h) / double(0x1000000) }]
    set cump 0.0
    set def [lindex $args end]
    set args [lreplace $args end end]
    foreach {val p} $args {
        set cump [expr {$cump + double($p)}]
        if {$x < $cump} { return $val }
    }
    return $def
}

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 }]} {
        getlog (junk)
        get-for $scope-fill
        get data rand 0 $mtu 1
        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-got {s v rv} {
    upvar #0 enum/val2name/$s-$v v2n
    if {[info exists v2n($rv)]} {
        getlog "$v=$v2n($rv)\[$rv]"
    } else {
        getlog "$v=$rv"
    }
    return $rv
}

proc get/enum-rand {s v min max} {
    set rv [choice-int $min $max]
    return [get-enum-got $s $v $rv]
}

proc get/enum-def {s v} {
    upvar #0 enum/val2name/$s-$v v2n
    set rv [choice-int 1 [array size v2n]]
    set rv [lindex [lsort [array names v2n]] [expr {$rv-1}]]
    return [get-enum-got $s $v $rv]
}

proc get/enum {s v min max prand} {
    get-for $s-$v
    get any choice $prand
    if {$any} {
        return [get/enum-rand $s $v $min $max]
    } else {
        return [get/enum-def $s $v]
    }
}

proc get/number {s v min max} {
    set rv [choice-int $min $max]
    getlog "$v=$rv"
    return $rv
}

proc get/hex {s v min max} {
    set rv [choice-int $min $max]
    getlog [format %s=0x%x $v $rv]
    return $rv
}

proc get/hex32 {s v} {
    set rv [random-bytes 4]
    getlog "$v=0x$rv"
    return 0x$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/rand {s v minlen maxlen blockbytes} {
    get-for $s-$v
    if {$maxlen<0} { getlog (full!); return {} }
    get l number [expr {$minlen/$blockbytes}] [expr {$maxlen/$blockbytes}]
    return [random-bytes [expr {$l*$blockbytes}]]
}

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 0x$b]
        set d .
    }
    getlog "$v=$p"
    return $rv
}

proc get/choice-mult {s v args} {
    set rv [eval choice-mult $args]
    getlog "($rv)"
    return $rv
}

proc get/string {s v minlen maxlen first rest} {
    set o {}
    set now $first
    for {set l [choice-int $minlen $maxlen]} {$l>0} {incr l -1} {
        set cn [choice-int 0 [expr {[string length $now]-1}]]
        append o [string index $now $cn]
        set now $rest
    }
    getlog "$v=\"$o\""
    return [packet-fromstring $o]
}

proc get/ntstring {s v minlen maxlen first rest} {
    set s [get/string $s $v $minlen $maxlen $first $rest]
    append s 00
    append s [random-bytes $maxlen]
    return [string range $s 0 [expr {$maxlen*2-1}]]
}

namespace eval Assembler {
    namespace export assemble assembly-overwrite

    proc assemble {outvarname format} {
        # format should look like those RFC diagrams.  +-+-+ stuff and
        # good formatting is mandatory.  You can have a single data
        # item at the end ending in ..., which means append that data
        # item.
        #
        # 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 names starting with digits are literal values instead.

        variable cache
        upvar 1 $outvarname out
        if {[catch { set parsed $cache($format) }]} {
            set parsed [parse $format]
            set cache($format) $parsed
        }

        manyset $parsed outbytes lout
        set out [string repeat 00 $outbytes]
        foreach {?_location varname locvarname} $lout {
            if {[regexp {^[0-9]} $varname]} {
                set value $varname
            } else {
                set value [uplevel 1 [list set $varname]]
            }
            if {[string length $locvarname]} {
                upvar 1 $locvarname lv
                set lv ${?_location}
            }
            if {[catch {
                assembly-overwrite out location $value
            } emsg]} {
                global errorInfo errorCode
                error $emsg \
                        "$errorInfo\n    setting\n$varname at ${?_location}" \
                        $errorCode
            }
        }
    }

    proc parse {format} {
        set lno 0
        set outbytes 0
        set atend 0
        debug 7 "ASSEMBLY $format"
        set format [exec expand << $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?"
                    }
                    incr outbytes [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?"
                        if {$atend} {
                            error "two things at end @$lno\n?$l?"
                        }
                        set varname [string tolower [string trim $midpart]]
                        if {[regexp {(.*[a-z0-9])\s*\.\.\.$} $varname \
                                dummy realvarname]} {
                            set varname $realvarname
                            set atend 1
                        }
                        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 {
                            $outbytes*8
                            - $words*$wordbits
                            + $atpos($p1)
                        }]
                        set bitlen [expr {
                            $atpos($p2) - $atpos($p1) + ($words-1)*$wordbits
                        }]
                        if {$atend} {
                            if {$bit1 % 8} {
                                error "atend not at byte @$lno\n?$l?"
                            }
                            set outbytes [expr {$bit1/8}]
                            set location [list $bit1 0 $varname]
                        } else {
                            set location [list $bit1 $bitlen $varname]
                        }
                        if {[regexp {^\?_(.*)} $varname dummy realvarname]} {
                            debug 7 "LOCATING $varname $location"
                            set locvarname $varname
                            set varname $realvarname
                        } else {
                            set locvarname {}
                        }
                        lappend lout $location $varname $locvarname
                        set l "$before="
                        append l [string repeat = [string length $midpart]]
                        append l |$after
                    }
                    debug 7 "REMAIN ?$l?"
                    if {![regexp {^[ =]*\|? *$} $l]} {
                        error "unclear @$lno\n?$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$outbytes\n$lout\n"
        return [list $outbytes $lout]
    }

    proc assembly-overwrite {outvarname locvarnameex value} {
        upvar 1 $outvarname out
        upvar 1 ?_$locvarnameex location
        manyset $location bit1 bitlen diag
        if {$bitlen > 0 && $bitlen != 32 && $value >= (1<<$bitlen)} {
            error "$diag $value >= 2**$bitlen"
        }
        if {!($bit1 % 8) && !($bitlen % 8)} {
            set char0no [expr {$bit1/4}]
            set charlen [expr {$bitlen/4}]
            set chareno [expr {$char0no + $charlen -1}]
            if {$bitlen > 0} {
 debug 8 "ASSEMBLY $diag == $value == 0x[format %x $value] (@$bit1+$bitlen)"
                set repl [format %0${charlen}x $value]
                set out [string replace $out $char0no $chareno $repl]
            } else {
 debug 8 "ASSEMBLY-ADD $diag (@$bit1)"
                # bitlen==0 => append
                set out [string range $out 0 $chareno]
                append out $value
            }
        } else {
            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
            }
        }
    }
}
namespace import Assembler::*

proc gen_1_ip {mtu source_spec dest_spec} {
    # RFC791
    upvar #0 ip_proto proto
    upvar #0 ip_source source
    upvar #0 ip_dest dest

    set source $source_spec
    set dest $dest_spec
    
    get-for ip
    set version 4
    get tos hex 0x00 0xff
    get id number 0x0000 0xffff
    get df flag 0.5
    if {$df || ![choice-prob ip-midfrag 0.05]} {
        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 0.05
    set flags [expr {$df*2 + $mf}]

    set header_checksum 0
    set ihl 0
    set total_length 0
    assemble ip {
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |Version| ? IHL |TOS            |       ? Total Length          |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |         Id                    |Flags|      Frag               |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |  TTL          |    Proto      |      ? Header Checksum        |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |                       Source                                  |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |                    Dest                                       |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
    }
    # we don't do any IP options

    set ihl [packet-len $ip]
    if {$ihl % 4} { error "ihl not mult of 4 bytes" }
    assembly-overwrite ip ihl [expr {$ihl / 4}]

    set body [depending-on ip proto $mtu -$ihl]
    set total_length [expr {[packet-len $ip] + [packet-len $body]}]

    assembly-overwrite ip total_length $total_length
    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 0.2
    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             |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |     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 0.4
    get body rand 0 $mbl 1
    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 0.4
    get gateway v4addr
    get data rand 0 [expr {$mbl-4}] 1
    assemble body {
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |                 Gateway                                       |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |     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 0.4
    get id hex 0 0xffff
    get seq hex 0 0xffff
    get data rand 0 [expr {$mbl-8}] 1
    assemble body {
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |       Id                      |        Seq                    |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |     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 0.4
    get id hex 0 0xffff
    get seq hex 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 0.4
    get id hex 0 0xffff
    get seq hex 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 4 ip {mtu} {
    # RFC2003
    get-for ip-ip
    get source v4addr
    get dest v4addr
    gen_1_ip $mtu $source $dest
}


define ip-proto 2 igmp {mtu} {
    get-for igmp
    get type enum 0 255 0.5
    get timeout number 0 255
    get group v4addr
    set checksum 0
    set extra {}
    assemble igmp {
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |      Type     |   Timeout     |         ? Checksum            |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |                         Group                                 |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |                       ? Extra ...                             |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
    }

    if {[choice-prob igmp-extra 0.3]} {
        get extra rand 1 [expr {$mtu - [packet-len $igmp]}] 1
        assembly-overwrite igmp extra $extra
    }
    
    assembly-overwrite igmp checksum [packet-csum-ip $igmp]
    return $igmp
}

define igmp-type 17 membquery {} {}
define igmp-type 16 membreport {} {}
define igmp-type 23 leavegroup {} {}
define igmp-type 18 membreport {} {}


define ip-proto 51 ah {mtu} {
    # RFC1826
    get-for ah
    get next number 0 255
    get reserved hex 0 0xffff
    get spi hex32
    get auth_data rand 0 [expr {$mtu-8}] 4
    set length [packet-len $auth_data]
    assemble ah {
     +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
     | Next          |   Length      |           RESERVED            |
     +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
     |                    SPI                                        |
     +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
     |                 Auth Data ...                                 |
     +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
    }
    get payload rand 0 [expr {$mtu - [packet-len $ah]}] 1
    append ah $payload
    return $ah
}


define ip-proto 17 udp {mtu} {
    # RFC768
    get-for udp

    set csum_mode [choice-mult \
            checksum_bad 0.10 \
            checksum_none 0.20 \
            checksum_good]

    get style choice-mult \
            request 0.15 \
            reply 0.15 \
            servers 0.20 \
            random

    if {"$style" != "random"} {
        get port enum-def
        set def_port $port
    } else {
        set def_port x
    }
    if {"$style" != "servers"} {
        get port enum-rand 0 0xffff
        set rand_port $port
    }
    switch -exact $style {
        random  { set source_port $rand_port; set dest_port $rand_port }
        request { set source_port $rand_port; set dest_port $def_port }
        reply   { set source_port $def_port;  set dest_port $rand_port }
        servers { set source_port $def_port;  set dest_port $def_port }
    }

    if {"$style" != "random"} {
        set port $def_port
        set data [depending-on udp port $mtu -8 $style]
    } else {
        get data rand 0 [expr {$mtu-8}] 1
    }

    set length 0
    set checksum 0
    assemble udp {
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |       Source Port             |        Dest Port              |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |       ? Length                |      ? Checksum               |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |     Data ...                                                  |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
    }
    set udp_length [packet-len $udp]
    assembly-overwrite udp length $udp_length

    if {"$csum_mode" == "checksum_none"} {
        set checksum 0
        getlog (nocsum)
    } else {
        global ip_source ip_dest ip_proto
        assemble pseudo {
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |       IP Source                                               |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |       IP Dest                                                 |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |       0       | IP Proto      |        UDP length             |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
        }
        set checksum [packet-csum-ip "$pseudo$udp"]
        if {!$checksum} { set checksum 0xffff }
        if {"$csum_mode" == "checksum_bad"} {
            get csumerror hex 1 0xffff
            set checksum [expr {$checksum ^ $csumerror}]
        }
    }
    assembly-overwrite udp checksum $checksum
    return $udp
}

define udp-port 50 remailck {mtu style} {
    # RFC1339
    get-for remailck
    if {"$style" == "request"} {
        get what choice-mult \
                req-baduser 0.15 \
                req-auth 0.15 \
                resp-ok 0.15 \
                resp-auth 0.15 \
                req-user
    } else {
        get what choice-mult \
                req-baduser 0.15 \
                req-auth 0.15 \
                resp-auth 0.15 \
                req-user 0.15 \
                resp-ok
    }
    switch -exact $what {
        req-user {
            set auth 0
            get user string 1 8 \
                    abcdefghijklmnopqrustuvwxyz \
                    abcdefghijklmnopqrustuvwxyz-0123456789_
        }
        req-baduser {
            set auth 0
            get user rand 0 [expr {$mtu - 4}] 1
        }
        req-auth {
            get auth enum 0 31 0.5
            set user [depending-on remailck auth $mtu -4]
        }
        resp-auth {
            get auth hex 0 0xffff
            set modified 0
            set read 0
        }
        resp-ok {
            get mail choice-mult \
                    newmail 0.15 \
                    oldmail 0.15 \
                    nomail 0.20 \
                    times
            set auth 0
            switch -exact $mail {
                newmail {
                    set modified 0
                    set read 1
                }
                oldmail {
                    set modified 1
                    set read 0
                }
                nomail {
                    set modified 0
                    set read 0
                }
                times {
                    get modified number 1 600
                    get read number 1 600
                }
                default { error "mail? $mail" }
            }
        }
        default { error "what? $what" }
    }
    switch -glob $what {
        req-* {
            assemble payload {
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |         Auth                                                  |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |     User ...                                                  |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
            }
        }
        resp-* {
            assemble payload {
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |         Auth                                                  |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |         Modified                                              |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |         Read                                                  |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
            }
        }
        default { error "what?? $what" }
    }
    return $payload
}

define remailck-auth 31 passwd {mtu} {
    get-for remailck-passwd
    get passwd string 6 8 \
            0123456789abcdefghijklmnopqrstuvxwyz \
            0123456789abcdefghijklmnopqrstuvxwyz
    return $passwd
}

define udp-port 67 dhcpserv {mtu style} { return [dhcp $mtu] }
define udp-port 68 dhcpclient {mtu style} { return [dhcp $mtu] }
proc dhcp {mtu} {
    get-for dhcp
    get op enum 0 255 0.2
    get htype enum 0 255 0.2
    set hlen 6
    get hops number 0 255
    get xid hex32
    get secs number 0 300
    get flags hex 0 255
    get ciaddr v4addr
    get yiaddr v4addr
    get siaddr v4addr
    get giaddr v4addr
    set chaddr [random-bytes 16]
    get sname ntstring 0 64 \
            0123456789abcdefghijklmnopqrstuvwxyz \
            0123456789abcdefghijklmnopqrstuvwxyz.-+
    get file ntstring 0 128 / \
            0123456789abcdefghijklmnopqrstuvwxyz.-+/_

    assemble dhcp {
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |     op        |   htype       |   hlen        |   hops        |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |                            xid                                |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |           secs                |           flags               |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |                          ciaddr                               |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |                          yiaddr                               |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |                          siaddr                               |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |                          giaddr                               |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
    }
    append dhcp $chaddr $sname $file

    return $dhcp
}
define dhcp-op 1 request {} {}
define dhcp-op 2 reply {} {}
define dhcp-htype 1 ethernet {} {}


define ip-proto 6 tcp {mtu} {
    # RFC793
    get-for tcp

    get source_port number 0 65535
    get dest_port number 0 65535
    get event choice-mult \
            connect 0.15 \
            accept 0.15 \
            close 0.15 \
            reset 0.15 \
            weird 0.15 \
            data
    set s 0
    set a 1
    set f 0
    set r 0
    switch -exact $event {
        connect { set s 1; set a 0 }
        accept { set s 1 }
        close { set f 1 }
        reset { set a 0; set r 1 }
        data { }
        weird {
            get s flag 0.5
            get a flag 0.5
            get f flag 0.5
            get r flag 0.5
        }
        default { error "event? $event" }
    }
    get seq hex32
    get ack hex32
    if {[choice-prob tcp-smallwindow 0.7]} {
        get window number 0 1
    } else {
        get window hex 0 0xffff
    }
    get p flag 0.5
    get u flag 0.3
    get urg hex 0 0xffff

    set options {}
    get optmode choice-mult badopt 0.3 opt 0.6 noopt
    switch -exact $optmode {
        noopt { }
        badopt {
            get options rand 1 60 1
        }
        opt {
            while {[choice-prob tcp-opts-more 0.4]} {
                get opt enum 1 255 0.5
                if {$opt == 1} {
                    assemble option {
   +-+-+-+-+-+-+-+-+
   |  Opt          |
   +-+-+-+-+-+-+-+-+
                    }
                } else {
                    set data [depending-on tcp opt 6 0]
                    set option_len 0
                    assemble option {
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |  Opt          | ? Option Len  |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |      Data ...                 |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
                    }
                    assembly-overwrite option option_len [packet-len $option]
                }
                append options $option
            }
        }
    }

    if {[choice-prob reserved-nonzero 0.25]} {
        get reserved hex 0 0x3f
    } else {
        set reserved 0
    }

    if {[packet-len $options] % 4 || [get optxpad choice 0.15]} {
        if {"$optmode" != "badopt"} { append options 00 }
        set padlen [expr {3 - ([packet-len $options] + 3) % 4}]
        append options [random-bytes $padlen]
    }

    set d_off 0
    set checksum 0
    assemble packet {
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |          Source Port          |       Dest Port               |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |                        Seq                                    |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |                    Ack                                        |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |? D Off| Reserved  |U|A|P|R|S|F|            Window             |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |         ? Checksum            |         Urg                   |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |                    Options     ...                            |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
    }

    set d_off [expr {([packet-len $packet]/4) & 0x0f}]
    assembly-overwrite packet d_off $d_off

    if {!($s || $r) || [get unexpdata flag 0.2]} {
        get data rand 0 [expr {$mtu - [packet-len $packet]}] 1
        append packet $data
    }
    set tcp_length [packet-len $packet]

    global ip_source ip_dest ip_proto
    assemble pseudo {
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |       IP Source                                               |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |       IP Dest                                                 |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |       0       | IP Proto      |        TCP length             |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
    }

    set csum [packet-csum-ip "$pseudo$packet"]
    if {[choice-prob tcp-badcsum 0.1]} {
        get csumerror hex 1 0xffff
        set csum [expr {$csum ^ $csumerror}]
    }
    assembly-overwrite packet checksum $csum
    return $packet
}

define tcp-opt 2 mss {mdl} {
    get-for tcp-opt
    get mss hex 0 0xffff
    assemble od {
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
   |        MSS                    |
   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
    }
    return $od
}


namespace eval PCap {
    namespace export pcap_open pcap_write pcap_write_raw pcap_close

    proc pcap_open {fn} {
        variable fh
        catch { close $fh }
        set fh [open $fn w]
        fconfigure $fh -translation binary
    }

    proc pcap_close {} {
        variable fh
        if {![info exists fh]} return
        close $fh
        unset fh
    }

    proc pcap_write_raw {packet} {
        variable fh
        if {![info exists fh]} return
        puts -nonewline $fh [binary format H* $packet]
    }

    proc pcap_write {valdeflist} {
        foreach {kind valvar} $valdeflist {
            if {![regexp {^([usx])([0-9]+)} $kind dummy mode bits]} {
                error "unknown kind $kind for $valvar"
            }
            set value [uplevel 1 [list set $valvar]]
            if {$bits % 8} { error "bits must be mult 8 in $kind for $valvar" }
            if {"$mode" != "x"} {
                set v {}
                set ov $value
                for {set i 0} {$i<$bits/8} {incr i} {
                    append v [format %02x [expr {$value & 0xff}]]
                    set value [expr {$value >> 8}]
                }
                if {$value != 0 && $value != -1} {
                    error "value $ov more than $bits bits (residue=$value)"
                }
                set value $v
            }
            if {[string length $value] != $bits/4} {
                error "$valvar value $value wrong length, not $bits bits"
            }
            pcap_write_raw $value
        }
    }
}
namespace import PCap::*

proc emit {seed} {
    global getlog_log errorInfo mtu fake_time_t
    global minframelen

    get-for ip
    get-config source 127.0.0.1 v4addr
    get-config dest 127.0.0.1 v4addr

    if {[catch {
        start_gen $seed
        set packet [gen_1_ip $mtu $source $dest]
        puts stdout "[format %6s $seed] $getlog_log\n       $packet"
    } emsg]} {
        puts stderr "\nERROR\n$seed\n\n$emsg\n\n$errorInfo\n\n"
        puts stdout "[format %6s $seed] error"
    } else {
        set ts_sec [incr fake_time_t]
        set ts_usec 0

        set l [packet-len $packet]
        if {$l < $minframelen} {
            append packet [string repeat 00 [expr {$minframelen - $l}]]
        }

        # RFC894
        set llpkt [random-bytes 12]
        append llpkt 0800
        append llpkt $packet
        
        set len [packet-len "$llpkt"]
        pcap_write {
            u32 ts_sec
            u32 ts_usec
            u32 len
            u32 len
        }
        pcap_write_raw $llpkt
    }
}


proc nextarg {} {
    global argv
    if {![llength $argv]} { error "need another arg" }
    set a [lindex $argv 0]
    set argv [lrange $argv 1 end]
    return $a
}

proc nextarg_num {} { return [expr {[nextarg] + 0}] }

set debug_level 0
set mtu 576
set upto {}
set xseed {}
while {[regexp {^\-\-} [lindex $argv 0]]} {
    set o [nextarg]
    switch -exact -- $o {
        --infinite { set upto -1 }
        --debug { set debug_level [nextarg_num] }
        --upto { set upto [nextarg_num] }
        --write { pcap_open [nextarg] }
        --mtu { set mtu [nextarg_num] }
        --xseed { set xseed [nextarg] }
        --source { set config/ip-source [nextarg] }
        --dest { set config/ip-dest [nextarg] }
        default { error "bad option $o" }
    }
}

set magic d4c3b2a1
set version_major 2
set version_minor 4
set thiszone 0
set sigfigs 0
set snaplen 131073

# RFC894
set linktype 1
set minframelen 46

pcap_write {
    x32 magic
    u16 version_major
    u16 version_minor
    s32 thiszone
    s32 sigfigs
    s32 snaplen
    s32 linktype
}

set fake_time_t [clock seconds]

if {[llength $argv]} {
    foreach count $argv { emit "$xseed$count" }
} else {
    if {![string length $upto]} { set upto 100 }
    for {set count 1} {$upto<0 || $count<=$upto} {incr count} {
        emit "$xseed$count"
    }
}

pcap_close