perl/Prefork.pm

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