Trying to exit an HTTP::Daemon based on JSON::RPC::Server::Daemon

First of all, please edit any code that you copy so that it includes only the minimal amount of material necessary to illustrate your point. (If you copied it from another, well-known source such as a CPAN module, please cite the module ... we can find it ourselves if we need to).

You can see from the referenced code that the receipt of a signal ought to merely cause a flag (e.g. $exit_now) to become true, and to wake up the process or thread to wake up if it is sleeping. This causes it to promptly exit from the while loop that it is parked in. The thread should then clean up its own affairs neatly, and exit normally. (If necessary, it can issue some signal or send some message to its parent before it dies.)

Also notice that “it is best to wake somebody up using an alarm clock, not a loaded pistol.” Certain signals, such as KILL, have specific meaning to the operating system. You do not want the OS to be the one who’s reacting to the signal that you give. You want the recipient to kill itself, not to “be killed.”

Finally, you want to be certain that the termination signal is handled “gracefully and cleanly,” and always at an appropriate point in the recipient’s normal business day. (If you shoot somebody in the head, you’re going to leave blood-n-guts on the floor ... and that is, y’know, very hard to clean.)

If you are, say, already using message-queues to talk between a set of processes or threads, simply design one of those messages to be “the mark of death.” Upon receipt of this special message, the thread breaks out of its message-handling loop, closes its side of the message-queue etc., and dies quietly. The sender of the message knows that any messages that might have been in the queue ahead of the “mark of death” message, will have been processed normally, as well. The “mark of death” message is an upleasant surprise, but like all other messages it is processed synchronously.

As a final matter of principle, you really want this sort of thing to only be happening when the program is closing down ... not as a regular part of the program’s daily routine. If the number of threads is kept sensibly small, any one of them can wait, even for many hours, with almost no overhead at all. A single thread might handle thousands of units-of-work during the course of its lifetime.

=begin nd
Provided an alternate version of JSON::RPC::Server::Daemon that can be
+ inturpted
using signals.
=cut
package JSON::RPC::Server::AltDaemon;
use strict;

use JSON::RPC::Server; # for old Perl 5.005
use base qw(JSON::RPC::Server);

$JSON::RPC::Server::AltDaemon::VERSION = '0.03';

use Data::Dumper;


=begin nd
Create a new instance of JSON::RPC::Server::Daemon::Alt

@param  $class      ref     Object reference/static class
@param  %args       hash    Arguments (timeout => '10')
@return undef
=cut
sub new {
    my $class = shift;
    my %args  = @_;
    my $self  = $class->SUPER::new();
    my $pkg;

    if(  grep { $_ =~ /^SSL_/ } @_ ){
        $self->{_daemon_pkg} = $pkg = 'HTTP::Daemon::SSL';
    }
    else{
        $self->{_daemon_pkg} = $pkg = 'HTTP::Daemon';
    }
    eval qq| require $pkg; |;
    if($@){ die $@ }

    $self->{_daemon} ||= $pkg->new(@_) or die;
    $self->{__timeout} = delete $args{timeout} || 10;
    return $self;
}

=begin nd
Starts the server

@param  $self       ref     Object reference/static class
@param  %args       hash    Arguments (signal => 'INT')
@return undef
=cut
sub handle {
    my $self = shift;
    my %args  = @_;
    my $d    = $self->{_daemon} ||= $self->{_daemon_pkg}->new(@_) or d
+ie;

    # Localize and set the signal handler as an exit route
    my @exit_signals;

    if (exists $args{signal} and $args{signal} ne 'NONE')
    {
        @exit_signals =
            (ref $args{signal}) ? @{$args{signal}} : $args{signal}
    }
    else
    {
        push @exit_signals, 'INT';
    }
    my $exit_now;
    local @SIG{@exit_signals} = (sub { $exit_now++;});

    my $timeout = $d->timeout(1);
    while (! $exit_now) {
        my $c = $d->accept;

        if ($exit_now) {
            last;
        }
        if (! $c) {
            next;
        }
        $c->timeout($self->timeout);

        $self->{con} = $c;
        while (my $r = $c->get_request) {
            $self->request($r);
            $self->path_info($r->url->path);
            $self->SUPER::handle();
            last;
        }
        $c->close;
        undef $c;
    }
    return;
}

