stest/common.tcl

   1 package require Tclx
   2
   3 load chiark_tcl_hbytes-1.so
   4 load chiark_tcl_dgram-1.so
   5
   6 set netlink(inside) {
   7     local-address "172.18.232.9";
   8     secnet-address "172.18.232.10";
   9     remote-networks "172.18.232.0/28";
  10 }
  11 set netlink(outside) {
  12     local-address "172.18.232.1";
  13     secnet-address "172.18.232.2";
  14     remote-networks "172.18.232.0/28";
  15 }
  16
  17 set ports(inside) {16913 16910}
  18 set ports(outside) 16900
  19
  20 set extra(inside) {
  21     local-mobile True;
  22     mtu-target 1260;
  23 }
  24 set extra(outside) {}
  25
  26 proc mkconf {which} {
  27     global tmp
  28     global builddir
  29     global netlink
  30     global ports
  31     global extra
  32     global netlinkfh
  33     set pipefp $tmp/$which.netlink
  34     foreach tr {t r} {
  35         file delete $pipefp.$tr
  36         exec mkfifo -m600 $pipefp.$tr
  37         set netlinkfh($which.$tr) [set fh [open $pipefp.$tr r+]]
  38         fconfigure $fh -blocking 0 -buffering none -translation binary
  39     }
  40     fileevent $netlinkfh($which.r) readable [list netlink-readable $which]
  41     set fakeuf $tmp/$which.fake-userv
  42     set fakeuh [open $fakeuf w 0755]
  43     puts $fakeuh "#!/bin/sh
  44 set -e
  45 exec 3<&0
  46 cat <&3 3<&- >$pipefp.r &
  47 exec 3<>$pipefp.t
  48 exec <$pipefp.t
  49 exec 3<&-
  50 exec cat
  51 "
  52     close $fakeuh
  53     set cfg "
  54         netlink userv-ipif {
  55             name \"netlink\";
  56             userv-path \"$fakeuf\";
  57         $netlink($which)
  58             mtu 1400;
  59             buffer sysbuffer(2048);
  60             interface \"secnet-test-[string range $which 0 0]\";
  61         };
  62         comm
  63 "
  64     set delim {}
  65     foreach port $ports($which) {
  66         append cfg "$delim
  67             udp {
  68                 port $port;
  69                 address \"::1\", \"127.0.0.1\";
  70                 buffer sysbuffer(4096);
  71             }
  72         "
  73         set delim ,
  74     }
  75     append cfg ";
  76         local-name \"test-example/$which/$which\";
  77         local-key rsa-private(\"$builddir/test-example/$which.key\");
  78 "
  79     append cfg $extra($which)
  80     append cfg {
  81         log logfile {
  82             filename "/dev/tty";
  83             class "info","notice","warning","error","security","fatal";
  84         };
  85         system {
  86         };
  87         resolver adns {
  88         };
  89         log-events "all";
  90         random randomfile("/dev/urandom",no);
  91         transform eax-serpent { }, serpent256-cbc { };
  92     }
  93
  94     set f [open $builddir/test-example/sites.conf r]
  95     set sites [read $f]
  96     close $f
  97     append cfg $sites
  98     append cfg {
  99         sites map(site,vpn/test-example/all-sites);
 100     }
 101     return $cfg
 102 }
 103
 104 proc spawn-secnet {which} {
 105     global tmp
 106     global builddir
 107     global netlinkfh
 108     upvar #0 pids($which) pid
 109     set cf $tmp/$which.conf
 110     set ch [open $cf w]
 111     puts $ch [mkconf $which]
 112     close $ch
 113     set argl [list $builddir/secnet -dvnc $cf]
 114     set pid [fork]
 115     if {!$pid} {
 116         execl [lindex $argl 0] [lrange $argl 1 end]
 117     }
 118     puts -nonewline $netlinkfh($which.t) [hbytes h2raw c0]
 119 }
 120
 121 proc netlink-readable {which} {
 122     global ok
 123     upvar #0 netlinkfh($which.r) fh
 124     read $fh; # empty the buffer
 125     switch -exact $which {
 126         inside {
 127             puts OK
 128             set ok 1; # what a bodge
 129             return
 130         }
 131         outside {
 132             error "inside rx'd!"
 133         }
 134     }
 135 }
 136
 137 proc bgerror {message} {
 138     global errorInfo errorCode
 139     catch {
 140         puts stderr "
 141 ----------------------------------------
 142 $errorInfo
 143
 144 $errorCode
 145 $message
 146 ----------------------------------------
 147     "
 148     }
 149     exit 1
 150 }
 151
 152 proc sendpkt {} {
 153     global netlinkfh
 154     set p {
 155         4500 0054 ed9d 4000 4001 24da ac12 e809
 156         ac12 e802 0800 1de4 2d96 0001 f1d4 a05d
 157         0000 0000 507f 0b00 0000 0000 1011 1213
 158         1415 1617 1819 1a1b 1c1d 1e1f 2021 2223
 159         2425 2627 2829 2a2b 2c2d 2e2f 3031 3233
 160         3435 3637
 161     }
 162     puts -nonewline $netlinkfh(inside.t) \
 163         [hbytes h2raw c0[join $p ""]c0]
 164 }
 165
 166 if {![catch {
 167     set builddir $env(STEST_BUILDDIR)
 168 }]} {} else {
 169     set builddir .
 170 }
 171
 172 if {![catch {
 173     set tmp $env(AUTOPKGTEST_ARTIACTS)
 174 }]} {} elseif {![catch {
 175     set tmp $env(AUTOPKGTEST_TMP)
 176 }]} {} elseif {[regsub {^stest/t-} $argv0 {stest/d-} tmp]} {
 177     set tmp $builddir/$tmp
 178     file mkdir $tmp
 179 }
 180 set socktmp $tmp/s
 181 exec mkdir -p -m700 $socktmp
 182 regsub {^(?!/)} $socktmp {./} socktmp ;# dgram-socket wants ./ or /
 183
 184 proc prefix_preload {lib} {
 185     global env
 186     set l {}
 187     catch { set l [split $env(PRELOAD) :] }
 188     set l [concat [list $lib] $l]
 189     set env(LD_PRELOAD) [join $l :]
 190 }
 191
 192 set env(UDP_PRELOAD_DIR) $socktmp
 193 prefix_preload $builddir/stest/udp-preload.so
 194
 195 proc udp-proxy {} {
 196     global socktmp udpsock
 197     set u $socktmp/udp
 198     file delete $u
 199     regsub {^(?!/)} $u {./} u
 200     set udpsock [dgram-socket create $u]
 201     dgram-socket on-receive $udpsock udp-relay
 202 }
 203
 204 proc udp-relay {data src sock args} {
 205     global udpsock socktmp
 206     set headerlen [expr {52+1}]
 207     set orgsrc $src
 208
 209     set dst [hbytes range $data 0 $headerlen]
 210     regsub {(?:00)*$} $dst {} dst
 211     set dst [hbytes h2raw $dst]
 212
 213     hbytes overwrite data 0 [hbytes zeroes $headerlen]
 214     regsub {.*/} $src {} src
 215     set srch [hbytes raw2h $src]
 216     hbytes append srch 00
 217     if {[catch {
 218         if {[regexp {[^.,:0-9a-f]} $dst c]} { error "bad dst" }
 219         if {[hbytes length $srch] > $headerlen} { error "src addr too long" }
 220         hbytes overwrite data 0 $srch
 221         dgram-socket transmit $udpsock $data $socktmp/$dst
 222     } emsg]} {
 223         puts stderr "$orgsrc -> $dst: $emsg"
 224     }
 225 }
 226
 227 proc test-kex {} {
 228     udp-proxy
 229     spawn-secnet inside
 230     spawn-secnet outside
 231
 232     after 500 sendpkt
 233     after 1000 sendpkt
 234     after 5000 timed-out
 235
 236     vwait ok
 237 }