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