Net-Clacks
view release on metacpan or search on metacpan
lib/Net/Clacks/Client.pm view on Meta::CPAN
package Net::Clacks::Client;
#---AUTOPRAGMASTART---
use v5.36;
use strict;
use diagnostics;
use mro 'c3';
use English qw(-no_match_vars);
use Carp qw[carp croak confess cluck longmess shortmess];
our $VERSION = 36;
use autodie qw( close );
use Array::Contains;
use utf8;
use Encode qw(is_utf8 encode_utf8 decode_utf8);
use Data::Dumper;
use builtin qw[true false is_bool];
no warnings qw(experimental::builtin); ## no critic (TestingAndDebugging::ProhibitNoWarnings)
#---AUTOPRAGMAEND---
use IO::Socket::IP;
#use IO::Socket::UNIX;
use Time::HiRes qw[sleep usleep time];
use Sys::Hostname;
use IO::Select;
use IO::Socket::SSL;
use MIME::Base64;
sub new($class, $server, $port, $username, $password, $clientname, $iscaching = 0) {
my $self = bless {}, $class;
if(!defined($server) || !length($server)) {
croak("server not defined!");
}
if(!defined($port) || !length($port)) {
croak("port not defined!");
}
if(!defined($username) || !length($username)) {
croak("username not defined!");
}
if(!defined($password) || !length($password)) {
croak("password not defined!");
}
if(!defined($clientname) || !length($clientname)) {
croak("clientname not defined!");
}
$self->{server} = $server;
$self->{port} = $port;
$self->init($username, $password, $clientname, $iscaching);
return $self;
}
sub newSocket($class, $socketpath, $username, $password, $clientname, $iscaching = 0) {
my $self = bless {}, $class;
if(!defined($socketpath) || !length($socketpath)) {
croak("socketpath not defined!");
}
if(!defined($username) || !length($username)) {
croak("username not defined!");
}
if(!defined($password) || !length($password)) {
croak("password not defined!");
}
if(!defined($clientname) || !length($clientname)) {
croak("clientname not defined!");
}
my $udsloaded = 0;
eval { ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
require IO::Socket::UNIX;
$udsloaded = 1;
};
if(!$udsloaded) {
croak("Specified a unix domain socket, but i couldn't load IO::Socket::UNIX!");
}
$self->{socketpath} = $socketpath;
$self->init($username, $password, $clientname, $iscaching);
return $self;
}
lib/Net/Clacks/Client.pm view on Meta::CPAN
$iscaching = 0;
}
$self->{iscaching} = $iscaching;
if($self->{iscaching}) {
$self->{cache} = {};
}
$self->{needreconnect} = 1;
$self->{inlines} = [];
$self->{firstconnect} = 1;
# Maximum number of seconds any synchronous request (retrieve, flush, keylist,
# clientlist) will wait for a server response before giving up. Without this
# cap a hung or silently-dropped server connection turned into an indefinite
# client-side hang. Callers can override this after construction.
$self->{requesttimeout} = 30;
# Maximum time to spend trying to drain the outbuffer when the server isn't
# reading (kernel send buffer full -> syswrite returns EAGAIN repeatedly).
# Tracked in doNetwork() via writefailtime; on expiry the connection is
# marked for reconnect. This is the symmetric counterpart of the server's
# stalledwritetimeout and is what stops the many "send loop" sites that
# otherwise spin forever when the server is alive but not consuming.
$self->{stalledwritetimeout} = 30;
# TCP connect timeout. Without this, a TCP connect to an unreachable host
# waits for the kernel SYN-retransmit timeout (~75 s on Linux) before
# giving up. Defaulted generously so a transiently-busy server (full
# listen backlog, scheduler delays under load) or a slow link doesn't
# produce false-positive failures. Unix-domain sockets are not affected —
# connect there fails or succeeds immediately.
$self->{connecttimeout} = 60;
# TLS handshake timeout. Implemented via deferred handshake + IO::Select
# polling so we don't depend on SIGALRM, which is unsafe in applications
# that already use signals or have their own event loop. Defaulted
# generously to tolerate slow servers (RSA signing on a small CPU is not
# instant) and high-RTT links.
$self->{ssltimeout} = 60;
$self->{memcached_compatibility} = 0;
$self->{remembrancenames} = [
'Ivy Bdubs',
'Terry Pratchett',
'Sven Guckes',
'Sheila', # faithful four-legged family member of @NightStorm_KPC
];
$self->{remembranceinterval} = 3600; # One hour
$self->{nextremembrance} = time + $self->{remembranceinterval};
$self->reconnect();
return;
}
sub _safeCloseSocket($self, $socket) {
return if(!defined($socket));
eval { ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
if(ref($socket) =~ /^IO::Socket::SSL/) {
$socket->close(SSL_no_shutdown => 1, SSL_fast_shutdown => 1);
} else {
$socket->close;
}
};
return;
}
# Perform a TLS handshake with our own deadline, without using SIGALRM.
# Strategy: put the socket into non-blocking mode up front, defer the handshake
# at start_SSL (SSL_startHandshake => 0), then drive connect_SSL() ourselves and
# poll with IO::Select::can_read / can_write between attempts. This is safe in
# applications that already use signals or have their own event loop.
#
# Returns the wrapped socket on success, or undef on timeout / handshake error.
# On failure, the caller is responsible for closing the original $socket.
sub _sslHandshakeWithTimeout($self, $socket, $timeout) {
$socket->blocking(0);
my $wrapped = IO::Socket::SSL->start_SSL($socket,
SSL_verify_mode => SSL_VERIFY_NONE,
SSL_startHandshake => 0,
);
if(!$wrapped) {
return;
}
my $deadline = time + $timeout;
my $select = IO::Select->new($wrapped);
while(1) {
if($wrapped->connect_SSL) {
return $wrapped;
}
# connect_SSL returned false; figure out why and (maybe) wait for the
# right kind of socket readiness.
my $remaining = $deadline - time;
if($remaining <= 0) {
return;
}
if($SSL_ERROR == SSL_WANT_READ) {
$select->can_read($remaining);
} elsif($SSL_ERROR == SSL_WANT_WRITE) {
$select->can_write($remaining);
} else {
# Real handshake error (cert mismatch, protocol error, etc.).
return;
}
}
}
sub reconnect($self) {
# Tear the old connection down: remove from the selector first (otherwise the
# selector keeps the handle alive and the OS FD stays open), then explicitly
# close. Without the explicit close, server-side FDs accumulate until the
# ping timeout — under reconnect churn the server can run out of FDs.
if(defined($self->{selector}) && defined($self->{socket})) {
eval { ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
$self->{selector}->remove($self->{socket});
};
}
undef $self->{selector};
if(defined($self->{socket})) {
$self->_safeCloseSocket($self->{socket});
delete $self->{socket};
}
if(!$self->{firstconnect}) {
# Not our first connection (=real reconnect).
# wait a short random time before reconnecting. In case all
# clients got disconnected, we want to avoid having all clients reconnect
# at the exact same time
my $waittime = rand(4000)/1000;
sleep($waittime);
}
my $socket;
if(defined($self->{server}) && defined($self->{port})) {
# Cap TCP connect at $self->{connecttimeout} so an unreachable host
# doesn't make us wait for the kernel SYN-retransmit timeout (~75s).
$socket = IO::Socket::IP->new(
lib/Net/Clacks/Client.pm view on Meta::CPAN
# delete. The previous "delete only" approach left the FD open whenever the
# selector or any other reference still pinned the socket.
if(defined($self->{selector}) && defined($self->{socket})) {
eval { ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
$self->{selector}->remove($self->{socket});
};
}
undef $self->{selector};
if(defined($self->{socket})) {
$self->_safeCloseSocket($self->{socket});
delete $self->{socket};
}
$self->{needreconnect} = 1;
return;
}
sub disconnect($self) {
if($self->{needreconnect}) {
# We are not connected, just do nothing
return;
}
$self->flush();
$self->{outbuffer} .= "QUIT\r\n";
my $endtime = time + 0.5; # Wait a maximum of half a second to send
while(1) {
last if(time > $endtime);
my $xstart = time;
$self->doNetwork(-1);
my $xend = time;
my $timetaken = $xend - $xstart;
if($timetaken > 1) {
#print STDERR "\n §§§§§§§§§§§§§§§§§§§§§§§§§§§§§ doNetwork() took ", $timetaken, " seconds\n";
}
last if(!length($self->{outbuffer}));
sleep(0.02);
}
sleep(0.2); # Wait for the OS to flush the socket
# Tear down properly: deselect, close, delete. Just `delete` left the FD open
# whenever IO::Select still held a reference, which is true here because we
# never removed it from the selector.
if(defined($self->{selector}) && defined($self->{socket})) {
eval { ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
$self->{selector}->remove($self->{socket});
};
}
undef $self->{selector};
if(defined($self->{socket})) {
$self->_safeCloseSocket($self->{socket});
delete $self->{socket};
}
$self->{needreconnect} = 1;
return;
}
sub DESTROY($self) {
# During Perl's global destruction phase, package symbol tables are torn
# down in arbitrary order. By the time DESTROY runs here, methods on
# IO::Socket::SSL, IO::Select, or even IO::Socket may already be
# unavailable. Skip cleanup entirely in that phase — the kernel closes
# any leftover FD when the process exits, and the server detects that
# as EOF and removes us cleanly. Trying to be "polite" here can stall
# exit (flush() waits up to requesttimeout seconds) or call methods on
# half-destroyed package state.
return if(${^GLOBAL_PHASE} eq 'DESTRUCT');
# Outside global destruction we do a *fast* close (no flush(), no QUIT,
# no sleeps). DESTROY can run at moments where the graceful path is
# inappropriate — e.g. a worker child unwinding after fork, an exception
# being propagated, a local-block exit. Callers who want a graceful
# protocol-level close should call $client->disconnect() explicitly
# before dropping their reference; this DESTROY is just the safety net.
eval { ## no critic (ErrorHandling::RequireCheckingReturnValueOfEval)
$self->fastdisconnect();
};
return;
}
1;
__END__
=head1 NAME
Net::Clacks::Client - client for CLACKS interprocess messaging
=head1 SYNOPSIS
use Net::Clacks::Client;
=head1 DESCRIPTION
This implements the client network protocol for the CLACKS interprocess messaging. This is
used a lot in PageCamel projects to let different processes (workers, webgui, PageCamelSVC) communicate
with each other
=head2 new
Create a new instance.
=head2 newSocket
Create a new instance, but use a Unix domain socket instead of tcp/ip
=head2 init
Internal function
=head2 reconnect
Reconnect to the CLACKS server when something went wrong.
=head2 getRawSocket
Returns the raw socket. You MUST NOT send or read data from because this will mess up the connection. Access to the raw
socket is only useful in speciality cases, like you want to wait on multiple Clacks sockets for incoming data using
IO::Select. In most cases, you wont need this.
( run in 0.382 second using v1.01-cache-2.11-cpan-f4a522933cf )