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