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