package require Tclx
+load chiark_tcl_hbytes-1.so
+load chiark_tcl_dgram-1.so
+
set netlink(inside) {
local-address "172.18.232.9";
secnet-address "172.18.232.10";
set extra(outside) {}
proc mkconf {which} {
+ global tmp
global netlink
global ports
global extra
+ global netlinkfh
+ set pipefp $tmp/$which.netlink
+ foreach tr {t r} {
+ file delete $pipefp.$tr
+ exec mkfifo -m600 $pipefp.$tr
+ set netlinkfh($which.$tr) [set fh [open $pipefp.$tr r+]]
+ fconfigure $fh -blocking 0 -buffering none -translation binary
+ }
+ fileevent $netlinkfh($which.r) readable [list netlink-readable $which]
+ set fakeuf $tmp/$which.fake-userv
+ set fakeuh [open $fakeuf w 0755]
+ puts $fakeuh "#!/bin/sh
+set -e
+exec 3<&0
+cat <&3 3<&- >$pipefp.r &
+exec 3<>$pipefp.t
+exec <$pipefp.t
+exec 3<&-
+exec cat
+"
+ close $fakeuh
set cfg "
- netlink tun {
- name \"netlink-tun\";
+ netlink userv-ipif {
+ name \"netlink\";
+ userv-path \"$fakeuf\";
$netlink($which)
mtu 1400;
buffer sysbuffer(2048);
append cfg "$delim
udp {
port $port;
+ address \"::1\", \"127.0.0.1\";
buffer sysbuffer(4096);
}
"
class "info","notice","warning","error","security","fatal";
};
system {
- userid "secnet";
};
resolver adns {
};
}
proc spawn-secnet {which} {
+ global netlinkfh
+ global tmp
upvar #0 pids($which) pid
- set cf test/$which.conf
+ set cf $tmp/$which.conf
set ch [open $cf w]
puts $ch [mkconf $which]
close $ch
- set argl [list ./secnet -dvnc $cf]
+ set argl [list strace -o$tmp/$which.strace ./secnet -dvnc $cf]
set pid [fork]
if {!$pid} {
- execl really $argl
+ execl [lindex $argl 0] [lrange $argl 1 end]
+ }
+ puts -nonewline $netlinkfh($which.t) [hbytes h2raw c0]
+}
+
+proc netlink-readable {which} {
+ global ok
+ upvar #0 netlinkfh($which.r) fh
+ read $fh; # empty the buffer
+ switch -exact $which {
+ inside {
+ puts OK
+ set ok 1; # what a bodge
+ return
+ }
+ outside {
+ error "inside rx'd!"
+ }
}
}
+proc bgerror {message} {
+ global errorInfo errorCode
+ catch {
+ puts stderr "
+----------------------------------------
+$errorInfo
+
+$errorCode
+$message
+----------------------------------------
+ "
+ }
+ exit 1
+}
+
+proc sendpkt {} {
+ global netlinkfh
+ set p {
+ 4500 0054 ed9d 4000 4001 24da ac12 e809
+ ac12 e802 0800 1de4 2d96 0001 f1d4 a05d
+ 0000 0000 507f 0b00 0000 0000 1011 1213
+ 1415 1617 1819 1a1b 1c1d 1e1f 2021 2223
+ 2425 2627 2829 2a2b 2c2d 2e2f 3031 3233
+ 3435 3637
+ }
+ puts -nonewline $netlinkfh(inside.t) \
+ [hbytes h2raw c0[join $p ""]c0]
+}
+
+file mkdir test/tmp
+set tmp test/tmp
+set socktmp $tmp
+regsub {^(?!/)} $socktmp {./} socktmp ;# dgram-socket wants ./ or /
+
+proc udp-proxy {} {
+ global socktmp udpsock
+ set u $socktmp/udp
+ file delete $u
+ regsub {^(?!/)} $u {./} u
+ set udpsock [dgram-socket create $u]
+ dgram-socket on-receive $udpsock udp-relay
+}
+
+proc udp-relay {data src sock args} {
+ global udpsock socktmp
+ set headerlen [expr {52+1}]
+ set orgsrc $src
+
+ set dst [hbytes range $data 0 $headerlen]
+ regsub {(?:00)*$} $dst {} dst
+ set dst [hbytes h2raw $dst]
+
+ hbytes overwrite data 0 [hbytes zeroes $headerlen]
+ regsub {.*/} $src {} src
+ set srch [hbytes raw2h $src]
+ hbytes append srch 00
+ if {[catch {
+ if {[regexp {[^.,:0-9a-f]} $dst c]} { error "bad dst" }
+ if {[hbytes length $srch] > $headerlen} { error "src addr too long" }
+ hbytes overwrite data 0 $srch
+ dgram-socket transmit $udpsock $data $socktmp/$dst
+ } emsg]} {
+ puts stderr "$orgsrc -> $dst: $emsg"
+ }
+}
+
+udp-proxy
spawn-secnet inside
spawn-secnet outside
+
+after 500 sendpkt
+after 1000 sendpkt
+after 5000 timed-out
+
+vwait ok