
package Proc::Prefork;
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT = qw(initialisation_complete);

use strict;

use Carp;
use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
use IO::FDPass;
use POSIX qw(_exit setsid :sys_wait_h :errno_h);
use Sys::Syslog qw(openlog syslog LOG_INFO LOG_ERR LOG_WARNING);

our $logger;

our $env_name = 'PREFORK_INTERP';

our @call_fds;
our $socket_path;
our $fail_log = 0;

sub fail_log ($) {
  my ($m) = @_;
  if ($fail_log) {
    syslog(LOG_ERR, "$0: prefork [$$]: error: $m");
  } else {
    croak "$0: prefork: initialisation error: $m";
  }
  _exit 127;
}

sub server_quit ($) {
  my ($m) = @_;
  syslog(LOG_INFO, "$0 prefork [$$]: $m, quitting");
  _exit(0);
}

# Returns in the executor process
sub become_monitor () {
  close LISTEN;

  # Make a process group for this call
  setpgrp or fail_log("setpgrp failed: $!");

  eval { protocol_exchange(); 1; }
    or fail_log("protocol exchange failed: $@");

  pipe EXECTERM, EXECTERMW or fail_log("pipe: $!");

  my $child = fork // fail_log("fork executor: $!");
  if (!$child) {
    #---- executor ----
    open ::STDIN , "<& $call_fds[0]" or fail_log("dup for fd0");
    open ::STDOUT, ">& $call_fds[1]" or fail_log("dup for fd1");
    open ::STDERR, ">& $call_fds[2]" or fail_log("dup for fd2");
    close EXECTERM;
    close_call_fds();
    $! = 0;
    return;
  }
  close EXECTERMW;

  #---- monitor [2] ----

  my $rbits = '';
  vec($rbits, fileno(CALL), 1) = 1;
  vec($rbits, fileno(EXECTERM), 1) = 1;
  my $ebits = $rbits;
  my $nfound = select($rbits, '', $ebits, undef);

  # Either the child has just died, or the caller has gone away

  $SIG{INT} = 'IGN';
  kill 'INT', 0 or fail_log("kill executor [$child]: $!");

  my $got = waitpid $child, 0;
  $got >= 0 // fail_log("wait for executor [$child] (2): $!");
  $got == $child or fail_log("wait for esecutor [$child] gave [$got]");

  protocol_write(pack "N", $?);
  _exit(0);
}

sub close_call_fds () {
  foreach (@call_fds) {
    POSIX::close($_);
  }
  close CALL;
}

sub protocol_write ($) {
  my ($d) = @_;
  return if (print CALL $d and flush CALL);
  _exit(0) if $!==EPIPE || $!==ECONNRESET;
  fail_log("protocol write: $!");
}

sub eintr_retry ($) {
  my ($f) = @_;
  for (;;) {
    my $r = $f->();
    return $r if defined $r;
    next if $!==EINTR;
    return $r;
  }
}

sub protocol_read_fail ($) {
  my ($what) = @_;
  _exit(0) if $!==ECONNRESET;
  die("recv $what: $!");
}

