| 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 | |
| 66 | our $default_ifname = 'userv%d'; |
| 67 | |
| 68 | sub badusage ($) { |
| 69 | my ($m) = @_; |
| 70 | die "bad usage: $m\n"; |
| 71 | } |
| 72 | |
| 73 | sub oneaddr ($) { |
| 74 | my ($ar) = @_; |
| 75 | my $x = $$ar; |
| 76 | $x // badusage "missing IP address"; |
| 77 | $x = new NetAddr::IP::Lite $x // badusage "bad IP address"; |
| 78 | $x->masklen == $x->bits or badusage "IP network where addr expected"; |
| 79 | die if $x->addr =~ m,/,; |
| 80 | $$ar = $x; |
| 81 | } |
| 82 | |
| 83 | @ARGV == 6 or badusage "wrong number of arguments"; |
| 84 | our ($v1config, $realservice, $v0config, $sep, $addrsarg, $rnets) = @ARGV; |
| 85 | |
| 86 | $sep eq '--' or badusage "separator should be \`--'"; |
| 87 | my ($local_addr, $peer_addr, $mtu, $protocol, $ifname) = |
| 88 | split /\,/, $addrsarg; |
| 89 | |
| 90 | oneaddr \$local_addr; |
| 91 | oneaddr \$peer_addr; |
| 92 | $mtu = 1500 unless length $mtu; |
| 93 | $mtu =~ m/^[1-9]\d{1,4}/ or badusage "bad mtu"; |
| 94 | $mtu += 0; |
| 95 | |
| 96 | $protocol = 'slip' unless length $protocol; |
| 97 | $protocol =~ m/\W/ and badusage "bad protocol"; |
| 98 | |
| 99 | $ifname = $default_ifname unless length $ifname; |
| 100 | |
| 101 | our @rnets = ($rnets eq '-' ? () : split /\,/, $rnets); |
| 102 | @rnets = map { new NetAddr::IP::Lite $_ } @rnets; |
| 103 | |
| 104 | |
| 105 | sub execreal ($) { |
| 106 | my ($use_v0config) = @_; |
| 107 | exec $realservice, $use_v0config, '--', |
| 108 | (join ',', $local_addr->addr, $peer_addr->addr, |
| 109 | $mtu, $protocol, $ifname), |
| 110 | @rnets ? (join ",", map { "$_" } @rnets) : "-" |
| 111 | or die "exec $realservice: $!\n"; |
| 112 | } |
| 113 | |
| 114 | our $cfgpath; |
| 115 | |
| 116 | sub badcfg ($) { |
| 117 | my ($m) = @_; |
| 118 | die "bad configuration: $cfgpath:$.: $m\n"; |
| 119 | } |
| 120 | |
| 121 | our %need_allow; |
| 122 | # $need_allow{CLASS}[] |
| 123 | # $need_allow{CLASS}[]{Desc} # For error messages |
| 124 | # $need_allow{CLASS}[]{Allow} # Starts out nonexistent |
| 125 | # $need_allow{CLASS}[]{IpAddr} # CLASS eq Local or Remote only |
| 126 | |
| 127 | sub allowent ($@) { |
| 128 | my ($desc, @xtra) = @_; |
| 129 | return { Desc => $desc, @xtra }; |
| 130 | } |
| 131 | sub allowent_addr ($$) { |
| 132 | my ($what, $addr) = @_; |
| 133 | return allowent "$what $addr", IpAddr => $addr; |
| 134 | } |
| 135 | sub need_allow_item ($$) { |
| 136 | my ($cl, $ne) = @_; |
| 137 | push @{ $need_allow{$cl} }, $ne |
| 138 | } |
| 139 | sub need_allow_singleton ($$) { |
| 140 | my ($cl, $ne) = @_; |
| 141 | $need_allow{$cl} ||= [ $ne ]; |
| 142 | } |
| 143 | |
| 144 | sub maybe_allow__entry ($$) { |
| 145 | my ($ne, $yes) = @_; |
| 146 | $ne->{Allowed} ||= $yes; |
| 147 | } |
| 148 | sub maybe_allow_singleton ($$) { |
| 149 | my ($cl, $yes) = @_; |
| 150 | my $ents = $need_allow{$cl}; |
| 151 | die $cl unless @$ents==1; |
| 152 | maybe_allow__entry $ents->[0], $yes; |
| 153 | } |
| 154 | sub default_allow_singleton ($$) { |
| 155 | # does nothing if maybe_allow_singleton was called for this $cl; |
| 156 | # otherwise allows the singleton iff $yes |
| 157 | my ($cl, $yes) = @_; |
| 158 | my $ents = $need_allow{$cl}; |
| 159 | die $cl unless @$ents==1; |
| 160 | $ents->[0]{Allowed} //= $yes; |
| 161 | } |
| 162 | sub maybe_allow_caller_env ($$$) { |
| 163 | my ($spec, @envvars) = @_; |
| 164 | foreach my $envvar (@envvars) { |
| 165 | my $val = $ENV{$envvar} // die $envvar; |
| 166 | my @vals = split / /, $val; |
| 167 | #use Data::Dumper; print Dumper($spec,$envvar,\@vals); |
| 168 | maybe_allow_singleton 'Caller', !!grep { $_ eq $spec } @vals; |
| 169 | } |
| 170 | } |
| 171 | sub maybe_allow_addrs ($$) { |
| 172 | my ($cl, $permitrange) = @_; |
| 173 | foreach my $ne (@{ $need_allow{$cl} }) { |
| 174 | confess unless defined $ne->{IpAddr}; |
| 175 | maybe_allow__entry $ne, $permitrange->contains($ne->{IpAddr}); |
| 176 | } |
| 177 | } |
| 178 | |
| 179 | sub readconfig ($); |
| 180 | sub readconfig ($) { |
| 181 | local ($cfgpath) = @_; |
| 182 | |
| 183 | my $dirfh; |
| 184 | if (opendir $dirfh, $cfgpath) { |
| 185 | while ($!=0, my $ent = readdir $dirfh) { |
| 186 | next if $ent =~ m/[^-A-Za-z0-9_]/; |
| 187 | readconfig "$cfgpath/$ent"; |
| 188 | } |
| 189 | die "$0: $cfgpath: $!\n" if $!; |
| 190 | return; |
| 191 | } |
| 192 | die "$0: $cfgpath: $!\n" unless $!==ENOENT || $!==ENOTDIR; |
| 193 | |
| 194 | my $cfgfh = new IO::File $cfgpath, "<"; |
| 195 | if (!$cfgfh) { |
| 196 | die "$0: $cfgpath: $!\n" unless $!==ENOENT; |
| 197 | return; |
| 198 | } |
| 199 | while (<$cfgfh>) { |
| 200 | s/^\s+//; |
| 201 | s/\s+$/\n/; |
| 202 | next if m/^\#/; |
| 203 | next unless m/\S/; |
| 204 | if (s{^permit\s+}{}) { |
| 205 | %need_allow = (); |
| 206 | need_allow_singleton 'Caller', allowent 'caller'; |
| 207 | need_allow_singleton 'Local', |
| 208 | allowent_addr "local interface", $local_addr; |
| 209 | need_allow_singleton 'Ifname', allowent 'interface name'; |
| 210 | need_allow_item 'Remote', |
| 211 | allowent_addr "peer point-to-point addr", $peer_addr; |
| 212 | foreach (@rnets) { |
| 213 | need_allow_item 'Remote', |
| 214 | allowent_addr "remote network", $_; |
| 215 | } |
| 216 | #use Data::Dumper; print Dumper(\%need_allow); |
| 217 | while (m{\S}) { |
| 218 | if (s{^user\s+(\S+)\s+}{}) { |
| 219 | maybe_allow_caller_env $1, 'USERV_USER', 'USERV_UID'; |
| 220 | } elsif (s{^group\s+(\S+)\s+}{}) { |
| 221 | maybe_allow_caller_env $1, 'USERV_GROUP', 'USERV_GID'; |
| 222 | } elsif (s{^everyone\s+}{}) { |
| 223 | maybe_allow_singleton 'Caller', 1; |
| 224 | } elsif (s{^hostnet\s+(\S+/\d+)\s+}{}) { |
| 225 | my $hn = new NetAddr::IP::Lite $1 or |
| 226 | badcfg "invalid ip address in hostnet"; |
| 227 | my $host = new NetAddr::IP::Lite $hn->addr or die; |
| 228 | my $net = $hn->network() or die; |
| 229 | maybe_allow_addrs 'Local', $host; |
| 230 | maybe_allow_addrs 'Remote', $net; |
| 231 | } elsif (s{^(local|remote|addrs)\s+(\S+)\ s+}{}) { |
| 232 | my $h = $1; |
| 233 | my $s = new NetAddr::IP::Lite $2 or |
| 234 | badcfg "invalid ip address or mask in $h"; |
| 235 | maybe_allow_addrs 'Local', $s if $h =~ m/addrs|local/; |
| 236 | maybe_allow_addrs 'Remote', $s if $h =~ m/addrs|remote/; |
| 237 | } elsif (s{^ifname\s+(\S+)\s+}{}) { |
| 238 | my ($spec) = $1; |
| 239 | maybe_allow_singleton 'Ifname', $ifname eq $spec; |
| 240 | } elsif (m{^\S+}) { |
| 241 | badcfg "unknown keyword in permit \`$1'"; |
| 242 | } else { |
| 243 | die; |
| 244 | } |
| 245 | } |
| 246 | default_allow_singleton 'Ifname', $ifname eq $default_ifname; |
| 247 | my @wrong; |
| 248 | foreach my $clval (values %need_allow) { |
| 249 | foreach my $ne (@$clval) { |
| 250 | next if $ne->{Allowed}; |
| 251 | push @wrong, $ne->{Desc}; |
| 252 | } |
| 253 | } |
| 254 | if (!@wrong) { |
| 255 | # yay! |
| 256 | if ($protocol eq 'debug') { |
| 257 | print "config $cfgpath:$.: matches\n"; |
| 258 | exit 0; |
| 259 | } |
| 260 | execreal '*'; |
| 261 | } |
| 262 | if ($protocol eq 'debug') { |
| 263 | #use Data::Dumper; print Dumper(\%need_allow); |
| 264 | print "config $cfgpath:$.: mismatch: $_\n" |
| 265 | foreach @wrong; |
| 266 | } |
| 267 | } elsif (m{^include\s+(\S+)$}) { |
| 268 | readconfig $1; |
| 269 | } else { |
| 270 | badcfg "unknown config directive or bad syntax"; |
| 271 | } |
| 272 | } |
| 273 | $cfgfh->error and die $!; |
| 274 | close $cfgfh; |
| 275 | |
| 276 | if ($v0config && $v0config =~ m{^[^#]} && $v0config ne '/dev/null') { |
| 277 | print "trying v0 config $v0config...\n" if $protocol eq 'debug'; |
| 278 | execreal $v0config; |
| 279 | } |
| 280 | die "permission denied\n"; |
| 281 | } |
| 282 | |
| 283 | readconfig $v1config; |