package IPC::Manager::Role::Service;
use strict;
use warnings;

our $VERSION = '0.000037';

# Not included in role:
use Carp qw/croak/;
use POSIX qw/:sys_wait_h/;
use List::Util qw/any/;
use Time::HiRes qw/time/;
use Test2::Util::UUID qw/gen_uuid/;

use IPC::Manager::Service::Handle();
use IPC::Manager::Service::Peer();

use Role::Tiny;

with 'IPC::Manager::Role::Service::Select';
with 'IPC::Manager::Role::Service::Requests';

# Included in role:
use IPC::Manager::Util qw/pid_is_running tinysleep/;

requires qw{
    new
    orig_io
    name
    run
    ipcm_info
    pid
    set_pid
    watch_pids
    handle_request
};

sub cycle                  { 0.2 }
sub interval               { 0.2 }
sub use_posix_exit         { 0 }
sub intercept_errors       { 0 }
sub expose_error_details   { 0 }
sub run_returns_to_caller  { 0 }

sub terminated    { $_[0]->{_TERMINATED} }
sub is_terminated { defined $_[0]->{_TERMINATED} ? 1 : 0 }
sub terminate     { $_[0]->{_TERMINATED} ||= pop if @_ > 1; $_[0]->{_TERMINATED} //= 0 }

sub peer_class   { 'IPC::Manager::Service::Peer' }
sub handle_class { 'IPC::Manager::Service::Handle' }

sub signals_to_grab { () }

sub redirect       { }
sub pre_fork_hook  { }
sub post_fork_hook { }

sub run_on_all             { }
sub run_on_cleanup         { }
sub run_on_general_message { }
sub run_on_interval        { }
sub run_on_peer_delta      { }
sub run_on_pid             { }
sub run_on_sig             { }
sub run_on_start           { }
sub run_should_end         { }

sub run_on_unhandled {
    my $self = shift;
    my ($activity) = @_;

    my @unhandled = keys %$activity;
    return unless @unhandled;

    die "Failed to handle activity: " . join(", " => @unhandled);
}

#<<<    Do not tidy this
sub _run_on_all        { my ($self, @args) = @_; $self->try(sub { $self->run_on_all(@args)        }) }
sub _run_on_cleanup    { my ($self, @args) = @_; $self->try(sub { $self->run_on_cleanup(@args)    }) }
sub _run_on_interval   { my ($self, @args) = @_; $self->try(sub { $self->run_on_interval(@args)   }) }
sub _run_on_message    { my ($self, @args) = @_; $self->try(sub { $self->run_on_message(@args)    }) }
sub _run_on_peer_delta { my ($self, @args) = @_; $self->try(sub { $self->run_on_peer_delta(@args) }) }
sub _run_on_pid        { my ($self, @args) = @_; $self->try(sub { $self->run_on_pid(@args)        }) }
sub _run_on_sig        { my ($self, @args) = @_; $self->try(sub { $self->run_on_sig(@args)        }) }
sub _run_on_start      { my ($self, @args) = @_; $self->try(sub { $self->run_on_start(@args)      }) }
sub _run_on_unhandled  { my ($self, @args) = @_; $self->try(sub { $self->run_on_unhandled(@args)  }) }
sub _run_should_end    { my ($self, @args) = @_; $self->try(sub { $self->run_should_end(@args)    }) }
#>>>

sub clear_service_fields {
    my $self = shift;

    $self->clear_serviceselect_fields;
    $self->clear_servicerequests_fields();

    delete $self->{_CLIENT};
    delete $self->{_LAST_INTERVAL};
    delete $self->{_ORIG_SIG};
    delete $self->{_PEER_CACHE};
    delete $self->{_PEER_STATE};
    delete $self->{_SIGS_SEEN};
    delete $self->{_TERMINATED};
    delete $self->{_WORKERS};
}

sub register_worker {
    my $self = shift;
    my ($name, $pid) = @_;

    $self->{_WORKERS}->{$pid} = $name;
}

sub workers {
    my $self = shift;
    return $self->{_WORKERS};
}

sub terminate_workers {
    my $self = shift;

    my $workers = $self->{_WORKERS} or return;

    $self->reap_workers(kill => 'TERM');

    my $start = time;
    while (keys %$workers) {
        my $kill;
        if (time - $start > 15) {
            $kill = 'KILL';
            $start = time;
        }

        $self->reap_workers(kill => $kill);
        tinysleep(0.05) if keys %$workers;
    }
}

sub reap_workers {
    my $self = shift;
    my %params = @_;

    my $workers = $self->{_WORKERS} or return;

    my %out;
    for my $pid (keys %$workers) {
        local $?;
        my $check = waitpid($pid, WNOHANG);
        my $exit = $?;

        unless ($check) {
            kill($params{kill}, $pid) if $params{kill};
            next;
        }

        my $name = delete $workers->{$pid};

        if ($check == $pid) {
            $out{$pid} = {name => $name, exit => $exit};
        }
        elsif ($check < 0) {
            $out{$pid} = {name => $name, exit => $check};
        }
        else {
            die "Nonsensical return from waitpid";
        }
    }

    return \%out;
}

sub reap_children {
    my $self = shift;
    local $?;

    my $workers = $self->{_WORKERS};
    my %pids;

    while (1) {
        my $pid = waitpid(-1, WNOHANG);
        last if $pid == 0 || $pid == -1;

        my $exit = $?;

        if ($workers && exists $workers->{$pid}) {
            delete $workers->{$pid};
            next;
        }

        $pids{$pid} = $exit;
    }

    return \%pids;
}

sub run_on_message {
    my $self = shift;
    my ($msg) = @_;

    my $c = $msg->content;

    if (ref($c) eq 'HASH') {
        return $self->run_on_request_message($msg)  if $c->{ipcm_request_id};
        return $self->run_on_response_message($msg) if $c->{ipcm_response_id};
    }

    return $self->run_on_general_message($msg);
}

sub run_on_response_message {
    my $self = shift;
    my ($msg) = @_;

    my $resp = $msg->content;
    $self->handle_response($resp, $msg);

    return;
}

sub send_response {
    my $self = shift;
    my ($peer, $id, $resp, $error) = @_;

    my %payload = (
        ipcm_response_id => $id,
        response         => $resp,
    );

    $payload{ipcm_error} = $error if defined $error;

    # Inside a service the client is non-blocking. send_message
    # honors send_blocking and dispatches through the outbox; the
    # event loop drains. No call site needs to know which mode the
    # client is in.
    $self->client->send_message($peer, \%payload);
}

sub run_on_request_message {
    my $self = shift;
    my ($msg) = @_;

    my $peer = $msg->from;
    my $req  = $msg->content;

    # return empty list to not send a response yet.
    # return one item (can be undef, 0, '', or any other value)
    my (@resp, $err);
    {
        local $@;
        eval { @resp = $self->handle_request($req, $msg); 1 } or $err = $@ || "There was an error: $@";
    }

    if (defined $err) {
        my $error_message = $self->expose_error_details
            ? "$err"
            : "Internal service error";

        $self->send_response($peer, $req->{ipcm_request_id}, undef, $error_message);
        return;
    }

    return unless @resp;
    croak "Incorrect number of responses to request" if @resp != 1;

    $self->send_response($peer, $req->{ipcm_request_id}, $resp[0]);

    return;
}

sub client {
    return $_[0]->{_CLIENT} if $_[0]->{_CLIENT};
    require IPC::Manager;
    return $_[0]->{_CLIENT} = IPC::Manager->connect($_[0]->name, $_[0]->ipcm_info);
}

sub in_correct_pid {
    my $self = shift;
    my $pid  = $self->pid;
    croak "Incorrect PID (did your fork leak? $$ vs $pid)" unless $$ == $pid;
}

sub debug {
    my $self = shift;

    my $io = $self->orig_io;
    my $fh = $io ? $io->{stderr} // $io->{stdout} // \*STDERR : \*STDERR;

    print $fh @_;
}

sub handle {
    my $self = shift;
    my (%params) = @_;

    croak "'name' is a required parameter" unless $params{name};

    return $self->handle_class->new(
        %params,
        service_name => $self->name,
        ipcm_info    => $self->ipcm_info,
    );
}

sub peer {
    my $self = shift;
    my ($name, %params) = @_;

    croak "peer() can only be called on the service in the service process"
        unless $self->pid == $$;

    return $self->{_PEER_CACHE}->{$name} //= $self->peer_class->new(
        %params,

        name      => $name,
        service   => $self,
        ipcm_info => $self->ipcm_info,
    );
}

