pax_global_header00006660000000000000000000000064120302460210014500gustar00rootroot0000000000000052 comment=8453e56509bc9c5fdc24e6a962075676cbc90dd0 perl-Server-Starter-0.12/000075500000000000000000000000001203024602100152505ustar00rootroot00000000000000perl-Server-Starter-0.12/.gitignore000064400000000000000000000002221203024602100172340ustar00rootroot00000000000000Makefile inc/ .c ppport.h .*.sw[pon] *.bak *.old Build _build/ xshelper.h META.yml MYMETA.yml .online blib/ pm_to_blib nytprof* core perltidy.ERR perl-Server-Starter-0.12/Changes000064400000000000000000000023331203024602100165440ustar00rootroot00000000000000Revision history for Perl extension Server::Starter. 0.12 - bugfix: support for programs with whitespaces (thanks to clkao) - add option: --signal-on-term (thanks to miyagawa) 0.11 - remove unix socket file on shutdown 0.10 - support for unix sockets with --path option 0.09 - added options: --signal-on-hup, --status-file, --restart 0.08 - added --pid-file option 0.07 Sat May 08 14:00:00 2010 - --port option is now omittable (so daemons _not_ binding to TCP ports (like FCGI servers binding to unix domain sockets) can be hot-deployied using Server::Starter) 0.06 Sat Jan 02 10:26:00 2010 - bugfix: start_server did not shutdown upon receiving SIGINT while the worker is failing to start up 0.05 Tue Oct 13 20:30:00 2009 - use $^X in tests (or tests will fail on hosts using a different installation of perl from one installed to /usr/bin/perl) 0.04 Fri Oct 09 19:25:00 2009 - signals received just after spawning worker process were dismissed (thanks to kazeburo for reporting and helping fix the problem) 0.03 Thu Sep 24 20:00:00 2009 - require 5.008 - require Test::TCP 0.11 to satisfy the dependencies 0.02 Thu Sep 09 17:06:00 2009 - add README, Changes 0.01 Thu Sep 09 17:00:00 2009 - initial version perl-Server-Starter-0.12/MANIFEST.SKIP000064400000000000000000000002061203024602100171440ustar00rootroot00000000000000\bRCS\b \bCVS\b ^MANIFEST\. ^Makefile$ ~$ \.old$ ^blib/ ^pm_to_blib ^MakeMaker-\d \.gz$ \.cvsignore \.shipit ^t/9\d_.*\.t \.svn \.git perl-Server-Starter-0.12/Makefile.PL000064400000000000000000000004701203024602100172230ustar00rootroot00000000000000use inc::Module::Install; name 'Server-Starter'; all_from 'lib/Server/Starter.pm'; license 'perl'; requires 'Getopt::Long'; requires 'List::MoreUtils'; requires 'Proc::Wait3'; requires 'Scope::Guard'; test_requires 'Test::TCP' => '0.11'; auto_include; auto_install; install_script 'start_server'; WriteAll; perl-Server-Starter-0.12/README000064400000000000000000000000321203024602100161230ustar00rootroot00000000000000see lib/Server/Starter.pm perl-Server-Starter-0.12/lib/000075500000000000000000000000001203024602100160165ustar00rootroot00000000000000perl-Server-Starter-0.12/lib/Server/000075500000000000000000000000001203024602100172645ustar00rootroot00000000000000perl-Server-Starter-0.12/lib/Server/Starter.pm000064400000000000000000000267231203024602100212600ustar00rootroot00000000000000package Server::Starter; use 5.008; use strict; use warnings; use Carp; use Fcntl; use IO::Handle; use IO::Socket::INET; use IO::Socket::UNIX; use List::MoreUtils qw(uniq); use POSIX qw(:sys_wait_h); use Proc::Wait3; use Scope::Guard; use Exporter qw(import); our $VERSION = '0.12'; our @EXPORT_OK = qw(start_server restart_server server_ports); my @signals_received; sub start_server { my $opts = { (@_ == 1 ? @$_[0] : @_), }; $opts->{interval} = 1 if not defined $opts->{interval}; $opts->{signal_on_hup} ||= 'TERM'; $opts->{signal_on_term} ||= 'TERM'; for ($opts->{signal_on_hup}, $opts->{signal_on_term}) { # normalize to the one that can be passed to kill tr/a-z/A-Z/; s/^SIG//i; } # prepare args my $ports = $opts->{port}; my $paths = $opts->{path}; croak "either of ``port'' or ``path'' option is mandatory\n" unless $ports || $paths; $ports = [ $ports ] if ! ref $ports && defined $ports; $paths = [ $paths ] if ! ref $paths && defined $paths; croak "mandatory option ``exec'' is missing or is not an arrayref\n" unless $opts->{exec} && ref $opts->{exec} eq 'ARRAY'; # open pid file my $pid_file_guard = sub { return unless $opts->{pid_file}; open my $fh, '>', $opts->{pid_file} or die "failed to open file:$opts->{pid_file}: $!"; print $fh "$$\n"; close $fh; return Scope::Guard->new( sub { unlink $opts->{pid_file}; }, ); }->(); # open log file if ($opts->{log_file}) { open my $fh, '>>', $opts->{log_file} or die "failed to open log file:$opts->{log_file}: $!"; STDOUT->flush; STDERR->flush; open STDOUT, '>&', $fh or die "failed to dup STDOUT to file: $!"; open STDERR, '>&', $fh or die "failed to dup STDERR to file: $!"; close $fh; } # create guard that removes the status file my $status_file_guard = $opts->{status_file} && Scope::Guard->new( sub { unlink $opts->{status_file}; }, ); print STDERR "start_server (pid:$$) starting now...\n"; # start listening, setup envvar my @sock; my @sockenv; for my $port (@$ports) { my $sock; if ($port =~ /^\s*(\d+)\s*$/) { $sock = IO::Socket::INET->new( Listen => Socket::SOMAXCONN(), LocalPort => $port, Proto => 'tcp', ReuseAddr => 1, ); } elsif ($port =~ /^\s*(.*)\s*:\s*(\d+)\s*$/) { $port = "$1:$2"; $sock = IO::Socket::INET->new( Listen => Socket::SOMAXCONN(), LocalAddr => $port, Proto => 'tcp', ReuseAddr => 1, ); } else { croak "invalid ``port'' value:$port\n" } die "failed to listen to $port:$!" unless $sock; fcntl($sock, F_SETFD, my $flags = '') or die "fcntl(F_SETFD, 0) failed:$!"; push @sockenv, "$port=" . $sock->fileno; push @sock, $sock; } my $path_remove_guard = Scope::Guard->new( sub { -S $_ and unlink $_ for @$paths; }, ); for my $path (@$paths) { if (-S $path) { warn "removing existing socket file:$path"; unlink $path or die "failed to remove existing socket file:$path:$!"; } unlink $path; my $sock = IO::Socket::UNIX->new( Listen => Socket::SOMAXCONN(), Local => $path, ) or die "failed to listen to file $path:$!"; fcntl($sock, F_SETFD, my $flags = '') or die "fcntl(F_SETFD, 0) failed:$!"; push @sockenv, "$path=" . $sock->fileno; push @sock, $sock; } $ENV{SERVER_STARTER_PORT} = join ";", @sockenv; $ENV{SERVER_STARTER_GENERATION} = 0; # setup signal handlers $SIG{$_} = sub { push @signals_received, $_[0]; } for (qw/INT TERM HUP/); $SIG{PIPE} = 'IGNORE'; # setup status monitor my ($current_worker, %old_workers); my $update_status = $opts->{status_file} ? sub { my $tmpfn = "$opts->{status_file}.$$"; open my $tmpfh, '>', $tmpfn or die "failed to create temporary file:$tmpfn:$!"; my %gen_pid = ( ($current_worker ? ($ENV{SERVER_STARTER_GENERATION} => $current_worker) : ()), map { $old_workers{$_} => $_ } keys %old_workers, ); print $tmpfh "$_:$gen_pid{$_}\n" for sort keys %gen_pid; close $tmpfh; rename $tmpfn, $opts->{status_file} or die "failed to rename $tmpfn to $opts->{status_file}:$!"; } : sub { }; # the main loop my $term_signal; $current_worker = _start_worker($opts); $update_status->(); while (1) { my @r = wait3(! scalar @signals_received); if (@r) { my ($died_worker, $status) = @r; if ($died_worker == $current_worker) { print STDERR "worker $died_worker died unexpectedly with status:$status, restarting\n"; $current_worker = _start_worker($opts); } else { print STDERR "old worker $died_worker died, status:$status\n"; delete $old_workers{$died_worker}; $update_status->(); } } for (; @signals_received; shift @signals_received) { if ($signals_received[0] eq 'HUP') { print STDERR "received HUP, spawning a new worker\n"; $old_workers{$current_worker} = $ENV{SERVER_STARTER_GENERATION}; $current_worker = _start_worker($opts); $update_status->(); print STDERR "new worker is now running, sending $opts->{signal_on_hup} to old workers:"; if (%old_workers) { print STDERR join(',', sort keys %old_workers), "\n"; } else { print STDERR "none\n"; } kill $opts->{signal_on_hup}, $_ for sort keys %old_workers; } else { $term_signal = $signals_received[0] eq 'TERM' ? $opts->{signal_on_term} : 'TERM'; goto CLEANUP; } } } CLEANUP: # cleanup $old_workers{$current_worker} = $ENV{SERVER_STARTER_GENERATION}; undef $current_worker; print STDERR "received $signals_received[0], sending $term_signal to all workers:", join(',', sort keys %old_workers), "\n"; kill $term_signal, $_ for sort keys %old_workers; while (%old_workers) { if (my @r = wait3(1)) { my ($died_worker, $status) = @r; print STDERR "worker $died_worker died, status:$status\n"; delete $old_workers{$died_worker}; $update_status->(); } } print STDERR "exiting\n"; } sub restart_server { my $opts = { (@_ == 1 ? @$_[0] : @_), }; die "--restart option requires --pid-file and --status-file to be set as well\n" unless $opts->{pid_file} && $opts->{status_file}; # get pid my $pid = do { open my $fh, '<', $opts->{pid_file} or die "failed to open file:$opts->{pid_file}:$!"; my $line = <$fh>; chomp $line; $line; }; # function that returns a list of active generations in sorted order my $get_generations = sub { open my $fh, '<', $opts->{status_file} or die "failed to open file:$opts->{status_file}:$!"; uniq sort { $a <=> $b } map { /^(\d+):/ ? ($1) : () } <$fh>; }; # wait for this generation my $wait_for = do { my @gens = $get_generations->() or die "no active process found in the status file"; pop(@gens) + 1; }; # send HUP kill 'HUP', $pid or die "failed to send SIGHUP to the server process:$!"; # wait for the generation while (1) { my @gens = $get_generations->(); last if scalar(@gens) == 1 && $gens[0] == $wait_for; sleep 1; } } sub server_ports { die "no environment variable SERVER_STARTER_PORT. Did you start the process using server_starter?", unless $ENV{SERVER_STARTER_PORT}; my %ports = map { +(split /=/, $_, 2) } split /;/, $ENV{SERVER_STARTER_PORT}; \%ports; } sub _start_worker { my $opts = shift; my $pid; while (1) { $ENV{SERVER_STARTER_GENERATION}++; $pid = fork; die "fork(2) failed:$!" unless defined $pid; if ($pid == 0) { my @args = @{$opts->{exec}}; # child process { exec { $args[0] } @args }; print STDERR "failed to exec $args[0]$!"; exit(255); } print STDERR "starting new worker $pid\n"; sleep $opts->{interval}; if ((grep { $_ ne 'HUP' } @signals_received) || waitpid($pid, WNOHANG) <= 0) { last; } print STDERR "new worker $pid seems to have failed to start, exit status:$?\n"; } $pid; } 1; __END__ =head1 NAME Server::Starter - a superdaemon for hot-deploying server programs =head1 SYNOPSIS # from command line % start_server --port=80 my_httpd # in my_httpd use Server::Starter qw(server_ports); my $listen_sock = IO::Socket::INET->new( Proto => 'tcp', ); $listen_sock->fdopen((values %{server_ports()})[0], 'w') or die "failed to bind to listening socket:$!"; while (1) { if (my $conn = $listen_sock->accept) { .... } } =head1 DESCRIPTION It is often a pain to write a server program that supports graceful restarts, with no resource leaks. L solves the problem by splitting the task into two. One is L, a script provided as a part of the module, which works as a superdaemon that binds to zero or more TCP ports or unix sockets, and repeatedly spawns the server program that actually handles the necessary tasks (for example, responding to incoming commenctions). The spawned server programs under L call accept(2) and handle the requests. To 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. By using L it is much easier to write a hot-deployable server. Following are the only requirements a server program to be run under L should conform to: - receive file descriptors to listen to through an environment variable - perform a graceful shutdown when receiving SIGTERM A Net::Server personality that can be run under L exists under the name L. =head1 METHODS =over 4 =item server_ports Returns zero 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|path_of_unix_socket) => file_descriptor. =item start_server Starts the superdaemon. Used by the C script. =back =head1 AUTHOR Kazuho Oku =head1 SEE ALSO L =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut perl-Server-Starter-0.12/start_server000075500000000000000000000051661203024602100177310ustar00rootroot00000000000000#! /usr/bin/perl use strict; use warnings; use Getopt::Long; use Pod::Usage; use Server::Starter qw(start_server restart_server); my %opts = ( port => [], path => [], ); GetOptions( map { $_ => do { my $name = (split '=', $_, 2)[0]; $name =~ s/-/_/g; $opts{$name} ||= undef; ref($opts{$name}) ? $opts{$name} : \$opts{$name}; }, } qw(port=s path=s interval=i log-file=s pid-file=s signal-on-hup=s signal-on-term=s status-file=s restart help version), ) or exit 1; pod2usage( -exitval => 0, -verbose => 1, ) if $opts{help}; if ($opts{version}) { print "$Server::Starter::VERSION\n"; exit 0; } if ($opts{restart}) { restart_server(%opts); exit 0; } # validate options die "server program not specified\n" unless @ARGV; start_server( %opts, exec => \@ARGV, ); __END__ =head1 NAME start_server - a superdaemon for hot-deploying server programs =head1 SYNOPSIS start_server [options] -- server-prog server-arg1 server-arg2 ... # start Plack using Starlet listening at TCP port 8000 start_server --port=8000 -- plackup -s Starlet --max-workers=100 index.psgi =head1 DESCRIPTION This script is a frontend of L. For more information please refer to the documentation of the module. =head1 OPTIONS =head2 --port=(port|host:port) TCP port to listen to (if omitted, will not bind to any ports) =head2 --path=path path at where to listen using unix socket (optional) =head2 --interval=seconds minimum interval to respawn the server program (default: 1) =head2 --signal-on-hup=SIGNAL name of the signal to be sent to the server process when start_server receives a SIGHUP (default: SIGTERM). If you use this option, be sure to also use C<--signal-on-term> below. =head2 --signal-on-term=SIGNAL name of the signal to be sent to the server process when start_server receives a SIGTERM (default: SIGTERM) =head2 --pid-file=filename if set, writes the process id of the start_server process to the file =head2 --status-file=filename if set, writes the status of the server process(es) to the file =head2 --restart this is a wrapper command that reads the pid of the start_server process from --pid-file, sends SIGHUP to the process and waits until the server(s) of the older generation(s) die by monitoring the contents of the --status-file =head2 --help prints this help =head2 --version prints the version number =head1 AUTHOR Kazuho Oku =head1 SEE ALSO L =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut perl-Server-Starter-0.12/t/000075500000000000000000000000001203024602100155135ustar00rootroot00000000000000perl-Server-Starter-0.12/t/00-base.t000064400000000000000000000001401203024602100170220ustar00rootroot00000000000000use strict; use warnings; use Test::More tests => 1; BEGIN { use_ok('Server::Starter'); } perl-Server-Starter-0.12/t/01-starter-echod.pl000075500000000000000000000012601203024602100210340ustar00rootroot00000000000000#! /usr/bin/perl use strict; use warnings; use lib qw(blib/lib lib); use IO::Socket::INET; use Server::Starter qw(server_ports); my $sigfn = shift @ARGV; open my $sigfh, '>', $sigfn or die "could not open file:$sigfn:$!"; $SIG{TERM} = $SIG{USR1} = sub { my $signame = shift; print $sigfh $signame; sleep 2; exit 0; }; my $listener = IO::Socket::INET->new( Proto => 'tcp', ); $listener->fdopen((values %{server_ports()})[0], 'w') or die "failed to bind listening socket:$!"; while (1) { if (my $conn = $listener->accept) { my $buf; while ($conn->sysread($buf, 1048576) > 0) { $conn->syswrite("$$:$buf"); } } } perl-Server-Starter-0.12/t/01-starter.t000064400000000000000000000050501203024602100176020ustar00rootroot00000000000000use strict; use warnings; use File::Temp (); use Test::TCP; use Test::More tests => 28; use Server::Starter qw(start_server); $SIG{PIPE} = sub {}; my $tempdir = File::Temp::tempdir(CLEANUP => 1); for my $signal_on_hup ('TERM', 'USR1') { test_tcp( server => sub { my $port = shift; start_server( port => $port, exec => [ $^X, qw(t/01-starter-echod.pl), "$tempdir/signame", ], status_file => "$tempdir/status", ($signal_on_hup ne 'TERM' ? (signal_on_hup => $signal_on_hup) : ()), ); }, client => sub { my ($port, $server_pid) = @_; my $buf; #sleep 1; my $sock = IO::Socket::INET->new( PeerAddr => "127.0.0.1:$port", Proto => 'tcp', ); ok($sock, 'connect'); # check response and get pid is($sock->syswrite("hello"), 5, 'write'); ok($sock->sysread($buf, 1048576), 'read'); undef $sock; like($buf, qr/^\d+:hello$/, 'read'); $buf =~ /^(\d+):/; my $worker_pid = $1; # switch to next gen sleep 2; my $status = get_status(); like(get_status(), qr/^1:\d+\n$/s, 'status before restart'); kill 'HUP', $server_pid; sleep 3; like(get_status(), qr/^1:\d+\n2:\d+$/s, 'status during restart'); sleep 2; like(get_status(), qr/^2:\d+\n$/s, 'status after restart'); is( do { open my $fh, '<', "$tempdir/signame" or die $!; <$fh>; }, $signal_on_hup, 'signal sent on hup', ); $sock = IO::Socket::INET->new( PeerAddr => "127.0.0.1:$port", Proto => 'tcp', ); ok($sock, 'reconnect'); is($sock->syswrite("hello"), 5, 'write after switching'); ok($sock->sysread($buf, 1048576), 'read after switching'); like($buf, qr/^\d+:hello$/, 'read after swiching (format)'); isnt($buf, "$worker_pid:hello", 'pid should have changed'); }, ); ok ! -e "$tempdir/status", 'no more status file'; } sub get_status { open my $fh, '<', "$tempdir/status" or die "failed to open file:$tempdir/status:$!"; do { undef $/; <$fh> }; } perl-Server-Starter-0.12/t/02-startfail-server.pl000075500000000000000000000010531203024602100215660ustar00rootroot00000000000000#! /usr/bin/perl use strict; use warnings; use lib qw(blib/lib lib); use IO::Socket::INET; use Server::Starter qw(server_ports); $SIG{TERM} = sub { exit 0; }; my $gen = $ENV{SERVER_STARTER_GENERATION}; if ($gen == 1 || 3 <= $gen && $gen < 5) { # emulate startup failure exit 1; } my $listener = IO::Socket::INET->new( Proto => 'tcp', ); $listener->fdopen((values %{server_ports()})[0], 'w') or die "failed to bind listening socket:$!"; while (1) { if (my $conn = $listener->accept) { $conn->syswrite($gen); } } perl-Server-Starter-0.12/t/02-startfail.t000064400000000000000000000031461203024602100201140ustar00rootroot00000000000000use strict; use warnings; use Test::TCP; use Test::More tests => 9; use Server::Starter qw(start_server); test_tcp( server => sub { my $port = shift; start_server( port => $port, exec => [ $^X, qw(t/02-startfail-server.pl) ], ); }, client => sub { my ($port, $server_pid) = @_; my $buf; sleep 3; { my $sock = IO::Socket::INET->new( PeerAddr => "127.0.0.1:$port", Proto => 'tcp', ); ok($sock, 'connect'); # check generation ok($sock->sysread($buf, 1048576), 'read'); is($buf, 2, 'check generation'); } # request restart, that will fail kill 'HUP', $server_pid; sleep 1; { my $sock = IO::Socket::INET->new( PeerAddr => "127.0.0.1:$port", Proto => 'tcp', ); ok($sock, 'connect'); ok( $sock->sysread($buf, 1048576), 'read while worker is failing to reboot', ); is($buf, 2, 'check generation'); } # wait until server succeds in reboot sleep 5; { my $sock = IO::Socket::INET->new( PeerAddr => "127.0.0.1:$port", Proto => 'tcp', ); ok($sock, 'connect'); ok( $sock->sysread($buf, 1048576), 'read after worker succeeds to reboot', ); is($buf, 5, 'check generation'); } }, ); perl-Server-Starter-0.12/t/03-starter-unix-echod.pl000064400000000000000000000007451203024602100220230ustar00rootroot00000000000000#! /usr/bin/perl use strict; use warnings; use lib qw(blib/lib lib); use IO::Socket::UNIX; use Server::Starter qw(server_ports); my $listener = IO::Socket::UNIX->new() or die "failed to create unix socket:$!"; $listener->fdopen((values %{server_ports()})[0], 'w') or die "failde to bind to listening socket:$!"; while (1) { if (my $conn = $listener->accept) { while ($conn->sysread(my $buf, 1048576) > 0) { $conn->syswrite($buf); } } } perl-Server-Starter-0.12/t/03-starter-unix.t000064400000000000000000000015561203024602100205740ustar00rootroot00000000000000use strict; use warnings; use File::Temp (); use IO::Socket::UNIX; use Test::More tests => 4; use Test::SharedFork; use Server::Starter qw(start_server); $SIG{PIPE} = sub {}; my $sockfile = File::Temp::tmpnam(); my $pid = fork; die "fork failed: $!" unless defined $pid; if ($pid == 0) { # child start_server( path => $sockfile, exec => [ $^X, qw(t/03-starter-unix-echod.pl) ], ); exit 0; } else { # parent sleep 1 until -e $sockfile; my $sock = IO::Socket::UNIX->new( Peer => $sockfile, ) or die "failed to connect to unix socket:$!"; is $sock->syswrite('hello', 5), 5, 'write'; is $sock->sysread(my $buf, 5), 5, 'read length'; is $buf, 'hello', 'read data'; kill 'TERM', $pid; while (wait != $pid) {} ok ! -e $sockfile, 'socket file removed after shutdown'; } unlink $sockfile;