Does re-mail-ck. About to profile

diff --git a/make-probes.tcl b/make-probes.tcl
index 8782f1a3e3002b6fcd8e0517ad2ae90cee087106..f41cae14986de7e989ba3904875a74c8c585f83e 100755 (executable)
--- a/make-probes.tcl
+++ b/make-probes.tcl
@@ -63,7 +63,7 @@ namespace import Random-Bytes::*
 proc choice-int {min max} {
     set rv 0x[random-bytes 3]
     return [expr {
-       int( double($rv) / double(0xffffff) * double($max+1-$min) )
+       int( double($rv) / double(0x1000000) * double($max+1-$min) )
        + $min
     }]
 }
@@ -74,6 +74,19 @@ proc choice-prob {cv def} {
     return [expr {$rv < double($prob)*0x1000000}]
 }
 
+proc choice-mult {args} {
+    if {!([llength $args] % 2)} { error "choice-mult must have default" }
+    set x 0x[random-bytes 3]
+    set x [expr { double($x) / 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
@@ -105,7 +118,7 @@ proc depending-on {scope enum_and_var mtu mtuadjust args} {
        # half the time random
        getlog (junk)
        get-for $scope-fill
-       get data randupto $mtu
+       get data rand 0 $mtu
        return $data
     } else {
        uplevel 1 [list $procname] $mtu $args
@@ -140,14 +153,8 @@ proc get-config {variable def kind args} {
     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}]]
-    }
+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 {
@@ -156,6 +163,28 @@ proc get/enum {s v min max} {
     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 [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"
@@ -174,9 +203,9 @@ proc get/choice {s v defprob} {
     return $rv
 }
 
-proc get/randupto {s v maxlen} {
+proc get/rand {s v minlen maxlen} {
     get-for $s-$v
-    get l number 0 $maxlen
+    get l number $minlen $maxlen
     return [random-bytes $l]
 }
 
@@ -200,6 +229,24 @@ proc get/v4addr {s v} {
     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 $o
+}
+
 
 proc assemble {outvarname format} {
     # format should look like those RFC diagrams.
@@ -365,7 +412,7 @@ proc gen_1_ip {mtu} {
        get frag number 0 0x1fff
     }
     get-config ttl 255 number 0 255
-    get proto enum 1 255
+    get proto enum 1 255 0.05
     get-config source 127.0.0.1 v4addr
     get-config dest 127.0.0.1 v4addr
     # we don't do any IP options
@@ -395,7 +442,7 @@ proc gen_1_ip {mtu} {
 define ip-proto 1 icmp {mtu} {
     # RFC792
     get-for icmp
-    get type enum 0 255
+    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
@@ -414,8 +461,8 @@ proc define-icmp-type-vanilla {num name} {
 }
 proc icmp-vanilla {mbl typename} {
     get-for icmp-$typename
-    get code enum 0 255
-    get body randupto $mbl
+    get code enum 0 255 0.4
+    get body rand 0 $mbl
     return [list $body $code]
 }
 
@@ -439,14 +486,14 @@ define icmp-sourcequench-code 0 quench {} {}
 
 define icmp-type 5 redirect {mbl} {
     get-for icmp-redirect
-    get code enum 0 255
+    get code enum 0 255 0.4
     get gateway v4addr
     assemble body {
    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
    |                 Gateway                                       |
    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
     }
-    get data randupto [expr {$mbl-4}]
+    get data rand 0 [expr {$mbl-4}]
     append body $data
     return [list $body $code]
 }
@@ -460,7 +507,7 @@ 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 code enum 0 255 0.4
     get id number 0 0xffff
     get seq number 0 0xffff
     assemble body {
@@ -468,7 +515,7 @@ proc icmp-echo {mbl} {
    |       Id                      |        Seq                    |
    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
     }
-    get data randupto [expr {$mbl-8}]
+    get data rand 0 [expr {$mbl-8}]
     append body $data
     return [list $body $code]
 }
@@ -478,7 +525,7 @@ 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 code enum 0 255 0.4
     get id number 0 0xffff
     get seq number 0 0xffff
     get originate ip-timestamp
@@ -503,7 +550,7 @@ 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 code enum 0 255 0.4
     get id number 0 0xffff
     get seq number 0 0xffff
     assemble body {
@@ -518,11 +565,45 @@ define icmp-inforeq-code 0 timestamp {} {}
 # MAYADD ICMP traceroute RFC1393
 # MAYADD ICMP router discovery RFC1256
 
+proc port_pair_data {scope mtu mtuadjust} {
+    get-for $scope
+
+    get style choice-mult \
+           request 0.24 \
+           reply 0.24 \
+           random 0.16 \
+           servers
+
+    if {"$style" != "random"} {
+       get port enum-def
+       set def_port $port
+    }
+    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 $scope port $mtu $mtuadjust $style]
+    } else {
+       get data rand 0 [expr {$mtu + $mtuadjust}]
+    }
+    return [list $source_port $dest_port $data]
+}
+
 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}]
+    get checksum choice-mult \
+           checksum_bad 0.20 \
+           checksum_none 0.20 \
+           checksum_good
+    manyset [port_pair_data udp $mtu 8] source_port dest_port data
     set length [packet-len $data]
     set checksum 0
     assemble udp {
@@ -533,19 +614,109 @@ define ip-proto 17 udp {mtu} {
    +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
     }
     append udp $data
-    get checksum choice 0.75
-    if {$checksum} {
+    if {"$checksum" != "none"} {
        set csum [packet-csum-ip $udp]
        if {!$csum} { set csum 0xffff }
+       if {"$checksum" == "bad"} {
+           get error number 1 0xffff
+           set csum [expr {$csum ^ $error}]
+       }
     } else {
        set csum 0
     }
     assembly-overwrite udp ${?_checksum} $csum
 }
 
-
-
-
+define udp-port 50 remailck {mtu style} {
+    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}]
+       }
+       req-auth {
+           get auth enum 0 31
+           set user [depending-on auth {$mtu - 4}]
+       }
+       resp-auth {
+           get auth number 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 packet {
+   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+   |         Auth                                                  |
+   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+            }
+           append packet $user
+       }
+       resp-* {
+           assemble packet {
+   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+   |         Auth                                                  |
+   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+   |         Modified                                              |
+   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+   |         Read                                                  |
+   +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+
+            }
+       }
+       default { error "what?? $what" }
+    }
+    return $packet
+}
 
 proc emit {count} {
     global getlog_log errorInfo