scripts/Proc/Prefork/Interp.pm

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