Commit | Line | Data |
---|---|---|
08e5c1c8 IJ |
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 | # | |
44b7fe58 | 16 | # .../ipif1 <v1config> <real-service-program> -- <service-args>... |
08e5c1c8 IJ |
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 | # | |
44b7fe58 IJ |
50 | # include <other-config-file> |
51 | # | |
08e5c1c8 IJ |
52 | # v0config <v0configfile> |
53 | # | |
54 | # If none of the `permit' lines match, will read <v0configfile> | |
44b7fe58 | 55 | # in old format. Must come after all `permit' lines. |
08e5c1c8 IJ |
56 | # |
57 | # <config> -- | |
58 | ||
59 | use strict; | |
44b7fe58 IJ |
60 | |
61 | use NetAddr::IP::Lite qw(:nofqdn :lower); | |
62 | #use NetAddr::IP; | |
63 | ||
64 | our $default_ifname = 'userv%d'; | |
65 | ||
66 | sub oneaddr ($) { | |
67 | my ($ar) = @_; | |
68 | $x = $$ar; | |
69 | $x // badusage "missing IP address"; | |
70 | $x = new NetAddr::IP::Lite $x // badusage "bad IP address"; | |
71 | $x->masklen == $x->bits or badusage "IP network where addr expected"; | |
72 | die if $x->addr =~ m,/,; | |
73 | $$ar = $x; | |
74 | } | |
75 | ||
76 | @ARGV == 5 or badusage "wrong number of arguments"; | |
77 | our ($v1config, $realservice, $sep, $addrsarg, $rnets) = @ARGV; | |
78 | ||
79 | $sep eq '--' or badusage "separator should be \`--'"; | |
80 | my ($local_addr, $peer_addr, $mtu, $protocol, $ifname) = | |
81 | split /\,/, $addrsarg; | |
82 | ||
83 | oneaddr \$local_addr; | |
84 | oneaddr \$peer_addr; | |
85 | $mtu = 1500 unless length $mtu; | |
86 | $mtu =~ m/^[1-9]\d{1,4}/ or badusage "bad mtu"; | |
87 | $mtu += 0; | |
88 | ||
89 | $protocol = 'slip' unless length $protocol; | |
90 | $protocol =~ m/\W/ and badusage "bad protocol"; | |
91 | ||
92 | $ifname = $default_ifname unless length $ifname; | |
93 | ||
94 | our @rnets = ($rnets eq '-' ? () : split /\,/, $rnets); | |
95 | @rnets = map { new NetAddr::IP::Lite $_ } @rnets; | |
96 | ||
97 | our %need_allow; | |
98 | # $need_allow{CLASS}[] | |
99 | # $need_allow{CLASS}[]{Desc} # For error messages | |
100 | # $need_allow{CLASS}[]{Allow} # Starts out nonexistent | |
101 | # $need_allow{CLASS}[]{IpAddr} # CLASS eq Local or Remote only | |
102 | ||
103 | sub need_allow__entry ($@) { | |
104 | my ($desc, @xtra) = @_; | |
105 | return { Desc => $desc, @xtra }; | |
106 | } | |
107 | sub need_allow_item ($$@) { | |
108 | my ($cl, $desc, @xtra) = @_; | |
109 | push @{ $need_allow{$cl} }, need_allow__entry $desc, @extra; | |
110 | } | |
111 | sub need_allow_singleton ($$) { | |
112 | my ($cl, $desc) = @_; | |
113 | $need_allow{$cl} ||= [ need_allow__entry $desc ]; | |
114 | } | |
115 | ||
116 | sub maybe_allow__entry ($$) { | |
117 | my ($ne, $yes) = @_; | |
118 | $ne->{Allowed} ||= $yes; | |
119 | } | |
120 | sub maybe_allow_singleton ($) { | |
121 | my ($cl, $yes) = @_; | |
122 | my $ents = $need_allow{$cl}; | |
123 | die $cl unless @$ents==1; | |
124 | maybe_allow__entry $ents->[0], $val; | |
125 | } | |
126 | sub default_allow_singleton ($$) { | |
127 | # does nothing if maybe_allow_singleton was called for this $cl; | |
128 | # otherwise allows the singleton iff $yes | |
129 | my ($cl, $yes) = @_; | |
130 | my $ents = $need_allow{$cl}; | |
131 | die $cl unless @$ents==1; | |
132 | $ents->[0]{Allowed} //= $yes; | |
133 | } | |
134 | ||
135 | sub maybe_allow_caller_env ($$) { | |
136 | my ($spec, @envvars) = @_; | |
137 | foreach my $envvar (@envvars) { | |
138 | my $val = $ENV{$envvar} // die $envvar; | |
139 | my @vals = split / /, $val; | |
140 | maybe_allow_singleton 'Caller', !!grep { $_ eq $spec } @vals; | |
141 | } | |
142 | } | |
143 | sub maybe_allow_addrs ($) { | |
144 | my ($cl, $permitrange) = @_; | |
145 | foreach my $ne (@{ $need_allow{$cl} }) { | |
146 | maybe_allow_entry $ne, $permitrange->contains($ne->{IpAddr}); | |
147 | } | |
148 | } | |
149 | ||
150 | sub readconfig ($) { | |
151 | my ($cfgpath) = @_; | |
152 | my $cfgfh = new IO::File "<", $cfgpath; | |
153 | if (!$cfgfh) { | |
154 | die "$0: $cfgpath: $!\n" unless $!==ENOENT; | |
155 | return; | |
156 | } | |
157 | while (<$cfgfh>) { | |
158 | s/^\s+//; | |
159 | s/\s+$/\n/; | |
160 | next if m/^\#/; | |
161 | next unless m/\S/; | |
162 | if (s{^permit\s+}{}) { | |
163 | badcfg "v0config before permit" if defined $v0config; | |
164 | %need_allowed = (); | |
165 | need_allow_singleton 'Caller', 'caller'; | |
166 | need_allow_singleton 'Local', "local interface addr $local_addr"; | |
167 | need_allow_singleton 'Ifname', 'interface name'; | |
168 | always_need_allow 'Remote', "peer point-to-point addr $peer_addr"; | |
169 | foreach (@rnets) { | |
170 | need_allow_item 'Remote', "remote network ".$_->cidr(), | |
171 | IpAddr => $_; | |
172 | } | |
173 | while (m{\S}) { | |
174 | if (s{^group\s+(\S+)\s+}{}) { | |
175 | maybe_allow_caller_env $1, 'USERV_USER', 'USERV_UID'; | |
176 | } elsif (s{^user\s+(\S+)\s+}{}) { | |
177 | maybe_allow_caller_env $1, 'USERV_GROUP', 'USERV_GID'; | |
178 | } elsif (s{^everyone\s+}{}) { | |
179 | maybe_allow_singleton 'Caller', 1; | |
180 | } elsif (s{^hostnet\s+(\S+/\d+)\s+}{}) { | |
181 | my $hn = new NetAddr:IP::Lite $1 or | |
182 | badcfg "invalid ip address in hostnet"; | |
183 | my $host = new NetAddr::IP::Lite $hn->addr or die; | |
184 | my $net = $hn->network() or die; | |
185 | maybe_allow_addrs 'Local', $host; | |
186 | maybe_ allow_addrs 'Remote', $net; | |
187 | } elsif (s{^(local|remote|addrs)\s+(\S+)\ s+}{}) { | |
188 | my $h = $1; | |
189 | my $s = new NetAddr::IP::Lite $2 or | |
190 | badcfg "invalid ip address or mask in $h"; | |
191 | maybe_allow_addrs 'Local', $s if $h =~ m/addrs|local/; | |
192 | maybe_allow_addrs 'Remote', $s if $h =~ m/addrs|remote/; | |
193 | } elsif (s{^ifname\s+(\S+)\s+}{}) { | |
194 | my ($spec) = $1; | |
195 | maybe_allow_singleton 'Ifname', $ifname eq $spec; | |
196 | } elsif (m{^\S+}) { | |
197 | badcfg "unknown keyword in permit \`$1'"; | |
198 | } else { | |
199 | die; | |
200 | } | |
201 | } | |
202 | default_allow_singleton 'Ifname', $ifname eq $default_ifname; | |
203 | my @wrong; | |
204 | foreach my $clval (values %need_allow) { | |
205 | foreach my $ne (@$clval) { | |
206 | next if $ne->{Allow}; | |
207 | push @wrong, $ne->{Desc}; | |
208 | } | |
209 | } | |
210 | if (!@wrong) { | |
211 | # yay! | |
212 | if ($protocol eq 'debug') { | |
213 | print "config $cfgh line $.: matches\n"; | |
214 | exit 0; | |
215 | } | |
216 | exec $realservice, '*', '--', | |
217 | "$local_addr,$peer_addr,$mtu,$protocol", | |
218 | @rnets ? (join ",", map { "$_" } @rnets) : "-"; | |
219 | die "exec $realservice: $!\n"; | |
220 | } | |
221 | if ($protocol eq 'debug') { | |
222 | print "config $cfgfh line $.: mismatch: $_\n" | |
223 | foreach @wrong; | |
224 | } | |
225 | } elsif (m{^v0config\s+(\S+)$}) { | |
226 | badcfg "repeated v0config" if defined $v0config; | |
227 | $v0config = $1; | |
228 | } elsif (m{^include\s+(\S+)$}) { | |
229 | readconfig $1; | |
230 | } else { | |
231 | badcfg "unknown config directive or bad syntax"; | |
232 | } | |
233 | } | |
234 | $cfgfh->error and die $!; | |
235 | close $cfgfh; | |
236 | } | |
237 |