#!/usr/bin/perl -w
#
# When invoked appropriately, it creates a point-to-point network
# interface with specified parameters.  It arranges for packets sent out
# via that interface by the kernel to appear on its own stdout in SLIP or
# CSLIP encoding, and packets injected into its own stdin to be given to
# the kernel as if received on that interface.  Optionally, additional
# routes can be set up to arrange for traffic for other address ranges to
# be routed through the new interface.
# 
# This is the access control wrapper for the service program.
# Arrangments should be made to invoke this as root from userv.
#
# Usage:
#
#   .../ipif1 <v1config> <real-service-program> -- <service-args>...
#
# Config file is a series of lines.
#
#   permit <keyword>....
#
#      if caller, local addr, all remote addrs and networks, and
#      ifname, all match, permits the request (and stops reading
#      the config)
#
#          group <groupname>|<gid>
#              matches caller if they are in that group
#          user <username>|<uid>
#              matches caller if they are that user
#          everyone
#              always matches caller
#
#          hostnet <ipaddr>/<prefixlen>
#              equivalent to   local <ipv4addr> remote <ipv4addr&prefix>
#          local <ipaddr>
#              matches local address when it is <ipv4addr>
#          remote <ipnetnet>/<prefixlen>
#              matches aplicable remote addrs (including p-t-p)
#          addrs <ipaddr>|<ipnetnet>/<prefixlen>
#              matches applicable local ore remote addrs
#
#          ifname <ifname>
#              matches interface name if it is exactly <ifname>
#              (<ifname> may contain %d, which is interpreted by
#              the kernel)
#              wildcards are not supported
#              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 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;
}