test/invoke

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