sub protocol_exchange () {
  my $greeting = "PFI\n\0\0\0\0";
  protocol_write($greeting);

  @call_fds = map {
    my $r;
    for (;;) {
      $! = 0;
      $r = IO::FDPass::recv(fileno(CALL));
      last if $r >= 0;
      _exit(0) if $!==0;
      protocol_read_fail("fd $_");
    }
    $r;
  } 0..2;

  my $len;
  my $r = read(CALL, $len, 4) // protocol_read_fail("message length");
  $r == 4 or _exit(0);

  $len = unpack "N", $len;
  my $data;
  $r = read(CALL, $data, $len) // protocol_read_fail("message data ($len)");
  $r == $len or _exit(0);

  @ARGV = split /\0/, $data, -1;
  @ARGV >= 2 or die("message data has too few strings (".(scalar @ARGV).")");
  length(pop(@ARGV)) and die("message data missing trailing nul");
  %ENV = ();
  while (my $s = shift @ARGV) {
    last if !length $s;
    $s =~ m/=/ or die("message data env var missing equals");
    $ENV{$`} = $';
  }
}

sub initialisation_complete {
  my %opts = @_;

  # if env var not set, we're not running under prefork-interp
  my @env_data = split / /, ($ENV{$env_name} // return);
  croak "$env_name has too few words" unless @env_data >= 2;
  my (@vsns) = split /,/, $env_data[0];
  croak "$env_name doesn't offer protocol v1" unless grep { $_ eq 'v1' } @vsns;
  my @env_fds = split /,/, $env_data[1];
  croak "$env_name has too few fds" unless @env_fds >= 4;;
  $#env_fds = 1;

  my $num_servers = $opts{max_servers} // 4;

  #---- setup (pm) [1] ----

  foreach (@env_fds) {
    $_ eq ($_+0) or croak "$env_name contains $_, not a number";
  }
  open LISTEN, "+>&=$env_fds[0]" or croak "listen fd: $!";
  open CALL,   "+>&=$env_fds[1]" or croak "call fd: $!";
  open WATCHE, ">+&=$env_fds[3]" or croak "watch stderr fd: $!";

  if (!$opts{no_openlog}) {
    openlog("prefork-interp $0", 'ndelay,nofatal,pid',
	    $opts{log_facility} // 'log_user');
  }

  open NULL, "+>/dev/null" or croak "open /dev/null: $!";

  #---- fork for server ----

  my $child = fork // croak "first fork failed: $!";
  if ($child) {
    #---- setup (pm) [2], exits ----
    _exit(0);
  }
  setsid() > 0 or fail_log("setsid: $!");
  # The server will be a session leader, but it won't open ttys,
  # so that is ok.

  #---- server(pm) [1] ----

  $child = fork // croak "second fork failed: $!";
  if (!$child) {
    # we are the child, i.e. the one fa-monitor
    local $0 = "$0 [monitor(init)]";
    return become_monitor();
  }

  our %children;
  $children{$child} = 1;
  
  # --- server(pm) [2] ----

  $fail_log = 1;
  open STDIN, "<&NULL" or fail_log("dup null onto stdin: $!");
  open STDOUT, ">&NULL" or fail_log("dup null onto stdout: $!");
  open STDERR, ">&NULL" or fail_log("dup null onto stderr: $!");
  close NULL;

  close_call_fds();

  my $flags = fcntl(LISTEN, F_GETFL, 0)
    or fail_log("F_GETFL listen socket: $!");
  $flags |= O_NONBLOCK;
  fcntl(LISTEN, F_SETFL, $flags)
    or fail_log("F_SETFL listen socket: $!");

  my $errcount = 0;

  local $0 = "$0 [server]";

  for (;;) {
    # reap children
    if (%children) {
      my $full = %children >= $num_servers;
      my $got = waitpid -1, ($full ? 0 : WNOHANG);
      $got >= 0 or fail_log("failed to wait for monitor(s)");
      last if $got == 0;
      if ($?) {
	syslog(LOG_WARNING,
 "$0 prefork [$$]: monitor process [$got] failed with wait status $?");
      }
      if (!exists $children{$got}) {
	syslog(LOG_WARNING,
 "$0 prefork [$$]: monitor process [$got] wasn't one of ours?!");
      }
      delete $children{$got};
      next;
    }

    # select for accepting or housekeeping timeout
    my $rbits = '';
    vec($rbits, fileno(LISTEN), 1) = 1;
    vec($rbits, fileno(WATCHE), 1) = 1;
    my $ebits = $rbits;
    my $nfound = select($rbits, '', $ebits, ($opts{idle_timeout} // 1000000));

    # Idle timeout?
    if (!$nfound) { _exit(0); }

    # Has the watcher told us to shut down, or died with a message ?
    my $msgbuf = '';
    my $r = sysread WATCHE, $msgbuf, 2048;
    if ($r > 0) {
      chomp $msgbuf;
      fail_log("watcher: $msgbuf");
    } elsif ($r == 0) {
      _exit(0);
    } elsif ($! == EINTR || $! == EAGAIN || $! == EWOULDBLOCK) {
    } else {
      fail_log("watcher stderr read: $!");
    }

    # TODO stat checking, quit here if we are stale

    # Anything to accept ?
    if (accept(CALL, LISTEN)) {
      $child = fork // fail_log("fork for accepted call failed: $!");
      if (!$child) {
	#---- monitor [1] ----
	local $0 = "$0 [monitor]";
	become_monitor();
      }
      close(CALL);
      $errcount = 0;
      $children{$child} = 1;
    } elsif ($! == EINTR || $! == EAGAIN || $! == EWOULDBLOCK) {
    } else {
      syslog(LOG_WARNING, "$0 prefork [$$]: accept failed: $!");
      if ($errcount > ($opts{max_errors} // 100)) {
	syslog(LOG_ERR,
	       "$0 prefork [$$]: too many accept failures, quitting");
	_exit(16);
      }
    }
  }
}

1;

__END__
