pm/Proc/Prefork/Interp.pm

   1
   2 package Proc::Prefork::Interp;
   3 require Exporter;
   4 our @ISA = qw(Exporter);
   5 our @EXPORT = qw(initialisation_complete);
   6
   7 use strict;
   8
   9 use Carp;
  10 use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
  11 use IO::FDPass;
  12 use POSIX qw(_exit setsid :sys_wait_h :errno_h :signal_h);
  13 use Sys::Syslog qw(openlog syslog LOG_INFO LOG_ERR LOG_WARNING);
  14
  15 our $logger;
  16
  17 our $env_name = 'PREFORK_INTERP';
  18
  19 our @call_fds;
  20 our $socket_path;
  21 our $fail_log = 0;
  22
  23 sub fail_log ($) {
  24   my ($m) = @_;
  25   if ($fail_log) {
  26     syslog(LOG_ERR, "$0: prefork [$$]: error: $m");
  27   } else {
  28     carp "$0: prefork: initialisation error: $m";
  29   }
  30   _exit 127;
  31 }
  32
  33 sub server_quit ($) {
  34   my ($m) = @_;
  35   syslog(LOG_INFO, "$0 prefork [$$]: $m, quitting");
  36   _exit(0);
  37 }
  38
  39 # Returns in the executor process
  40 sub become_monitor () {
  41   close LISTEN;
  42   close WATCHI;
  43   close WATCHE;
  44
  45   # Make a process group for this call
  46   setpgrp or fail_log("setpgrp failed: $!");
  47
  48   eval { protocol_exchange(); 1; }
  49     or fail_log("protocol exchange failed: $@");
  50
  51   pipe EXECTERM, EXECTERMW or fail_log("pipe: $!");
  52
  53   my $child = fork // fail_log("fork executor: $!");
  54   if (!$child) {
  55     #---- executor ----
  56     open ::STDIN , "<& $call_fds[0]" or fail_log("dup for fd0");
  57     open ::STDOUT, ">& $call_fds[1]" or fail_log("dup for fd1");
  58     open ::STDERR, ">& $call_fds[2]" or fail_log("dup for fd2");
  59     close EXECTERM;
  60     close_call_fds();
  61     $! = 0;
  62     return;
  63   }
  64   close EXECTERMW;
  65
  66   #---- monitor [2] ----
  67
  68   my $rbits = '';
  69   vec($rbits, fileno(CALL), 1) = 1;
  70   vec($rbits, fileno(EXECTERM), 1) = 1;
  71   my $ebits = $rbits;
  72   my $nfound = select($rbits, '', $ebits, undef);
  73
  74   # Either the child has just died, or the caller has gone away
  75
  76   $SIG{INT} = 'IGN';
  77   kill 'INT', 0 or fail_log("kill executor [$child]: $!");
  78
  79   my $got = waitpid $child, 0;
  80   $got >= 0 // fail_log("wait for executor [$child] (2): $!");
  81   $got == $child or fail_log("wait for esecutor [$child] gave [$got]");
  82
  83   protocol_write(pack "N", $?);
  84   _exit(0);
  85 }
  86
  87 sub close_call_fds () {
  88   foreach (@call_fds) {
  89     POSIX::close($_);
  90   }
  91   close CALL;
  92 }
  93
  94 sub protocol_write ($) {
  95   my ($d) = @_;
  96   return if (print CALL $d and flush CALL);
  97   _exit(0) if $!==EPIPE || $!==ECONNRESET;
  98   fail_log("protocol write: $!");
  99 }
 100
 101 sub eintr_retry ($) {
 102   my ($f) = @_;
 103   for (;;) {
 104     my $r = $f->();
 105     return $r if defined $r;
 106     next if $!==EINTR;
 107     return $r;
 108   }
 109 }
 110
 111 sub protocol_read_fail ($) {
 112   my ($what) = @_;
 113   _exit(0) if $!==ECONNRESET;
 114   die("recv $what: $!");
 115 }
 116
 117 sub protocol_exchange () {
 118   my $greeting = "PFI\n\0\0\0\0";
 119   protocol_write($greeting);
 120
 121   @call_fds = map {
 122     my $r;
 123     for (;;) {
 124       $! = 0;
 125       $r = IO::FDPass::recv(fileno(CALL));
 126       last if $r >= 0;
 127       _exit(0) if $!==0;
 128       protocol_read_fail("fd $_");
 129     }
 130     $r;
 131   } 0..2;
 132
 133   my $len;
 134   my $r = read(CALL, $len, 4) // protocol_read_fail("message length");
 135   $r == 4 or _exit(0);
 136
 137   $len = unpack "N", $len;
 138   my $data;
 139   $r = read(CALL, $data, $len) // protocol_read_fail("message data ($len)");
 140   $r == $len or _exit(0);
 141
 142   @ARGV = split /\0/, $data, -1;
 143   @ARGV >= 2 or die("message data has too few strings (".(scalar @ARGV).")");
 144   length(pop(@ARGV)) and die("message data missing trailing nul");
 145   %ENV = ();
 146   while (my $s = shift @ARGV) {
 147     last if !length $s;
 148     $s =~ m/=/ or die("message data env var missing equals");
 149     $ENV{$`} = $';
 150   }
 151 }
 152
 153 sub initialisation_complete {
 154   my %opts = @_;
 155
 156   # if env var not set, we're not running under prefork-interp
 157   my @env_data = split / /, ($ENV{$env_name} // return);
 158   croak "$env_name has too few words" unless @env_data >= 2;
 159   my (@vsns) = split /,/, $env_data[0];
 160   croak "$env_name doesn't offer protocol v1" unless grep { $_ eq 'v1' } @vsns;
 161   my @env_fds = split /,/, $env_data[1];
 162   croak "$env_name has too few fds" unless @env_fds >= 4;;
 163   $#env_fds = 3;
 164
 165   my $num_servers = $opts{max_servers} // 4;
 166
 167   #---- setup (pm) [1] ----
 168
 169   foreach (@env_fds) {
 170     $_ eq ($_+0) or croak "$env_name contains $_, not a number";
 171   }
 172   open LISTEN, "+>&=$env_fds[0]" or croak "listen fd: $!";
 173   open CALL,   "+>&=$env_fds[1]" or croak "call fd: $!";
 174   open WATCHI, "+>&=$env_fds[2]" or croak "call fd: $!";
 175   open WATCHE, "+>&=$env_fds[3]" or croak "watch stderr fd: $!";
 176
 177   if (!$opts{no_openlog}) {
 178     openlog("prefork-interp $0", 'ndelay,nofatal,pid',
 179             $opts{log_facility} // 'log_user');
 180   }
 181
 182   open NULL, "+>/dev/null" or croak "open /dev/null: $!";
 183
 184   #---- fork for server ----
 185
 186   my $child = fork // croak "first fork failed: $!";
 187   if ($child) {
 188     #---- setup (pm) [2], exits ----
 189     _exit(0);
 190   }
 191   setsid() > 0 or fail_log("setsid: $!");
 192   # The server will be a session leader, but it won't open ttys,
 193   # so that is ok.
 194
 195   #---- server(pm) [1] ----
 196
 197   $child = fork // croak "second fork failed: $!";
 198   if (!$child) {
 199     # we are the child, i.e. the one fa-monitor
 200     local $0 = "$0 [monitor(init)]";
 201     return become_monitor();
 202   }
 203   close CALL;
 204
 205   our %children;
 206   $children{$child} = 1;
 207
 208   # --- server(pm) [2] ----
 209
 210   local $0 = "$0 [server]";
 211
 212   $fail_log = 1;
 213   open STDIN, "<&NULL" or fail_log("dup null onto stdin: $!");
 214   open STDOUT, ">&NULL" or fail_log("dup null onto stdout: $!");
 215   open STDERR, ">&NULL" or fail_log("dup null onto stderr: $!");
 216   close NULL;
 217
 218   my $errcount = 0;
 219
 220   for (;;) {
 221     # reap children
 222     if (%children) {
 223       my $full = %children >= $num_servers;
 224       my $got = waitpid -1, ($full ? 0 : WNOHANG);
 225       $got >= 0 or fail_log("failed to wait for monitor(s): $!");
 226       if ($got) {
 227         if ($? && $? != SIGPIPE) {
 228           syslog(LOG_WARNING,
 229  "$0 prefork [$$]: monitor process [$got] failed with wait status $?");
 230         }
 231         if (!exists $children{$got}) {
 232           syslog(LOG_WARNING,
 233  "$0 prefork [$$]: monitor process [$got] wasn't one of ours?!");
 234         }
 235         delete $children{$got};
 236         next;
 237       }
 238     }
 239
 240     # select for accepting or housekeeping timeout
 241     my $rbits = '';
 242     vec($rbits, fileno(LISTEN), 1) = 1;
 243     vec($rbits, fileno(WATCHE), 1) = 1;
 244     my $ebits = $rbits;
 245     my $nfound = select($rbits, '', $ebits, ($opts{idle_timeout} // 1000000));
 246
 247     # Idle timeout?
 248     last if $nfound == 0;
 249     if ($nfound < 0) {
 250       next if $! == EINTR;
 251       fail_log("select failed: $!");
 252     }
 253
 254     # Has the watcher told us to shut down, or died with a message ?
 255     my $msgbuf = '';
 256     my $r = sysread WATCHE, $msgbuf, 2048;
 257     if ($r > 0) {
 258       chomp $msgbuf;
 259       fail_log("watcher: $msgbuf");
 260     } elsif (defined $r) {
 261       last;
 262     } elsif ($! == EINTR || $! == EAGAIN || $! == EWOULDBLOCK) {
 263     } else {
 264       fail_log("watcher stderr read: $!");
 265     }
 266
 267     # TODO stat checking, quit here if we are stale
 268
 269     # Anything to accept ?
 270     if (accept(CALL, LISTEN)) {
 271       $child = fork // fail_log("fork for accepted call failed: $!");
 272       if (!$child) {
 273         #---- monitor [1] ----
 274         local $0 = "$0 [monitor]";
 275         return become_monitor();
 276       }
 277       close(CALL);
 278       $errcount = 0;
 279       $children{$child} = 1;
 280     } elsif ($! == EINTR || $! == EAGAIN || $! == EWOULDBLOCK) {
 281     } else {
 282       syslog(LOG_WARNING, "$0 prefork [$$]: accept failed: $!");
 283       if ($errcount > ($opts{max_errors} // 100)) {
 284         fail_log("too many accept failures, quitting");
 285       }
 286     }
 287   }
 288   _exit(0);
 289 }
 290
 291 1;
 292
 293 __END__