package IPC::Manager;
use strict;
use warnings;
use feature qw/state/;

our $VERSION = '0.000037';

use Carp qw/croak/;
use Scalar::Util qw/blessed/;

use Role::Tiny();

use IPC::Manager::Spawn();
use IPC::Manager::Serializer::JSON();

BEGIN {
    require IPC::Manager::Service::State;
    *ipcm_service = \&IPC::Manager::Service::State::ipcm_service;
    *ipcm_worker  = \&IPC::Manager::Service::State::ipcm_worker;
}

use IPC::Manager::Util qw/require_mod/;

use Importer Importer => 'import';

our @EXPORT_OK = qw{
    ipcm_connect
    ipcm_reconnect
    ipcm_spawn
    ipcm

    ipcm_default_protocol
    ipcm_default_serializer
    ipcm_default_protocol_list

    ipcm_service
    ipcm_worker
};

sub ipcm()                { __PACKAGE__ }
sub connect               { shift; ipcm_connect(@_) }
sub reconnect             { shift; ipcm_reconnect(@_) }
sub spawn                 { shift; ipcm_spawn(@_) }
sub service               { shift; ipcm_service(@_) }
sub worker                { shift; ipcm_worker(@_) }
sub default_protocol      { shift; ipcm_default_protocol(@_) }
sub default_serializer    { shift; ipcm_default_serializer(@_) }
sub default_protocol_list { shift; ipcm_default_protocol_list(@_) }
sub ipcm_connect          { _connect(connect   => @_) }
sub ipcm_reconnect        { _connect(reconnect => @_) }

sub _parse_cinfo {
    my $cinfo = shift;

    my ($protocol, $route, $serializer);

    my $rtype = ref $cinfo;
    if ($rtype eq 'ARRAY') {
        ($protocol, $serializer, $route) = @$cinfo;
    }
    elsif (!$rtype) {
        ($protocol, $serializer, $route) = @{IPC::Manager::Serializer::JSON->deserialize($cinfo)};
    }
    else {
        croak "Not sure what to do with $cinfo";
    }

    $protocol   = _parse_protocol($protocol);
    $serializer = _parse_serializer($serializer);

    require_mod($protocol);

    return ($protocol, $serializer, $route);
}

sub _parse_protocol {
    my $protocol = shift;
    $protocol = "IPC::Manager::Client::$protocol" unless $protocol =~ s/^\+// || $protocol =~ m/^IPC::Manager::Client::/;
    return $protocol;
}

# Map DBI driver name (from $dbh->{Driver}{Name}) to an
# IPC::Manager::Client::* protocol class.
my %DBD_PROTOCOL_MAP = (
    Pg      => 'PostgreSQL',
    MariaDB => 'MariaDB',
    mysql   => 'MariaDB',
    SQLite  => 'SQLite',
);

sub _protocol_from_dbh {
    my $dbh = shift;
    my $drv = eval { $dbh->{Driver}->{Name} }
        or croak "Could not introspect DBI driver from \$dbh: $@";
    my $proto = $DBD_PROTOCOL_MAP{$drv}
        or croak "No IPC::Manager protocol mapping for DBI driver '$drv'";
    return _parse_protocol($proto);
}

sub _serializer_class {
    my $name = shift;
    $name = "IPC::Manager::Serializer::$name"
        unless $name =~ s/^\+// || $name =~ m/^IPC::Manager::Serializer::/;
    return $name;
}

my %SERIALIZER_CACHE;

sub _serializer_cache_key {
    my ($class, @args) = @_;
    my %h = @args;
    return join(
        "\0",
        $class,
        map { ($_, defined $h{$_} ? $h{$_} : "\0\0undef\0\0") } sort keys %h,
    );
}

sub _parse_serializer {
    my $spec = shift;

    return $spec if blessed $spec;

    if (ref($spec) eq 'ARRAY') {
        my ($class, @args) = @$spec;
        $class = _serializer_class($class);
        require_mod($class);
        my $key = _serializer_cache_key($class, @args);
        return $SERIALIZER_CACHE{$key} //= $class->new(@args);
    }

    croak "Don't know how to interpret serializer spec '$spec'" if ref $spec;

    my $class = _serializer_class($spec);
    require_mod($class);
    return $class;
}

