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