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