sub _connect {
    my ($meth, $id, $cinfo, %params) = @_;

    # Two cinfo shapes:
    #   - normal cinfo (string/arrayref): parse it for [protocol, serializer, route]
    #   - hashref of params (caller passes dbh + protocol omitted): derive
    #     protocol from $dbh, route from $dbh->{Driver}{Name} + ->{Name}
    if (ref($cinfo) eq 'HASH') {
        %params = (%$cinfo, %params);
        $cinfo = undef;
    }

    my ($protocol, $serializer, $route);
    if (!defined($cinfo) && $params{dbh}) {
        $protocol   = delete($params{protocol})
            ? _parse_protocol(delete $params{protocol})
            : _protocol_from_dbh($params{dbh});
        require_mod($protocol);
        $route      = delete($params{route}) // $protocol->route_from_dbh($params{dbh});
        $serializer = _parse_serializer(delete($params{serializer}) // ipcm_default_serializer());
    }
    else {
        ($protocol, $serializer, $route) = _parse_cinfo($cinfo);
    }

    return $protocol->$meth($id, $serializer, $route, %params);
}

sub ipcm_default_protocol {
    state $default = undef;

    if (@_) {
        my $protocol = _parse_protocol(@_);
        require_mod($protocol);
        $default = $protocol;
    }

    return $default;
}

sub ipcm_default_protocol_list {
    state $default = [
        'AtomicPipe',
        'UnixSocket',
        'ConnectionUnix',
        'SQLite',
        'PostgreSQL',
        'MariaDB',
        'MySQL',
        'MessageFiles',
    ];

    if (@_) {
        if (@_ == 1 && ref($_[0]) eq 'ARRAY') {
            $default = [ @{$_[0]} ];
        }
        else {
            $default = [@_];
        }
    }

    return $default;
}

sub _pick_default_serializer {
    return 'JSON::Zstd'
        if eval { require IPC::Manager::Serializer::JSON::Zstd; IPC::Manager::Serializer::JSON::Zstd->viable };
    return 'JSON';
}

sub ipcm_default_serializer {
    state $default;

    if (@_) {
        my $spec = @_ == 1 ? $_[0] : [@_];
        $default = _parse_serializer($spec);
    }

    $default //= _pick_default_serializer();

    return $default;
}

sub ipcm_spawn {
    my %params = @_;

    my $guard           = delete $params{guard}           // 1;
    my $do_sanity_check = delete $params{do_sanity_check} // 0;
    my $debug           = delete $params{debug}           // 0;
    my $serializer      = delete $params{serializer}      // ipcm_default_serializer();
    my $protocol        = delete $params{protocol}        // ipcm_default_protocol();
    my $protocols       = delete $params{protocols}       // ipcm_default_protocol_list();

    if (!$protocol && $params{dbh}) {
        $protocol = _protocol_from_dbh($params{dbh});
        require_mod($protocol);
    }
    elsif ($protocol) {
        $protocol = _parse_protocol($protocol);
        require_mod($protocol);
    }
    else {
        for my $prot (@$protocols) {
            $prot = _parse_protocol($prot);

            local $@;
            eval { require_mod($prot); $prot->viable } or next;

            $protocol = $prot;
            last;
        }

        croak "Could not find a viable protocol" unless $protocol;
    }

    $serializer = _parse_serializer($serializer);

    my ($route, $stash) = $protocol->spawn(%params, serializer => $serializer);

    return IPC::Manager::Spawn->new(
        protocol        => $protocol,
        serializer      => $serializer,
        route           => $route,
        stash           => $stash,
        guard           => $guard,
        do_sanity_check => $do_sanity_check,
        debug           => $debug,
    );
}

1;

__END__

=pod

=encoding UTF-8

=head1 NAME

IPC::Manager - Decentralized local IPC through various protocols.

=head1 DESCRIPTION

IPC::Manager provides a way to do message based IPC between local (on a single
machine) processes. It provides multiple protocols for doing this, as well as
pluggable serialization.

The idea is to first initialize a data store, provide the info to access the
data store, then any process may use that info to send/recieve messages. The
datastore can be temporary (guarded) or persistent.

=head1 SYNOPSIS

    use IPC::Manager qw/ipcm_connect ipcm_spawn/;

    # Let the system pick a protocol and serialization
    my $ipcm = ipcm_spawn();

    my $info = $ipcm->info;
    print "You can connect to the IPC using this string: $info\n";

    # Get a connection
    my $con1 = ipcm_connect(con1 => $info);
    my $con2 = ipcm_connect(con2 => $info);

    # Send a message
    $con1->send_message(con2 => {hello => 'world'});

    # Get messages
    if (my @messages = $con2->get_messages) {
        # hashref: {hello => 'world'}
        my $payload = $message[0]->content;
        ...
    }

    # Cleanup the datastore (unless `guard => 0` was passed in).
    $guard = undef;

The idea is to use the ipcm data store as the medium for transferring messages.
You can use the string returned by C<< $ipcm->info >> from any process to reach
the data store.

You can set up persistent data stores, in which case the C<ipcm_spawn()> export
is not needed. How to set up a persistent data store is documented in each
client protocol.

Messages are instances of L<IPC::Manager::Message>. You can make the instances
yourself manually and send them, or you can let C<send_message()> create them
for you:

    $con1->send_message(con2 => IPC::Manager::Message->new(content => \%CONTENT, ...));
    $con1->send_message(con2 => \%CONTENT);

=head1 EXPORTS

=over 4

=item $ipcm = ipcm->spawn(...)

=item $con = ipcm->connect(...)

=item $con = ipcm->reconnect(...)

C<ipcm()> is an alias for C<IPC::Manager>. You can use it to call spawn,
connect, or reconnect without importing C<ipcm_spawn()>, C<ipcm_connect()>, or
C<ipcm_reconnect()> into your namespace.

=item $protocol = ipcm_default_protocol()

=item ipcm_default_protocol($protocol)

Get or set the default protocol. This is undef until set.

=item $protocol_list = ipcm_default_protocol_list()

=item ipcm_default_protocol_list(\@protocol_list)

Default set of protocols to try, in the order they should be tried.

=item $serializer = ipcm_default_serializer()

=item ipcm_default_serializer($serializer)

=item ipcm_default_serializer([$class, %args])

=item ipcm_default_serializer($class, %args)

Get or set the default serializer. The default is C<'JSON::Zstd'> when
L<Compress::Zstd> 0.20 or newer is installed, otherwise C<'JSON'>.

The setter accepts either a class string (uses class methods, no
construction) or an arrayref whose first element is the class and whose
remaining elements are constructor arguments. The arrayref form (or the
flat-list spelling, which is treated identically) builds and caches a
single shared instance keyed on C<($class, %args)>; subsequent
C<ipcm_spawn> / C<ipcm_connect> calls with the same spec reuse it.

=item $ipcm = ipcm_spawn()

=item $ipcm = ipcm_spawn(protocol => $PROTOCOL)

=item $ipcm = ipcm_spawn(protocols => \@PROTOCOLS)

=item $ipcm = ipcm_spawn(serializer => 'JSON', guard => 1, signal => $SIGNAL)

=item $ipcm = ipcm_spawn(dbh => $dbh)

This will create a new data store for IPC. By default it will be temporary and
will be destroyed when the $ipcm object falls out of scope.

You can set C<< guard => 0 >> to prevent the destruction of the datastore when
the object falls out of scope.

You can also set a signal, such as C<'INT'> or C<'TERM'> to have the signal
sent to the PID for all clients when the instance is shut down.

You can set the serializer with the C<< serializer => $CLASS >> option.
'IPC::Manager::Serializer::' will be prefixed onto the class name unless it is
already present, or if the class name starts with '+'. To configure a
serializer that takes constructor arguments (for example to set a custom
compression level or dictionary on
L<IPC::Manager::Serializer::JSON::Zstd>) pass an arrayref of
C<< [$class, %args] >>: C<< serializer => ['JSON::Zstd', level => 9] >>. The
arrayref form builds a single cached instance shared across all peer
connections; the string form keeps using class methods directly.

You can pick a protocol with the C<< protocol => $CLASS >> option.
'IPC::Manager::Client::' will be prefixed onto the class name unless it is
already present, or if the class name starts with '+'.

If you do not care what protocol is used you can leave it blank, in which case
one will be picked for you based on what your system supports. Order in which
it will try protocols is subject to change at any time.

If you want to narrow down to a specific set of protocols you may provide a
list: C<< protocols => [ 'AtomicPipe', 'UnixSocket', 'PostgreSQL', ... ] >>.
The first viable protocol will be used.

B<Spawning against an existing DBI handle.>
For DBI-backed protocols you may pass C<< dbh => $dbh >> instead of letting
the protocol bootstrap its own database. The protocol is auto-detected from
C<< $dbh->{Driver}{Name} >> using this map:

    Pg      -> IPC::Manager::Client::PostgreSQL
    MariaDB -> IPC::Manager::Client::MariaDB
    mysql   -> IPC::Manager::Client::MariaDB   (see DBD::mysql note below)
    SQLite  -> IPC::Manager::Client::SQLite

You can still pass C<< protocol => $CLASS >> alongside C<< dbh => $dbh >> to
override the auto-detection.

C<ipcm_spawn> runs C<init_db> against the supplied handle to create the
C<ipcm_peers> and C<ipcm_messages> tables, then returns a Spawn object whose
route is reassembled from C<< $dbh->{Driver}{Name} >> and C<< $dbh->{Name} >>
so that the C<< $ipcm->info >> string is still usable by peers reconnecting
from another process (each peer constructs its own DBI handle from the
reassembled DSN — the in-process handle is not, and cannot be, shared
across processes).

Useful for embedding IPC::Manager inside an application that already owns a
DBI connection without forcing it to bootstrap a separate one (e.g. you
already have a long-lived $dbh in a web app and want to use the same
database for IPC).

B<DBD::mysql note.>
C<IPC::Manager::Client::MySQL> is built against L<DBD::MariaDB>, not
L<DBD::mysql>. If you happen to pass in a C<$dbh> whose driver name is
C<mysql>, it is tolerated — the auto-detect map points it at the MariaDB
client class and things will normally work — but C<DBD::mysql> is not in
the dependency list and is not exercised by the test suite, so this path
is best-effort only. Prefer L<DBD::MariaDB>.

The object returned is an instance of L<IPC::Manager::Spawn>.

=item $con = ipcm_connect($name => $info)

This is used to establish a connection. The C<$name> should be a unique name
for your connection, it will be used as the 'from' field for any message you
send, and will be used by other clients to send messages to you.

The C<$info> argument must be the connection info needed to connect to the data
store. This is always a 3 element arrayref, or a JSON string with the 3 element
arrayref.

    [$protocol_class, $serializer_class, $route]
    '["PROTOCOL_CLASS", "SERIALIZER_CLASS", "ROUTE"]'

The protocol should always be an L<IPC::Manager::Client> subclass. The
serializer slot may be a class string, in which case the receiver uses class
methods on it, or a C<< [$class, %args] >> arrayref, in which case the
receiver constructs (and caches) a configured instance. The connection info
string itself is always plain JSON; only message payloads carried over the
chosen protocol are subject to the serializer's encoding (e.g. zstd
compression). The route is protocol specific, it may be a file, a directory,
a DBI DSN string, etc.

