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