#!/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> <v0config> -- <service-args>...
#
# Config file is a series of lines, or a directory.  If a directory,
# all files with names matching ^[-A-Za-z0-9_]+$ are processed.
#
#   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-or-directory>
#
# <v0config>
#
#     If none of the `permit' lines match, will process <v0config> in
#     old format.  See service.c head comment.  <v0config> may be
#     `' or `#' or `/dev/null' to process new-style config only.
#
#   <config> --

use strict;
use POSIX;
use Carp;
use NetAddr::IP::Lite qw(:nofqdn :lower);
use File::Basename;

our $default_ifname = 'userv%d';

sub badusage ($) {
    my ($m) = @_;
    die "bad usage: $m\n";
}

sub oneaddr ($) {
    my ($ar) = @_;
    my $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 == 6 or badusage "wrong number of arguments";
our ($v1config, $realservice, $v0config, $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;


sub execreal ($) {
    my ($use_v0config) = @_;
    exec $realservice, $use_v0config, '--',
	(join ',', $local_addr->addr, $peer_addr->addr,
	           $mtu, $protocol, $ifname),
	@rnets ? (join ",", map { "$_" } @rnets) : "-"
	or die "exec $realservice: $!\n";
}

our $cfgpath;

sub badcfg ($) {
    my ($m) = @_;
    die "bad configuration: $cfgpath:$.: $m\n";
}

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 allowent ($@) {
    my ($desc, @xtra) = @_;
    return { Desc => $desc, @xtra };
}
sub allowent_addr ($$) {
    my ($what, $addr) = @_;
    return allowent "$what $addr", IpAddr => $addr;
}
sub need_allow_item ($$) {
    my ($cl, $ne) = @_;
    push @{ $need_allow{$cl} }, $ne
}
sub need_allow_singleton ($$) {
    my ($cl, $ne) = @_;
    $need_allow{$cl} ||= [ $ne ];
}

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], $yes;
}
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;
	#use Data::Dumper; print Dumper($spec,$envvar,\@vals);
	maybe_allow_singleton 'Caller', !!grep { $_ eq $spec } @vals;
    }
}
sub maybe_allow_addrs ($$) {
    my ($cl, $permitrange) = @_;
    foreach my $ne (@{ $need_allow{$cl} }) {
	confess unless defined $ne->{IpAddr};
	maybe_allow__entry $ne, $permitrange->contains($ne->{IpAddr});
    }
}

sub readconfig ($);
sub readconfig ($) {
    local ($cfgpath) = @_;

    my $dirfh;
    if (opendir $dirfh, $cfgpath) {
	while ($!=0, my $ent = readdir $dirfh) {
	    next if $ent =~ m/[^-A-Za-z0-9_]/;
	    readconfig "$cfgpath/$ent";
	}
	die "$0: $cfgpath: $!\n" if $!;
	return;
    }
    die "$0: $cfgpath: $!\n" unless $!==ENOENT || $!==ENOTDIR;

    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+}{}) {
	    %need_allow = ();
	    need_allow_singleton 'Caller', allowent 'caller';
	    need_allow_singleton 'Local',
		allowent_addr "local interface", $local_addr;
	    need_allow_singleton 'Ifname', allowent 'interface name';
	    need_allow_item 'Remote',
		allowent_addr "peer point-to-point addr", $peer_addr;
	    foreach (@rnets) {
		need_allow_item 'Remote',
		    allowent_addr "remote network", $_;
	    }
	    #use Data::Dumper; print Dumper(\%need_allow);
	    while (m{\S}) {
		if (s{^user\s+(\S+)\s+}{}) {
		    maybe_allow_caller_env $1, 'USERV_USER', 'USERV_UID';
		} elsif (s{^group\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->{Allowed};
		    push @wrong, $ne->{Desc};
		}
	    }
	    if (!@wrong) {
		# yay!
		if ($protocol eq 'debug') {
		    print "config $cfgpath:$.: matches\n";
		    exit 0;
		}
		execreal '*';
	    }
	    if ($protocol eq 'debug') {
		#use Data::Dumper; print Dumper(\%need_allow);
		print "config $cfgpath:$.: mismatch: $_\n"
		    foreach @wrong;
	    }
	} elsif (m{^include\s+(\S+)$}) {
	    my $include = $1;
	    $include =~ s{^(?!/)}{ dirname($cfgpath)."/" }e;
	    readconfig $include;
	} else {
	    badcfg "unknown config directive or bad syntax";
	}
    }
    $cfgfh->error and die $!;
    close $cfgfh;
}

sub try_v0config() {
    return unless $v0config;
    return unless $v0config =~ m{^[^#]};
    return if $v0config eq '/dev/null';
    if ($v0config =~ m{^/}) {
	if (!stat $v0config) {
	    die "v0 config $v0config: $!\n" unless $!==ENOENT;
	    return;
	}
    }
    print "trying v0 config $v0config...\n" if $protocol eq 'debug';
    execreal $v0config;
}

readconfig $v1config;
try_v0config();

die "permission denied\n";