sub retrieve_json_from_post {
    return $_[0]->request->content;
}


sub retrieve_json_from_get {
}


sub response {
    my ($self, $response) = @_;
    $self->{con}->send_response($response);
}

=begin nd
This sets the timeout for processing connections after a new connectio
+n has been accepted.
It returns the old timeout value.  If you pass in no value, it returns
+ the current timeout.

@param  $self       ref     Object reference/static class
@param  $timeout    int     New timeout value
@return integer     Current timeout value
=cut
sub timeout {
    my ($self, $timeout) = @_;
    my $old_timeout = $self->{__timeout};
    if ($timeout) {
        $self->{__timeout} = $timeout;
    }
    return $old_timeout;
}

1;
[download]

[reply]
[d/l]

$svr->handle(signal => 'KILL');
[download]

That seems an awful lot like wishful thinking, please see the signal section of threads

I have a similar app based on RPC::XML::Server that works this way. It too relies on HTTP::Daemon so I know its possible.

Great, maybe you can view the source to see how it works :)

[reply]
[d/l]

package JSON::RPC::Server::Daemon;

use strict;
use JSON::RPC::Server; # for old Perl 5.005
use base qw(JSON::RPC::Server);

$JSON::RPC::Server::Daemon::VERSION = '0.03';

use Data::Dumper;

sub new {
    my $class = shift;
    my $self  = $class->SUPER::new();
    my $pkg;

    if(  grep { $_ =~ /^SSL_/ } @_ ){
        $self->{_daemon_pkg} = $pkg = 'HTTP::Daemon::SSL';
    }
    else{
        $self->{_daemon_pkg} = $pkg = 'HTTP::Daemon';
    }
    eval qq| require $pkg; |;
    if($@){ die $@ }

    $self->{_daemon} ||= $pkg->new(@_) or die;

    return $self;
}


sub handle {
    my $self = shift;
    my %opt  = @_;
    my $d    = $self->{_daemon} ||= $self->{_daemon_pkg}->new(@_) or d
+ie;

    while (my $c = $d->accept) {
        $self->{con} = $c;
        while (my $r = $c->get_request) {
            $self->request($r);
            $self->path_info($r->url->path);
            $self->SUPER::handle();
            last;
        }
        $c->close;
    }

}
[download]

package RPC::XML::Server;

use 5.006001;
use strict;
use warnings;
use vars qw($VERSION @ISA $INSTANCE $INSTALL_DIR %FAULT_TABLE  @XPL_PA
+TH
            $IO_SOCKET_SSL_HACK_NEEDED $COMPRESSION_AVAILABLE);

use Carp qw(carp croak);
use AutoLoader 'AUTOLOAD';
use File::Spec;
use IO::Handle;

use HTTP::Status;
use HTTP::Response;
use URI;
use Scalar::Util 'blessed';

use RPC::XML;
use RPC::XML::ParserFactory;
use RPC::XML::Procedure;

....

