root/lang/perl/Server-Starter/trunk/lib/Server/Starter.pm @ 36369

Revision 36369, 7.0 kB (checked in by kazuho, 4 years ago)

fix typo (thanks to markstos)

Line 
1package Server::Starter;
2
3use 5.008;
4use strict;
5use warnings;
6use Carp;
7use Fcntl;
8use IO::Socket::INET;
9use POSIX qw(:sys_wait_h);
10use Proc::Wait3;
11
12use Exporter qw(import);
13
14our $VERSION = '0.06';
15our @EXPORT_OK = qw(start_server server_ports);
16
17my @signals_received;
18
19sub start_server {
20    my $opts = @_ == 1 ? shift : { @_ };
21    $opts->{interval} ||= 1;
22   
23    # prepare args
24    my $ports = $opts->{port}
25        or croak "mandatory option ``port'' is missing\n";
26    $ports = [ $ports ]
27        unless ref $ports eq 'ARRAY';
28    croak "``port'' should specify at least one port to listen to\n"
29        unless @$ports;
30    croak "mandatory option ``exec'' is missing or is not an arrayref\n"
31        unless $opts->{exec} && ref $opts->{exec} eq 'ARRAY';
32   
33    print STDERR "start_server (pid:$$) starting now...\n";
34   
35    # start listening, setup envvar
36    my @sock;
37    my @sockenv;
38    for my $port (@$ports) {
39        my $sock;
40        if ($port =~ /^\s*(\d+)\s*$/) {
41            $sock = IO::Socket::INET->new(
42                Listen    => Socket::SOMAXCONN(),
43                LocalPort => $port,
44                Proto     => 'tcp',
45                ReuseAddr => 1,
46            );
47        } elsif ($port =~ /^\s*(.*)\s*:\s*(\d+)\s*$/) {
48            $port = "$1:$2";
49            $sock = IO::Socket::INET->new(
50                Listen    => Socket::SOMAXCONN(),
51                LocalAddr => $port,
52                Proto     => 'tcp',
53                ReuseAddr => 1,
54            );
55        } else {
56            croak "invalid ``port'' value:$port\n"
57        }
58        die "failed to listen to $port:$!"
59            unless $sock;
60        fcntl($sock, F_SETFD, my $flags = '')
61                or die "fcntl(F_SETFD, 0) failed:$!";
62        push @sockenv, "$port=" . $sock->fileno;
63        push @sock, $sock;
64    }
65    $ENV{SERVER_STARTER_PORT} = join ";", @sockenv;
66    $ENV{SERVER_STARTER_GENERATION} = 0;
67   
68    # setup signal handlers
69    $SIG{$_} = sub {
70        push @signals_received, $_[0];
71    } for (qw/INT TERM HUP/);
72    $SIG{PIPE} = 'IGNORE';
73   
74    # the main loop
75    my $current_worker = _start_worker($opts);
76    my %old_workers;
77    while (1) {
78        my @r = wait3(! scalar @signals_received);
79        if (@r) {
80            my ($died_worker, $status) = @r;
81            if ($died_worker == $current_worker) {
82                print STDERR "worker $died_worker died unexpectedly with status:$status, restarting\n";
83                $current_worker = _start_worker($opts);
84            } else {
85                print STDERR "old worker $died_worker died, status:$status\n";
86                delete $old_workers{$died_worker};
87            }
88        }
89        for (; @signals_received; shift @signals_received) {
90            if ($signals_received[0] eq 'HUP') {
91                print STDERR "received HUP, spawning a new worker\n";
92                $old_workers{$current_worker} = 1;
93                $current_worker = _start_worker($opts);
94                print STDERR "new worker is now running, sending TERM to old workers:";
95                if (%old_workers) {
96                    print STDERR join(',', sort keys %old_workers), "\n";
97                } else {
98                    print STDERR "none\n";
99                }
100                kill 'TERM', $_
101                    for sort keys %old_workers;
102            } else {
103                goto CLEANUP;
104            }
105        }
106    }
107   
108 CLEANUP:
109    # cleanup
110    $old_workers{$current_worker} = 1;
111    undef $current_worker;
112    print STDERR "received $signals_received[0], sending TERM to all workers:",
113        join(',', sort keys %old_workers), "\n";
114    kill 'TERM', $_
115        for sort keys %old_workers;
116    while (%old_workers) {
117        if (my @r = wait3(1)) {
118            my ($died_worker, $status) = @r;
119            print STDERR "worker $died_worker died, status:$status\n";
120            delete $old_workers{$died_worker};
121        }
122    }
123   
124    print STDERR "exitting\n";
125}
126
127sub server_ports {
128    die "no environment variable SERVER_STARTER_PORT. Did you start the process using server_starter?",
129        unless $ENV{SERVER_STARTER_PORT};
130    my %ports = map {
131        +(split /=/, $_, 2)
132    } split /;/, $ENV{SERVER_STARTER_PORT};
133    \%ports;
134}
135
136sub _start_worker {
137    my $opts = shift;
138    my $pid;
139    while (1) {
140        $ENV{SERVER_STARTER_GENERATION}++;
141        $pid = fork;
142        die "fork(2) failed:$!"
143            unless defined $pid;
144        if ($pid == 0) {
145            # child process
146            { exec(@{$opts->{exec}}) };
147            print STDERR "failed to exec $opts->{exec}->[0]:$!";
148            exit(255);
149        }
150        print STDERR "starting new worker $pid\n";
151        sleep $opts->{interval};
152        if ((grep { $_ ne 'HUP' } @signals_received)
153                || waitpid($pid, WNOHANG) <= 0) {
154            last;
155        }
156        print STDERR "new worker $pid seems to have failed to start, exit status:$?\n";
157    }
158    $pid;
159}
160
1611;
162__END__
163
164=head1 NAME
165
166Server::Starter - a superdaemon for hot-deploying server programs
167
168=head1 SYNOPSIS
169
170  # from command line
171  % start_server --port=80 my_httpd
172
173  # in my_httpd
174  use Server::Starter qw(server_ports);
175
176  my $listen_sock = IO::Socket::INET->new(
177      Proto => 'tcp',
178  );
179  $listen_sock->fdopen((values %{server_ports()})[0], 'w')
180      or die "failed to bind to listening socket:$!";
181
182  while (1) {
183      if (my $conn = $listen_sock->accept) {
184          ....
185      }
186  }
187
188=head1 DESCRIPTION
189
190It is often a pain to write a server program that supports graceful restarts, with no resource leaks.  L<Server::Starter>, solves the problem by splitting the task into two.  One is L<start_server>, a script provided as a part of the module, which works as a superdaemon that binds to one or more TCP ports, and repeatedly spawns the server program that actually handles the incoming commenctions.  The spawned server programs under L<Server::Starter> call accept(2) and handle the requests.
191
192To gracefully restart the server program, send SIGHUP to the superdaemon.  The superdaemon spawns a new server program, and if (and only if) it starts up successfully, sends SIGTERM to the old server program.
193
194By using L<Server::Starter> it is much easier to write a hot-deployable server.  Following are the only requirements a server program to be run under L<Server::Starter> should conform to:
195
196- receive file descriptors to listen to through an environment variable
197- perform a graceful shutdown when receiving SIGTERM
198
199A Net::Server personality that can be run under L<Server::Starter> exists under the name L<Net::Server::SS::PreFork>.
200
201=head1 METHODS
202
203=over 4
204
205=item server_ports
206
207Returns one or more file descriptors on which the server program should call accept(2) in a hashref.  Each element of the hashref is: (host:port|port)=file_descriptor.
208
209=item start_server
210
211Starts the superdaemon.  Used by the C<strat_server> scirpt.
212
213=back
214
215=head1 AUTHOR
216
217Kazuho Oku E<lt>kazuhooku@gmail.comE<gt>
218Copyright (C) 2009 Cybozu Labs, Inc.
219
220=head1 SEE ALSO
221
222L<Net::Server::SS::PreFork>
223
224=head1 LICENSE
225
226This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.
227
228=cut
Note: See TracBrowser for help on using the browser.