ipif: service-wrap: implementation, does not work yet

Signed-off-by: Ian Jackson <ijackson@chiark.greenend.org.uk>

1 files changed, 182 insertions, 2 deletions

diff --git a/ipif/service-wrap b/ipif/service-wrap
index ad9de06..424b76a 100644..100755
--- a/ipif/service-wrap
+++ b/ipif/service-wrap
@@ -13,7 +13,7 @@
 #
 # Usage:
 #
-#   .../ipif1 <v1config> -- <service-args>...
+#   .../ipif1 <v1config> <real-service-program> -- <service-args>...
 #
 # Config file is a series of lines.
 #
@@ -47,11 +47,191 @@
 #              if a permit has no ifname at all, it is as if
 #              `ifname userv%d' was specified
 #
+#   include <other-config-file>
+#
 #   v0config <v0configfile>
 #
 #     If none of the `permit' lines match, will read <v0configfile>
-#     in old format.  Must be the last line in the file.     
+#     in old format.  Must come after all `permit' lines.
 #
 #   <config> --
 
 use strict;
+
+use NetAddr::IP::Lite qw(:nofqdn :lower);
+#use NetAddr::IP;
+
+our $default_ifname = 'userv%d';
+
+sub oneaddr ($) {
+    my ($ar) = @_;
+    $x = $$ar;
+    $x // badusage "missing IP address";
+    $x = new NetAddr::IP::Lite $x // badusage "bad IP address";
+    $x->masklen == $x->bits or badusage "IP network where addr expected";
+    die if $x->addr =~ m,/,;
+    $$ar = $x;
+}
+
+@ARGV == 5 or badusage "wrong number of arguments";
+our ($v1config, $realservice, $sep, $addrsarg, $rnets) = @ARGV;
+
+$sep eq '--' or badusage "separator should be \`--'";
+my ($local_addr, $peer_addr, $mtu, $protocol, $ifname) =
+    split /\,/, $addrsarg;
+
+oneaddr \$local_addr;
+oneaddr \$peer_addr;
+$mtu = 1500 unless length $mtu;
+$mtu =~ m/^[1-9]\d{1,4}/ or badusage "bad mtu";
+$mtu += 0;
+
+$protocol = 'slip' unless length $protocol;
+$protocol =~ m/\W/ and badusage "bad protocol";
+
+$ifname = $default_ifname unless length $ifname;
+
+our @rnets = ($rnets eq '-' ? () : split /\,/, $rnets);
+@rnets = map { new NetAddr::IP::Lite $_ } @rnets;
+
+our %need_allow;
+# $need_allow{CLASS}[]
+# $need_allow{CLASS}[]{Desc}   # For error messages
+# $need_allow{CLASS}[]{Allow}  # Starts out nonexistent
+# $need_allow{CLASS}[]{IpAddr} # CLASS eq Local or Remote only
+
+sub need_allow__entry ($@) {
+    my ($desc, @xtra) = @_;
+    return { Desc => $desc, @xtra };
+}
+sub need_allow_item ($$@) {
+    my ($cl, $desc, @xtra) = @_;
+    push @{ $need_allow{$cl} }, need_allow__entry $desc, @extra;
+}
+sub need_allow_singleton ($$) {
+    my ($cl, $desc) = @_;
+    $need_allow{$cl} ||= [ need_allow__entry $desc ];
+}
+
+sub maybe_allow__entry ($$) {
+    my ($ne, $yes) = @_;
+    $ne->{Allowed} ||= $yes;
+}
+sub maybe_allow_singleton ($) {
+    my ($cl, $yes) = @_;
+    my $ents = $need_allow{$cl};
+    die $cl unless @$ents==1;
+    maybe_allow__entry $ents->[0], $val;
+}
+sub default_allow_singleton ($$) {
+    # does nothing if maybe_allow_singleton was called for this $cl;
+    # otherwise allows the singleton iff $yes
+    my ($cl, $yes) = @_;
+    my $ents = $need_allow{$cl};
+    die $cl unless @$ents==1;
+    $ents->[0]{Allowed} //= $yes;
+}
+    
+sub maybe_allow_caller_env ($$) {
+    my ($spec, @envvars) = @_;
+    foreach my $envvar (@envvars) {
+	my $val = $ENV{$envvar} // die $envvar;
+	my @vals = split / /, $val;
+	maybe_allow_singleton 'Caller', !!grep { $_ eq $spec } @vals;
+    }
+}
+sub maybe_allow_addrs ($) {
+    my ($cl, $permitrange) = @_;
+    foreach my $ne (@{ $need_allow{$cl} }) {
+	maybe_allow_entry $ne, $permitrange->contains($ne->{IpAddr});
+    }
+}
+
+sub readconfig ($) {
+    my ($cfgpath) = @_;
+    my $cfgfh = new IO::File "<", $cfgpath;
+    if (!$cfgfh) {
+	die "$0: $cfgpath: $!\n" unless $!==ENOENT;
+	return;
+    }
+    while (<$cfgfh>) {
+	s/^\s+//;
+	s/\s+$/\n/;
+	next if m/^\#/;
+	next unless m/\S/;
+	if (s{^permit\s+}{}) {
+	    badcfg "v0config before permit" if defined $v0config;
+	    %need_allowed = ();
+	    need_allow_singleton 'Caller', 'caller';
+	    need_allow_singleton 'Local',  "local interface addr $local_addr";
+	    need_allow_singleton 'Ifname', 'interface name';
+	    always_need_allow 'Remote', "peer point-to-point addr $peer_addr";
+	    foreach (@rnets) {
+		need_allow_item 'Remote', "remote network ".$_->cidr(),
+		    IpAddr => $_;
+	    }
+	    while (m{\S}) {
+		if (s{^group\s+(\S+)\s+}{}) {
+		    maybe_allow_caller_env $1, 'USERV_USER', 'USERV_UID';
+		} elsif (s{^user\s+(\S+)\s+}{}) {
+		    maybe_allow_caller_env $1, 'USERV_GROUP', 'USERV_GID';
+		} elsif (s{^everyone\s+}{}) {
+		    maybe_allow_singleton 'Caller', 1;
+		} elsif (s{^hostnet\s+(\S+/\d+)\s+}{}) {
+		    my $hn = new NetAddr:IP::Lite $1 or
+			badcfg "invalid ip address in hostnet";
+		    my $host = new NetAddr::IP::Lite $hn->addr or die;
+		    my $net = $hn->network() or die;
+		    maybe_allow_addrs 'Local', $host;
+		    maybe_ allow_addrs 'Remote', $net;
+		} elsif (s{^(local|remote|addrs)\s+(\S+)\ s+}{}) {
+		    my $h = $1;
+		    my $s = new NetAddr::IP::Lite $2 or
+			badcfg "invalid ip address or mask in $h";
+		    maybe_allow_addrs 'Local', $s if $h =~ m/addrs|local/;
+		    maybe_allow_addrs 'Remote', $s if $h =~ m/addrs|remote/;
+		} elsif (s{^ifname\s+(\S+)\s+}{}) {
+		    my ($spec) = $1;
+		    maybe_allow_singleton 'Ifname', $ifname eq $spec;
+		} elsif (m{^\S+}) {
+		    badcfg "unknown keyword in permit \`$1'";
+		} else {
+		    die;
+		}
+	    }
+	    default_allow_singleton 'Ifname', $ifname eq $default_ifname;
+	    my @wrong;
+	    foreach my $clval (values %need_allow) {
+		foreach my $ne (@$clval) {
+		    next if $ne->{Allow};
+		    push @wrong, $ne->{Desc};
+		}
+	    }
+	    if (!@wrong) {
+		# yay!
+		if ($protocol eq 'debug') {
+		    print "config $cfgh line $.: matches\n";
+		    exit 0;
+		}
+		exec $realservice, '*', '--',
+		    "$local_addr,$peer_addr,$mtu,$protocol",
+		    @rnets ? (join ",", map { "$_" } @rnets) : "-";
+		die "exec $realservice: $!\n";
+	    }
+	    if ($protocol eq 'debug') {
+		print "config $cfgfh line $.: mismatch: $_\n"
+		    foreach @wrong;
+	    }
+	} elsif (m{^v0config\s+(\S+)$}) {
+	    badcfg "repeated v0config" if defined $v0config;
+	    $v0config = $1;
+	} elsif (m{^include\s+(\S+)$}) {
+	    readconfig $1;
+	} else {
+	    badcfg "unknown config directive or bad syntax";
+	}
+    }
+    $cfgfh->error and die $!;
+    close $cfgfh;
+}
+