=item $con = ipcm_connect($name, undef, dbh => $dbh)

=item $con = ipcm_reconnect($name, undef, dbh => $dbh)

For DBI-backed protocols you may pass a pre-connected C<$dbh> in place of an
C<$info> string. The protocol is auto-detected from C<< $dbh->{Driver}{Name} >>
(same map as documented under C<ipcm_spawn>), the route is reassembled from
C<< $dbh->{Driver}{Name} + $dbh->{Name} >> for storage in the resulting
Client object, and the Client reuses the supplied handle directly instead of
calling C<< DBI->connect >>.

The same C<DBD::mysql>-is-tolerated-not-supported caveat applies — see the
C<ipcm_spawn> section above.

=item $con = ipcm_reconnect($name => $info)

Same as 'connect', but used to reconnect as a client that was suspended or
otherwise disconnected.

=item $peer = ipcm_service($name => \&callback)

=item $peer = ipcm_service($name, \%params, \&callback)

=item $peer = ipcm_service($name, %params)

Forks a new service process. When called from outside a service the return
value is an L<IPC::Manager::Service::Handle> connected to the new service over
a freshly spawned IPC bus.

When called from B<inside> a running service (i.e. from within a service
callback) the new service shares the existing IPC bus, and the return value is
an L<IPC::Manager::Service::Peer> that the calling service can use to send
requests to the nested service.

