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