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