perl/Prefork.pm

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