stest/common.tcl

   1 source test-common.tcl
   2
   3 package require Tclx
   4
   5 load chiark_tcl_hbytes-1.so
   6 load chiark_tcl_dgram-1.so
   7
   8 set netlink(inside) {
   9     local-address "172.18.232.9";
  10     secnet-address "172.18.232.10";
  11     remote-networks "172.18.232.0/28";
  12 }
  13 set netlink(outside) {
  14     local-address "172.18.232.1";
  15     secnet-address "172.18.232.2";
  16     remote-networks "172.18.232.0/28";
  17 }
  18
  19 set ports(inside) {16913 16910}
  20 set ports(outside) 16900
  21
  22 set extra(inside) {
  23     local-mobile True;
  24     mtu-target 1260;
  25 }
  26 set extra(outside) {}
  27
  28 set privkey(inside) test-example/inside.privkeys/
  29 set privkey(outside) test-example/outside.privkeys/
  30
  31 proc sitesconf_hook {l} { return $l }
  32
  33 proc oldsecnet {site} {
  34     upvar #0 oldsecnet($site) oldsecnet
  35     expr {[info exists oldsecnet] && [set oldsecnet]}
  36 }
  37
  38 proc mkconf {location site} {
  39     global tmp
  40     global builddir
  41     global netlink
  42     global ports
  43     global extra
  44     global netlinkfh
  45     upvar #0 privkey($site) privkey
  46     set pipefp $tmp/$site.netlink
  47     foreach tr {t r} {
  48         file delete $pipefp.$tr
  49         exec mkfifo -m600 $pipefp.$tr
  50         set netlinkfh($site.$tr) [set fh [open $pipefp.$tr r+]]
  51         fconfigure $fh -blocking 0 -buffering none -translation binary
  52     }
  53     fileevent $netlinkfh($site.r) readable \
  54         [list netlink-readable $location $site]
  55     set fakeuf $tmp/$site.fake-userv
  56     set fakeuh [open $fakeuf w 0755]
  57     puts $fakeuh "#!/bin/sh
  58 set -e
  59 exec 3<&0
  60 cat <&3 3<&- >$pipefp.r &
  61 exec 3<>$pipefp.t
  62 exec <$pipefp.t
  63 exec 3<&-
  64 exec cat
  65 "
  66     close $fakeuh
  67     set cfg "
  68         hash sha1;
  69         netlink userv-ipif {
  70             name \"netlink\";
  71             userv-path \"$fakeuf\";
  72         $netlink($site)
  73             mtu 1400;
  74             buffer sysbuffer(2048);
  75             interface \"secnet-test-[string range $site 0 0]\";
  76         };
  77         comm
  78 "
  79     set delim {}
  80     foreach port $ports($site) {
  81         append cfg "$delim
  82             udp {
  83                 port $port;
  84                 address \"::1\", \"127.0.0.1\";
  85                 buffer sysbuffer(4096);
  86             }
  87         "
  88         set delim ,
  89     }
  90     append cfg ";
  91         local-name \"test-example/$location/$site\";
  92 "
  93     switch -glob $privkey {
  94         */ {
  95             set sitesconf sites.conf
  96             append cfg "
  97                 key-cache priv-cache({
  98                     privkeys \"$builddir/${privkey}priv.\";
  99                 });
 100 "
 101         }
 102         * {
 103             set sitesconf sites-nonego.conf
 104             append cfg "
 105                 local-key rsa-private(\"$builddir/$privkey\");
 106 "
 107         }
 108     }
 109     set sitesconf $builddir/test-example/$sitesconf
 110
 111     append cfg $extra($site)
 112     append cfg "
 113         log logfile {
 114             prefix \"$site\";
 115             class \"debug\",\"info\",\"notice\",\"warning\",\"error\",\"security\",\"fatal\";
 116     "
 117     if {[oldsecnet $site]} { append cfg "
 118             filename \"/dev/stderr\";
 119     " }
 120     append cfg "
 121         };
 122     "
 123     append cfg {
 124         system {
 125         };
 126         resolver adns {
 127         };
 128         log-events "all";
 129         random randomfile("/dev/urandom",no);
 130         transform eax-serpent { }, serpent256-cbc { };
 131     }
 132
 133     set pubkeys $tmp/$site.pubkeys
 134     file delete -force $pubkeys
 135     exec cp -rl $builddir/test-example/pubkeys $pubkeys
 136
 137     set f [open $sitesconf r]
 138     while {[gets $f l] >= 0} {
 139         regsub {\"[^\"]*test-example/pubkeys/} $l "\"$pubkeys/" l
 140         set l [sitesconf_hook $l]
 141         append cfg $l "\n"
 142     }
 143     set sites [read $f]
 144     close $f
 145     append cfg $sites
 146     append cfg {
 147         sites map(site,all-sites);
 148     }
 149
 150     return $cfg
 151 }
 152
 153 proc spawn-secnet {location site} {
 154     global tmp
 155     global builddir
 156     global netlinkfh
 157     global env
 158     global pidmap
 159     global readbuf
 160     upvar #0 pids($site) pid
 161     set readbuf($site) {}
 162     set cf $tmp/$site.conf
 163     set ch [open $cf w]
 164     puts $ch [mkconf $location $site]
 165     close $ch
 166     set secnet $builddir/secnet
 167     if {[oldsecnet $site]} {
 168         set secnet $env(OLD_SECNET_DIR)/secnet
 169     }
 170     set argl [list $secnet -dvnc $cf]
 171     set divertk SECNET_STEST_DIVERT_$site
 172     puts -nonewline "spawn"
 173     foreach k [array names env] {
 174         switch -glob $k {
 175             SECNET_STEST_DIVERT_* -
 176             SECNET_TEST_BUILDDIR - OLD_SECNET_DIR { }
 177             *SECNET* -
 178             *PRELOAD* { puts -nonewline " $k=$env($k)" }
 179         }
 180     }
 181     puts " $argl"
 182     if {[info exists env($divertk)]} {
 183         switch -glob $env($divertk) {
 184             i {
 185                 puts -nonewline "run ^ command, hit return "
 186                 flush stdout
 187                 gets stdin
 188                 set argl {}
 189             }
 190             0 - "" {
 191             }
 192             * {
 193                 set argl [split $env($divertk)]
 194             }
 195         }
 196     }
 197     if {[llength $argl]} {
 198         set pid [fork]
 199         set pidmap($pid) "secnet $location/$site"
 200         if {!$pid} {
 201             execl [lindex $argl 0] [lrange $argl 1 end]
 202         }
 203     }
 204     puts -nonewline $netlinkfh($site.t) [hbytes h2raw c0]
 205 }
 206
 207 proc netlink-readable {location site} {
 208     global ok
 209     upvar #0 readbuf($site) buf
 210     upvar #0 netlinkfh($site.r) fh
 211     while 1 {
 212         set x [read $fh]
 213         set h [hbytes raw2h $x]
 214         if {![hbytes length $h]} return
 215         append buf $h
 216         #puts "READABLE $site buf=$buf"
 217         while {[regexp {^((?:..)*?)c0(.*)$} $buf dummy now buf]} {
 218             #puts "READABLE $site now=$now (buf=$buf)"
 219             regsub -all {^((?:..)*?)dbdc} $now {\1c0} now
 220             regsub -all {^((?:..)*?)dbdd} $now {\1db} now
 221             puts "netlink-got-packet $location $site $now"
 222             netlink-got-packet $location $site $now
 223         }
 224     }
 225 }
 226
 227 proc netlink-got-packet {location site data} {
 228     if {![hbytes length $data]} return
 229     switch -exact $site {
 230         inside {
 231             switch -glob $data {
 232                 45000054ed9d4000fe0166d9ac12e802ac12e80900* {
 233                     puts "OK $data"
 234                     finish 0
 235                 }
 236                 * {
 237                     error "unexpected $site $data"
 238                 }
 239             }
 240         }
 241         outside {
 242             error "inside rx'd!"
 243         }
 244     }
 245 }
 246
 247 proc bgerror {message} {
 248     global errorInfo errorCode
 249     catch {
 250         puts stderr "
 251 ----------------------------------------
 252 $errorInfo
 253
 254 $errorCode
 255 $message
 256 ----------------------------------------
 257     "
 258     }
 259     finish 1
 260 }
 261
 262 proc sendpkt {} {
 263     global netlinkfh
 264     set p {
 265         4500 0054 ed9d 4000 4001 24da ac12 e809
 266         ac12 e802 0800 1de4 2d96 0001 f1d4 a05d
 267         0000 0000 507f 0b00 0000 0000 1011 1213
 268         1415 1617 1819 1a1b 1c1d 1e1f 2021 2223
 269         2425 2627 2829 2a2b 2c2d 2e2f 3031 3233
 270         3435 3637
 271     }
 272     puts -nonewline $netlinkfh(inside.t) \
 273         [hbytes h2raw c0[join $p ""]c0]
 274 }
 275
 276 set socktmp $tmp/s
 277 exec mkdir -p -m700 $socktmp
 278 regsub {^(?!/|\./)} $socktmp {./} socktmp ;# dgram-socket wants ./ or /
 279
 280 proc prefix_preload {lib} { prefix_some_path LD_PRELOAD $lib }
 281
 282 set env(UDP_PRELOAD_DIR) $socktmp
 283 prefix_preload $builddir/stest/udp-preload.so
 284
 285 proc finish {estatus} {
 286     puts stderr "FINISHING $estatus"
 287     signal default SIGCHLD
 288     global pidmap
 289     foreach pid [array names pidmap] {
 290         kill KILL $pid
 291     }
 292     exit $estatus
 293 }
 294
 295 proc reap {} {
 296     global pidmap
 297     #puts stderr REAPING
 298     foreach pid [array names pidmap] {
 299         set got [wait -nohang $pid]
 300         if {![llength $got]} continue
 301         set info $pidmap($pid)
 302         unset pidmap($pid)
 303         puts stderr "reaped $info: $got"
 304         finish 1
 305     }
 306 }
 307
 308 signal -restart trap SIGCHLD { after idle reap }
 309
 310 proc udp-proxy {} {
 311     global socktmp udpsock
 312     set u $socktmp/udp
 313     file delete $u
 314     regsub {^(?!/)} $u {./} u
 315     set udpsock [dgram-socket create $u]
 316     dgram-socket on-receive $udpsock udp-relay
 317 }
 318
 319 proc udp-relay {data src sock args} {
 320     global udpsock socktmp
 321     set headerlen [expr {52+1}]
 322     set orgsrc $src
 323
 324     set dst [hbytes range $data 0 $headerlen]
 325     regsub {(?:00)*$} $dst {} dst
 326     set dst [hbytes h2raw $dst]
 327
 328     hbytes overwrite data 0 [hbytes zeroes $headerlen]
 329     regsub {.*/} $src {} src
 330     set srch [hbytes raw2h $src]
 331     hbytes append srch 00
 332     if {[catch {
 333         if {[regexp {[^.,:0-9a-f]} $dst c]} { error "bad dst" }
 334         if {[hbytes length $srch] > $headerlen} { error "src addr too long" }
 335         hbytes overwrite data 0 $srch
 336         dgram-socket transmit $udpsock $data $socktmp/$dst
 337     } emsg]} {
 338         puts stderr "$orgsrc -> $dst: $emsg"
 339     }
 340 }
 341
 342 proc test-kex {} {
 343     udp-proxy
 344     spawn-secnet in inside
 345     spawn-secnet out outside
 346
 347     after 500 sendpkt
 348     after 1000 sendpkt
 349     after 5000 timed-out
 350
 351     vwait ok
 352 }