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