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