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