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 Carp;
   8 use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
   9 use POSIX;
  10 use Sys::Syslog;
  11
  12 our $logger;
  13
  14 our $env_name = 'PREFORK_INTERP';
  15
  16 our @call_fds;
  17 our $socket_path;
  18
  19 sub fail ($) {
  20   my ($m) = @_;
  21   print STDERR "$0: prefork [$$]: $m\n";
  22   flush STDERR;
  23   _exit 127;
  24 }
  25
  26 sub server_quit ($) {
  27   my ($m) = @_;
  28   syslog(LOG_INFO, "$0 prefork [$$]: $m, quitting");
  29   _exit(0);
  30 }
  31
  32 # Returns in the executor process
  33 sub become_monitor () {
  34   my $child = fork // fail("fork executor: $!");
  35   if (!$child) {
  36     #---- executor ----
  37     open ::STDIN , "<& $call_fds[0]" or fail("dup for fd0");
  38     open ::STDOUT, ">& $call_fds[1]" or fail("dup for fd1");
  39     open ::STDERR, ">& $call_fds[2]" or fail("dup for fd2");
  40     POSIX::close($_) foreach @call_fds;
  41     close CALL;
  42     return;
  43   }
  44
  45   #---- monitor [2] ----
  46   my $got = waitpid $child, 0 // fail("wait for executor: $!");
  47   $got == $child or fail("wait for esecutor gave $got, expected $child");
  48
  49   protocol_write(pack "L", $?);
  50   _exit(0);
  51 }
  52
  53 sub protocol_write ($) {
  54   my ($d) = @_;
  55   return if (print CALL $d and flush CALL);
  56   _exit(0) if $!==EPIPE || $!==ECONNRESET;
  57   fail("protocol write: $!");
  58 }
  59
  60 sub eintr_retry ($) {
  61   my ($f) = @_;
  62   for (;;) {
  63     my $r = $f->();
  64     return $r if defined $r;
  65     next if $!==EINTR;
  66     return $r;
  67   }
  68 }
  69
  70 sub protocol_read_fail ($) {
  71   my ($what) = @_;
  72   _exit(0) if $!==ECONNRESET;
  73   fail("recv $what: $!");
  74 }
  75
  76 sub protocol_exchange () {
  77   protocol_write('\n');
  78
  79   @call_fds = map {
  80     my $r;
  81     for (;;) {
  82       $! = 0;
  83       $r = IO::FDPass::recv(fileno(CALL));
  84       last if $r >= 0;
  85       _exit(0) if $!==0;
  86       protocol_read_fail("fd $_");
  87     }
  88     $r;
  89   } 0..2;
  90
  91   my $len;
  92   $r = read(CALL, $len, 4) // protocol_read_fail("message length");
  93   $r == 4 or _exit(0);
  94
  95   $len = unpack "L", $len;
  96   my $data;
  97   $r = read(CALL, $data, $len) // protocol_read_fail("message data ($len)");
  98   $r == $len or _exit(0);
  99
 100   @ARGV = split /\0/, $data;
 101   @ARGV >= 2 or fail("message data has too few strings");
 102   length(pop(@ARGV)) and fail("message data missing trailing nul");
 103   %ENV = ();
 104   while (my $s = shift @ARGV) {
 105     last if !length $s;
 106     $s =~ m/=/ or fail("message data env var missing equals");
 107     $ENV{$`} = $';
 108   }
 109 }
 110
 111 sub initialisation_complete {
 112   my %opts = @_;
 113
 114   # if env var not set, we're not running under prefork-interp
 115   my @env_params = split /,/, ($ENV{$env_name} // return), 5;
 116   croak "$env_name has too few entries" unless @env_params == 5;
 117
 118   $num_servers = $opts{max_servers} // 4;
 119
 120   #---- setup (pm) [1] ----
 121
 122   $socket_path = pop @env_params;
 123   foreach (@env_params) {
 124     $_ eq ($_+0) or croak "$env_name contains $_, not a number";
 125   }
 126   open LISTEN, "+>&=$env_params[0]" or croak "listen fd: $!";
 127   open CALL,   "+>&=$env_params[1]" or croak "listen fd: $!";
 128   @call_fds = ($env_params[2], $env_params[3], 2);
 129
 130   if (!$opts{no_openlog}) {
 131     openlog("prefork-interp $0", 'ndelay,nofatal,pid',
 132             $opts{log_facility} // 'log_user');
 133   }
 134
 135   open NULL, "+>/dev/null" or croak "open /dev/null: $!";
 136
 137   #---- fork for server ----
 138
 139   my $child = fork // croak "first fork failed: $!";
 140   if ($child) {
 141     #---- setup (pm) [2], exits ----
 142     _exit(0);
 143   }
 144
 145   #---- server(pm) [1] ----
 146
 147   $child = fork // croak "second fork failed: $!";
 148   if (!$child) {
 149     # we are the child, i.e. the one fa-monitor
 150     return become_monitor();
 151   }
 152
 153   our %children;
 154   $children{$child} = 1;
 155
 156   # --- server(pm) [2] ----
 157
 158   setsid() > 0 or fail("setsid: $!");
 159   open STDIN, "<&NULL" or fail("dup null onto stdin: $!");
 160   open STDOUT, ">&NULL" or fail("dup null onto stdout: $!");
 161   open STDERR, ">&NULL" or fail("dup null onto stderr: $!");
 162   close NULL;
 163
 164   POSIX::close($_) foreach @call_fds;
 165   close CALL;
 166
 167   my $flags = fcntl(LISTEN, F_GETFL, 0) or fail("F_GETFL listen socket: $!");
 168   $flags |= O_NONBLOCK;
 169   fcntl(LISTEN, F_SETFL, $flags) or fail("F_SETFL listen socket: $!");
 170
 171   my $errcount = 0;
 172
 173   for (;;) {
 174     # reap children
 175     if (%children) {
 176       my $full = %children >= $num_servers;
 177       my $got = waitpid -1, ($full ? 0 : WNOHANG);
 178       if ($?) {
 179         syslog(LOG_WARNING,
 180  "$0 prefork [$$]: monitor process [$got] failed with wait status $?");
 181       }
 182       if (!exists $children{$got}) {
 183         syslog(LOG_WARNING,
 184  "$0 prefork [$$]: monitor process [$got] wasn't one of ours?!");
 185       }
 186       delete $children{$got};
 187       next;
 188     }
 189
 190     # select for accepting or housekeeping timeout
 191     my $rbits = '';
 192     vec($rbits, fileno(LISTEN), 1) = 1;
 193     my $ebits = $rbits;
 194     my $nfound = select($rbits, '', $ebits, ($opts{check_interval} // 300));
 195
 196     if ($nfound) {
 197       if (accept(CALL, LISTEN)) {
 198         $child = fork // fail("fork for accepted call failed: $!");
 199         if (!$child) {
 200           #---- monitor [1] ----
 201           close LISTEN;
 202           protocol_exchange();
 203           return become_monitor();
 204         }
 205         close(CALL);
 206         $errcount = 0;
 207         $children{$child} = 1;
 208       } elsif ($! == EINTR || $! == EAGAIN || $! == EWOULDBLOCK) {
 209       } else {
 210         syslog(LOG_WARNING, "$0 prefork [$$]: accept failed: $!");
 211         if ($errcount > ($opts{max_errors} // 100)) {
 212           syslog(LOG_ERR,
 213                  "$0 prefork [$$]: too many accept failures, quitting");
 214           _exit(16);
 215         }
 216       }
 217       next;
 218     }
 219
 220     # are we still live?
 221     my @st_listen = stat(LISTEN) // fail("fstat listening socket: $!");
 222     my @st_socket = stat($socket_path) // do {
 223       if ($! == ENOENT) { server_quit("socket $socket is ENOENT"); }
 224       fail("stat socket $socket: $!");
 225     };
 226     if ("@st_listen[0..2]" ne "@st_socket[0..2]") {
 227       server_quit("socket $socket is no longer ours");
 228     }
 229   }
 230 }
 231
 232 1;
 233
 234 __END__