The returned handle or peer carries the first-fork child pid via
C<< $handle->child_pid >> - useful for supervisors that track services by
pid.  See L<IPC::Manager::Service::Handle/child_pid> for the first-fork
caveat around C<post_fork_hook> daemonization.

B<Void context and the ready race>: when called in void context from inside a
service, C<ipcm_service> forks the nested service and returns immediately
without waiting for it to finish connecting to the bus. If you intend to
contact the nested service shortly after (e.g. from C<handle_request>), you
must wait for it yourself before returning from the enclosing callback:

    on_start => sub {
        ipcm_service nested => sub { ... };   # void context - no wait
        $self->peer('nested')->ready(0);      # block until ready
    },

Failing to do so is a race condition: a request may be forwarded to the nested
service before it has connected, causing the caller to stall indefinitely.

=item $pid = ipcm_worker($name, \&callback)

Fork a named worker process from B<inside> a running service.  Dies if called
outside a service.

The worker runs C<\&callback> instead of a normal service event loop.  It is
registered with the enclosing service so that it is automatically reaped when
the service exits.

Returns the worker PID to the caller (the parent service process); the
callback is entered in the forked child and the function never returns there.

=back

=head1 CLIENT PROTOCOLS

See L<IPC::Manager::Client> for common methods across all client types.

