Commit | Line | Data |
---|---|---|
e8e64c07 MW |
1 | #! /usr/bin/perl -w |
2 | ### | |
3 | ### Adverbial modifier conferring AUTHINFO GENERIC support on NNTP clients | |
4 | ### | |
5 | ### (c) 2016 Mark Wooding | |
6 | ### | |
7 | ||
8 | ###----- Licensing notice --------------------------------------------------- | |
9 | ### | |
10 | ### This program is free software; you can redistribute it and/or modify | |
11 | ### it under the terms of the GNU General Public License as published by | |
12 | ### the Free Software Foundation; either version 2 of the License, or | |
13 | ### (at your option) any later version. | |
14 | ### | |
15 | ### This program is distributed in the hope that it will be useful, | |
16 | ### but WITHOUT ANY WARRANTY; without even the implied warranty of | |
17 | ### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
18 | ### GNU General Public License for more details. | |
19 | ### | |
20 | ### You should have received a copy of the GNU General Public License | |
21 | ### along with this program; if not, write to the Free Software Foundation, | |
22 | ### Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. | |
23 | ||
e8e64c07 MW |
24 | my $VERSION = "0.1.0~unfinished"; |
25 | ||
26 | use strict; | |
27 | ||
28 | ###-------------------------------------------------------------------------- | |
29 | ### External modules. | |
30 | ||
31 | ## Included batteries. | |
32 | use Fcntl qw(:mode); | |
33 | use File::stat; | |
34 | use Getopt::Long qw(:config gnu_compat bundling | |
35 | require_order no_getopt_compat); | |
36 | use POSIX qw(:errno_h :fcntl_h :sys_wait_h); | |
37 | use Socket qw(/^[AP]F_/ /^SOCK_/ /^sockaddr_/ | |
38 | getaddrinfo /^AI_/ /^EAI_/ | |
39 | getnameinfo /^NI_/); | |
40 | use Sys::Hostname; | |
41 | ||
42 | ## External batteries. | |
43 | use File::FcntlLock; | |
44 | ||
45 | ###-------------------------------------------------------------------------- | |
46 | ### Configuration variables. | |
47 | ||
48 | ## The global configuration. | |
49 | my %C = ( | |
50 | "rundir" => undef | |
51 | ); | |
52 | ||
53 | ## The per-server configuration. | |
54 | my %S; | |
55 | my %SPARAM = map { $_ => 1 } | |
56 | "local", "nntpauth", "remote", "sshbind", "via"; | |
57 | ||
58 | ## Various facts we might discover. | |
59 | my $HOME = $ENV{"HOME"}; | |
60 | (my $PROG = $0) =~ s:^.*/::; | |
61 | my $VERBOSE = 0; | |
62 | my $CONF = undef; | |
63 | my $TAG = undef; | |
64 | my $RUNDIR = undef; | |
65 | ||
66 | ## Other bits of useful state. | |
67 | my @CLEANUP = (); | |
68 | my $SESSDIR = undef; | |
69 | my %SERVMAP = (); | |
70 | my %CLIENT_NOIP = (); | |
71 | my %KIDMAP = (); | |
a3775340 | 72 | my $CLIENTKID = -1; |
e8e64c07 MW |
73 | |
74 | ###-------------------------------------------------------------------------- | |
75 | ### Utilities. | |
76 | ||
77 | my $BAD = 0; | |
78 | ||
79 | sub moan ($) { | |
80 | my ($msg) = @_; | |
81 | print STDERR "$PROG: $msg\n"; | |
82 | } | |
83 | ||
84 | sub fail ($;$) { | |
85 | my ($msg, $rc) = @_; | |
86 | moan $msg; | |
87 | exit ($rc // 1); | |
88 | } | |
89 | ||
90 | sub sysfail ($) { | |
91 | my ($msg) = @_; | |
92 | fail $msg, 16; | |
93 | } | |
94 | ||
95 | sub bad ($) { | |
96 | my ($msg) = @_; | |
97 | moan $msg; | |
98 | $BAD = 1; | |
99 | } | |
100 | ||
101 | sub inform ($) { | |
102 | my ($msg) = @_; | |
103 | print STDERR "$PROG: ;; $msg\n" if $VERBOSE; | |
104 | } | |
105 | ||
106 | sub trim ($) { | |
107 | my ($s) = @_; | |
108 | $s =~ s/^\s+//; | |
109 | $s =~ s/\s+$//; | |
110 | return $s; | |
111 | } | |
112 | ||
113 | sub ensure_home () { | |
114 | defined $HOME or fail "no home directory set"; | |
115 | return $HOME; | |
116 | } | |
117 | ||
118 | sub ensure_dir_exists ($$) { | |
119 | my ($dir, $mode) = @_; | |
120 | mkdir $dir, $mode or $! == EEXIST or | |
121 | sysfail "failed to create directory `$dir': $!"; | |
122 | } | |
123 | ||
124 | sub zap ($); | |
125 | sub zap ($) { | |
126 | my ($f) = @_; | |
127 | if (-d $f) { | |
128 | my $d; | |
129 | unless (opendir $d, $f) { | |
130 | moan "failed to open directory `$d': $!"; | |
131 | return; | |
132 | } | |
133 | ENTRY: for (;;) { | |
134 | defined (my $b = readdir $d) or last ENTRY; | |
135 | next ENTRY if grep { $b eq $_ } ".", ".."; | |
136 | zap "$f/$b"; | |
137 | } | |
138 | closedir $d; | |
139 | rmdir $f or $! == ENOENT or moan "failed to zap directory `$f': $!"; | |
140 | } else { | |
141 | unlink $f or $! == ENOENT or moan "failed to zap file thing `$f': $!"; | |
142 | } | |
143 | } | |
144 | ||
145 | sub set_cloexec ($) { | |
146 | my ($fh) = @_; | |
147 | my $f = fcntl $fh, F_GETFD, 0 or sysfail "failed to get per-fd flags: $!"; | |
148 | fcntl $fh, F_SETFD, $f | FD_CLOEXEC or | |
149 | sysfail "failed to set close-on-exec: $!"; | |
150 | } | |
151 | ||
38877c89 MW |
152 | sub set_nonblock ($) { |
153 | my ($fh) = @_; | |
154 | my $f = fcntl $fh, F_GETFL, 0 or sysfail "failed to get file flags: $!"; | |
155 | fcntl $fh, F_SETFL, $f | O_NONBLOCK or | |
156 | sysfail "failed to set non-blockingness: $!"; | |
157 | } | |
158 | ||
e8e64c07 MW |
159 | sub lockedp ($) { |
160 | my ($f) = @_; | |
161 | my $l = new File::FcntlLock; | |
162 | $l->lock($f, F_GETLK) or sysfail "couldn't read locking for `$f': $!"; | |
163 | return $l->l_type != F_UNLCK; | |
164 | } | |
165 | ||
399b694f MW |
166 | sub write_to_file ($$) { |
167 | my ($file, $contents) = @_; | |
168 | my $new = "$file.new"; | |
169 | open my $fh, ">", $new or sysfail "couldn't open `$new' for writing: $!"; | |
170 | print $fh $contents; | |
171 | $fh->flush && !$fh->error && close $fh | |
172 | or sysfail "failed to write to `$new': $!"; | |
173 | rename $new, $file or sysfail "failed to rename `$new' to `$file': $!"; | |
174 | } | |
175 | ||
e8e64c07 MW |
176 | my $INKIDP = 0; |
177 | sub myfork () { | |
178 | my $kid = fork; | |
179 | if (defined $kid && !$kid) { $INKIDP = 1; } | |
180 | return $kid; | |
181 | } | |
182 | ||
183 | my $SEQ = 0; | |
184 | sub sequence () { return $SEQ++; } | |
185 | ||
186 | ###-------------------------------------------------------------------------- | |
187 | ### Setting up the configuration. | |
188 | ||
189 | sub set_global_param ($$) { | |
190 | my ($param, $value) = @_; | |
191 | exists $C{$param} or fail "unknown global parameter `$param'"; | |
192 | $C{$param} = $value; | |
193 | } | |
194 | ||
195 | sub notice_server ($$) { | |
196 | my ($server, $where) = @_; | |
197 | inform "found server `$server' $where"; | |
198 | $S{$server} //= {}; | |
199 | } | |
200 | ||
201 | sub set_server_param ($$$) { | |
202 | my ($server, $param, $value) = @_; | |
203 | $S{$server} or bad "unknown server `$param'"; | |
204 | $SPARAM{$param} or bad "unknown server parameter `$param'"; | |
205 | $S{$server}{$param} = $value; | |
206 | } | |
207 | ||
208 | sub chew_cli_server_configs (\@) { | |
209 | my ($args) = @_; | |
210 | my $server = undef; | |
211 | ||
212 | ARG: for (;;) { | |
213 | last ARG unless @$args; | |
4ed4f066 | 214 | my $arg = shift @$args; |
e8e64c07 MW |
215 | if ($arg eq "+") { last ARG; } |
216 | elsif ($arg =~ /^\+/) { | |
217 | $server = substr $arg, 1; | |
218 | notice_server $server, "on command line"; | |
219 | } | |
220 | elsif (!defined $server or $arg !~ /^([^=]+)=(.*)$/) | |
221 | { unshift @$args, $arg; last ARG; } | |
222 | else { set_server_param $server, $1, $2; } | |
223 | } | |
224 | } | |
225 | ||
226 | sub parse_config_file () { | |
227 | ||
228 | ## If we already know what we're doing then forbid a configuration file as | |
229 | ## well. | |
230 | if (%S) { | |
231 | return unless defined $CONF; | |
232 | fail "servers defined on command-line; won't read config file too"; | |
233 | } | |
234 | ||
235 | ## Search about to find a suitable configuration file. | |
236 | my $cf; | |
237 | my @confpath = | |
238 | ($ENV{"XDG_CONFIG_HOME"} // ensure_home . "/.config", | |
239 | split /:/, $ENV{"XDG_CONFIG_DIRS"} // "/etc/xdg"); | |
240 | inform "searching for a configuration file with tag `$TAG'..."; | |
241 | PATH: for my $dir (@confpath) { | |
242 | for my $base ($TAG, "\@default") { | |
243 | my $f = "$dir/with-authinfo-kludge/$base.conf"; | |
244 | if (open $cf, "<", $f) { | |
245 | inform " found `$f'; search over"; | |
246 | $CONF = $f; last PATH; | |
247 | } elsif ($! != ENOENT) { | |
248 | bad "couldn't open `$f' for reading: $!"; | |
249 | } else { | |
250 | inform " `$f' not found; search continues"; | |
251 | } | |
252 | } | |
253 | } | |
254 | ||
255 | ## If we still don't have a configuration file then synthesize one from the | |
256 | ## `$NNTPSERVER' variable. | |
257 | unless ($CONF) { | |
258 | my $server = $ENV{"NNTPSERVER"}; | |
259 | defined $server or fail "no `NNTPSERVER' defined in the environment"; | |
260 | inform "no config file found; synthesizing default"; | |
261 | notice_server $server, "in environment"; | |
262 | return; | |
263 | } | |
264 | ||
265 | ## Work through the configuration file setting up servers. | |
266 | my $set_param = \&set_global_param; | |
267 | while (<$cf>) { | |
268 | next if /^\s*([#;]|$)/; | |
269 | if (/^\s*\[(.+)\]\s*$/) { | |
270 | my $head = trim $1; | |
271 | if ($head eq "\@GLOBAL") { $set_param = \&set_global_param; } | |
272 | else { | |
273 | notice_server $head, "in config file"; | |
274 | $set_param = sub { set_server_param $head, $_[0], $_[1]; }; | |
275 | } | |
276 | } elsif (/^([^=]+)=(.*)$/) { $set_param->(trim $1, trim $2); } | |
277 | else { bad "$CONF:$.: couldn't parse configuration file line"; } | |
278 | } | |
279 | (!$cf->error and close $cf) | |
280 | or sysfail "error reading configuration file `$CONF': $!"; | |
281 | } | |
282 | ||
283 | sub format_value ($); | |
284 | sub format_value ($) { | |
285 | my ($value) = @_; | |
286 | if (!defined $value) { return "<undef>"; } | |
287 | elsif (my $r = ref $value) { | |
288 | if ($r eq "ARRAY") { | |
289 | return "[" . join(", ", map { format_value $_ } @$value) . "]"; | |
290 | } elsif ($r eq "HASH") { | |
291 | return "{ " . | |
292 | join(", ", map { format_value $_ . " => " . | |
293 | format_value $value->{$_} } sort keys %$value) . | |
294 | " }"; | |
295 | } else { | |
296 | return "<$r ref>"; | |
297 | } | |
298 | } else { return "`$value'"; } | |
299 | } | |
300 | ||
301 | sub inform_param ($$) { | |
302 | my ($param, $value) = @_; | |
303 | inform " $param = " . format_value $value; | |
304 | } | |
305 | ||
306 | sub dump_configuration () { | |
307 | inform "Global parameters..."; | |
308 | for my $p (sort keys %C) { inform_param $p, $C{$p}; } | |
309 | ||
310 | for my $s (sort keys %S) { | |
311 | inform "Server `$s' parameters..."; | |
4ed4f066 | 312 | for my $p (sort keys %{$S{$s}}) { inform_param $p, $S{$s}{$p}; } |
e8e64c07 MW |
313 | } |
314 | } | |
315 | ||
316 | ###-------------------------------------------------------------------------- | |
317 | ### Managing the runtime directory. | |
318 | ### | |
319 | ### Truly told, this bit is probably the trickiest part of the program. | |
320 | ||
321 | ## How long we allow for a new server directory to be set up. | |
322 | my $BIRTHTIME = 300; | |
323 | ||
324 | sub find_rundir () { | |
325 | ||
326 | ## Maybe we've done all of this already. | |
327 | defined $RUNDIR and return; | |
328 | ||
329 | ## Find a suitable place to put things. | |
330 | SEARCH: { | |
331 | inform "searching for a suitable runtime directory..."; | |
332 | ||
333 | ## Maybe the user's configured a directory explicitly. (Maybe we still | |
334 | ## have to arrange for this to exist.) | |
335 | if (defined ($RUNDIR = $C{"rundir"})) { | |
336 | inform "using runtime directory from configuration"; | |
337 | last SEARCH; | |
338 | } | |
339 | ||
340 | ## First attempt: use `$XDG_RUNTIME_DIR'. | |
341 | if (defined (my $runhome = $ENV{"XDG_RUNTIME_DIR"})) { | |
342 | inform "setting runtime directory from `XDG_RUNTIME_DIR'"; | |
343 | $RUNDIR = "$runhome/with-authinfo-kludge"; | |
344 | last SEARCH; | |
345 | } | |
346 | ||
347 | ## Second attempt: let's use /tmp, or whatever `$TMPDIR' is set. | |
348 | my $tmpdir = $ENV{"TMPDIR"} // "/tmp"; | |
349 | inform "investigating putting runtime directory under tmpdir `$tmpdir'"; | |
350 | my $dir = "$tmpdir/with-authinfo-kludge-$>"; | |
351 | my $st = lstat $dir; | |
352 | if (!$st && $! == ENOENT) { | |
353 | mkdir $dir, 0700 or sysfail "failed to create directory `$dir': $!"; | |
354 | $st = lstat $dir; | |
355 | inform "created `$dir'"; | |
356 | } | |
357 | if (!-d $st) { inform "alas, `$dir' isn't a directory"; } | |
358 | elsif ($st->uid != $>) { inform "alas, we don't own `$dir'"; } | |
359 | elsif ($st->mode & 0077) { inform "alas, `$dir' has liberal perms"; } | |
360 | else { | |
361 | inform "accepting `$dir' as runtime directory"; | |
362 | $RUNDIR = $dir; | |
363 | last SEARCH; | |
364 | } | |
365 | ||
366 | ## Third attempt: we'll use the XDG cache directory. | |
367 | my $cachehome = $ENV{"XDG_CACHE_HOME"} // ensure_home . "/.cache"; | |
368 | ensure_dir_exists $cachehome, 0777; | |
369 | my $host = hostname; | |
370 | $RUNDIR = "$cachehome/with-authinfo-kludge.$host"; | |
371 | inform "last ditch: using `$RUNDIR' as runtime directory"; | |
372 | } | |
373 | ||
374 | ## Make the runtime directory if it doesn't exist. Be paranoid here; users | |
375 | ## can override if they really want. (Note that noip(1) is untweakably | |
376 | ## picky about its socket directories, so this is less generous than it | |
377 | ## looks.) | |
378 | ensure_dir_exists $RUNDIR, 0700; | |
379 | for my $d ("junk", "new") { ensure_dir_exists "$RUNDIR/$d", 0777; } | |
380 | } | |
381 | ||
382 | sub junk_rundir_thing ($$) { | |
383 | my ($f, $what) = @_; | |
384 | inform "junking $what `$f'"; | |
385 | ||
386 | ## Find a name to rename it to under the `junk' directory. Anyone can put | |
387 | ## things in the `junk' directory, and anyone is allowed to delete them; | |
388 | ## the only tricky bit is making sure the names don't collide. | |
389 | my $junk; | |
390 | NAME: for (;;) { | |
391 | my $r = int rand 1000000; | |
392 | $junk = "$RUNDIR/junk/j.$r"; | |
393 | ||
394 | ## It'll be OK if this fails because someone else has junked the file (in | |
395 | ## which case we end happy), or if the target exists (in which case we | |
396 | ## pick another and try again). | |
397 | if (rename $f, $junk or ($! == ENOENT && !-e $f)) { last NAME; } | |
398 | elsif ($! != EEXIST) { sysfail "couldn't rename `$f' to `$junk': $!"; } | |
399 | } | |
400 | ||
401 | return $junk; | |
402 | } | |
403 | ||
404 | sub clean_up_rundir () { | |
405 | inform "cleaning up stale things from runtime directory"; | |
406 | ||
407 | ## Work through the things in the directory, making sure they're meant to | |
408 | ## be there. | |
409 | opendir my $dh, $RUNDIR or | |
410 | sysfail "failed to open directory `$RUNDIR': $!"; | |
411 | ENTRY: for (;;) { | |
412 | defined (my $base = readdir $dh) or last ENTRY; | |
413 | next ENTRY if grep { $base eq $_ } ".", ".."; | |
414 | my $f = "$RUNDIR/$base"; | |
415 | ||
416 | ## If this thing isn't a directory then it shouldn't be there. Maybe a | |
417 | ## later version of us put it there. | |
418 | unless (-d $f) { | |
419 | inform "found unexpected thing `$f' in runtime directory"; | |
420 | next ENTRY; | |
421 | } | |
422 | ||
423 | ## Maybe it's a standard thing that's meant to be here. We'll clean | |
424 | ## those up later. | |
425 | next ENTRY if grep { $base eq $_ } "junk", "new"; | |
426 | ||
427 | ## If the name doesn't have a `.' in it, then it's some other special | |
428 | ## thing which we don't understand. | |
429 | if ($base !~ /^s.*\.\d+/) { | |
430 | inform "found unexpected special directory `$f' in runtime directory"; | |
431 | next ENTRY; | |
432 | } | |
433 | ||
434 | ## Otherwise, it's a session directory. If its lockfile isn't locked | |
435 | ## then it's fair game. | |
436 | my $lk = "$f/lock"; | |
437 | if (open my $fh, "<", $lk) { | |
438 | my $ownedp = lockedp $fh; | |
439 | close $fh or sysfail "couldn't close file, what's up with that?: $!"; | |
440 | if (!$ownedp) { junk_rundir_thing $f, "stale session dir"; } | |
441 | } elsif ($! == ENOENT) { | |
442 | junk_rundir_thing $f, "session dir without `lock' file"; | |
443 | } else { | |
444 | moan "couldn't open `$lk' (found in runtime dir) for reading: $!"; | |
445 | inform "leaving `$f' alone"; | |
446 | } | |
447 | } | |
448 | closedir $dh; | |
449 | ||
450 | ## Work through the things in the `new' directory. | |
451 | my $thresh = time - $BIRTHTIME; | |
452 | my $newdir = "$RUNDIR/new"; | |
453 | opendir $dh, $newdir or | |
454 | sysfail "failed to open directory `$newdir': $!"; | |
455 | NEW: for (;;) { | |
456 | defined (my $base = readdir $dh) or last NEW; | |
457 | next NEW if grep { $base eq $_ } ".", ".."; | |
458 | my $f = "$newdir/$base"; | |
459 | unless (-d $f) { | |
460 | inform "found unexepected nondirectory thing `$f' in nursery"; | |
461 | next NEW; | |
462 | } | |
463 | if ($base !~ /^n\.(\d+)\./) { | |
464 | inform "found directory with unexpected name `$f' in nursery"; | |
465 | next NEW; | |
466 | } | |
467 | my $stamp = $1; | |
468 | $stamp >= $thresh or junk_rundir_thing $f, "stillborn session directory"; | |
469 | } | |
470 | closedir $dh; | |
471 | ||
472 | ## Work through the things in the `junk' directory. Anyone can put things | |
473 | ## in the `junk' directory, and anyone is allowed to delete them. | |
474 | ## Therefore we can just zap everything in here. The `zap' function is | |
475 | ## (somewhat) careful not to screw up if someone else is also zapping the | |
476 | ## same thing. | |
477 | my $junkdir = "$RUNDIR/junk"; | |
478 | opendir $dh, $junkdir or | |
479 | sysfail "failed to open directory `$junkdir': $!"; | |
480 | NEW: for (;;) { | |
481 | defined (my $base = readdir $dh) or last NEW; | |
482 | next NEW if grep { $base eq $_ } ".", ".."; | |
483 | my $f = "$junkdir/$base"; | |
484 | zap $f; | |
485 | } | |
486 | closedir $dh; | |
487 | } | |
488 | ||
489 | sub make_session_dir () { | |
490 | inform "making session directory for `$TAG'"; | |
491 | ||
492 | ## Make a new directory in the nursery. Only the creator of a nursery | |
493 | ## directory is allowed to put things in it. | |
494 | my $newdir = "$RUNDIR/new"; | |
495 | my $n; | |
496 | NAME: for (;;) { | |
497 | my $now = time; | |
498 | my $r = int rand 1000000; | |
499 | $n = "$newdir/n.$now.$$.$r"; | |
500 | if (mkdir $n, 0777) { last NAME; } | |
501 | elsif ($! != EEXIST) { sysfail "failed to create `$n': $!"; } | |
502 | } | |
503 | ||
504 | ## Create the lockfile, and take out a lock. | |
505 | open my $fh, ">", "$n/lock"; | |
506 | set_cloexec $fh; | |
507 | my $l = File::FcntlLock->new(l_type => F_WRLCK, | |
508 | l_whence => SEEK_SET, | |
509 | l_start => 0, | |
510 | l_len => 0); | |
511 | $l->lock($fh, F_SETLK) or sysfail "failed to lock `$n/lock: $!"; | |
512 | ||
513 | ## Rename the directory into its proper place. We have already cleaned out | |
514 | ## stale directories, and the target name has our PID in it, so it can't | |
515 | ## exist any more unless something unfortunate has happened. | |
516 | $SESSDIR = "$RUNDIR/s.$TAG.$$"; | |
517 | rename $n, $SESSDIR or sysfail "failed to rename `$n' to `$SESSDIR': $!"; | |
518 | ||
519 | ## Create some necessary things. | |
520 | ensure_dir_exists "$SESSDIR/noip-client", 0700; | |
521 | } | |
522 | ||
523 | END { | |
524 | zap junk_rundir_thing $SESSDIR, "cleanup on exit" | |
525 | if !$INKIDP && defined $SESSDIR; | |
526 | } | |
527 | ||
528 | ###-------------------------------------------------------------------------- | |
529 | ### Setting up a session. | |
530 | ||
531 | sub parse_address ($;$) { | |
532 | my ($addr, $defport) = @_; | |
533 | inform "parsing address `$addr'..."; | |
534 | ||
535 | my ($host, $port); | |
536 | if ($addr =~ /^\[([^]]*)\]:(\d+)$/ || $addr =~ /^([^:]+):(\d+)$/) | |
537 | { $host = $1; $port = $2; } | |
538 | elsif (defined $defport) { $host = $addr; $port = $defport; } | |
539 | else { fail "invalid address `$addr': missing port number"; } | |
540 | inform " host = `$host'; port = $port"; | |
541 | return ($host, $port); | |
542 | } | |
543 | ||
544 | sub format_address ($$) { | |
545 | my ($host, $port) = @_; | |
546 | $host =~ /:/ and $host = "[$host]"; | |
547 | return "$host:$port"; | |
548 | } | |
549 | ||
550 | sub canonify_address ($;$) { | |
551 | my ($addr, $defport) = @_; | |
552 | my ($host, $port) = parse_address $addr, $defport; | |
553 | return format_address $host, $port; | |
554 | } | |
555 | ||
556 | sub resolve_parsed_address ($$) { | |
557 | my ($host, $port) = @_; | |
558 | inform "resolving host `$host', port $port"; | |
559 | ||
560 | my ($err, @a) = getaddrinfo $host, $port, { flags => AI_NUMERICSERV }; | |
561 | $err and fail "failed to resolve `$host': $err"; | |
562 | ||
563 | my @res; | |
564 | my %seen; | |
565 | for my $a (@a) { | |
566 | ($err, $host, $port) = | |
567 | getnameinfo $a->{addr}, NI_NUMERICHOST | NI_NUMERICSERV; | |
568 | $err and sysfail "unexpectedly failed to convert addr to text: $err"; | |
569 | inform " resolved to $host $port"; | |
570 | my $r = format_address $host, $port; | |
571 | unless ($seen{$r}) { push @res, $r; $seen{$r} = 1; } | |
572 | } | |
573 | ||
574 | return @res; | |
575 | } | |
576 | ||
577 | sub resolve_address ($;$) { | |
578 | my ($addr, $defport) = @_; | |
579 | my ($host, $port) = parse_address $addr, $defport; | |
580 | return resolve_parsed_address $host, $port; | |
581 | } | |
582 | ||
583 | sub fix_server_config ($) { | |
584 | my ($server) = @_; | |
585 | my $s = $S{$server}; | |
586 | ||
587 | ## Keep the name. This is useful for diagnostics, but it's also important | |
588 | ## for finding the right socket directory if we're doing SSH forwarding. | |
589 | $s->{"_name"} = $server; | |
590 | ||
591 | ## Sort out the various addresses. | |
592 | my ($host, $port); | |
593 | ($host, $port) = parse_address($s->{"local"} // $server, 119); | |
594 | $s->{"local"} = format_address $host, $port; | |
595 | $s->{"_laddrs"} = [resolve_parsed_address $host, $port]; | |
596 | $s->{"remote"} = canonify_address($s->{"remote"} // $server, 119); | |
597 | ($host, $port) = parse_address($s->{"sshbind"} // "127.1.0.1", 1119); | |
598 | $s->{"sshbind"} = format_address $host, $port; | |
599 | $s->{"_sshaddrs"} = [resolve_parsed_address $host, $port]; | |
600 | ||
601 | ## Initialize other settings. | |
602 | $s->{"_proxy_noip"} = undef; | |
603 | $s->{"_proxy_sockdir"} = undef; | |
604 | $s->{"_proxy_server"} = defined $s->{"via"} ? | |
605 | $s->{"sshbind"} : $s->{"remote"}; | |
b1436e12 MW |
606 | $s->{"_proxy_server"} =~ s/:119$//; |
607 | $s->{"_proxy_server"} =~ s/^\[(.*)\]$/$1/; | |
e8e64c07 | 608 | $s->{"_sshkid"} = undef; |
b17683b0 MW |
609 | $s->{"_ssh_stdin"} = undef; |
610 | $s->{"_ssh_stdout"} = undef; | |
e8e64c07 MW |
611 | } |
612 | ||
613 | sub hack_noip_envvar ($$) { | |
614 | my ($var, $val) = @_; | |
615 | inform " hack env for noip: $var = `$val'"; | |
616 | $ENV{$var} = $val; | |
617 | } | |
618 | ||
619 | sub hack_noip_env ($$) { | |
620 | my ($vars, $dir) = @_; | |
621 | return unless $vars; | |
622 | ||
623 | hack_noip_envvar "LD_PRELOAD", | |
624 | "noip.so" . | |
625 | (exists $ENV{"LD_PRELOAD"} ? ":" . $ENV{"LD_PRELOAD"} : ""); | |
626 | for my $k (keys %ENV) { delete $ENV{$k} if $k =~ /^NOIP_/; } | |
627 | hack_noip_envvar "NOIP_CONFIG", "$RUNDIR/noip.conf.notexist"; | |
628 | hack_noip_envvar "NOIP_SOCKETDIR", $dir; | |
629 | hack_noip_envvar "NOIP_DEBUG", $VERBOSE; | |
630 | for my $acl ("REALBIND", "REALCONNECT") { | |
631 | hack_noip_envvar "NOIP_$acl", | |
632 | join ",", @{$vars->{$acl} // []}, "+any"; | |
633 | } | |
634 | } | |
635 | ||
636 | sub server_listen ($) { | |
637 | my ($server) = @_; | |
638 | my $s = $S{$server}; | |
639 | ||
640 | ## Set up the listening sockets for this server's addresses. | |
641 | inform "set up sockets for `$server'"; | |
642 | for my $a (@{$s->{"_laddrs"}}) { | |
643 | socket my $sk, PF_UNIX, SOCK_STREAM, 0 | |
644 | or sysfail "failed to make Unix-domain socket: $!"; | |
38877c89 | 645 | set_cloexec $sk; set_nonblock $sk; |
e8e64c07 MW |
646 | my $sa = "$SESSDIR/noip-client/$a"; |
647 | bind $sk, sockaddr_un $sa | |
648 | or sysfail "failed to bind Unix-domain socket to `$sa': $!"; | |
649 | listen $sk, 5 or sysfail "failed to listen on Unix-domain socket: $!"; | |
650 | $SERVMAP{fileno $sk} = [$s, $a, $sk]; | |
651 | inform " listening on $a"; | |
652 | push @{$CLIENT_NOIP{"REALCONNECT"}}, "-$a"; | |
653 | } | |
654 | ||
655 | ## If we're forwarding via SSH then set that up too. | |
656 | if (defined (my $via = $s->{"via"})) { | |
657 | inform "set up SSH tunnel to `$server' via $via..."; | |
658 | my %ssh_noip = (); | |
659 | my $sockdir = "$SESSDIR/noip-ssh.$server"; | |
660 | ensure_dir_exists $sockdir, 0700; | |
661 | my $sshbind = $s->{"sshbind"}; | |
662 | my $remote = $s->{"remote"}; | |
663 | for my $a (@{$s->{"_sshaddrs"}}) { | |
664 | push @{$ssh_noip{"REALBIND"}}, "-$a"; | |
665 | inform " listening on $a"; | |
666 | push @{$s->{"_proxy_noip"}{"REALCONNECT"}}, "-$a"; | |
667 | } | |
668 | $s->{"_proxy_sockdir"} = $sockdir; | |
669 | ||
b17683b0 MW |
670 | ## The `-L' option sets up the tunnel that we actually wanted. The `-v' |
671 | ## makes SSH spew stuff to stdout, which might be useful if you're | |
672 | ## debugging. . The `-S' detaches OpenSSH from any control master | |
673 | ## things which might be going on, because they tend to interfere with | |
674 | ## forwarding (and, besides, the existing master won't be under the same | |
675 | ## noip configuration). The `echo' will let us know that it's started | |
676 | ## up, and the `read' will keep the tunnel open until we close our end, | |
677 | ## which we do implicitly when we exit. | |
e8e64c07 | 678 | inform " starting SSH tunnel"; |
b17683b0 | 679 | my @sshargs = ("ssh", "-L$sshbind:$remote", "-Snone"); |
e8e64c07 | 680 | $VERBOSE and push @sshargs, "-v"; |
b17683b0 MW |
681 | push @sshargs, $via, <<EOF; |
682 | ## with-authinfo-kludge tunnel: $TAG -> $server | |
683 | set -e; echo started; read hunoz | |
684 | EOF | |
685 | pipe my $rin, my $win and pipe my $rout, my $wout | |
686 | or sysfail "failed to create pipe: $!"; | |
687 | set_cloexec $win; | |
688 | set_cloexec $rout; set_nonblock $rout; | |
e8e64c07 MW |
689 | defined (my $kid = myfork) or sysfail "failed to fork: $!"; |
690 | if (!$kid) { | |
b17683b0 MW |
691 | open STDIN, "<&", $rin or sysfail "failed to dup pipe to stdin: $!"; |
692 | open STDOUT, "<&", $wout or sysfail "failed to dup pipe to stdout: $!"; | |
e8e64c07 MW |
693 | hack_noip_env \%ssh_noip, $sockdir; |
694 | exec @sshargs or sysfail "failed to exec SSH: $!"; | |
695 | } | |
b17683b0 MW |
696 | close $rin; |
697 | close $wout; | |
e8e64c07 | 698 | $s->{"_sshkid"} = $kid; |
b17683b0 MW |
699 | $s->{"_ssh_stdin"} = $win; |
700 | $s->{"_ssh_stdout"} = $rout; | |
e8e64c07 | 701 | $KIDMAP{$kid} = [$s, "SSH tunnel"]; |
399b694f | 702 | write_to_file "$SESSDIR/ssh-$server.pid", "$kid\n"; |
e8e64c07 MW |
703 | } |
704 | } | |
705 | ||
706 | sub wait_for_ssh () { | |
b17683b0 MW |
707 | my $rfd_in = ""; |
708 | ||
709 | ## Collect up all the `stdout' pipes. | |
710 | my %fd = (); | |
711 | SETUP: for my $s (values %S) { | |
712 | next SETUP unless $s->{"_sshkid"}; | |
713 | my $fd = fileno $s->{"_ssh_stdout"}; | |
714 | vec($rfd_in, $fd, 1) = 1; | |
715 | $fd{$fd} = [$s->{"_ssh_stdout"}, $s]; | |
716 | } | |
717 | unless (%fd) { | |
718 | inform "no SSH tunnels to start"; | |
719 | return; | |
720 | } | |
721 | ||
722 | ## Wait for each of them to become readable, and try to read a thing. | |
723 | ## Either we'll get a byte or EOF; either means that the respective tunnel | |
724 | ## is as ready as it's ever going to be. | |
e8e64c07 | 725 | inform "waiting for SSH tunnels to start..."; |
b17683b0 MW |
726 | my $nbad = 0; |
727 | SELECT: while (%fd) { | |
728 | my ($n, $t) = select my $rfd_out = $rfd_in, undef, undef, undef; | |
729 | if ($n >= 0) { } | |
730 | elsif ($! == EINTR) { next SELECT; } | |
731 | else { sysfail "select failed: $!"; } | |
732 | FD: for my $fd (keys %fd) { | |
733 | next FD unless vec $rfd_out, $fd, 1; | |
734 | my ($sk, $s) = @{$fd{$fd}}; | |
735 | my $n = sysread $sk, my $hunoz, 128; | |
736 | if (defined $n) { | |
737 | vec($rfd_in, $fd, 1) = 0; | |
738 | if ($n) { inform " tunnel to $s->{remote} started ok"; } | |
739 | else { inform " tunnel to $s->{remote} FAILED"; $nbad++; } | |
740 | delete $fd{$fd}; | |
741 | } elsif ($! != EAGAIN && $! != EWOULDBLOCK) { | |
742 | sysfail "failed to read from pipe: $!"; | |
e8e64c07 MW |
743 | } |
744 | } | |
e8e64c07 | 745 | } |
b17683b0 MW |
746 | if ($nbad) { inform " tunnels started; $nbad FAILED"; } |
747 | else { inform " all tunnels started ok"; } | |
e8e64c07 MW |
748 | } |
749 | ||
750 | $SIG{"CHLD"} = sub { | |
751 | KID: for (;;) { | |
752 | defined (my $kid = waitpid -1, WNOHANG) | |
753 | or sysfail "failed to reap child: $!"; | |
754 | last KID if $kid <= 0; | |
755 | my ($how, $rc); | |
756 | if ($? == 0) { | |
757 | $how = "exited successfully"; | |
758 | $rc = 0; | |
759 | } elsif ($? & 0xff) { | |
760 | my $sig = $? & 0x7f; | |
761 | $how = "killed by signal $sig"; | |
762 | $how .= " (core dumped)" if $? & 0x80; | |
763 | $rc = $sig | 0x80; | |
764 | } else { | |
765 | $rc = $? >> 8; | |
766 | $how = "exited with status $rc"; | |
767 | } | |
768 | if ($kid == $CLIENTKID) { | |
769 | inform "client kid $how; shutting down"; | |
770 | exit $rc; | |
771 | } elsif (exists $KIDMAP{$kid}) { | |
772 | my ($s, $what) = @{$KIDMAP{$kid}}; | |
773 | inform "$what for server `$s->{_name}' collapsed ($how)"; | |
774 | delete $KIDMAP{$kid}; | |
775 | } else { | |
776 | inform "unrecognized child $kid $how"; | |
777 | } | |
778 | } | |
779 | }; | |
780 | ||
781 | sub run_client (@) { | |
782 | my (@args) = @_; | |
783 | ||
784 | inform "starting client"; | |
785 | defined (my $kid = myfork) or sysfail "failed to fork: $!"; | |
786 | if (!$kid) { | |
787 | hack_noip_env \%CLIENT_NOIP, "$SESSDIR/noip-client"; | |
788 | my $prog = $args[0]; | |
789 | exec @args or sysfail "failed to exec `$prog': $!"; | |
790 | } | |
791 | $CLIENTKID = $kid; | |
399b694f | 792 | write_to_file "$SESSDIR/client.pid", "$kid\n"; |
e8e64c07 MW |
793 | } |
794 | ||
795 | sub accept_loop () { | |
796 | my $rfd_in = ""; | |
797 | for my $fd (keys %SERVMAP) { vec($rfd_in, $fd, 1) = 1; } | |
9b7b093f | 798 | SELECT: for (;;) { |
e8e64c07 | 799 | my ($n, $t) = select my $rfd_out = $rfd_in, undef, undef, undef; |
9b7b093f MW |
800 | if ($n >= 0) { } |
801 | elsif ($! == EINTR) { next SELECT; } | |
802 | else { sysfail "select failed: $!"; } | |
e8e64c07 | 803 | FD: for my $fd (keys %SERVMAP) { |
e0b2f327 | 804 | next FD unless vec $rfd_out, $fd, 1; |
e8e64c07 MW |
805 | my ($s, $a, $sk) = @{$SERVMAP{$fd}}; |
806 | my $nsk; | |
807 | unless (accept $nsk, $sk) { | |
38877c89 MW |
808 | moan "failed to accept new connection: $!" |
809 | unless $! == EAGAIN || $! == EWOULDBLOCK; | |
e8e64c07 MW |
810 | next FD; |
811 | } | |
812 | set_cloexec $nsk; | |
813 | inform "incoming connection `$s->{_name}' to $a; starting proxy..."; | |
814 | defined (my $kid = myfork) or sysfail "failed to fork: $!"; | |
815 | if (!$kid) { | |
816 | $ENV{"NNTPAUTH"} = $s->{"nntpauth"} if exists $s->{"nntpauth"}; | |
817 | hack_noip_env $s->{"_proxy_noip"}, $s->{"_proxy_sockdir"}; | |
818 | open STDIN, "<&", $nsk | |
819 | or sysfail "failed to dup socket to kid stdin: $!"; | |
820 | open STDOUT, ">&", $nsk | |
821 | or sysfail "failed to dup socket to kid stdin: $!"; | |
822 | inform "running proxy to `$s->{_proxy_server}'"; | |
823 | exec "authinfo-kludge", $s->{"_proxy_server"} | |
824 | or sysfail "failed to exec `authinfo-kludge': $!"; | |
825 | } | |
826 | $KIDMAP{$kid} = [$s, "proxy"]; | |
827 | } | |
828 | } | |
829 | } | |
830 | ||
831 | ###-------------------------------------------------------------------------- | |
832 | ### Main program. | |
833 | ||
834 | sub version (\*) { | |
835 | my ($fh) = @_; | |
836 | print $fh "$PROG, version $VERSION\n"; | |
837 | } | |
838 | ||
839 | sub usage (\*) { | |
840 | my ($fh) = @_; | |
841 | print $fh <<EOF; | |
842 | usage: $PROG [-v] [-d DIR] [-f CONF] [-t TAG] | |
843 | [ [+SERVER] [PARAM=VALUE ...] ...] [+] | |
844 | COMMAND [ARGS ...] | |
845 | EOF | |
846 | } | |
847 | ||
848 | sub help () { | |
849 | version *STDOUT; | |
850 | print "\n"; | |
851 | usage *STDOUT; | |
852 | print <<EOF; | |
853 | ||
854 | Command-line options: | |
855 | -h, --help Show this help text. | |
856 | -d, --rundir=DIR Use DIR to store runtime state. | |
857 | -f, --config=FILE Read configuration from FILE. | |
858 | -t, --tag=TAG Use TAG to identify this session. | |
859 | -v, --verbose Emit running commentary to stderr. | |
860 | ||
861 | Server parameter summary: | |
862 | local=ADDRESS Listen on ADDRESS for client connections. | |
863 | nntpauth=AUTH-METHOD Set authentication method and arguments. | |
864 | remote=ADDRESS Connect to server at ADDRESS. | |
865 | sshbind=ADDRESS Use ADDRESS for local SSH tunnel endpoint. | |
866 | via=SSH-HOST Use SSH to connect to remote server. | |
867 | ||
868 | See the manual page for full details. | |
869 | EOF | |
870 | } | |
871 | ||
872 | sub main () { | |
873 | GetOptions | |
874 | "h|help" => sub { help; exit 0; }, | |
875 | "version" => sub { version *STDOUT; exit 0; }, | |
876 | "d|rundir=s" => \$RUNDIR, | |
877 | "f|config=s" => \$CONF, | |
878 | "t|tag=s" => \$TAG, | |
879 | "v|verbose" => \$VERBOSE | |
880 | or $BAD = 1; | |
881 | chew_cli_server_configs @ARGV; | |
882 | if (@ARGV) { | |
883 | (my $cmd = $ARGV[0]) =~ s:^.*/::; | |
884 | $TAG //= $cmd; | |
885 | } else { | |
886 | $BAD = 1; | |
887 | } | |
888 | if ($BAD) { usage *STDERR; exit 1; } | |
889 | parse_config_file; | |
890 | for my $server (keys %S) { fix_server_config $server; } | |
891 | dump_configuration if $VERBOSE; | |
892 | find_rundir; | |
893 | clean_up_rundir; | |
894 | make_session_dir; | |
895 | for my $server (keys %S) { server_listen $server; } | |
896 | wait_for_ssh; | |
897 | run_client @ARGV; | |
898 | accept_loop; | |
899 | } | |
900 | ||
901 | main; | |
902 | ||
903 | ###----- That's all, folks -------------------------------------------------- |