Servidor con Preforking Adaptativo: Programa Principal

En un servidor adaptativo con preforking se usan dos parámetros denominados low water mark y high water mark. Estos dos parámetros - junto con el parámetro PREFORK_CHILDREN - gobiernan la política de planificación familiar del servidor:

• Inicialmente se crean PREFORK_CHILDREN hijos
• Si el número de hijos ociosos @idle desciende por debajo de LO_WATER_MARK el padre creará LO_WATER_MARK-@idle hijos
• Si el número de hijos ociosos @idle excede HI_WATER_MARK el padre eliminará @idle - HI_WATER_MARK hijos

Ese es el significado de las constantes:

lhp@nereida:~/projects/perl/src/perl_networking/ch15$ cat -n prefork_pipe_server2.pl
 1  #!/usr/bin/perl -w
 2  use strict;
 3  use IO::Socket;
 4  use IO::File;
 5  use IO::Select;
 6  use IO::Pipe;
 7  use Fcntl ':flock';
 8  use DaemonSimple;
 9  use HTTPServer2;
10
11  use constant PREFORK_CHILDREN  => 3;
12  use constant MAX_REQUEST       => 30;
13  use constant PIDFILE           => "/tmp/prefork.pid";
14  use constant HI_WATER_MARK     => 5;
15  use constant LO_WATER_MARK     => 2;
16  use constant DEBUG             => 1;

Después de servir MAX_REQUEST peticiones un hijo termina. De este modo podemos ver como el proceso de coordinación crea hijos para sustituir a los que se marchan.

La variable $DONE se va a usar para detectar la terminación. Esta es activada por las señales INT y TERM.

18  my $DONE        = 0;   # set flag to true when server done
19  my %STATUS      = ();
20
21  $SIG{INT}  = $SIG{TERM} = sub { $DONE++ };

Es el hash STATUS está indexado en los PIDs de los hijos y tiene por valor el estado de actividad del hijo. Puede ser: idle, busy o done.

Después de crear el socket de la forma habitual se procede a crear un pipe para la comunicación entre los hijos y el padre. Los hijos lo usaran para comunicar su estado con mensajes de la forma PID status:

22  my $port = shift || 8081;
23  my $socket = IO::Socket::INET->new( LocalPort => $port,
24                                      Listen    => SOMAXCONN,
25                                      Reuse     => 1 ) or die "Can't create listen socket: $!";
26
27  # create a pipe for IPC
28  pipe(CHILD_READ,CHILD_WRITE) or die "Can't make pipe!\n";
29  my $IN = IO::Select->new(\*CHILD_READ);

Programa Principal

lhp@nereida:~/projects/perl/src/perl_networking/ch15$ cat -n prefork_pipe_server2.pl
 1  #!/usr/bin/perl -w
 2  use strict;
 3  use IO::Socket;
 4  use IO::File;
 5  use IO::Select;
 6  use Fcntl ':flock';
 7  use DaemonSimple;
 8  use HTTPServer2;
 9
10  use constant PREFORK_CHILDREN  => 3;
11  use constant MAX_REQUEST       => 30;
12  use constant PIDFILE           => "/tmp/prefork.pid";
13  use constant HI_WATER_MARK     => 5;
14  use constant LO_WATER_MARK     => 2;
15  use constant DEBUG             => 1;
16
17  my $DONE        = 0;   # set flag to true when server done
18  my %STATUS      = ();
19
20  $SIG{INT}  = $SIG{TERM} = sub { $DONE++ };
21
22  my $port = shift || 8081;
23  my $socket = IO::Socket::INET->new( LocalPort => $port,
24                                      Listen    => SOMAXCONN,
25                                      Reuse     => 1 ) or die "Can't create listen socket: $!";
26
27  # create a pipe for IPC
28  pipe(CHILD_READ,CHILD_WRITE) or die "Can't make pipe!\n";
29  my $IN = IO::Select->new(\*CHILD_READ);
30
31  # create PID file and go into background
32  init_server(PIDFILE);
33
34  # prefork some children
35  make_new_child() for (1..PREFORK_CHILDREN);
36
37  while (!$DONE) {
38
39    if ($IN->can_read) { # got a message from one of the children
40      my $message;
41      next unless sysread(CHILD_READ,$message,4096);
42      my @messages = split "\n",$message;
43      foreach (@messages) {
44        next unless my ($pid,$status) = /^(\d+) (.+)$/;
45        if ($status ne 'done') {
46          $STATUS{$pid} = $status;
47        } else {
48          delete $STATUS{$pid};
49        }
50      }
51    }
52
53    # get the list of idle children
54    warn join(' ', map {"$_=>$STATUS{$_}"} keys %STATUS),"\n" if DEBUG;
55    my @idle = sort {$a <=> $b} grep {$STATUS{$_} eq 'idle'} keys %STATUS;
56
57    if (@idle < LO_WATER_MARK) {
58      make_new_child() for (0..LO_WATER_MARK-@idle-1);  # bring the number up
59    } elsif (@idle > HI_WATER_MARK) {
60      my @goners = @idle[0..@idle - HI_WATER_MARK() - 1];   # kill the oldest ones
61      my $killed = kill HUP => @goners;
62      warn "killed $killed children\n" if DEBUG;
63    }
64
65  }
66
67  warn "Termination received, killing children\n" if DEBUG;
68  kill_children();
69  warn "Normal termination.\n";
70  exit 0;
71
72  sub make_new_child {
73    my $child = launch_child(\&cleanup_child);
74    if ($child) {  # child > 0, so we're the parent
75      warn "launching child $child\n" if DEBUG;
76      $STATUS{$child} = 'idle';
77    } else {
78      close CHILD_READ;          # no need to read from pipe
79      do_child($socket);      # child handles incoming connections
80      exit 0;                 # child is done
81    }
82  }
83
84  sub do_child {
85    my $socket = shift;
86    my $lock = IO::File->new(PIDFILE,O_RDONLY) or die "Can't open lock file: $!";
87    my $cycles = MAX_REQUEST;
88    my $done = 0;
89
90    $SIG{HUP} = sub { $done++ };
91    while ( !$done && $cycles-- ) {
92      syswrite CHILD_WRITE,"$$ idle\n";
93      my $c;
94      next unless eval {
95        local $SIG{HUP} = sub { $done++; die };
96        flock($lock,LOCK_EX);
97        warn "child $$: calling accept()\n" if DEBUG;
98        $c = $socket->accept;
99        flock($lock,LOCK_UN);
100      };
101      syswrite CHILD_WRITE,"$$ busy\n";
102      handle_connection($c);
103      close $c;
104    }
105    warn "child $$ done\n" if DEBUG;
106    syswrite CHILD_WRITE,"$$ done\n";
107    close $_ foreach ($socket,$lock,\*CHILD_WRITE);
108  }
109
110  sub cleanup_child {
111    my $child = shift;
112    delete $STATUS{$child};
113  }

