#! /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~unfinished"; 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 $INKIDP = 0; sub myfork () { my $kid = fork; if (defined $kid && !$kid) { $INKIDP = 1; } 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 ""; } 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, < $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"; } } $SIG{"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 < 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 --------------------------------------------------