view release on metacpan or  search on metacpan

lib/Net/Clacks/Server.pm  view on Meta::CPAN

                    $self->_safeCloseSocket($msocket);
                    return;
                }
            }

            $msocket->blocking(0);
            #binmode($msocket, ':bytes');
            my %tmp = (
                buffer  => '',
                charbuffer => [],
                listening => {},
                socket => $msocket,
                lastping => $now,
                mirror => 0,
                outbuffer => "CLACKS PageCamel $VERSION in interclacks client mode\r\n" .  # Tell the server we are using PageCamel Interclacks...
                             "OVERHEAD A " . $self->{authtoken} . "\r\n" .              # ...send Auth token
                             "OVERHEAD I 1\r\n",                                        # ...and turn interclacks master mode ON on remote side
                clientinfo => 'Interclacks link',
                client_timeoffset => 0,
                interclacks => 1,
                interclacksclient => 1,
                lastinterclacksping => $now,
                lastmessage => $now,
                authtimeout => $now + $self->{config}->{authtimeout},
                authok => 0,
                failtime => 0,
                writefailtime => 0,  # streak-start time for stalled writes; 0 = no streak in progress
                outmessages => [],
                inmessages => [],
                messagedelay => 0,
                inmessagedelay => 0,
                outmessagedelay => 0,
                permissions => {
                    read => 1,
                    write => 1,
                    manage => 1,
                    interclacks => 1,
                },
            );

            if(defined($self->{config}->{master}->{ip})) {
                $tmp{host} = $self->{config}->{master}->{ip}->[0];
                $tmp{port} = $self->{config}->{master}->{port};
            }
            $self->{clients}->{$mcid} = \%tmp;
            $msocket->_setClientID($mcid);
            $self->{selector}->add($msocket);

            $self->{workCount}++;
        }
    }
    return;
}

sub _addNewClients($self) {
    my $now = $self->_getTime();
    foreach my $tcpsocket (@{$self->{tcpsockets}}) {
        # Drain the listen queue rather than accepting one connection per iteration.
        # The listener is non-blocking, so accept() returns undef once the queue is empty.
        # This prevents a burst of connects from being rejected at the kernel level when
        # the backlog fills up while the main loop is busy elsewhere.
        my $acceptedThisCycle = 0;
        while(1) {
            # Hard cap to keep one rogue burst from monopolising the loop and starving
            # existing clients. Any remaining pending connects will be picked up in the
            # next runOnce() iteration.
            last if($acceptedThisCycle >= 64);

            my $clientsocket = $tcpsocket->accept;
            if(!defined($clientsocket)) {
                # EAGAIN/EWOULDBLOCK (no more pending) or a transient error like
                # ECONNABORTED (peer RST between the kernel queueing the connection
                # and our accept). Either way, stop draining this listener.
                last;
            }
            $acceptedThisCycle++;

            $clientsocket->blocking(0);

            # Build a guaranteed-unique CID. The previous "$now:$rand(1_000_000)" scheme
            # had a 50% birthday collision chance after ~1180 connects in the same
            # second, and TCP CIDs based on $peerhost:$peerport collide whenever the
            # kernel reuses an ephemeral port. A process-monotonic serial fixes both.
            my $serial = $self->_nextClientSerial();
            my ($cid, $chost, $cport);
            if(ref $tcpsocket eq 'IO::Socket::UNIX') {
                $chost = 'unixdomainsocket';
                $cport = $now . ':' . $serial;
            } else {
                ($chost, $cport) = ($clientsocket->peerhost, $clientsocket->peerport);
                # Append the serial so a reused ephemeral port can never alias an
                # existing or recently-disconnected client.
                $cport .= ':' . $serial;
            }
            $cid = "$chost:$cport";
            print "Got a new client $cid!\n";
            foreach my $debugcid (keys %{$self->{clients}}) {
                if($self->{clients}->{$debugcid}->{mirror}) {
                    $self->{clients}->{$debugcid}->{outbuffer} .= "DEBUG CONNECTED=" . $cid . "\r\n";
                }
            }

            if(ref $clientsocket ne 'IO::Socket::UNIX') {
                # ONLY USE SSL WHEN RUNNING OVER THE NETWORK
                # There is simply no point in running it over a local socket.
                my $encrypted = IO::Socket::SSL->start_SSL($clientsocket,
                                                           SSL_server => 1,
                                                           SSL_cert_file => $self->{config}->{ssl}->{cert},
                                                           SSL_key_file => $self->{config}->{ssl}->{key},
                                                           SSL_cipher_list => 'ALL:!ADH:!RC4:+HIGH:+MEDIUM:!LOW:!SSLv2:!SSLv3!EXPORT',
                                                           SSL_create_ctx_callback => sub {
                                                                my $ctx = shift;

                                                                # Enable workarounds for broken clients
                                                                Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL); ## no critic (Subroutines::ProhibitAmpersandSigils)

                                                                # Disable session resumption completely
                                                                Net::SSLeay::CTX_set_session_cache_mode($ctx, $SSL_SESS_CACHE_OFF);

                                                                # Disable session tickets
                                                                Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_NO_TICKET); ## no critic (Subroutines::ProhibitAmpersandSigils)

lib/Net/Clacks/Server.pm  view on Meta::CPAN

sub _handleMessageDirect($self, $cid, $inmsg) {
    if($inmsg =~ /^NOTIFY\ (.*)/) {
        return true unless($self->_requirePermission($cid, 'write'));
        my %tmp = (
            sender => $cid,
            type => 'NOTIFY',
            name => $1,
        );
        push @{$self->{outbox}}, \%tmp;
    } elsif($inmsg =~ /^SET\ (.+?)\=(.*)/) {
        return true unless($self->_requirePermission($cid, 'write'));
        my %tmp = (
            sender => $cid,
            type => 'SET',
            name => $1,
            value => $2,
        );
        push @{$self->{outbox}}, \%tmp;
    } else {
        # "not handled in this sub"
        return false;
    }

    return true;
}

1;
__END__

=head1 NAME

Net::Clacks::Server - server for CLACKS interprocess messaging

=head1 SYNOPSIS

  use Net::Clacks::Server;



=head1 DESCRIPTION

This implements the server for the CLACKS interprocess messaging protocol. It supports Interclacks mode,
for a master/client server architecture.

=head2 new

Create a new instance.

=head2 init

DEPRECATED: Initialize server instance (required before running). This is now a dummy function that will show a deprecation warning and return.
Initialization is now done automatically when calling run().

=head2 run

Run the server instance in it's own event loop. Only returns when server is shutdown.

=head2 runOnce

Run through the event loop once. This allows you to use your own programs event loop, and call runOnce a couple of times per second. It is a good idea to call runShutdown() to cleanly
disconnect clients before exiting your program. runOnce() returns a "work count" number, on which you *may* decide on how busy the server is and when to call runOnce() next.

=head2 runShutdown

Shuts down all connections. This is called automatically if you use run(), but not if you use runOnce()

=head1 IMPORTANT NOTE

Please make sure and read the documentations for L<Net::Clacks> as it contains important information
pertaining to upgrades and general changes!

=head1 AUTHOR

Rene Schickbauer, E<lt>cavac@cpan.orgE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2008-2024 Rene Schickbauer

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.10.0 or,
at your option, any later version of Perl 5 you may have available.

=cut