sub new ## no critic (ProhibitExcessComplexity)
{
    my ($class, %args) = @_;

    my (
        $self,     $http,        $resp, $host,
        $port,     $queue,       $path, $URI,
        $srv_name, $srv_version, $timeout
    );

    $class = ref($class) || $class;
    $self = bless {}, $class;

    $srv_version = delete $args{server_version} || $self->version;
    $srv_name    = delete $args{server_name}    || $class;
    $self->{__version} = "$srv_name/$srv_version";

    if (delete $args{no_http})
    {
        $self->{__host} = delete $args{host} || q{};
        $self->{__port} = delete $args{port} || q{};
    }
    else
    {
        require HTTP::Daemon;

        $host  = delete $args{host}  || q{};
        $port  = delete $args{port}  || q{};
        $queue = delete $args{queue} || 5;
        $http  = HTTP::Daemon->new(
            Reuse => 1,
            ($host  ? (LocalHost => $host)  : ()),
            ($port  ? (LocalPort => $port)  : ()),
            ($queue ? (Listen    => $queue) : ())
        );
        if (! $http)
        {
            return "${class}::new: Unable to create HTTP::Daemon objec
+t";
        }
        $URI              = URI->new($http->url);
        $self->{__host}   = $URI->host;
        $self->{__port}   = $URI->port;
        $self->{__daemon} = $http;
    }

    # Create and store the cached response object for later cloning an
+d use
    $resp = HTTP::Response->new();
    if (! $resp)
    {
        return "${class}::new: Unable to create HTTP::Response object"
+;
    }

    $resp->header(    # This is essentially the same string returned b
+y the
                      # default "identity" method that may be loaded f
+rom a
                      # XPL file. But it hasn't been loaded yet, and m
+ay not
                      # be, hence we set it here (possibly from option
+ values)
        RPC_Server   => $self->{__version},
        RPC_Encoding => 'XML-RPC',
        # Set any other headers as well
        Accept => 'text/xml'
    );
    $resp->content_type('text/xml');
    $resp->code(RC_OK);
    $resp->message('OK');
    $self->{__response} = $resp;

    # Basic (scalar) properties
    $self->{__path}         = delete $args{path} || q{};
    $self->{__started}      = 0;
    $self->{__method_table} = {};
    $self->{__requests}     = 0;
    $self->{__auto_methods} = delete $args{auto_methods} || 0;
    $self->{__auto_updates} = delete $args{auto_updates} || 0;
    $self->{__debug}        = delete $args{debug} || 0;
    $self->{__xpl_path}     = delete $args{xpl_path} || [];
    $self->{__timeout}      = delete $args{timeout} || 10;
    $self->{__parser}       = RPC::XML::ParserFactory->new(
        $args{parser} ? @{delete $args{parser}} : ());

    # Set up the default methods unless requested not to
    if (! delete $args{no_default})
    {
        $self->add_default_methods;
    }

    # Compression support
    $self->{__compress} = q{};
    if (delete $args{no_compress})
    {
        $self->{__compress} = q{};
    }
    else
    {
        $self->{__compress} = $COMPRESSION_AVAILABLE;
        # Add some more headers to the default response object for com
+pression.
        # It looks wasteful to keep using the hash key, but it makes i
+t easier
        # to change the string in just one place (above) if I have to.
        if ($self->{__compress})
        {
            $resp->header(Accept_Encoding => $self->{__compress});
        }
        $self->{__compress_thresh} = delete $args{compress_thresh} || 
+4096;
        # Yes, I know this is redundant. It's for future expansion/fle
+xibility.
        $self->{__compress_re} =
            $self->{__compress} ? qr/$self->{__compress}/ : qr/deflate
+/;
    }

    # Parameters to control the point at which messages are shunted to
+ temp
    # files due to size, and where to home the temp files. Start with 
+a size
    # threshhold of 1Meg and no specific dir (which will fall-through 
+to the
    # tmpdir() method of File::Spec).
    $self->{__message_file_thresh} = delete $args{message_file_thresh}
+ ||
        1_048_576;
    $self->{__message_temp_dir} = delete $args{message_temp_dir} || q{
+};

    # Set up the table of response codes/messages that will be used wh
+en the
    # server is sending a controlled error message to a client (as opp
+osed to
    # something HTTP-level that is less within our control).
    $self->{__fault_table} = {%FAULT_TABLE};
    if ($args{fault_code_base})
    {
        my $base = delete $args{fault_code_base};
        # Apply the numerical offset to all (current) error codes
        for my $key (keys %{$self->{__fault_table}})
        {
            if (ref($self->{__fault_table}->{$key}))
            {
                # A ref is a listref where the first element is the co
+de
                $self->{__fault_table}->{$key}->[0] += $base;
            }
            else
            {
                $self->{__fault_table}->{$key} += $base;
            }
        }
    }
    if ($args{fault_table})
    {
        my $local_table = delete $args{fault_table};
        # Merge any data from this table into the object's fault-table
        for my $key (keys %{$local_table})
        {
            $self->{__fault_table}->{$key} = (ref $local_table->{$key}
+) ?
                [ @{$local_table->{$key}} ] : $local_table->{$key};
        }
    }

    # Copy the remaining args over untouched
    for (keys %args)
    {
        $self->{$_} = $args{$_};
    }

    return $self;
}

