chiark - git - mdw - with-authinfo-kludge/blob - with-authinfo-kludge

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