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