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