| 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 | ## 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 | |
| 156 | sub lockedp ($) { |
| 157 | my ($f) = @_; |
| 158 | my $l = new File::FcntlLock; |
| 159 | $l->lock($f, F_GETLK) or sysfail "couldn't read locking for `$f': $!"; |
| 160 | return $l->l_type != F_UNLCK; |
| 161 | } |
| 162 | |
| 163 | my $INKIDP = 0; |
| 164 | sub myfork () { |
| 165 | my $kid = fork; |
| 166 | if (defined $kid && !$kid) { $INKIDP = 1; } |
| 167 | return $kid; |
| 168 | } |
| 169 | |
| 170 | my $SEQ = 0; |
| 171 | sub sequence () { return $SEQ++; } |
| 172 | |
| 173 | ###-------------------------------------------------------------------------- |
| 174 | ### Setting up the configuration. |
| 175 | |
| 176 | sub set_global_param ($$) { |
| 177 | my ($param, $value) = @_; |
| 178 | exists $C{$param} or fail "unknown global parameter `$param'"; |
| 179 | $C{$param} = $value; |
| 180 | } |
| 181 | |
| 182 | sub notice_server ($$) { |
| 183 | my ($server, $where) = @_; |
| 184 | inform "found server `$server' $where"; |
| 185 | $S{$server} //= {}; |
| 186 | } |
| 187 | |
| 188 | sub set_server_param ($$$) { |
| 189 | my ($server, $param, $value) = @_; |
| 190 | $S{$server} or bad "unknown server `$param'"; |
| 191 | $SPARAM{$param} or bad "unknown server parameter `$param'"; |
| 192 | $S{$server}{$param} = $value; |
| 193 | } |
| 194 | |
| 195 | sub chew_cli_server_configs (\@) { |
| 196 | my ($args) = @_; |
| 197 | my $server = undef; |
| 198 | |
| 199 | ARG: for (;;) { |
| 200 | last ARG unless @$args; |
| 201 | my $arg = shift @$args; |
| 202 | if ($arg eq "+") { last ARG; } |
| 203 | elsif ($arg =~ /^\+/) { |
| 204 | $server = substr $arg, 1; |
| 205 | notice_server $server, "on command line"; |
| 206 | } |
| 207 | elsif (!defined $server or $arg !~ /^([^=]+)=(.*)$/) |
| 208 | { unshift @$args, $arg; last ARG; } |
| 209 | else { set_server_param $server, $1, $2; } |
| 210 | } |
| 211 | } |
| 212 | |
| 213 | sub parse_config_file () { |
| 214 | |
| 215 | ## If we already know what we're doing then forbid a configuration file as |
| 216 | ## well. |
| 217 | if (%S) { |
| 218 | return unless defined $CONF; |
| 219 | fail "servers defined on command-line; won't read config file too"; |
| 220 | } |
| 221 | |
| 222 | ## Search about to find a suitable configuration file. |
| 223 | my $cf; |
| 224 | my @confpath = |
| 225 | ($ENV{"XDG_CONFIG_HOME"} // ensure_home . "/.config", |
| 226 | split /:/, $ENV{"XDG_CONFIG_DIRS"} // "/etc/xdg"); |
| 227 | inform "searching for a configuration file with tag `$TAG'..."; |
| 228 | PATH: for my $dir (@confpath) { |
| 229 | for my $base ($TAG, "\@default") { |
| 230 | my $f = "$dir/with-authinfo-kludge/$base.conf"; |
| 231 | if (open $cf, "<", $f) { |
| 232 | inform " found `$f'; search over"; |
| 233 | $CONF = $f; last PATH; |
| 234 | } elsif ($! != ENOENT) { |
| 235 | bad "couldn't open `$f' for reading: $!"; |
| 236 | } else { |
| 237 | inform " `$f' not found; search continues"; |
| 238 | } |
| 239 | } |
| 240 | } |
| 241 | |
| 242 | ## If we still don't have a configuration file then synthesize one from the |
| 243 | ## `$NNTPSERVER' variable. |
| 244 | unless ($CONF) { |
| 245 | my $server = $ENV{"NNTPSERVER"}; |
| 246 | defined $server or fail "no `NNTPSERVER' defined in the environment"; |
| 247 | inform "no config file found; synthesizing default"; |
| 248 | notice_server $server, "in environment"; |
| 249 | return; |
| 250 | } |
| 251 | |
| 252 | ## Work through the configuration file setting up servers. |
| 253 | my $set_param = \&set_global_param; |
| 254 | while (<$cf>) { |
| 255 | next if /^\s*([#;]|$)/; |
| 256 | if (/^\s*\[(.+)\]\s*$/) { |
| 257 | my $head = trim $1; |
| 258 | if ($head eq "\@GLOBAL") { $set_param = \&set_global_param; } |
| 259 | else { |
| 260 | notice_server $head, "in config file"; |
| 261 | $set_param = sub { set_server_param $head, $_[0], $_[1]; }; |
| 262 | } |
| 263 | } elsif (/^([^=]+)=(.*)$/) { $set_param->(trim $1, trim $2); } |
| 264 | else { bad "$CONF:$.: couldn't parse configuration file line"; } |
| 265 | } |
| 266 | (!$cf->error and close $cf) |
| 267 | or sysfail "error reading configuration file `$CONF': $!"; |
| 268 | } |
| 269 | |
| 270 | sub format_value ($); |
| 271 | sub format_value ($) { |
| 272 | my ($value) = @_; |
| 273 | if (!defined $value) { return "<undef>"; } |
| 274 | elsif (my $r = ref $value) { |
| 275 | if ($r eq "ARRAY") { |
| 276 | return "[" . join(", ", map { format_value $_ } @$value) . "]"; |
| 277 | } elsif ($r eq "HASH") { |
| 278 | return "{ " . |
| 279 | join(", ", map { format_value $_ . " => " . |
| 280 | format_value $value->{$_} } sort keys %$value) . |
| 281 | " }"; |
| 282 | } else { |
| 283 | return "<$r ref>"; |
| 284 | } |
| 285 | } else { return "`$value'"; } |
| 286 | } |
| 287 | |
| 288 | sub inform_param ($$) { |
| 289 | my ($param, $value) = @_; |
| 290 | inform " $param = " . format_value $value; |
| 291 | } |
| 292 | |
| 293 | sub dump_configuration () { |
| 294 | inform "Global parameters..."; |
| 295 | for my $p (sort keys %C) { inform_param $p, $C{$p}; } |
| 296 | |
| 297 | for my $s (sort keys %S) { |
| 298 | inform "Server `$s' parameters..."; |
| 299 | for my $p (sort keys %{$S{$s}}) { inform_param $p, $S{$s}{$p}; } |
| 300 | } |
| 301 | } |
| 302 | |
| 303 | ###-------------------------------------------------------------------------- |
| 304 | ### Managing the runtime directory. |
| 305 | ### |
| 306 | ### Truly told, this bit is probably the trickiest part of the program. |
| 307 | |
| 308 | ## How long we allow for a new server directory to be set up. |
| 309 | my $BIRTHTIME = 300; |
| 310 | |
| 311 | sub find_rundir () { |
| 312 | |
| 313 | ## Maybe we've done all of this already. |
| 314 | defined $RUNDIR and return; |
| 315 | |
| 316 | ## Find a suitable place to put things. |
| 317 | SEARCH: { |
| 318 | inform "searching for a suitable runtime directory..."; |
| 319 | |
| 320 | ## Maybe the user's configured a directory explicitly. (Maybe we still |
| 321 | ## have to arrange for this to exist.) |
| 322 | if (defined ($RUNDIR = $C{"rundir"})) { |
| 323 | inform "using runtime directory from configuration"; |
| 324 | last SEARCH; |
| 325 | } |
| 326 | |
| 327 | ## First attempt: use `$XDG_RUNTIME_DIR'. |
| 328 | if (defined (my $runhome = $ENV{"XDG_RUNTIME_DIR"})) { |
| 329 | inform "setting runtime directory from `XDG_RUNTIME_DIR'"; |
| 330 | $RUNDIR = "$runhome/with-authinfo-kludge"; |
| 331 | last SEARCH; |
| 332 | } |
| 333 | |
| 334 | ## Second attempt: let's use /tmp, or whatever `$TMPDIR' is set. |
| 335 | my $tmpdir = $ENV{"TMPDIR"} // "/tmp"; |
| 336 | inform "investigating putting runtime directory under tmpdir `$tmpdir'"; |
| 337 | my $dir = "$tmpdir/with-authinfo-kludge-$>"; |
| 338 | my $st = lstat $dir; |
| 339 | if (!$st && $! == ENOENT) { |
| 340 | mkdir $dir, 0700 or sysfail "failed to create directory `$dir': $!"; |
| 341 | $st = lstat $dir; |
| 342 | inform "created `$dir'"; |
| 343 | } |
| 344 | if (!-d $st) { inform "alas, `$dir' isn't a directory"; } |
| 345 | elsif ($st->uid != $>) { inform "alas, we don't own `$dir'"; } |
| 346 | elsif ($st->mode & 0077) { inform "alas, `$dir' has liberal perms"; } |
| 347 | else { |
| 348 | inform "accepting `$dir' as runtime directory"; |
| 349 | $RUNDIR = $dir; |
| 350 | last SEARCH; |
| 351 | } |
| 352 | |
| 353 | ## Third attempt: we'll use the XDG cache directory. |
| 354 | my $cachehome = $ENV{"XDG_CACHE_HOME"} // ensure_home . "/.cache"; |
| 355 | ensure_dir_exists $cachehome, 0777; |
| 356 | my $host = hostname; |
| 357 | $RUNDIR = "$cachehome/with-authinfo-kludge.$host"; |
| 358 | inform "last ditch: using `$RUNDIR' as runtime directory"; |
| 359 | } |
| 360 | |
| 361 | ## Make the runtime directory if it doesn't exist. Be paranoid here; users |
| 362 | ## can override if they really want. (Note that noip(1) is untweakably |
| 363 | ## picky about its socket directories, so this is less generous than it |
| 364 | ## looks.) |
| 365 | ensure_dir_exists $RUNDIR, 0700; |
| 366 | for my $d ("junk", "new") { ensure_dir_exists "$RUNDIR/$d", 0777; } |
| 367 | } |
| 368 | |
| 369 | sub junk_rundir_thing ($$) { |
| 370 | my ($f, $what) = @_; |
| 371 | inform "junking $what `$f'"; |
| 372 | |
| 373 | ## Find a name to rename it to under the `junk' directory. Anyone can put |
| 374 | ## things in the `junk' directory, and anyone is allowed to delete them; |
| 375 | ## the only tricky bit is making sure the names don't collide. |
| 376 | my $junk; |
| 377 | NAME: for (;;) { |
| 378 | my $r = int rand 1000000; |
| 379 | $junk = "$RUNDIR/junk/j.$r"; |
| 380 | |
| 381 | ## It'll be OK if this fails because someone else has junked the file (in |
| 382 | ## which case we end happy), or if the target exists (in which case we |
| 383 | ## pick another and try again). |
| 384 | if (rename $f, $junk or ($! == ENOENT && !-e $f)) { last NAME; } |
| 385 | elsif ($! != EEXIST) { sysfail "couldn't rename `$f' to `$junk': $!"; } |
| 386 | } |
| 387 | |
| 388 | return $junk; |
| 389 | } |
| 390 | |
| 391 | sub clean_up_rundir () { |
| 392 | inform "cleaning up stale things from runtime directory"; |
| 393 | |
| 394 | ## Work through the things in the directory, making sure they're meant to |
| 395 | ## be there. |
| 396 | opendir my $dh, $RUNDIR or |
| 397 | sysfail "failed to open directory `$RUNDIR': $!"; |
| 398 | ENTRY: for (;;) { |
| 399 | defined (my $base = readdir $dh) or last ENTRY; |
| 400 | next ENTRY if grep { $base eq $_ } ".", ".."; |
| 401 | my $f = "$RUNDIR/$base"; |
| 402 | |
| 403 | ## If this thing isn't a directory then it shouldn't be there. Maybe a |
| 404 | ## later version of us put it there. |
| 405 | unless (-d $f) { |
| 406 | inform "found unexpected thing `$f' in runtime directory"; |
| 407 | next ENTRY; |
| 408 | } |
| 409 | |
| 410 | ## Maybe it's a standard thing that's meant to be here. We'll clean |
| 411 | ## those up later. |
| 412 | next ENTRY if grep { $base eq $_ } "junk", "new"; |
| 413 | |
| 414 | ## If the name doesn't have a `.' in it, then it's some other special |
| 415 | ## thing which we don't understand. |
| 416 | if ($base !~ /^s.*\.\d+/) { |
| 417 | inform "found unexpected special directory `$f' in runtime directory"; |
| 418 | next ENTRY; |
| 419 | } |
| 420 | |
| 421 | ## Otherwise, it's a session directory. If its lockfile isn't locked |
| 422 | ## then it's fair game. |
| 423 | my $lk = "$f/lock"; |
| 424 | if (open my $fh, "<", $lk) { |
| 425 | my $ownedp = lockedp $fh; |
| 426 | close $fh or sysfail "couldn't close file, what's up with that?: $!"; |
| 427 | if (!$ownedp) { junk_rundir_thing $f, "stale session dir"; } |
| 428 | } elsif ($! == ENOENT) { |
| 429 | junk_rundir_thing $f, "session dir without `lock' file"; |
| 430 | } else { |
| 431 | moan "couldn't open `$lk' (found in runtime dir) for reading: $!"; |
| 432 | inform "leaving `$f' alone"; |
| 433 | } |
| 434 | } |
| 435 | closedir $dh; |
| 436 | |
| 437 | ## Work through the things in the `new' directory. |
| 438 | my $thresh = time - $BIRTHTIME; |
| 439 | my $newdir = "$RUNDIR/new"; |
| 440 | opendir $dh, $newdir or |
| 441 | sysfail "failed to open directory `$newdir': $!"; |
| 442 | NEW: for (;;) { |
| 443 | defined (my $base = readdir $dh) or last NEW; |
| 444 | next NEW if grep { $base eq $_ } ".", ".."; |
| 445 | my $f = "$newdir/$base"; |
| 446 | unless (-d $f) { |
| 447 | inform "found unexepected nondirectory thing `$f' in nursery"; |
| 448 | next NEW; |
| 449 | } |
| 450 | if ($base !~ /^n\.(\d+)\./) { |
| 451 | inform "found directory with unexpected name `$f' in nursery"; |
| 452 | next NEW; |
| 453 | } |
| 454 | my $stamp = $1; |
| 455 | $stamp >= $thresh or junk_rundir_thing $f, "stillborn session directory"; |
| 456 | } |
| 457 | closedir $dh; |
| 458 | |
| 459 | ## Work through the things in the `junk' directory. Anyone can put things |
| 460 | ## in the `junk' directory, and anyone is allowed to delete them. |
| 461 | ## Therefore we can just zap everything in here. The `zap' function is |
| 462 | ## (somewhat) careful not to screw up if someone else is also zapping the |
| 463 | ## same thing. |
| 464 | my $junkdir = "$RUNDIR/junk"; |
| 465 | opendir $dh, $junkdir or |
| 466 | sysfail "failed to open directory `$junkdir': $!"; |
| 467 | NEW: for (;;) { |
| 468 | defined (my $base = readdir $dh) or last NEW; |
| 469 | next NEW if grep { $base eq $_ } ".", ".."; |
| 470 | my $f = "$junkdir/$base"; |
| 471 | zap $f; |
| 472 | } |
| 473 | closedir $dh; |
| 474 | } |
| 475 | |
| 476 | sub make_session_dir () { |
| 477 | inform "making session directory for `$TAG'"; |
| 478 | |
| 479 | ## Make a new directory in the nursery. Only the creator of a nursery |
| 480 | ## directory is allowed to put things in it. |
| 481 | my $newdir = "$RUNDIR/new"; |
| 482 | my $n; |
| 483 | NAME: for (;;) { |
| 484 | my $now = time; |
| 485 | my $r = int rand 1000000; |
| 486 | $n = "$newdir/n.$now.$$.$r"; |
| 487 | if (mkdir $n, 0777) { last NAME; } |
| 488 | elsif ($! != EEXIST) { sysfail "failed to create `$n': $!"; } |
| 489 | } |
| 490 | |
| 491 | ## Create the lockfile, and take out a lock. |
| 492 | open my $fh, ">", "$n/lock"; |
| 493 | set_cloexec $fh; |
| 494 | my $l = File::FcntlLock->new(l_type => F_WRLCK, |
| 495 | l_whence => SEEK_SET, |
| 496 | l_start => 0, |
| 497 | l_len => 0); |
| 498 | $l->lock($fh, F_SETLK) or sysfail "failed to lock `$n/lock: $!"; |
| 499 | |
| 500 | ## Rename the directory into its proper place. We have already cleaned out |
| 501 | ## stale directories, and the target name has our PID in it, so it can't |
| 502 | ## exist any more unless something unfortunate has happened. |
| 503 | $SESSDIR = "$RUNDIR/s.$TAG.$$"; |
| 504 | rename $n, $SESSDIR or sysfail "failed to rename `$n' to `$SESSDIR': $!"; |
| 505 | |
| 506 | ## Create some necessary things. |
| 507 | ensure_dir_exists "$SESSDIR/noip-client", 0700; |
| 508 | } |
| 509 | |
| 510 | END { |
| 511 | zap junk_rundir_thing $SESSDIR, "cleanup on exit" |
| 512 | if !$INKIDP && defined $SESSDIR; |
| 513 | } |
| 514 | |
| 515 | ###-------------------------------------------------------------------------- |
| 516 | ### Setting up a session. |
| 517 | |
| 518 | sub parse_address ($;$) { |
| 519 | my ($addr, $defport) = @_; |
| 520 | inform "parsing address `$addr'..."; |
| 521 | |
| 522 | my ($host, $port); |
| 523 | if ($addr =~ /^\[([^]]*)\]:(\d+)$/ || $addr =~ /^([^:]+):(\d+)$/) |
| 524 | { $host = $1; $port = $2; } |
| 525 | elsif (defined $defport) { $host = $addr; $port = $defport; } |
| 526 | else { fail "invalid address `$addr': missing port number"; } |
| 527 | inform " host = `$host'; port = $port"; |
| 528 | return ($host, $port); |
| 529 | } |
| 530 | |
| 531 | sub format_address ($$) { |
| 532 | my ($host, $port) = @_; |
| 533 | $host =~ /:/ and $host = "[$host]"; |
| 534 | return "$host:$port"; |
| 535 | } |
| 536 | |
| 537 | sub canonify_address ($;$) { |
| 538 | my ($addr, $defport) = @_; |
| 539 | my ($host, $port) = parse_address $addr, $defport; |
| 540 | return format_address $host, $port; |
| 541 | } |
| 542 | |
| 543 | sub resolve_parsed_address ($$) { |
| 544 | my ($host, $port) = @_; |
| 545 | inform "resolving host `$host', port $port"; |
| 546 | |
| 547 | my ($err, @a) = getaddrinfo $host, $port, { flags => AI_NUMERICSERV }; |
| 548 | $err and fail "failed to resolve `$host': $err"; |
| 549 | |
| 550 | my @res; |
| 551 | my %seen; |
| 552 | for my $a (@a) { |
| 553 | ($err, $host, $port) = |
| 554 | getnameinfo $a->{addr}, NI_NUMERICHOST | NI_NUMERICSERV; |
| 555 | $err and sysfail "unexpectedly failed to convert addr to text: $err"; |
| 556 | inform " resolved to $host $port"; |
| 557 | my $r = format_address $host, $port; |
| 558 | unless ($seen{$r}) { push @res, $r; $seen{$r} = 1; } |
| 559 | } |
| 560 | |
| 561 | return @res; |
| 562 | } |
| 563 | |
| 564 | sub resolve_address ($;$) { |
| 565 | my ($addr, $defport) = @_; |
| 566 | my ($host, $port) = parse_address $addr, $defport; |
| 567 | return resolve_parsed_address $host, $port; |
| 568 | } |
| 569 | |
| 570 | sub fix_server_config ($) { |
| 571 | my ($server) = @_; |
| 572 | my $s = $S{$server}; |
| 573 | |
| 574 | ## Keep the name. This is useful for diagnostics, but it's also important |
| 575 | ## for finding the right socket directory if we're doing SSH forwarding. |
| 576 | $s->{"_name"} = $server; |
| 577 | |
| 578 | ## Sort out the various addresses. |
| 579 | my ($host, $port); |
| 580 | ($host, $port) = parse_address($s->{"local"} // $server, 119); |
| 581 | $s->{"local"} = format_address $host, $port; |
| 582 | $s->{"_laddrs"} = [resolve_parsed_address $host, $port]; |
| 583 | $s->{"remote"} = canonify_address($s->{"remote"} // $server, 119); |
| 584 | ($host, $port) = parse_address($s->{"sshbind"} // "127.1.0.1", 1119); |
| 585 | $s->{"sshbind"} = format_address $host, $port; |
| 586 | $s->{"_sshaddrs"} = [resolve_parsed_address $host, $port]; |
| 587 | |
| 588 | ## Initialize other settings. |
| 589 | $s->{"_proxy_noip"} = undef; |
| 590 | $s->{"_proxy_sockdir"} = undef; |
| 591 | $s->{"_proxy_server"} = defined $s->{"via"} ? |
| 592 | $s->{"sshbind"} : $s->{"remote"}; |
| 593 | $s->{"_proxy_server"} =~ s/:119$//; |
| 594 | $s->{"_proxy_server"} =~ s/^\[(.*)\]$/$1/; |
| 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 | SELECT: for (;;) { |
| 770 | my ($n, $t) = select my $rfd_out = $rfd_in, undef, undef, undef; |
| 771 | if ($n >= 0) { } |
| 772 | elsif ($! == EINTR) { next SELECT; } |
| 773 | else { sysfail "select failed: $!"; } |
| 774 | FD: for my $fd (keys %SERVMAP) { |
| 775 | next FD unless vec $rfd_out, $fd, 1; |
| 776 | my ($s, $a, $sk) = @{$SERVMAP{$fd}}; |
| 777 | my $nsk; |
| 778 | unless (accept $nsk, $sk) { |
| 779 | moan "failed to accept new connection: $!"; |
| 780 | next FD; |
| 781 | } |
| 782 | set_cloexec $nsk; |
| 783 | inform "incoming connection `$s->{_name}' to $a; starting proxy..."; |
| 784 | defined (my $kid = myfork) or sysfail "failed to fork: $!"; |
| 785 | if (!$kid) { |
| 786 | $ENV{"NNTPAUTH"} = $s->{"nntpauth"} if exists $s->{"nntpauth"}; |
| 787 | hack_noip_env $s->{"_proxy_noip"}, $s->{"_proxy_sockdir"}; |
| 788 | open STDIN, "<&", $nsk |
| 789 | or sysfail "failed to dup socket to kid stdin: $!"; |
| 790 | open STDOUT, ">&", $nsk |
| 791 | or sysfail "failed to dup socket to kid stdin: $!"; |
| 792 | inform "running proxy to `$s->{_proxy_server}'"; |
| 793 | exec "authinfo-kludge", $s->{"_proxy_server"} |
| 794 | or sysfail "failed to exec `authinfo-kludge': $!"; |
| 795 | } |
| 796 | $KIDMAP{$kid} = [$s, "proxy"]; |
| 797 | } |
| 798 | } |
| 799 | } |
| 800 | |
| 801 | ###-------------------------------------------------------------------------- |
| 802 | ### Main program. |
| 803 | |
| 804 | sub version (\*) { |
| 805 | my ($fh) = @_; |
| 806 | print $fh "$PROG, version $VERSION\n"; |
| 807 | } |
| 808 | |
| 809 | sub usage (\*) { |
| 810 | my ($fh) = @_; |
| 811 | print $fh <<EOF; |
| 812 | usage: $PROG [-v] [-d DIR] [-f CONF] [-t TAG] |
| 813 | [ [+SERVER] [PARAM=VALUE ...] ...] [+] |
| 814 | COMMAND [ARGS ...] |
| 815 | EOF |
| 816 | } |
| 817 | |
| 818 | sub help () { |
| 819 | version *STDOUT; |
| 820 | print "\n"; |
| 821 | usage *STDOUT; |
| 822 | print <<EOF; |
| 823 | |
| 824 | Command-line options: |
| 825 | -h, --help Show this help text. |
| 826 | -d, --rundir=DIR Use DIR to store runtime state. |
| 827 | -f, --config=FILE Read configuration from FILE. |
| 828 | -t, --tag=TAG Use TAG to identify this session. |
| 829 | -v, --verbose Emit running commentary to stderr. |
| 830 | |
| 831 | Server parameter summary: |
| 832 | local=ADDRESS Listen on ADDRESS for client connections. |
| 833 | nntpauth=AUTH-METHOD Set authentication method and arguments. |
| 834 | remote=ADDRESS Connect to server at ADDRESS. |
| 835 | sshbind=ADDRESS Use ADDRESS for local SSH tunnel endpoint. |
| 836 | via=SSH-HOST Use SSH to connect to remote server. |
| 837 | |
| 838 | See the manual page for full details. |
| 839 | EOF |
| 840 | } |
| 841 | |
| 842 | sub main () { |
| 843 | GetOptions |
| 844 | "h|help" => sub { help; exit 0; }, |
| 845 | "version" => sub { version *STDOUT; exit 0; }, |
| 846 | "d|rundir=s" => \$RUNDIR, |
| 847 | "f|config=s" => \$CONF, |
| 848 | "t|tag=s" => \$TAG, |
| 849 | "v|verbose" => \$VERBOSE |
| 850 | or $BAD = 1; |
| 851 | chew_cli_server_configs @ARGV; |
| 852 | if (@ARGV) { |
| 853 | (my $cmd = $ARGV[0]) =~ s:^.*/::; |
| 854 | $TAG //= $cmd; |
| 855 | } else { |
| 856 | $BAD = 1; |
| 857 | } |
| 858 | if ($BAD) { usage *STDERR; exit 1; } |
| 859 | parse_config_file; |
| 860 | for my $server (keys %S) { fix_server_config $server; } |
| 861 | dump_configuration if $VERBOSE; |
| 862 | find_rundir; |
| 863 | clean_up_rundir; |
| 864 | make_session_dir; |
| 865 | for my $server (keys %S) { server_listen $server; } |
| 866 | wait_for_ssh; |
| 867 | run_client @ARGV; |
| 868 | accept_loop; |
| 869 | } |
| 870 | |
| 871 | main; |
| 872 | |
| 873 | ###----- That's all, folks -------------------------------------------------- |