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