mdw@git.distorted.org.uk Git - userv-utils/blob - ipif/service-wrap

   1 #!/usr/bin/perl -w
   2 #
   3 # When invoked appropriately, it creates a point-to-point network
   4 # interface with specified parameters.  It arranges for packets sent out
   5 # via that interface by the kernel to appear on its own stdout in SLIP or
   6 # CSLIP encoding, and packets injected into its own stdin to be given to
   7 # the kernel as if received on that interface.  Optionally, additional
   8 # routes can be set up to arrange for traffic for other address ranges to
   9 # be routed through the new interface.
  10 #
  11 # This is the access control wrapper for the service program.
  12 # Arrangments should be made to invoke this as root from userv.
  13 #
  14 # Usage:
  15 #
  16 #   .../ipif1 <v1config> <real-service-program> <v0config> -- <service-args>...
  17 #
  18 # Config file is a series of lines, or a directory.  If a directory,
  19 # all files with names matching ^[-A-Za-z0-9_]+$ are processed.
  20 #
  21 #   permit <keyword>....
  22 #
  23 #      if caller, local addr, all remote addrs and networks, and
  24 #      ifname, all match, permits the request (and stops reading
  25 #      the config)
  26 #
  27 #          group <groupname>|<gid>
  28 #              matches caller if they are in that group
  29 #          user <username>|<uid>
  30 #              matches caller if they are that user
  31 #          everyone
  32 #              always matches caller
  33 #
  34 #          hostnet <ipaddr>/<prefixlen>
  35 #              equivalent to   local <ipv4addr> remote <ipv4addr&prefix>
  36 #          local <ipaddr>
  37 #              matches local address when it is <ipv4addr>
  38 #          remote <ipnetnet>/<prefixlen>
  39 #              matches aplicable remote addrs (including p-t-p)
  40 #          addrs <ipaddr>|<ipnetnet>/<prefixlen>
  41 #              matches applicable local ore remote addrs
  42 #
  43 #          ifname <ifname>
  44 #              matches interface name if it is exactly <ifname>
  45 #              (<ifname> may contain %d, which is interpreted by
  46 #              the kernel)
  47 #              wildcards are not supported
  48 #              if a permit has no ifname at all, it is as if
  49 #              `ifname userv%d' was specified
  50 #
  51 #   include <other-config-file-or-directory>
  52 #
  53 # <v0config>
  54 #
  55 #     If none of the `permit' lines match, will process <v0config> in
  56 #     old format.  See service.c head comment.  <v0config> may be
  57 #     `' or `#' or `/dev/null' to process new-style config only.
  58 #
  59 #   <config> --
  60
  61 use strict;
  62 use POSIX;
  63 use Carp;
  64 use NetAddr::IP::Lite qw(:nofqdn :lower);
  65 use File::Basename;
  66
  67 our $default_ifname = 'userv%d';
  68
  69 sub badusage ($) {
  70     my ($m) = @_;
  71     die "bad usage: $m\n";
  72 }
  73
  74 sub oneaddr ($) {
  75     my ($ar) = @_;
  76     my $x = $$ar;
  77     $x // badusage "missing IP address";
  78     $x = new NetAddr::IP::Lite $x // badusage "bad IP address";
  79     $x->masklen == $x->bits or badusage "IP network where addr expected";
  80     die if $x->addr =~ m,/,;
  81     $$ar = $x;
  82 }
  83
  84 @ARGV == 6 or badusage "wrong number of arguments";
  85 our ($v1config, $realservice, $v0config, $sep, $addrsarg, $rnets) = @ARGV;
  86
  87 $sep eq '--' or badusage "separator should be \`--'";
  88 my ($local_addr, $peer_addr, $mtu, $protocol, $ifname) =
  89     split /\,/, $addrsarg;
  90
  91 oneaddr \$local_addr;
  92 oneaddr \$peer_addr;
  93 $mtu = 1500 unless length $mtu;
  94 $mtu =~ m/^[1-9]\d{1,4}/ or badusage "bad mtu";
  95 $mtu += 0;
  96
  97 $protocol = 'slip' unless length $protocol;
  98 $protocol =~ m/\W/ and badusage "bad protocol";
  99
 100 $ifname = $default_ifname unless length $ifname;
 101
 102 our @rnets = ($rnets eq '-' ? () : split /\,/, $rnets);
 103 @rnets = map { new NetAddr::IP::Lite $_ } @rnets;
 104
 105
 106 sub execreal ($) {
 107     my ($use_v0config) = @_;
 108     exec $realservice, $use_v0config, '--',
 109         (join ',', $local_addr->addr, $peer_addr->addr,
 110                    $mtu, $protocol, $ifname),
 111         @rnets ? (join ",", map { "$_" } @rnets) : "-"
 112         or die "exec $realservice: $!\n";
 113 }
 114
 115 our $cfgpath;
 116
 117 sub badcfg ($) {
 118     my ($m) = @_;
 119     die "bad configuration: $cfgpath:$.: $m\n";
 120 }
 121
 122 our %need_allow;
 123 # $need_allow{CLASS}[]
 124 # $need_allow{CLASS}[]{Desc}   # For error messages
 125 # $need_allow{CLASS}[]{Allow}  # Starts out nonexistent
 126 # $need_allow{CLASS}[]{IpAddr} # CLASS eq Local or Remote only
 127
 128 sub allowent ($@) {
 129     my ($desc, @xtra) = @_;
 130     return { Desc => $desc, @xtra };
 131 }
 132 sub allowent_addr ($$) {
 133     my ($what, $addr) = @_;
 134     return allowent "$what $addr", IpAddr => $addr;
 135 }
 136 sub need_allow_item ($$) {
 137     my ($cl, $ne) = @_;
 138     push @{ $need_allow{$cl} }, $ne
 139 }
 140 sub need_allow_singleton ($$) {
 141     my ($cl, $ne) = @_;
 142     $need_allow{$cl} ||= [ $ne ];
 143 }
 144
 145 sub maybe_allow__entry ($$) {
 146     my ($ne, $yes) = @_;
 147     $ne->{Allowed} ||= $yes;
 148 }
 149 sub maybe_allow_singleton ($$) {
 150     my ($cl, $yes) = @_;
 151     my $ents = $need_allow{$cl};
 152     die $cl unless @$ents==1;
 153     maybe_allow__entry $ents->[0], $yes;
 154 }
 155 sub default_allow_singleton ($$) {
 156     # does nothing if maybe_allow_singleton was called for this $cl;
 157     # otherwise allows the singleton iff $yes
 158     my ($cl, $yes) = @_;
 159     my $ents = $need_allow{$cl};
 160     die $cl unless @$ents==1;
 161     $ents->[0]{Allowed} //= $yes;
 162 }
 163 sub maybe_allow_caller_env ($$$) {
 164     my ($spec, @envvars) = @_;
 165     foreach my $envvar (@envvars) {
 166         my $val = $ENV{$envvar} // die $envvar;
 167         my @vals = split / /, $val;
 168         #use Data::Dumper; print Dumper($spec,$envvar,\@vals);
 169         maybe_allow_singleton 'Caller', !!grep { $_ eq $spec } @vals;
 170     }
 171 }
 172 sub maybe_allow_addrs ($$) {
 173     my ($cl, $permitrange) = @_;
 174     foreach my $ne (@{ $need_allow{$cl} }) {
 175         confess unless defined $ne->{IpAddr};
 176         maybe_allow__entry $ne, $permitrange->contains($ne->{IpAddr});
 177     }
 178 }
 179
 180 sub readconfig ($);
 181 sub readconfig ($) {
 182     local ($cfgpath) = @_;
 183
 184     my $dirfh;
 185     if (opendir $dirfh, $cfgpath) {
 186         while ($!=0, my $ent = readdir $dirfh) {
 187             next if $ent =~ m/[^-A-Za-z0-9_]/;
 188             readconfig "$cfgpath/$ent";
 189         }
 190         die "$0: $cfgpath: $!\n" if $!;
 191         return;
 192     }
 193     die "$0: $cfgpath: $!\n" unless $!==ENOENT || $!==ENOTDIR;
 194
 195     my $cfgfh = new IO::File $cfgpath, "<";
 196     if (!$cfgfh) {
 197         die "$0: $cfgpath: $!\n" unless $!==ENOENT;
 198         return;
 199     }
 200     while (<$cfgfh>) {
 201         s/^\s+//;
 202         s/\s+$/\n/;
 203         next if m/^\#/;
 204         next unless m/\S/;
 205         if (s{^permit\s+}{}) {
 206             %need_allow = ();
 207             need_allow_singleton 'Caller', allowent 'caller';
 208             need_allow_singleton 'Local',
 209                 allowent_addr "local interface", $local_addr;
 210             need_allow_singleton 'Ifname', allowent 'interface name';
 211             need_allow_item 'Remote',
 212                 allowent_addr "peer point-to-point addr", $peer_addr;
 213             foreach (@rnets) {
 214                 need_allow_item 'Remote',
 215                     allowent_addr "remote network", $_;
 216             }
 217             #use Data::Dumper; print Dumper(\%need_allow);
 218             while (m{\S}) {
 219                 if (s{^user\s+(\S+)\s+}{}) {
 220                     maybe_allow_caller_env $1, 'USERV_USER', 'USERV_UID';
 221                 } elsif (s{^group\s+(\S+)\s+}{}) {
 222                     maybe_allow_caller_env $1, 'USERV_GROUP', 'USERV_GID';
 223                 } elsif (s{^everyone\s+}{}) {
 224                     maybe_allow_singleton 'Caller', 1;
 225                 } elsif (s{^hostnet\s+(\S+/\d+)\s+}{}) {
 226                     my $hn = new NetAddr::IP::Lite $1 or
 227                         badcfg "invalid ip address in hostnet";
 228                     my $host = new NetAddr::IP::Lite $hn->addr or die;
 229                     my $net = $hn->network() or die;
 230                     maybe_allow_addrs 'Local', $host;
 231                     maybe_allow_addrs 'Remote', $net;
 232                 } elsif (s{^(local|remote|addrs)\s+(\S+)\ s+}{}) {
 233                     my $h = $1;
 234                     my $s = new NetAddr::IP::Lite $2 or
 235                         badcfg "invalid ip address or mask in $h";
 236                     maybe_allow_addrs 'Local', $s if $h =~ m/addrs|local/;
 237                     maybe_allow_addrs 'Remote', $s if $h =~ m/addrs|remote/;
 238                 } elsif (s{^ifname\s+(\S+)\s+}{}) {
 239                     my ($spec) = $1;
 240                     maybe_allow_singleton 'Ifname', $ifname eq $spec;
 241                 } elsif (m{^\S+}) {
 242                     badcfg "unknown keyword in permit \`$1'";
 243                 } else {
 244                     die;
 245                 }
 246             }
 247             default_allow_singleton 'Ifname', $ifname eq $default_ifname;
 248             my @wrong;
 249             foreach my $clval (values %need_allow) {
 250                 foreach my $ne (@$clval) {
 251                     next if $ne->{Allowed};
 252                     push @wrong, $ne->{Desc};
 253                 }
 254             }
 255             if (!@wrong) {
 256                 # yay!
 257                 if ($protocol eq 'debug') {
 258                     print "config $cfgpath:$.: matches\n";
 259                     exit 0;
 260                 }
 261                 execreal '*';
 262             }
 263             if ($protocol eq 'debug') {
 264                 #use Data::Dumper; print Dumper(\%need_allow);
 265                 print "config $cfgpath:$.: mismatch: $_\n"
 266                     foreach @wrong;
 267             }
 268         } elsif (m{^include\s+(\S+)$}) {
 269             my $include = $1;
 270             $include =~ s{^(?!/)}{ dirname($cfgpath)."/" }e;
 271             readconfig $include;
 272         } else {
 273             badcfg "unknown config directive or bad syntax";
 274         }
 275     }
 276     $cfgfh->error and die $!;
 277     close $cfgfh;
 278 }
 279
 280 sub try_v0config() {
 281     return unless $v0config;
 282     return unless $v0config =~ m{^[^#]};
 283     return if $v0config eq '/dev/null';
 284     if ($v0config =~ m{^/}) {
 285         if (!stat $v0config) {
 286             die "v0 config $v0config: $!\n" unless $!==ENOENT;
 287             return;
 288         }
 289     }
 290     print "trying v0 config $v0config...\n" if $protocol eq 'debug';
 291     execreal $v0config;
 292 }
 293
 294 readconfig $v1config;
 295 try_v0config();
 296
 297 die "permission denied\n";