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