[with-authinfo-kludge] / with-authinfo-kludge

#! /usr/bin/perl -w
###
### Adverbial modifier conferring AUTHINFO GENERIC support on NNTP clients
###
### (c) 2016 Mark Wooding
###

###----- Licensing notice ---------------------------------------------------
###
### This program is free software; you can redistribute it and/or modify
### it under the terms of the GNU General Public License as published by
### the Free Software Foundation; either version 2 of the License, or
### (at your option) any later version.
###
### This program is distributed in the hope that it will be useful,
### but WITHOUT ANY WARRANTY; without even the implied warranty of
### MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
### GNU General Public License for more details.
###
### You should have received a copy of the GNU General Public License
### along with this program; if not, write to the Free Software Foundation,
### Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

my $VERSION = "0.1.0";

use strict;

###--------------------------------------------------------------------------
### External modules.

## Included batteries.
use Fcntl qw(:mode);
use File::stat;
use Getopt::Long qw(:config gnu_compat bundling
		    require_order no_getopt_compat);
use POSIX qw(:errno_h :fcntl_h :sys_wait_h);
use Socket qw(/^[AP]F_/ /^SOCK_/ /^sockaddr_/
	      getaddrinfo /^AI_/ /^EAI_/
	      getnameinfo /^NI_/);
use Sys::Hostname;

## External batteries.
use File::FcntlLock;

###--------------------------------------------------------------------------
### Configuration variables.

## The global configuration.
my %C = (
  "rundir" => undef
);

## The per-server configuration.
my %S;
my %SPARAM = map { $_ => 1 }
  "local", "nntpauth", "remote", "sshbind", "via";

## Various facts we might discover.
my $HOME = $ENV{"HOME"};
(my $PROG = $0) =~ s:^.*/::;
my $VERBOSE = 0;
my $CONF = undef;
my $TAG = undef;
my $RUNDIR = undef;

## Other bits of useful state.
my @CLEANUP = ();
my $SESSDIR = undef;
my %SERVMAP = ();
my %CLIENT_NOIP = ();
my %KIDMAP = ();
my $CLIENTKID = -1;

###--------------------------------------------------------------------------
### Utilities.

my $BAD = 0;

sub moan ($) {
  my ($msg) = @_;
  print STDERR "$PROG: $msg\n";
}