=head2 FileSystem Based

These are all based off of L<IPC::Manager::Base::FS>. These are all based on a
directory structure of some kind.

=over 4

=item MessageFiles

L<IPC::Manager::Client::MessageFiles>

This is the most universal protocol, it works in the most places.

This uses a directory as the 'route'. Within this directory each client creates
a subdirectory. Messages are sent by writing a file per message to the clients
directory. Messages are deleted from the filesystem when read.

=item AtomicPipe

L<IPC::Manager::Client::AtomicPipe>

This uses a directory as the 'route'. This uses the L<Atomic::Pipe> library to
send atomic messages across pipes. Each client has its own FIFO pipe any other
process can write to when sending a message. Messages are recieved by reading
from the pipe. (Multiple writer, single reader).

=item UnixSocket

L<IPC::Manager::Client::UnixSocket>

This uses a directory as the 'route'. This uses unix sockets, one per client.
Messages are sent by writing them to the correct clients socket.  (Multiple
writer, single reader).

=item ConnectionUnix

L<IPC::Manager::Client::ConnectionUnix>

Like UnixSocket but uses C<SOCK_STREAM> connection-oriented UNIX sockets.
Each client either listens for incoming connections (default) or registers as
a non-listener and may only be reached via connections it has itself
initiated.  Per-connection management methods are provided by
L<IPC::Manager::Role::Client::Connection>.

=back

=head2 DBI Based

These are all based off of L<IPC::Manager::Base::DBI>. These all use a database
as the message store.

These all have 1 table for tracking clients, and another for tracking messages.
Messages are deleted once read. The 'route' is a DSN. You also usually need to
provide a username and password.

    my $con = ipcm_connect(my_con => $info, user => $USER, pass => $PASS);

=over 4

=item MariaDB

L<IPC::Manager::Client::MariaDB>

=item MySQL

L<IPC::Manager::Client::MySQL>

=item PostgreSQL

L<IPC::Manager::Client::PostgreSQL>

=item SQLite

L<IPC::Manager::Client::SQLite>

=back

=head1 CLEANUP

When using a temporary instance that cleans up after itself, the cleanup
process will send terminations messages to all clients, then wait for them to
disconnect. It will also tell you if there is a mismtach between sent and
recieved messages.

See L<IPC::Manager::Spawn> for more information.

=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
