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