El Módulo Daemon Simplificado

lhp@nereida:~/projects/perl/src/perl_networking/ch15$ cat -n DaemonSimple.pm
 1  package DaemonSimple;
 2  use strict;
 3  use vars qw(@EXPORT @ISA @EXPORT_OK $VERSION);
 4
 5  use POSIX qw(:signal_h setsid WNOHANG);
 6  use Carp 'croak','cluck';
 7  use File::Basename;
 8  use IO::File;
 9  require Exporter;
10
11  @EXPORT_OK = qw( init_server launch_child prepare_child);
12  @EXPORT = @EXPORT_OK;
13  @ISA = qw(Exporter);
14  $VERSION = '1.00';
15  our %CHILDREN;
16
17  use constant PIDPATH  => '/tmp';
18  my ($pid,$pidfile);
19
20  sub init_server {
21    $pidfile = shift || getpidfilename();
22    my $fh = open_pid_file($pidfile);
23    become_daemon();
24    print $fh $$;
25    close $fh;
26    return $pid = $$;
27  }
28
29  sub become_daemon {
30    chdir '/';                    # change working directory
31    umask(0);                     # forget file mode creation mask
32    $ENV{PATH} = '/bin:/sbin:/usr/bin:/usr/sbin';
33    $SIG{CHLD} = \&reap_child;
34    return $$;
35  }
36
37  sub getpidfilename {
38    my $basename = basename($0,'.pl');
39    return PIDPATH . "/$basename.pid";
40  }
41
42  sub open_pid_file {
43    my $file = shift;
44    if (-e $file) {               # oops.  pid file already exists
45      my $fh = IO::File->new($file) || return;
46      my $pid = <$fh>;
47      if ($pid && $pid =~ /^\d+$/) {
48        croak "Server already running with PID $pid" if kill 0 => $pid;
49      }
50      else {
51        $pid = "unknown";
52      }
53      cluck "Removing PID file for defunct server process $pid.\n";
54      croak"Can't unlink PID file $file" unless -w $file && unlink $file;
55    }
56    return IO::File->new($file,O_WRONLY|O_CREAT|O_EXCL,0644)
57      or die "Can't create $file: $!\n";
58  }
59
60  sub reap_child {
61    do { } while waitpid(-1,WNOHANG) > 0;
62  }
63
64  sub launch_child {
65    my $callback = shift;
66    my $home     = shift;
67    my $signals = POSIX::SigSet->new(SIGINT,SIGCHLD,SIGTERM,SIGHUP);
68    sigprocmask(SIG_BLOCK,$signals);  # block inconvenient signals
69    die("Can't fork: $!") unless defined (my $child = fork());
70    if ($child) {
71      $CHILDREN{$child} = $callback || 1;
72    } else {
73      $SIG{HUP} = $SIG{INT} = $SIG{CHLD} = $SIG{TERM} = 'DEFAULT';
74      prepare_child($home);
75    }
76    sigprocmask(SIG_UNBLOCK,$signals);  # unblock signals
77    return $child;
78  }
79
80  sub prepare_child {
81    my $home = shift;
82    if ($home) {
83      chdir  $home || croak "chdir(): $!";
84    }
85  }
86
87
88  sub kill_children {
89    my $n = kill TERM => keys %CHILDREN;
90    # wait until all the children die
91    wait for 1..$n
92  }
93
94
95  END { unlink $pidfile if defined $pid and $$ == $pid }
96
97  1;