chiark / gitweb /
7f6dad46becb56bc3fa3cdd422f127b2a9f28c6b
[userv-utils.git] / 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> -- <service-args>...
17 #
18 # Config file is a series of lines.
19 #
20 #   permit <keyword>....
21 #
22 #      if caller, local addr, all remote addrs and networks, and
23 #      ifname, all match, permits the request (and stops reading
24 #      the config)
25 #
26 #          group <groupname>|<gid>
27 #              matches caller if they are in that group
28 #          user <username>|<uid>
29 #              matches caller if they are that user
30 #          everyone
31 #              always matches caller
32 #
33 #          hostnet <ipaddr>/<prefixlen>
34 #              equivalent to   local <ipv4addr> remote <ipv4addr&prefix>
35 #          local <ipaddr>
36 #              matches local address when it is <ipv4addr>
37 #          remote <ipnetnet>/<prefixlen>
38 #              matches aplicable remote addrs (including p-t-p)
39 #          addrs <ipaddr>|<ipnetnet>/<prefixlen>
40 #              matches applicable local ore remote addrs
41 #
42 #          ifname <ifname>
43 #              matches interface name if it is exactly <ifname>
44 #              (<ifname> may contain %d, which is interpreted by
45 #              the kernel)
46 #              wildcards are not supported
47 #              if a permit has no ifname at all, it is as if
48 #              `ifname userv%d' was specified
49 #
50 #   include <other-config-file>
51 #
52 #   v0config <v0configfile>
53 #
54 #     If none of the `permit' lines match, will read <v0configfile>
55 #     in old format.  Must come after all `permit' lines.
56 #
57 #   <config> --
58
59 use strict;
60 use POSIX;
61 use Carp;
62 use NetAddr::IP::Lite qw(:nofqdn :lower);
63
64 our $default_ifname = 'userv%d';
65
66 sub badusage ($) {
67     my ($m) = @_;
68     die "bad usage: $m\n";
69 }
70
71 sub oneaddr ($) {
72     my ($ar) = @_;
73     my $x = $$ar;
74     $x // badusage "missing IP address";
75     $x = new NetAddr::IP::Lite $x // badusage "bad IP address";
76     $x->masklen == $x->bits or badusage "IP network where addr expected";
77     die if $x->addr =~ m,/,;
78     $$ar = $x;
79 }
80
81 @ARGV == 5 or badusage "wrong number of arguments";
82 our ($v1config, $realservice, $sep, $addrsarg, $rnets) = @ARGV;
83
84 $sep eq '--' or badusage "separator should be \`--'";
85 my ($local_addr, $peer_addr, $mtu, $protocol, $ifname) =
86     split /\,/, $addrsarg;
87
88 oneaddr \$local_addr;
89 oneaddr \$peer_addr;
90 $mtu = 1500 unless length $mtu;
91 $mtu =~ m/^[1-9]\d{1,4}/ or badusage "bad mtu";
92 $mtu += 0;
93
94 $protocol = 'slip' unless length $protocol;
95 $protocol =~ m/\W/ and badusage "bad protocol";
96
97 $ifname = $default_ifname unless length $ifname;
98
99 our @rnets = ($rnets eq '-' ? () : split /\,/, $rnets);
100 @rnets = map { new NetAddr::IP::Lite $_ } @rnets;
101
102
103 sub execreal ($) {
104     my ($use_v0config) = @_;
105     exec $realservice, $use_v0config, '--',
106         (join ',', $local_addr->addr, $peer_addr->addr,
107                    $mtu, $protocol, $ifname),
108         @rnets ? (join ",", map { "$_" } @rnets) : "-"
109         or die "exec $realservice: $!\n";
110 }
111
112 our $v0config;
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     local ($cfgpath) = @_;
181     my $cfgfh = new IO::File $cfgpath, "<";
182     if (!$cfgfh) {
183         die "$0: $cfgpath: $!\n" unless $!==ENOENT;
184         return;
185     }
186     while (<$cfgfh>) {
187         s/^\s+//;
188         s/\s+$/\n/;
189         next if m/^\#/;
190         next unless m/\S/;
191         if (s{^permit\s+}{}) {
192             badcfg "v0config before permit" if defined $v0config;
193             %need_allow = ();
194             need_allow_singleton 'Caller', allowent 'caller';
195             need_allow_singleton 'Local',
196                 allowent_addr "local interface", $local_addr;
197             need_allow_singleton 'Ifname', allowent 'interface name';
198             need_allow_item 'Remote',
199                 allowent_addr "peer point-to-point addr", $peer_addr;
200             foreach (@rnets) {
201                 need_allow_item 'Remote',
202                     allowent_addr "remote network", $_;
203             }
204             #use Data::Dumper; print Dumper(\%need_allow);
205             while (m{\S}) {
206                 if (s{^user\s+(\S+)\s+}{}) {
207                     maybe_allow_caller_env $1, 'USERV_USER', 'USERV_UID';
208                 } elsif (s{^group\s+(\S+)\s+}{}) {
209                     maybe_allow_caller_env $1, 'USERV_GROUP', 'USERV_GID';
210                 } elsif (s{^everyone\s+}{}) {
211                     maybe_allow_singleton 'Caller', 1;
212                 } elsif (s{^hostnet\s+(\S+/\d+)\s+}{}) {
213                     my $hn = new NetAddr::IP::Lite $1 or
214                         badcfg "invalid ip address in hostnet";
215                     my $host = new NetAddr::IP::Lite $hn->addr or die;
216                     my $net = $hn->network() or die;
217                     maybe_allow_addrs 'Local', $host;
218                     maybe_allow_addrs 'Remote', $net;
219                 } elsif (s{^(local|remote|addrs)\s+(\S+)\ s+}{}) {
220                     my $h = $1;
221                     my $s = new NetAddr::IP::Lite $2 or
222                         badcfg "invalid ip address or mask in $h";
223                     maybe_allow_addrs 'Local', $s if $h =~ m/addrs|local/;
224                     maybe_allow_addrs 'Remote', $s if $h =~ m/addrs|remote/;
225                 } elsif (s{^ifname\s+(\S+)\s+}{}) {
226                     my ($spec) = $1;
227                     maybe_allow_singleton 'Ifname', $ifname eq $spec;
228                 } elsif (m{^\S+}) {
229                     badcfg "unknown keyword in permit \`$1'";
230                 } else {
231                     die;
232                 }
233             }
234             default_allow_singleton 'Ifname', $ifname eq $default_ifname;
235             my @wrong;
236             foreach my $clval (values %need_allow) {
237                 foreach my $ne (@$clval) {
238                     next if $ne->{Allowed};
239                     push @wrong, $ne->{Desc};
240                 }
241             }
242             if (!@wrong) {
243                 # yay!
244                 if ($protocol eq 'debug') {
245                     print "config $cfgpath:$.: matches\n";
246                     exit 0;
247                 }
248                 execreal '*';
249             }
250             if ($protocol eq 'debug') {
251                 #use Data::Dumper; print Dumper(\%need_allow);
252                 print "config $cfgpath:$.: mismatch: $_\n"
253                     foreach @wrong;
254             }
255         } elsif (m{^v0config\s+(\S+)$}) {
256             badcfg "repeated v0config" if defined $v0config;
257             $v0config = $1;
258         } elsif (m{^include\s+(\S+)$}) {
259             readconfig $1;
260         } else {
261             badcfg "unknown config directive or bad syntax";
262         }
263     }
264     $cfgfh->error and die $!;
265     close $cfgfh;
266
267     if (defined $v0config) {
268         $v0config =~ s{^}{./} unless $v0config =~ m{^/};
269         print "trying v0 config $v0config...\n" if $protocol eq 'debug';
270         execreal $v0config;
271     }
272     die "permission denied\n";
273 }
274
275 readconfig $v1config;