sub try {
    my $self = shift;
    my ($cb) = @_;

    unless ($self->intercept_errors) {
        my $out = $cb->();
        return {ok => 1, err => '', out => $out};
    }

    my $err;
    {
        local $@;
        my $out;
        if (eval { $out = $cb->(); 1 }) {
            return {ok => 1, err => '', out => $out};
        }
        $err  = $@;
    }

    $self->debug("Peer '" . $self->name . "' caught exception: $err");
    warn $err;

    return {ok => 0, err => $err};
}

sub peer_delta {
    my $self = shift;
    my (%params) = @_;

    my $prev = $self->{_PEER_STATE};
    my $curr = {map {($_ => 1)} $self->client->peers};

    my $delta = { %$curr };
    if ($prev) {
        # Any that exist, and already existed will be set to 0
        # Any that used to exist, but do not now will be set to -1
        # Any that did not exist, but do now will be set to 1
        for my $peer (keys %$prev) {
            $delta->{$peer}--;
            delete $delta->{$peer} unless $delta->{$peer};
        }
    }

    $self->{_PEER_STATE} = $curr unless $params{peek};

    return $delta if keys %$delta;
    return undef;
}

sub select_handles {
    my $self = shift;
    my $client = $self->client;

    my @message_handles = $client->have_handles_for_select      ? $client->handles_for_select      : ();
    my @peer_handles    = $client->have_handles_for_peer_change ? $client->handles_for_peer_change : ();

    return (@message_handles, @peer_handles);
}