sub fail ($;$) {
  my ($msg, $rc) = @_;
  moan $msg;
  exit ($rc // 1);
}

sub sysfail ($) {
  my ($msg) = @_;
  fail $msg, 16;
}

sub bad ($) {
  my ($msg) = @_;
  moan $msg;
  $BAD = 1;
}

sub inform ($) {
  my ($msg) = @_;
  print STDERR "$PROG: ;; $msg\n" if $VERBOSE;
}

sub trim ($) {
  my ($s) = @_;
  $s =~ s/^\s+//;
  $s =~ s/\s+$//;
  return $s;
}

sub ensure_home () {
  defined $HOME or fail "no home directory set";
  return $HOME;
}

sub ensure_dir_exists ($$) {
  my ($dir, $mode) = @_;
  mkdir $dir, $mode or $! == EEXIST or
    sysfail "failed to create directory `$dir': $!";
}

sub zap ($);
sub zap ($) {
  my ($f) = @_;
  if (-d $f) {
    my $d;
    unless (opendir $d, $f) {
      moan "failed to open directory `$d': $!";
      return;
    }
    ENTRY: for (;;) {
      defined (my $b = readdir $d) or last ENTRY;
      next ENTRY if grep { $b eq $_ } ".", "..";
      zap "$f/$b";
    }
    closedir $d;
    rmdir $f or $! == ENOENT or moan "failed to zap directory `$f': $!";
  } else {
    unlink $f or $! == ENOENT or moan "failed to zap file thing `$f': $!";
  }
}

sub set_cloexec ($) {
  my ($fh) = @_;
  my $f = fcntl $fh, F_GETFD, 0 or sysfail "failed to get per-fd flags: $!";
  fcntl $fh, F_SETFD, $f | FD_CLOEXEC or
    sysfail "failed to set close-on-exec: $!";
}

sub set_nonblock ($) {
  my ($fh) = @_;
  my $f = fcntl $fh, F_GETFL, 0 or sysfail "failed to get file flags: $!";
  fcntl $fh, F_SETFL, $f | O_NONBLOCK or
    sysfail "failed to set non-blockingness: $!";
}

sub lockedp ($) {
  my ($f) = @_;
  my $l = new File::FcntlLock;
  $l->lock($f, F_GETLK) or sysfail "couldn't read locking for `$f': $!";
  return $l->l_type != F_UNLCK;
}

sub write_to_file ($$) {
  my ($file, $contents) = @_;
  my $new = "$file.new";
  open my $fh, ">", $new or sysfail "couldn't open `$new' for writing: $!";
  print $fh $contents;
  $fh->flush && !$fh->error && close $fh
    or sysfail "failed to write to `$new': $!";
  rename $new, $file or sysfail "failed to rename `$new' to `$file': $!";
}

my %OLDSIGS;
sub set_sighandler ($$) {
  my ($sig, $handler) = @_;
  unless (exists $OLDSIGS{$sig}) { $OLDSIGS{$sig} = $SIG{$sig}; }
  $SIG{$sig} = $handler;
}

my $INKIDP = 0;
sub myfork () {
  my $kid = fork;
  if (defined $kid && !$kid) {
    $INKIDP = 1;
    for my $sig (keys %OLDSIGS) { $SIG{$sig} = $OLDSIGS{$sig}; }
  }
  return $kid;
}

my $SEQ = 0;
sub sequence () { return $SEQ++; }

###--------------------------------------------------------------------------
### Setting up the configuration.

sub set_global_param ($$) {
  my ($param, $value) = @_;
  exists $C{$param} or fail "unknown global parameter `$param'";
  $C{$param} = $value;
}

sub notice_server ($$) {
  my ($server, $where) = @_;
  inform "found server `$server' $where";
  $S{$server} //= {};
}

sub set_server_param ($$$) {
  my ($server, $param, $value) = @_;
  $S{$server} or bad "unknown server `$param'";
  $SPARAM{$param} or bad "unknown server parameter `$param'";
  $S{$server}{$param} = $value;
}

sub chew_cli_server_configs (\@) {
  my ($args) = @_;
  my $server = undef;

  ARG: for (;;) {
    last ARG unless @$args;
    my $arg = shift @$args;
    if ($arg eq "+") { last ARG; }
    elsif ($arg =~ /^\+/) {
      $server = substr $arg, 1;
      notice_server $server, "on command line";
    }
    elsif (!defined $server or $arg !~ /^([^=]+)=(.*)$/)
      { unshift @$args, $arg; last ARG; }
    else { set_server_param $server, $1, $2; }
  }
}

sub parse_config_file () {

  ## If we already know what we're doing then forbid a configuration file as
  ## well.
  if (%S) {
    return unless defined $CONF;
    fail "servers defined on command-line; won't read config file too";
  }

  ## Search about to find a suitable configuration file.
  my $cf;
  my @confpath =
    ($ENV{"XDG_CONFIG_HOME"} // ensure_home . "/.config",
     split /:/, $ENV{"XDG_CONFIG_DIRS"} // "/etc/xdg");
  inform "searching for a configuration file with tag `$TAG'...";
  PATH: for my $dir (@confpath) {
    for my $base ($TAG, "\@default") {
      my $f = "$dir/with-authinfo-kludge/$base.conf";
      if (open $cf, "<", $f) {
	inform "  found `$f'; search over";
	$CONF = $f; last PATH;
      } elsif ($! != ENOENT) {
	bad "couldn't open `$f' for reading: $!";
      } else {
	inform "  `$f' not found; search continues";
      }
    }
  }

  ## If we still don't have a configuration file then synthesize one from the
  ## `$NNTPSERVER' variable.
  unless ($CONF) {
    my $server = $ENV{"NNTPSERVER"};
    defined $server or fail "no `NNTPSERVER' defined in the environment";
    inform "no config file found; synthesizing default";
    notice_server $server, "in environment";
    return;
  }

  ## Work through the configuration file setting up servers.
  my $set_param = \&set_global_param;
  while (<$cf>) {
    next if /^\s*([#;]|$)/;
    if (/^\s*\[(.+)\]\s*$/) {
      my $head = trim $1;
      if ($head eq "\@GLOBAL") { $set_param = \&set_global_param; }
      else {
	notice_server $head, "in config file";
	$set_param = sub { set_server_param $head, $_[0], $_[1]; };
      }
    } elsif (/^([^=]+)=(.*)$/) { $set_param->(trim $1, trim $2); }
    else { bad "$CONF:$.: couldn't parse configuration file line"; }
  }
  (!$cf->error and close $cf)
    or sysfail "error reading configuration file `$CONF': $!";
}

sub format_value ($);
sub format_value ($) {
  my ($value) = @_;
  if (!defined $value) { return "<undef>"; }
  elsif (my $r = ref $value) {
    if ($r eq "ARRAY") {
      return "[" . join(", ", map { format_value $_ } @$value) . "]";
    } elsif ($r eq "HASH") {
      return "{ " .
	join(", ", map { format_value $_  . " => " .
			   format_value $value->{$_} } sort keys %$value) .
	" }";
    } else {
      return "<$r ref>";
    }
  } else { return "`$value'"; }
}

sub inform_param ($$) {
  my ($param, $value) = @_;
  inform "  $param = " . format_value $value;
}

sub dump_configuration () {
  inform "Global parameters...";
  for my $p (sort keys %C) { inform_param $p, $C{$p}; }

  for my $s (sort keys %S) {
    inform "Server `$s' parameters...";
    for my $p (sort keys %{$S{$s}}) { inform_param $p, $S{$s}{$p}; }
  }
}

###--------------------------------------------------------------------------
### Managing the runtime directory.
###
### Truly told, this bit is probably the trickiest part of the program.

## How long we allow for a new server directory to be set up.
my $BIRTHTIME = 300;

sub find_rundir () {

  ## Maybe we've done all of this already.
  defined $RUNDIR and return;

  ## Find a suitable place to put things.
  SEARCH: {
    inform "searching for a suitable runtime directory...";

    ## Maybe the user's configured a directory explicitly.  (Maybe we still
    ## have to arrange for this to exist.)
    if (defined ($RUNDIR = $C{"rundir"})) {
      inform "using runtime directory from configuration";
      last SEARCH;
    }

    ## First attempt: use `$XDG_RUNTIME_DIR'.
    if (defined (my $runhome = $ENV{"XDG_RUNTIME_DIR"})) {
      inform "setting runtime directory from `XDG_RUNTIME_DIR'";
      $RUNDIR = "$runhome/with-authinfo-kludge";
      last SEARCH;
    }

    ## Second attempt: let's use /tmp, or whatever `$TMPDIR' is set.
    my $tmpdir = $ENV{"TMPDIR"} // "/tmp";
    inform "investigating putting runtime directory under tmpdir `$tmpdir'";
    my $dir = "$tmpdir/with-authinfo-kludge-$>";
    my $st = lstat $dir;
    if (!$st && $! == ENOENT) {
      mkdir $dir, 0700 or sysfail "failed to create directory `$dir': $!";
      $st = lstat $dir;
      inform "created `$dir'";
    }
    if (!-d $st) { inform "alas, `$dir' isn't a directory"; }
    elsif ($st->uid != $>) { inform "alas, we don't own `$dir'"; }
    elsif ($st->mode & 0077) { inform "alas, `$dir' has liberal perms"; }
    else {
      inform "accepting `$dir' as runtime directory";
      $RUNDIR = $dir;
      last SEARCH;
    }

    ## Third attempt: we'll use the XDG cache directory.
    my $cachehome = $ENV{"XDG_CACHE_HOME"} // ensure_home . "/.cache";
    ensure_dir_exists $cachehome, 0777;
    my $host = hostname;
    $RUNDIR = "$cachehome/with-authinfo-kludge.$host";
    inform "last ditch: using `$RUNDIR' as runtime directory";
  }

  ## Make the runtime directory if it doesn't exist.  Be paranoid here; users
  ## can override if they really want.  (Note that noip(1) is untweakably
  ## picky about its socket directories, so this is less generous than it
  ## looks.)
  ensure_dir_exists $RUNDIR, 0700;
  for my $d ("junk", "new") { ensure_dir_exists "$RUNDIR/$d", 0777; }
}

sub junk_rundir_thing ($$) {
  my ($f, $what) = @_;
  inform "junking $what `$f'";

  ## Find a name to rename it to under the `junk' directory.  Anyone can put
  ## things in the `junk' directory, and anyone is allowed to delete them;
  ## the only tricky bit is making sure the names don't collide.
  my $junk;
  NAME: for (;;) {
    my $r = int rand 1000000;
    $junk = "$RUNDIR/junk/j.$r";

    ## It'll be OK if this fails because someone else has junked the file (in
    ## which case we end happy), or if the target exists (in which case we
    ## pick another and try again).
    if (rename $f, $junk or ($! == ENOENT && !-e $f)) { last NAME; }
    elsif ($! != EEXIST) { sysfail "couldn't rename `$f' to `$junk': $!"; }
  }

  return $junk;
}

sub clean_up_rundir () {
  inform "cleaning up stale things from runtime directory";

  ## Work through the things in the directory, making sure they're meant to
  ## be there.
  opendir my $dh, $RUNDIR or
    sysfail "failed to open directory `$RUNDIR': $!";
  ENTRY: for (;;) {
    defined (my $base = readdir $dh) or last ENTRY;
    next ENTRY if grep { $base eq $_ } ".", "..";
    my $f = "$RUNDIR/$base";

    ## If this thing isn't a directory then it shouldn't be there.  Maybe a
    ## later version of us put it there.
    unless (-d $f) {
      inform "found unexpected thing `$f' in runtime directory";
      next ENTRY;
    }

    ## Maybe it's a standard thing that's meant to be here.  We'll clean
    ## those up later.
    next ENTRY if grep { $base eq $_ } "junk", "new";

    ## If the name doesn't have a `.' in it, then it's some other special
    ## thing which we don't understand.
    if ($base !~ /^s.*\.\d+/) {
      inform "found unexpected special directory `$f' in runtime directory";
      next ENTRY;
    }

    ## Otherwise, it's a session directory.  If its lockfile isn't locked
    ## then it's fair game.
    my $lk = "$f/lock";
    if (open my $fh, "<", $lk) {
      my $ownedp = lockedp $fh;
      close $fh or sysfail "couldn't close file, what's up with that?: $!";
      if (!$ownedp) { junk_rundir_thing $f, "stale session dir"; }
    } elsif ($! == ENOENT) {
      junk_rundir_thing $f, "session dir without `lock' file";
    } else {
      moan "couldn't open `$lk' (found in runtime dir) for reading: $!";
      inform "leaving `$f' alone";
    }
  }
  closedir $dh;

  ## Work through the things in the `new' directory.
  my $thresh = time - $BIRTHTIME;
  my $newdir = "$RUNDIR/new";
  opendir $dh, $newdir or
    sysfail "failed to open directory `$newdir': $!";
  NEW: for (;;) {
    defined (my $base = readdir $dh) or last NEW;
    next NEW if grep { $base eq $_ } ".", "..";
    my $f = "$newdir/$base";
    unless (-d $f) {
      inform "found unexepected nondirectory thing `$f' in nursery";
      next NEW;
    }
    if ($base !~ /^n\.(\d+)\./) {
      inform "found directory with unexpected name `$f' in nursery";
      next NEW;
    }
    my $stamp = $1;
    $stamp >= $thresh or junk_rundir_thing $f, "stillborn session directory";
  }
  closedir $dh;

  ## Work through the things in the `junk' directory.  Anyone can put things
  ## in the `junk' directory, and anyone is allowed to delete them.
  ## Therefore we can just zap everything in here.  The `zap' function is
  ## (somewhat) careful not to screw up if someone else is also zapping the
  ## same thing.
  my $junkdir = "$RUNDIR/junk";
  opendir $dh, $junkdir or
    sysfail "failed to open directory `$junkdir': $!";
  NEW: for (;;) {
    defined (my $base = readdir $dh) or last NEW;
    next NEW if grep { $base eq $_ } ".", "..";
    my $f = "$junkdir/$base";
    zap $f;
  }
  closedir $dh;
}

sub make_session_dir () {
  inform "making session directory for `$TAG'";

  ## Make a new directory in the nursery.  Only the creator of a nursery
  ## directory is allowed to put things in it.
  my $newdir = "$RUNDIR/new";
  my $n;
  NAME: for (;;) {
    my $now = time;
    my $r = int rand 1000000;
    $n = "$newdir/n.$now.$$.$r";
    if (mkdir $n, 0777) { last NAME; }
    elsif ($! != EEXIST) { sysfail "failed to create `$n': $!"; }
  }

  ## Create the lockfile, and take out a lock.
  open my $fh, ">", "$n/lock";
  set_cloexec $fh;
  my $l = File::FcntlLock->new(l_type => F_WRLCK,
			       l_whence => SEEK_SET,
			       l_start => 0,
			       l_len => 0);
  $l->lock($fh, F_SETLK) or sysfail "failed to lock `$n/lock: $!";

  ## Rename the directory into its proper place.  We have already cleaned out
  ## stale directories, and the target name has our PID in it, so it can't
  ## exist any more unless something unfortunate has happened.
  $SESSDIR = "$RUNDIR/s.$TAG.$$";
  rename $n, $SESSDIR or sysfail "failed to rename `$n' to `$SESSDIR': $!";

  ## Create some necessary things.
  ensure_dir_exists "$SESSDIR/noip-client", 0700;
}

END {
  zap junk_rundir_thing $SESSDIR, "cleanup on exit"
    if !$INKIDP && defined $SESSDIR;
}

###--------------------------------------------------------------------------
### Setting up a session.

sub parse_address ($;$) {
  my ($addr, $defport) = @_;
  inform "parsing address `$addr'...";

  my ($host, $port);
  if ($addr =~ /^\[([^]]*)\]:(\d+)$/ || $addr =~ /^([^:]+):(\d+)$/)
    { $host = $1; $port = $2; }
  elsif (defined $defport) { $host = $addr; $port = $defport; }
  else { fail "invalid address `$addr': missing port number"; }
  inform "  host = `$host'; port = $port";
  return ($host, $port);
}

sub format_address ($$) {
  my ($host, $port) = @_;
  $host =~ /:/ and $host = "[$host]";
  return "$host:$port";
}

sub canonify_address ($;$) {
  my ($addr, $defport) = @_;
  my ($host, $port) = parse_address $addr, $defport;
  return format_address $host, $port;
}

sub resolve_parsed_address ($$) {
  my ($host, $port) = @_;
  inform "resolving host `$host', port $port";

  my ($err, @a) = getaddrinfo $host, $port, { flags => AI_NUMERICSERV };
  $err and fail "failed to resolve `$host': $err";

  my @res;
  my %seen;
  for my $a (@a) {
    ($err, $host, $port) =
      getnameinfo $a->{addr}, NI_NUMERICHOST | NI_NUMERICSERV;
    $err and sysfail "unexpectedly failed to convert addr to text: $err";
    inform "  resolved to $host $port";
    my $r = format_address $host, $port;
    unless ($seen{$r}) { push @res, $r; $seen{$r} = 1; }
  }

  return @res;
}

sub resolve_address ($;$) {
  my ($addr, $defport) = @_;
  my ($host, $port) = parse_address $addr, $defport;
  return resolve_parsed_address $host, $port;
}

sub fix_server_config ($) {
  my ($server) = @_;
  my $s = $S{$server};

  ## Keep the name.  This is useful for diagnostics, but it's also important
  ## for finding the right socket directory if we're doing SSH forwarding.
  $s->{"_name"} = $server;

  ## Sort out the various addresses.
  my ($host, $port);
  ($host, $port) = parse_address($s->{"local"} // $server, 119);
  $s->{"local"} = format_address $host, $port;
  $s->{"_laddrs"} = [resolve_parsed_address $host, $port];
  $s->{"remote"} = canonify_address($s->{"remote"} // $server, 119);
  ($host, $port) = parse_address($s->{"sshbind"} // "127.1.0.1", 1119);
  $s->{"sshbind"} = format_address $host, $port;
  $s->{"_sshaddrs"} = [resolve_parsed_address $host, $port];

  ## Initialize other settings.
  $s->{"_proxy_noip"} = undef;
  $s->{"_proxy_sockdir"} = undef;
  $s->{"_proxy_server"} = defined $s->{"via"} ?
    $s->{"sshbind"} : $s->{"remote"};
  $s->{"_proxy_server"} =~ s/:119$//;
  $s->{"_proxy_server"} =~ s/^\[(.*)\]$/$1/;
  $s->{"_sshkid"} = undef;
  $s->{"_ssh_stdin"} = undef;
  $s->{"_ssh_stdout"} = undef;
}

sub hack_noip_envvar ($$) {
  my ($var, $val) = @_;
  inform "  hack env for noip: $var = `$val'";
  $ENV{$var} = $val;
}

sub hack_noip_env ($$) {
  my ($vars, $dir) = @_;
  return unless $vars;

  hack_noip_envvar "LD_PRELOAD",
    "noip.so" .
    (exists $ENV{"LD_PRELOAD"} ? ":" . $ENV{"LD_PRELOAD"} : "");
  for my $k (keys %ENV) { delete $ENV{$k} if $k =~ /^NOIP_/; }
  hack_noip_envvar "NOIP_CONFIG", "$RUNDIR/noip.conf.notexist";
  hack_noip_envvar "NOIP_SOCKETDIR", $dir;
  hack_noip_envvar "NOIP_DEBUG", $VERBOSE;
  for my $acl ("REALBIND", "REALCONNECT") {
    hack_noip_envvar "NOIP_$acl",
      join ",", @{$vars->{$acl} // []}, "+any";
  }
}

sub server_listen ($) {
  my ($server) = @_;
  my $s = $S{$server};

  ## Set up the listening sockets for this server's addresses.
  inform "set up sockets for `$server'";
  for my $a (@{$s->{"_laddrs"}}) {
    socket my $sk, PF_UNIX, SOCK_STREAM, 0
      or sysfail "failed to make Unix-domain socket: $!";
    set_cloexec $sk; set_nonblock $sk;
    my $sa = "$SESSDIR/noip-client/$a";
    bind $sk, sockaddr_un $sa
      or sysfail "failed to bind Unix-domain socket to `$sa': $!";
    listen $sk, 5 or sysfail "failed to listen on Unix-domain socket: $!";
    $SERVMAP{fileno $sk} = [$s, $a, $sk];
    inform "  listening on $a";
    push @{$CLIENT_NOIP{"REALCONNECT"}}, "-$a";
  }

  ## If we're forwarding via SSH then set that up too.
  if (defined (my $via = $s->{"via"})) {
    inform "set up SSH tunnel to `$server' via $via...";
    my %ssh_noip = ();
    my $sockdir = "$SESSDIR/noip-ssh.$server";
    ensure_dir_exists $sockdir, 0700;
    my $sshbind = $s->{"sshbind"};
    my $remote = $s->{"remote"};
    for my $a (@{$s->{"_sshaddrs"}}) {
      push @{$ssh_noip{"REALBIND"}}, "-$a";
      inform "  listening on $a";
      push @{$s->{"_proxy_noip"}{"REALCONNECT"}}, "-$a";
    }
    $s->{"_proxy_sockdir"} = $sockdir;

    ## The `-L' option sets up the tunnel that we actually wanted.  The `-v'
    ## makes SSH spew stuff to stdout, which might be useful if you're
    ## debugging.  The `-S' detaches OpenSSH from any control master things
    ## which might be going on, because they tend to interfere with
    ## forwarding (and, besides, the existing master won't be under the same
    ## noip configuration).  The `echo' will let us know that it's started
    ## up, and the `read' will keep the tunnel open until we close our end,
    ## which we do implicitly when we exit.
    inform "  starting SSH tunnel";
    my @sshargs = ("ssh", "-L$sshbind:$remote", "-Snone");
    $VERBOSE and push @sshargs, "-v";
    push @sshargs, $via, <<EOF;
## with-authinfo-kludge tunnel: $TAG -> $server
set -e; echo started; read hunoz
EOF
    pipe my $rin, my $win and pipe my $rout, my $wout
      or sysfail "failed to create pipe: $!";
    set_cloexec $win;
    set_cloexec $rout; set_nonblock $rout;
    defined (my $kid = myfork) or sysfail "failed to fork: $!";
    if (!$kid) {
      open STDIN, "<&", $rin or sysfail "failed to dup pipe to stdin: $!";
      open STDOUT, "<&", $wout or sysfail "failed to dup pipe to stdout: $!";
      hack_noip_env \%ssh_noip, $sockdir;
      exec @sshargs or sysfail "failed to exec SSH: $!";
    }
    close $rin;
    close $wout;
    $s->{"_sshkid"} = $kid;
    $s->{"_ssh_stdin"} = $win;
    $s->{"_ssh_stdout"} = $rout;
    $KIDMAP{$kid} = [$s, "SSH tunnel"];
    write_to_file "$SESSDIR/ssh-$server.pid", "$kid\n";
  }
}

sub wait_for_ssh () {
  my $rfd_in = "";

  ## Collect up all the `stdout' pipes.
  my %fd = ();
  SETUP: for my $s (values %S) {
    next SETUP unless $s->{"_sshkid"};
    my $fd = fileno $s->{"_ssh_stdout"};
    vec($rfd_in, $fd, 1) = 1;
    $fd{$fd} = [$s->{"_ssh_stdout"}, $s];
  }
  unless (%fd) {
    inform "no SSH tunnels to start";
    return;
  }

  ## Wait for each of them to become readable, and try to read a thing.
  ## Either we'll get a byte or EOF; either means that the respective tunnel
  ## is as ready as it's ever going to be.
  inform "waiting for SSH tunnels to start...";
  my $nbad = 0;
  SELECT: while (%fd) {
    my ($n, $t) = select my $rfd_out = $rfd_in, undef, undef, undef;
    if ($n >= 0) { }
    elsif ($! == EINTR) { next SELECT; }
    else { sysfail "select failed: $!"; }
    FD: for my $fd (keys %fd) {
      next FD unless vec $rfd_out, $fd, 1;
      my ($sk, $s) = @{$fd{$fd}};
      my $n = sysread $sk, my $hunoz, 128;
      if (defined $n) {
	vec($rfd_in, $fd, 1) = 0;
	if ($n) { inform "  tunnel to $s->{remote} started ok"; }
	else { inform "  tunnel to $s->{remote} FAILED"; $nbad++; }
	delete $fd{$fd};
      } elsif ($! != EAGAIN && $! != EWOULDBLOCK) {
	sysfail "failed to read from pipe: $!";
      }
    }
  }
  if ($nbad) { inform "  tunnels started; $nbad FAILED"; }
  else { inform "  all tunnels started ok"; }
}

set_sighandler "CHLD", sub {
  KID: for (;;) {
    defined (my $kid = waitpid -1, WNOHANG)
      or sysfail "failed to reap child: $!";
    last KID if $kid <= 0;
    my ($how, $rc);
    if ($? == 0) {
      $how = "exited successfully";
      $rc = 0;
    } elsif ($? & 0xff) {
      my $sig = $? & 0x7f;
      $how = "killed by signal $sig";
      $how .= " (core dumped)" if $? & 0x80;
      $rc = $sig | 0x80;
    } else {
      $rc = $? >> 8;
      $how = "exited with status $rc";
    }
    if ($kid == $CLIENTKID) {
      inform "client kid $how; shutting down";
      exit $rc;
    } elsif (exists $KIDMAP{$kid}) {
      my ($s, $what) = @{$KIDMAP{$kid}};
      inform "$what for server `$s->{_name}' collapsed ($how)";
      delete $KIDMAP{$kid};
    } else {
      inform "unrecognized child $kid $how";
    }
  }
};

sub run_client (@) {
  my (@args) = @_;

  inform "starting client";
  defined (my $kid = myfork) or sysfail "failed to fork: $!";
  if (!$kid) {
    hack_noip_env \%CLIENT_NOIP, "$SESSDIR/noip-client";
    my $prog = $args[0];
    exec @args or sysfail "failed to exec `$prog': $!";
  }
  $CLIENTKID = $kid;
  write_to_file "$SESSDIR/client.pid", "$kid\n";
}

sub accept_loop () {
  my $rfd_in = "";
  for my $fd (keys %SERVMAP) { vec($rfd_in, $fd, 1) = 1; }
  SELECT: for (;;) {
    my ($n, $t) = select my $rfd_out = $rfd_in, undef, undef, undef;
    if ($n >= 0) { }
    elsif ($! == EINTR) { next SELECT; }
    else { sysfail "select failed: $!"; }
    FD: for my $fd (keys %SERVMAP) {
      next FD unless vec $rfd_out, $fd, 1;
      my ($s, $a, $sk) = @{$SERVMAP{$fd}};
      my $nsk;
      unless (accept $nsk, $sk) {
	moan "failed to accept new connection: $!"
	  unless $! == EAGAIN || $! == EWOULDBLOCK;
	next FD;
      }
      set_cloexec $nsk;
      inform "incoming connection `$s->{_name}' to $a; starting proxy...";
      defined (my $kid = myfork) or sysfail "failed to fork: $!";
      if (!$kid) {
	$ENV{"NNTPAUTH"} = $s->{"nntpauth"} if exists $s->{"nntpauth"};
	hack_noip_env $s->{"_proxy_noip"}, $s->{"_proxy_sockdir"};
	open STDIN, "<&", $nsk
	  or sysfail "failed to dup socket to kid stdin: $!";
	open STDOUT, ">&", $nsk
	  or sysfail "failed to dup socket to kid stdin: $!";
	inform "running proxy to `$s->{_proxy_server}'";
	exec "authinfo-kludge", $s->{"_proxy_server"}
	  or sysfail "failed to exec `authinfo-kludge': $!";
      }
      $KIDMAP{$kid} = [$s, "proxy"];
    }
  }
}

###--------------------------------------------------------------------------
### Main program.

sub version (\*) {
  my ($fh) = @_;
  print $fh "$PROG, version $VERSION\n";
}

sub usage (\*) {
  my ($fh) = @_;
  print $fh <<EOF;
usage: $PROG [-v] [-d DIR] [-f CONF] [-t TAG]
	[ [+SERVER] [PARAM=VALUE ...] ...] [+]
	COMMAND [ARGS ...]
EOF
}

sub help () {
  version *STDOUT;
  print "\n";
  usage *STDOUT;
  print <<EOF;

Command-line options:
  -h, --help			Show this help text.
  -d, --rundir=DIR		Use DIR to store runtime state.
  -f, --config=FILE		Read configuration from FILE.
  -t, --tag=TAG			Use TAG to identify this session.
  -v, --verbose			Emit running commentary to stderr.

Server parameter summary:
  local=ADDRESS			Listen on ADDRESS for client connections.
  nntpauth=AUTH-METHOD		Set authentication method and arguments.
  remote=ADDRESS		Connect to server at ADDRESS.
  sshbind=ADDRESS		Use ADDRESS for local SSH tunnel endpoint.
  via=SSH-HOST			Use SSH to connect to remote server.

See the manual page for full details.
EOF
}

sub main () {
  GetOptions
    "h|help" => sub { help; exit 0; },
    "version" => sub { version *STDOUT; exit 0; },
    "d|rundir=s" => \$RUNDIR,
    "f|config=s" => \$CONF,
    "t|tag=s" => \$TAG,
    "v|verbose" => \$VERBOSE
      or $BAD = 1;
  chew_cli_server_configs @ARGV;
  if (@ARGV) {
    (my $cmd = $ARGV[0]) =~ s:^.*/::;
    $TAG //= $cmd;
  } else {
    $BAD = 1;
  }
  if ($BAD) { usage *STDERR; exit 1; }
  parse_config_file;
  for my $server (keys %S) { fix_server_config $server; }
  dump_configuration if $VERBOSE;
  find_rundir;
  clean_up_rundir;
  make_session_dir;
  for my $server (keys %S) { server_listen $server; }
  wait_for_ssh;
  run_client @ARGV;
  accept_loop;
}

main;

###----- That's all, folks --------------------------------------------------