...

######################################################################
+#########
#
#   Sub Name:       server_loop
#
#   Description:    Enter a server-loop situation, using the accept() 
+loop of
#                   HTTP::Daemon if $self has such an object, or falli
+ng back
#                   Net::Server otherwise.
#
#                   The critic disabling is because we may manipulate 
+@_
#                   when using Net::Server.
#
#   Arguments:      NAME      IN/OUT  TYPE      DESCRIPTION
#                   $self     in      ref       Object of this class
#                   %args     in      hash      Additional parameters 
+to set up
#                                                 before calling the s
+uperclass
#                                                 Run method
#
#   Returns:        string if error, otherwise void
#
######################################################################
+#########
sub server_loop ## no critic (RequireArgUnpacking,ProhibitExcessComple
+xity)
{
    my $self = shift;

    if ($self->{__daemon})
    {
        my ($conn, $req, $resp, $reqxml, $respxml, $exit_now, $timeout
+);

        my %args = @_;

        # Localize and set the signal handler as an exit route
        my @exit_signals;

        if (exists $args{signal} and $args{signal} ne 'NONE')
        {
            @exit_signals =
                (ref $args{signal}) ? @{$args{signal}} : $args{signal}
+;
        }
        else
        {
            push @exit_signals, 'INT';
        }

        local @SIG{@exit_signals} = (sub { $exit_now++ }) x @exit_sign
+als;

        $self->started('set');
        $exit_now = 0;
        $timeout  = $self->{__daemon}->timeout(1);
        while (! $exit_now)
        {
            $conn = $self->{__daemon}->accept;

            if ($exit_now)
            {
                last;
            }
            if (! $conn)
            {
                next;
            }
            $conn->timeout($self->timeout);
            $self->process_request($conn);
            $conn->close;
            undef $conn;    # Free up any lingering resources
        }

        if (defined $timeout)
        {
            $self->{__daemon}->timeout($timeout);
        }
    }
    else
    {
        # This is the Net::Server block, but for now HTTP::Daemon is n
+eeded
        # for the code that converts socket data to a HTTP::Request ob
+ject
        require HTTP::Daemon;

        my $conf_file_flag = 0;
        my $port_flag      = 0;
        my $host_flag      = 0;

        # Disable critic on the C-style for-loop because we need to st
+ep by
        # 2 as we check for Net::Server arguments...
        for (my $i = 0; $i < @_; $i += 2) ## no critic (ProhibitCStyle
+ForLoops)
        {
            if ($_[$i] eq 'conf_file') { $conf_file_flag = 1; }
            if ($_[$i] eq 'port')      { $port_flag      = 1; }
            if ($_[$i] eq 'host')      { $host_flag      = 1; }
        }

        # An explicitly-given conf-file trumps any specified at creati
+on
        if (exists($self->{conf_file}) and (!$conf_file_flag))
        {
            push @_, 'conf_file', $self->{conf_file};
            $conf_file_flag = 1;
        }

        # Don't do this next part if they've already given a port, or 
+are
        # pointing to a config file:
        if (! ($conf_file_flag || $port_flag))
        {
            push @_, 'port', $self->{port} || $self->port || 9000;
            push @_, 'host', $self->{host} || $self->host || q{*};
        }

        # Try to load the Net::Server::MultiType module
        if (! eval { require Net::Server::MultiType; 1; })
        {
            if ($@)
            {
                return ref($self) .
                    "::server_loop: Error loading Net::Server::MultiTy
+pe: $@";
            }
        }
        unshift @RPC::XML::Server::ISA, 'Net::Server::MultiType';

        $self->started('set');
        # ...and we're off!
        $self->run(@_);
    }

    return;
}
[download]

[reply]
[d/l]
[select]

I think that is somehow setting signal handlers in the server_loop function?

Yes, the only way to set signal handlers is to assign to %SIG. threads explains about threads and signaling, perlipc explains more.

[reply]


Welcome to the Monastery
	PerlMonks