pm/Proc/Prefork/Interp.pm

   1
   2 package Proc::Prefork::Interp;
   3 require Exporter;
   4 our @ISA = qw(Exporter);
   5 our @EXPORT = qw(initialisation_complete);
   6
   7 use strict;
   8
   9 use Carp;
  10 use Fcntl qw(F_GETFL F_SETFL O_NONBLOCK);
  11 use IO::FDPass;
  12 use POSIX qw(_exit setsid :sys_wait_h :errno_h :signal_h);
  13 use Sys::Syslog qw(openlog syslog LOG_INFO LOG_ERR LOG_WARNING);
  14
  15 our $logger;
  16
  17 our $env_name = 'PREFORK_INTERP';
  18
  19 our @call_fds;
  20 our $socket_path;
  21 our $fail_log = 0;
  22 our $startup_mtime;
  23
  24 sub fail_log ($) {
  25   my ($m) = @_;
  26   if ($fail_log) {
  27     syslog(LOG_ERR, "$0: prefork [$$]: error: $m");
  28   } else {
  29     carp "$0: prefork: initialisation error: $m";
  30   }
  31   _exit 127;
  32 }
  33
  34 sub server_quit ($) {
  35   my ($m) = @_;
  36   syslog(LOG_INFO, "$0 prefork [$$]: $m, quitting");
  37   _exit(0);
  38 }
  39
  40 # Returns in the executor process
  41 sub become_monitor () {
  42   close LISTEN;
  43   close WATCHI;
  44   close WATCHE;
  45
  46   # Make a process group for this call
  47   setpgrp or fail_log("setpgrp failed: $!");
  48
  49   eval { protocol_exchange(); 1; }
  50     or fail_log("protocol exchange failed: $@");
  51
  52   pipe EXECTERM, EXECTERMW or fail_log("pipe: $!");
  53
  54   my $child = fork // fail_log("fork executor: $!");
  55   if (!$child) {
  56     #---- executor ----
  57     open ::STDIN , "<& $call_fds[0]" or fail_log("dup for fd0");
  58     open ::STDOUT, ">& $call_fds[1]" or fail_log("dup for fd1");
  59     open ::STDERR, ">& $call_fds[2]" or fail_log("dup for fd2");
  60     close EXECTERM;
  61     close_call_fds();
  62     $! = 0;
  63     return;
  64   }
  65   close EXECTERMW;
  66
  67   #---- monitor [2] ----
  68
  69   for (;;) {
  70     my $rbits = '';
  71     vec($rbits, fileno(CALL), 1) = 1;
  72     vec($rbits, fileno(EXECTERM), 1) = 1;
  73     my $ebits = $rbits;
  74     my $nfound = select($rbits, '', $ebits, undef);
  75     last if $nfound > 0;
  76     next if $! == EINTR;
  77     fail_log("monitor select() failed: $!");
  78   }
  79
  80   # Either the child has just died, or the caller has gone away
  81
  82   $SIG{INT} = 'IGN';
  83   kill 'INT', 0 or fail_log("kill executor [$child]: $!");
  84
  85   my $got = waitpid $child, 0;
  86   $got >= 0 // fail_log("wait for executor [$child] (2): $!");
  87   $got == $child or fail_log("wait for esecutor [$child] gave [$got]");
  88
  89   protocol_write(pack "N", $?);
  90   _exit(0);
  91 }
  92
  93 sub close_call_fds () {
  94   foreach (@call_fds) {
  95     POSIX::close($_);
  96   }
  97   close CALL;
  98 }
  99
 100 sub protocol_write ($) {
 101   my ($d) = @_;
 102   return if (print CALL $d and flush CALL);
 103   _exit(0) if $!==EPIPE || $!==ECONNRESET;
 104   fail_log("protocol write: $!");
 105 }
 106
 107 sub eintr_retry ($) {
 108   my ($f) = @_;
 109   for (;;) {
 110     my $r = $f->();
 111     return $r if defined $r;
 112     next if $!==EINTR;
 113     return $r;
 114   }
 115 }
 116
 117 sub protocol_read_fail ($) {
 118   my ($what) = @_;
 119   _exit(0) if $!==ECONNRESET;
 120   die("recv $what: $!");
 121 }
 122
 123 sub protocol_exchange () {
 124   my $greeting = "PFI\n\0\0\0\0";
 125   protocol_write($greeting);
 126
 127   @call_fds = map {
 128     my $r;
 129     for (;;) {
 130       $! = 0;
 131       $r = IO::FDPass::recv(fileno(CALL));
 132       last if $r >= 0;
 133       _exit(0) if $!==0;
 134       protocol_read_fail("fd $_");
 135     }
 136     $r;
 137   } 0..2;
 138
 139   my $len;
 140   my $r = read(CALL, $len, 4) // protocol_read_fail("message length");
 141   $r == 4 or _exit(0);
 142
 143   $len = unpack "N", $len;
 144   my $data;
 145   $r = read(CALL, $data, $len) // protocol_read_fail("message data ($len)");
 146   $r == $len or _exit(0);
 147
 148   @ARGV = split /\0/, $data, -1;
 149   @ARGV >= 2 or die("message data has too few strings (".(scalar @ARGV).")");
 150   length(pop(@ARGV)) and die("message data missing trailing nul");
 151   %ENV = ();
 152   while (my $s = shift @ARGV) {
 153     last if !length $s;
 154     $s =~ m/=/ or die("message data env var missing equals");
 155     $ENV{$`} = $';
 156   }
 157 }
 158
 159 sub initialisation_complete {
 160   my %opts = @_;
 161
 162   # if env var not set, we're not running under prefork-interp
 163   my @env_data = split / /, ($ENV{$env_name} // return);
 164   croak "$env_name has too few words" unless @env_data >= 2;
 165   my (@vsns) = split /,/, $env_data[0];
 166   croak "$env_name doesn't specify v1" unless @vsns >= 2 && $vsns[0] eq 'v1';
 167   $startup_mtime = $vsns[1];
 168   my @env_fds = split /,/, $env_data[1];
 169   croak "$env_name has too few fds" unless @env_fds >= 4;;
 170   $#env_fds = 3;
 171
 172   my $num_servers = $opts{max_servers} // 4;
 173
 174   #---- setup (pm) [1] ----
 175
 176   foreach (@env_fds) {
 177     $_ eq ($_+0) or croak "$env_name contains $_, not a number";
 178   }
 179   open LISTEN, "+>&=$env_fds[0]" or croak "listen fd: $!";
 180   open CALL,   "+>&=$env_fds[1]" or croak "call fd: $!";
 181   open WATCHI, "+>&=$env_fds[2]" or croak "call fd: $!";
 182   open WATCHE, "+>&=$env_fds[3]" or croak "watch stderr fd: $!";
 183
 184   if (!$opts{no_openlog}) {
 185     openlog("prefork-interp $0", 'ndelay,nofatal,pid',
 186             $opts{log_facility} // 'log_user');
 187   }
 188
 189   open NULL, "+>/dev/null" or croak "open /dev/null: $!";
 190
 191   #---- fork for server ----
 192
 193   my $child = fork // croak "first fork failed: $!";
 194   if ($child) {
 195     #---- setup (pm) [2], exits ----
 196     _exit(0);
 197   }
 198   setsid() > 0 or fail_log("setsid: $!");
 199   # The server will be a session leader, but it won't open ttys,
 200   # so that is ok.
 201
 202   #---- server(pm) [1] ----
 203
 204   $child = fork // croak "second fork failed: $!";
 205   if (!$child) {
 206     # we are the child, i.e. the one fa-monitor
 207     local $0 = "$0 [monitor(init)]";
 208     return become_monitor();
 209   }
 210   close CALL;
 211
 212   our %children;
 213   $children{$child} = 1;
 214
 215   # --- server(pm) [2] ----
 216
 217   local $0 = "$0 [server]";
 218
 219   $fail_log = 1;
 220   open STDIN, "<&NULL" or fail_log("dup null onto stdin: $!");
 221   open STDOUT, ">&NULL" or fail_log("dup null onto stdout: $!");
 222   open STDERR, ">&NULL" or fail_log("dup null onto stderr: $!");
 223   close NULL;
 224
 225   my $errcount = 0;
 226
 227   for (;;) {
 228     # reap children
 229     if (%children) {
 230       my $full = %children >= $num_servers;
 231       my $got = waitpid -1, ($full ? 0 : WNOHANG);
 232       $got >= 0 or fail_log("failed to wait for monitor(s): $!");
 233       if ($got) {
 234         if ($? && $? != SIGPIPE) {
 235           syslog(LOG_WARNING,
 236  "$0 prefork [$$]: monitor process [$got] failed with wait status $?");
 237         }
 238         if (!exists $children{$got}) {
 239           syslog(LOG_WARNING,
 240  "$0 prefork [$$]: monitor process [$got] wasn't one of ours?!");
 241         }
 242         delete $children{$got};
 243         next;
 244       }
 245     }
 246
 247     # select for accepting or housekeeping timeout
 248     my $rbits = '';
 249     vec($rbits, fileno(LISTEN), 1) = 1;
 250     vec($rbits, fileno(WATCHE), 1) = 1;
 251     my $ebits = $rbits;
 252     my $nfound = select($rbits, '', $ebits, ($opts{idle_timeout} // 1000000));
 253
 254     # Idle timeout?
 255     last if $nfound == 0;
 256     if ($nfound < 0) {
 257       next if $! == EINTR;
 258       fail_log("select failed: $!");
 259     }
 260
 261     # Has the watcher told us to shut down, or died with a message ?
 262     my $msgbuf = '';
 263     my $r = sysread WATCHE, $msgbuf, 2048;
 264     if ($r > 0) {
 265       chomp $msgbuf;
 266       fail_log("watcher: $msgbuf");
 267     } elsif (defined $r) {
 268       last;
 269     } elsif ($! == EINTR || $! == EAGAIN || $! == EWOULDBLOCK) {
 270     } else {
 271       fail_log("watcher stderr read: $!");
 272     }
 273
 274     # TODO stat checking, quit here if we are stale
 275
 276     # Anything to accept ?
 277     if (accept(CALL, LISTEN)) {
 278       $child = fork // fail_log("fork for accepted call failed: $!");
 279       if (!$child) {
 280         #---- monitor [1] ----
 281         local $0 = "$0 [monitor]";
 282         return become_monitor();
 283       }
 284       close(CALL);
 285       $errcount = 0;
 286       $children{$child} = 1;
 287     } elsif ($! == EINTR || $! == EAGAIN || $! == EWOULDBLOCK) {
 288     } else {
 289       syslog(LOG_WARNING, "$0 prefork [$$]: accept failed: $!");
 290       if ($errcount > ($opts{max_errors} // 100)) {
 291         fail_log("too many accept failures, quitting");
 292       }
 293     }
 294   }
 295   _exit(0);
 296 }
 297
 298 1;
 299
 300 __END__