sub watch {
    my $self = shift;

    my $sig           = $self->{_SIGS_SEEN} // {};
    my $cycle         = $self->cycle;
    my $client        = $self->client;
    my $interval      = $self->interval;
    my $have_interval = defined $interval;

    my $last_interval = $self->{_LAST_INTERVAL} //= time;

    my $term = $self->terminated;

    while (1) {
        my @messages;
        my %activity;

        my $reaped = $self->reap_children;
        $activity{pids} = $reaped if $reaped && keys %$reaped;

        # Drain any queued outbound messages first; a previous
        # iteration may have left bytes pending and the kernel may
        # have made room while we were not looking.
        $client->drain_pending if $client->have_pending_sends;

        my $select_r = $self->select;
        my $select_w = $self->select_write;    # undef when no backlog

        if ($select_r || $select_w) {
            require IO::Select;
            my ($r, $w) = IO::Select->select($select_r, $select_w, undef, $cycle);

            if ($r && @$r) {
                @messages = $client->get_messages;
                $client->reset_handles_for_peer_change if $client->have_handles_for_peer_change;
            }

            # If any writable handle fired, drain again. This is the
            # portability path: on platforms where the FIFO buffer
            # cannot grow past the kernel default, the loop wakes the
            # moment room appears.
            $client->drain_pending if $w && @$w;
        }
        else {
            @messages = $client->get_messages;
        }

        my $term2 = $self->terminated;
        if (defined($term2) && !(defined($term) && $term == $term2)) {
            $activity{terminated} = {value => $term2};
        }

        $activity{messages} = \@messages if @messages;
        $activity{sigs}     = $sig       if keys %$sig;

        if (my $delta = $self->peer_delta) {
            $activity{peer_delta} = $delta;
        }

        my $now = time;
        if ($now - $last_interval >= $interval) {
            $activity{interval} = 1;

            # This will get reset when we run our callbacks, but put this here as a safety
            $self->{_LAST_INTERVAL} = $now;
        }

        if (my $pids = $self->watch_pids) {
            $activity{pid_watch} = 1 if any { !$self->pid_is_running($_) } @$pids;
        }

        return \%activity if keys %activity;

        tinysleep($cycle) unless $select_r || $select_w;
    }
}

