view release on metacpan or  search on metacpan

lib/App/Base/Daemon/Supervisor.pm  view on Meta::CPAN

code inside.

=cut

requires 'supervised_shutdown';

=head1 ATTRIBUTES

=cut

=head2 is_supervisor

returns true inside supervisor process and false inside supervised daemon

=cut

has is_supervisor => (
    is      => 'rw',
    default => 1,
);

=head2 delay_before_respawn

how long supervisor should wait after child process exited before starting a
new child. Default value is 5.

=cut

has delay_before_respawn => (
    is      => 'rw',
    default => 5,
);

=head2 supervisor_pipe

File descriptor of the pipe to supervisor

=cut

has supervisor_pipe => (
    is     => 'rw',
    writer => '_supervisor_pipe',
);

has _child_pid => (is => 'rw');

=head1 METHODS

=cut

=head2 $self->ping_supervisor

Should only be called from supervised process. Checks if supervisor is alive
and initiates shutdown if it is not.

=cut

sub ping_supervisor {
    my $self = shift;
    my $pipe = $self->supervisor_pipe or $self->error("Supervisor pipe is not defined");
    say $pipe "ping";
    my $pong = <$pipe>;
    unless (defined $pong) {
        $self->error("Error reading from supervisor pipe: $!");
    }
    return;
}

=head2 $self->ready_to_take_over

Used to support hot reloading. If daemon support hot restart,
I<supervised_process> is called while the old daemon is still running.
I<supervised_process> should perform initialization, e.g. open listening
sockets, and then call this method. Method will cause termination of old daemon
and after return the new process may start serving clients.

=cut

sub ready_to_take_over {
    my $self = shift;
    my $pipe = $self->supervisor_pipe or die "Supervisor pipe is not defined";
    say $pipe "takeover";
    my $ok = <$pipe>;
    defined($ok) or $self->error("Failed to take over");
    return;
}

=head2 $self->daemon_run

See L<App::Base::Daemon>

=cut

sub daemon_run {
    my $self = shift;
    $self->_set_hot_reload_handler;

    while (1) {
        socketpair my $chld, my $par, Socket::AF_UNIX, Socket::SOCK_STREAM, Socket::PF_UNSPEC;
        my $pid = fork;
        $self->_child_pid($pid);
        if ($pid) {
            local $SIG{QUIT} = sub {
                kill TERM => $pid;
                waitpid $pid, 0;
                exit 0;
            };
            $chld->close;
            $par->autoflush(1);
            $self->_supervisor_pipe($par);
            while (local $_ = <$par>) {
                chomp;
                if ($_ eq 'ping') {
                    say $par 'pong';
                } elsif ($_ eq 'takeover') {
                    $self->_control_takeover;
                    say $par 'ok';
                } elsif ($_ eq 'shutdown') {
                    kill KILL => $pid;
                    close $par;
                } else {
                    warn("Received unknown command from the supervised process: $_") unless $self->getOption('no-warn');
                }
            }
            my $kid = waitpid $pid, 0;
            warn("Supervised process $kid exited with status $?") unless $self->getOption('no-warn');
        } elsif (not defined $pid) {
            warn("Couldn't fork: $!") unless $self->getOption('no-warn');
        } else {
            local $SIG{USR2};
            $par->close;
            $chld->autoflush(1);
            $self->_supervisor_pipe($chld);
            $self->is_supervisor(0);
            $self->supervised_process;
            exit 0;
        }
        Time::HiRes::usleep(1_000_000 * $self->delay_before_respawn);
    }

    # for critic
    return;
}

# this initializes SIGUSR2 handler to perform hot reload
sub _set_hot_reload_handler {
    my $self = shift;

    return unless $self->can_do_hot_reload;
    my $upgrading;

    ## no critic (RequireLocalizedPunctuationVars)
    $SIG{USR2} = sub {
        return unless $ENV{APP_BASE_DAEMON_PID} == $$;
        if ($upgrading) {
            warn("Received USR2, but hot reload is already in progress") unless $self->getOption('no-warn');
            return;
        }
        warn("Received USR2, initiating hot reload") unless $self->getOption('no-warn');
        my $pid;
        unless (defined($pid = fork)) {
            warn("Could not fork, cancelling reload") unless $self->getOption('no-warn');
        }
        unless ($pid) {
            exec($ENV{APP_BASE_SCRIPT_EXE}, @{$self->{orig_args}})
                or $self->error("Couldn't exec: $!");
        }
        $upgrading = time;
        if ($SIG{ALRM}) {
            warn("ALRM handler is already defined!") unless $self->getOption('no-warn');
        }
        $SIG{ALRM} = sub {
            warn("Hot reloading timed out, cancelling") unless $self->getOption('no-warn');
            kill KILL => $pid;
            undef $upgrading;
        };
        alarm 60;