test/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         include test-example/sites.conf
  92         sites map(site,vpn/test-example/all-sites);
  93     }
  94     return $cfg
  95 }
  96
  97 proc spawn-secnet {which} {
  98     global netlinkfh
  99     global tmp
 100     upvar #0 pids($which) pid
 101     set cf $tmp/$which.conf
 102     set ch [open $cf w]
 103     puts $ch [mkconf $which]
 104     close $ch
 105     set argl [list strace -o$tmp/$which.strace ./secnet -dvnc $cf]
 106     set pid [fork]
 107     if {!$pid} {
 108         execl [lindex $argl 0] [lrange $argl 1 end]
 109     }
 110     puts -nonewline $netlinkfh($which.t) [hbytes h2raw c0]
 111 }
 112
 113 proc netlink-readable {which} {
 114     global ok
 115     upvar #0 netlinkfh($which.r) fh
 116     read $fh; # empty the buffer
 117     switch -exact $which {
 118         inside {
 119             puts OK
 120             set ok 1; # what a bodge
 121             return
 122         }
 123         outside {
 124             error "inside rx'd!"
 125         }
 126     }
 127 }
 128
 129 proc bgerror {message} {
 130     global errorInfo errorCode
 131     catch {
 132         puts stderr "
 133 ----------------------------------------
 134 $errorInfo
 135
 136 $errorCode
 137 $message
 138 ----------------------------------------
 139     "
 140     }
 141     exit 1
 142 }
 143
 144 proc sendpkt {} {
 145     global netlinkfh
 146     set p {
 147         4500 0054 ed9d 4000 4001 24da ac12 e809
 148         ac12 e802 0800 1de4 2d96 0001 f1d4 a05d
 149         0000 0000 507f 0b00 0000 0000 1011 1213
 150         1415 1617 1819 1a1b 1c1d 1e1f 2021 2223
 151         2425 2627 2829 2a2b 2c2d 2e2f 3031 3233
 152         3435 3637
 153     }
 154     puts -nonewline $netlinkfh(inside.t) \
 155         [hbytes h2raw c0[join $p ""]c0]
 156 }
 157
 158 if {![catch {
 159     set tmp $env(AUTOPKGTEST_ARTIACTS)
 160 }]} {} elseif {![catch {
 161     set tmp $env(AUTOPKGTEST_TMP)
 162 }]} {} elseif {[regsub {^test/t-} $argv0 {test/d-} tmp]} {
 163     file mkdir $tmp
 164 }
 165
 166 set socktmp $tmp/s
 167 exec mkdir -p -m700 $socktmp
 168 regsub {^(?!/)} $socktmp {./} socktmp ;# dgram-socket wants ./ or /
 169
 170 proc prefix_preload {lib} {
 171     global env
 172     set l {}
 173     catch { set l [split $env(PRELOAD) :] }
 174     set l [concat [list $lib] $l]
 175     set env(LD_PRELOAD) [join $l :]
 176 }
 177
 178 set env(UDP_PRELOAD_DIR) $socktmp
 179 prefix_preload test/udp-preload.so
 180
 181 proc udp-proxy {} {
 182     global socktmp udpsock
 183     set u $socktmp/udp
 184     file delete $u
 185     regsub {^(?!/)} $u {./} u
 186     set udpsock [dgram-socket create $u]
 187     dgram-socket on-receive $udpsock udp-relay
 188 }
 189
 190 proc udp-relay {data src sock args} {
 191     global udpsock socktmp
 192     set headerlen [expr {52+1}]
 193     set orgsrc $src
 194
 195     set dst [hbytes range $data 0 $headerlen]
 196     regsub {(?:00)*$} $dst {} dst
 197     set dst [hbytes h2raw $dst]
 198
 199     hbytes overwrite data 0 [hbytes zeroes $headerlen]
 200     regsub {.*/} $src {} src
 201     set srch [hbytes raw2h $src]
 202     hbytes append srch 00
 203     if {[catch {
 204         if {[regexp {[^.,:0-9a-f]} $dst c]} { error "bad dst" }
 205         if {[hbytes length $srch] > $headerlen} { error "src addr too long" }
 206         hbytes overwrite data 0 $srch
 207         dgram-socket transmit $udpsock $data $socktmp/$dst
 208     } emsg]} {
 209         puts stderr "$orgsrc -> $dst: $emsg"
 210     }
 211 }