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