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