test/invoke

   1 #! /usr/bin/tclsh
   2
   3 package require Tclx
   4
   5 load chiark_tcl_hbytes-1.so
   6
   7 set netlink(inside) {
   8     local-address "172.18.232.9";
   9     secnet-address "172.18.232.10";
  10     remote-networks "172.18.232.0/28";
  11 }
  12 set netlink(outside) {
  13     local-address "172.18.232.1";
  14     secnet-address "172.18.232.2";
  15     remote-networks "172.18.232.0/28";
  16 }
  17
  18 set ports(inside) {16913 16910}
  19 set ports(outside) 16900
  20
  21 set extra(inside) {
  22     local-mobile True;
  23     mtu-target 1260;
  24 }
  25 set extra(outside) {}
  26
  27 proc mkconf {which} {
  28     global netlink
  29     global ports
  30     global extra
  31     global netlinkfh
  32     set pipefp test/$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 test/$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                 buffer sysbuffer(4096);
  69             }
  70         "
  71         set delim ,
  72     }
  73     append cfg ";
  74         local-name \"test-example/$which/$which\";
  75         local-key rsa-private(\"test-example/$which.key\");
  76 "
  77     append cfg $extra($which)
  78     append cfg {
  79         log logfile {
  80             filename "/dev/tty";
  81             class "info","notice","warning","error","security","fatal";
  82         };
  83         system {
  84         };
  85         resolver adns {
  86         };
  87         log-events "all";
  88         random randomfile("/dev/urandom",no);
  89         transform eax-serpent { }, serpent256-cbc { };
  90         include test-example/sites.conf
  91         sites map(site,vpn/test-example/all-sites);
  92     }
  93     return $cfg
  94 }
  95
  96 proc spawn-secnet {which} {
  97     global netlinkfh
  98     upvar #0 pids($which) pid
  99     set cf test/$which.conf
 100     set ch [open $cf w]
 101     puts $ch [mkconf $which]
 102     close $ch
 103     set argl [list -dvnc $cf]
 104     set pid [fork]
 105     if {!$pid} {
 106         execl ./secnet $argl
 107     }
 108     puts -nonewline $netlinkfh($which.t) [hbytes h2raw c0]
 109 }
 110
 111 proc netlink-readable {which} {
 112     global ok
 113     upvar #0 netlinkfh($which.r) fh
 114     read $fh; # empty the buffer
 115     switch -exact $which {
 116         outside {
 117             puts OK
 118             set ok 1; # what a bodge
 119             return
 120         }
 121         inside {
 122             error "inside rx'd!"
 123         }
 124     }
 125 }
 126
 127 proc bgerror {message} {
 128     global errorInfo errorCode
 129     catch {
 130         puts stderr "
 131 ----------------------------------------
 132 $errorInfo
 133
 134 $errorCode
 135 $message
 136 ----------------------------------------
 137     "
 138     }
 139     exit 1
 140 }
 141
 142 spawn-secnet inside
 143 spawn-secnet outside
 144
 145 vwait ok