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