sub run {
    my $self = shift;

    $self->in_correct_pid;

    my %sig_seen;
    $self->{_ORIG_SIG}  = {%SIG};
    $self->{_SIGS_SEEN} = \%sig_seen;

    for my $sig ($self->signals_to_grab) {
        my $key = "$sig";
        $SIG{$key} = sub { $sig_seen{$key}++ };
    }

    my $start_res = $self->_run_on_start();

    # Inside the service event loop, sends never block: the loop
    # drains the outbox each iteration when needed. Clients that do
    # not consume Role::Outbox treat this as a no-op. Done AFTER
    # _run_on_start so startup-time sends keep the simpler
    # synchronous semantics that custom services may depend on.
    $self->client->set_send_blocking(0);

    # If there was an exception on startup we do not keep going
    die "Exception in process startup, aborting" unless $start_res->{ok};

    $self->peer_delta; # Initialize it
    until ($self->is_terminated) {
        my $activity;
        $self->try(sub { $activity = $self->watch(\%sig_seen) })->{ok} or next;
        next unless $activity;

        $self->_run_on_all($activity);

        if (my $sigs = delete $activity->{sigs}) {
            for my $sig (keys %$sigs) {
                my $count = delete $sigs->{$sig} or next;
                $self->_run_on_sig($sig) for $count;
            }
        }

        if (my $pids = delete $activity->{pids}) {
            for my $pid (keys %$pids) {
                $self->_run_on_pid($pid, $pids->{$pid});
            }
        }

        if (delete $activity->{pid_watch}) {
            $self->terminate(0);
            last;
        }

        if (delete $activity->{interval}) {
            $self->_run_on_interval();
            $self->{_LAST_INTERVAL} = time;
        }

        if (my $delta = delete $activity->{peer_delta}) {
            my $client = $self->client;
            for my $peer (keys %$delta) {
                $client->peer_left($peer) if $delta->{$peer} < 0;
            }
            $self->_run_on_peer_delta($delta);
        }

        if (my $msgs = delete $activity->{messages}) {
            for my $msg (@$msgs) {
                $self->terminate(0) if $msg->is_terminate;
                $self->try(sub { $self->_run_on_message($msg) });
            }
        }

        $self->_run_on_unhandled($activity) if keys %$activity;

        $self->terminate(0) if $self->_run_should_end()->{out};
    }

    $self->_run_on_cleanup();

    # Drain any queued outbound IPC sends before terminating
    # workers / returning. Sends queued during the last loop
    # iteration (e.g. the response to a 'terminate' request) must
    # reach the peer before this process exits, or the caller will
    # see 'peer went away while awaiting response'. Loop with a
    # 5-second deadline so a wedged peer cannot wedge our exit.
    {
        my $client   = $self->client;
        my $deadline = time + 5;
        while ($client->have_pending_sends && time < $deadline) {
            $client->drain_pending or last;
            tinysleep(0.01) if $client->have_pending_sends;
        }
    }

    $self->terminate_workers();

    %SIG = %{$self->{_ORIG_SIG}};

    return $self->terminated // 0;
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

IPC::Manager::Role::Service - Role for implementing IPC services with message handling

=head1 DESCRIPTION

This role provides the core functionality for IPC services including:

=over 4

=item Message handling (requests/responses)

=item Peer management and delta detection

=item Signal handling

=item Worker process management

=item Main event loop via the C<run()> method

=back

It composes with L<IPC::Manager::Role::Service::Select> and
L<IPC::Manager::Role::Service::Requests> for I/O multiplexing and request/response
patterns.

=head1 SYNOPSIS

    package MyService;
    use Role::Tiny::With;
    with 'IPC::Manager::Role::Service';

    sub new { ... }

    sub orig_io { ... }

    sub name { ... }

    sub run { ... }

    sub ipcm_info { ... }

    sub pid { ... }

    sub set_pid { ... }

    sub watch_pids { ... }

    sub handle_request { ... }

    1;

=head1 REQUIRED METHODS

These methods must be implemented by the consuming class:

=over 4

=item $inst = $class->new(%params)

Constructor. Must accept parameters for initialization.

=item $io = $self->orig_io()

Returns a hashref with optional C<stdout>, C<stderr>, or C<stdin> filehandles.

=item $string = $self->name()

Returns the service name.

=item $exit = $self->run()

Runs the main event loop. Returns when the service is terminated. Should return
an exit code.

=item $info = $self->ipcm_info()

Returns connection information for the IPC system.

=item $pid = $self->pid()

Returns the process ID the service is supposed to be confined to.

=item $self->set_pid($pid)

Sets the process ID (used after fork).

=item $pids_arrayref = $self->watch_pids()

Returns an arrayref of PIDs to watch. If any terminates, the service exits.

=item ($resp) = $self->handle_request($request, $msg)

Handles an incoming request message.

Should return an empty list if the request is being processed, but no response
is ready.

Should return a single item (undef, scalar, or reference) for a response.

If this returns multiple items an exception will be thrown.

=back

=head1 METHODS

=over 4

=item $self->cycle()

Returns the select cycle time (default: 0.2 seconds).

=item $self->interval()

Returns the interval for C<run_on_interval> callbacks (default: 0.2 seconds).

=item $self->use_posix_exit()

Returns whether to use POSIX exit codes (default: 0).

=item $self->run_returns_to_caller()

When true, C<_ipcm_service> returns to its caller after C<run()> returns rather
than calling C<POSIX::_exit> / C<exit>.  This is meaningful only when the
service was launched via C<exec.stay_in_begin = 1>: in that mode C<_ipcm_service>
is invoked synchronously from inside the boot C<-M> BEGIN hook of the exec'd
perl process, so returning from C<_ipcm_service> lets control propagate back
through C<IPC::Manager::Service::State::import> and out of BEGIN.  Services
that want to drive a BEGIN-time C<goto::file> handoff (e.g. a preload service
that forks a grandchild and then hands the test file off via C<goto::file>)
must override this to return true.  Default is C<0>, which preserves the
existing "always exit after run() returns" behaviour for every other service.

=item $self->intercept_errors()

Returns whether to intercept and log errors (default: 0).

=item $self->expose_error_details()

Returns whether exception text from C<handle_request> should be included in
error responses.  When false (the default), a generic C<"Internal service
error"> message is sent.  When true, the stringified exception is sent as the
C<ipcm_error> value.

=item $val = $self->terminated()

Gets the termination status.

=item $self->is_terminated()

Returns true if the service is terminated.

=item $val = $self->terminate()

=item $val = $self->terminate($val)

Sets the termination status. If no value is provided then C<0> is used. Returns
the new value.

=item $class = $self->peer_class()

Returns the class to use for peer connections (default: C<IPC::Manager::Service::Peer>).

=item $class = $self->handle_class()

Returns the class to use for handles (default: C<IPC::Manager::Service::Handle>).

=item @signal_names = $self->signals_to_grab()

Returns a list of signals to intercept (default: empty).

=item $self->redirect()

Override to redirect I/O. Called during startup. Default implementation is a
no-op.

=item $self->pre_fork_hook()

Override to run code before forking workers. Default implementation is a no-op.

=item $self->post_fork_hook()

Called in the child process after C<ipcm_service> forks but before the service
takes over. Override this to implement a double-fork/daemonize pattern: fork
inside the hook, have the middle process do its work and exit within the hook,
and let the grandchild return from the hook to become the service.

Default implementation is a no-op.

=item $self->run_on_all($activity)

Called for every iteration of the service's main loop.

See the L</"ACTIVITY HASH"> for a description of the C<$activity> input.

=item $self->run_on_cleanup()

Called when the service is shutting down.

=item $self->run_on_general_message($msg)

Called for messages that are not requests or responses.

=item $self->run_on_interval()

Called at regular intervals (controlled by C<interval()>).

=item $self->run_on_peer_delta($delta)

Called when peer connections change. C<$delta> is a hashref showing added/removed peers.

The L</"ACTIVITY HASH"> section shows the structure of the peer_delta as well.

=item $self->run_on_pid($pid, $exit)

Called when a non-worker child process is reaped by C<reap_children> during the
service loop.  C<$pid> is the process ID and C<$exit> is the raw C<$?> value
captured from C<waitpid>.  Worker processes registered via C<register_worker>
are handled internally and do B<not> reach this callback.

=item $self->run_on_sig($sig)

Called when a signal is received. May be called multiple times in rapid
succession in a single loop iteration if a signal is recieved more than once.

=item $self->run_on_start()

Called on startup before the main loop.

=item $self->run_should_end()

Called to determine if the service should exit. Return true to terminate.

=item $self->run_on_unhandled($activity)

Called when activity remains unhandled after processing. Dies by default.

See the L</"ACTIVITY HASH"> for a description of the C<$activity> input.

=item $self->clear_service_fields()

Clears all internal state fields.

=item $self->register_worker($name, $pid)

Registers a worker process.

=item $self->workers()

Returns a hashref of worker PIDs to names.

=item $self->reap_workers()

Reaps terminated worker processes by calling C<waitpid> on each registered
worker PID.  Used by C<terminate_workers> at shutdown; the main service loop
uses C<reap_children> instead.

Returns a hashref of results.

=item $pids = $self->reap_children()

Calls C<waitpid(-1, WNOHANG)> in a loop to reap any ready child process.
For each reaped PID that matches a registered worker the worker is removed
from the internal workers hash.  For any other PID the pair is collected into
a hashref mapping C<< $pid => $exit >> (the raw C<$?> value), which is
returned.  C<$?> is localized so the caller's value is not disturbed.

This is called once per iteration of the service loop and is what feeds the
C<pids> key of the L</"ACTIVITY HASH">.

=item $self->send_response($peer, $id, $resp)

=item $self->send_response($peer, $id, $resp, $error)

Sends a response message to a peer.  If C<$error> is provided, the response
payload includes an C<ipcm_error> key with the error string.

=item $client = $self->client()

Returns the client connection for this service.

=item $self->in_correct_pid()

Verifies we're running in the correct process. Dies if not.

=item $self->debug(@msg)

Outputs debug messages to the appropriate filehandle.

=item $self->handle(name => $name, %params)

Creates a new handle for connecting to this service.

=item $self->peer($name, %params)

Creates a peer connection to another service.

=item $res = $self->try($cb)

Executes a callback with optional error interception.

$res is a hashref:

    {
        ok => $bool,
        err => $string,
        out => ...,
    }

=item $delta = $self->peer_delta(%params)

Returns a hashref showing changes in peer connections.

=item @handles = $self->select_handles()

Returns a list of filehandles for select().

=item $activity = $self->watch($sig_seen)

Waits for activity and returns an activity hashref.

See the L</"ACTIVITY HASH"> for a description of the C<$activity> output.

=item $terminated = $self->run()

Runs the main event loop until terminated. Returns the termination value.

=back

=head1 ACTIVITY HASH

The methods that take an activity hash get this structure:

Note that all keys that are not applicable may be omitted.

    {
        # Set if the time interval has passed since the last iteration
        interval => $bool,

        # An arrayref of messages, if any
        messages => \@messages,

        # A hashref for peers that have been added or removed, -1 means removed, 1 means added.
        peer_delta => {peer1 => -1, peer3 => 1},

        # True if a wtached pid has exited
        pid_watch => $bool,

        # Hashref of non-worker child pids reaped this iteration mapped to their raw $? exit values
        pids => {pid1 => $exit1, pid2 => $exit2},

        # Hashref of all signals intercepted since the last iteration, plus a count of how many times they were recieved
        sigs => {sig => $count, sig2 => $count2},

        # Set if termination has occured, along with the termination value as a key on the hashref.
        terminated => { value => $value },
    }

=head1 SOURCE

The source code repository for IPC::Manager can be found at
L<https://github.com/exodist/IPC-Manager>.

=head1 MAINTAINERS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 AUTHORS

=over 4

=item Chad Granum E<lt>exodist@cpan.orgE<gt>

=back

=head1 COPYRIGHT

Copyright Chad Granum E<lt>exodist7@gmail.comE<gt>.

This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.

See L<https://dev.perl.org/licenses/>

=cut
