view release on metacpan or  search on metacpan

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

package Net::Clacks::Server;
#---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 = 35;
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 XML::Simple;
use Time::HiRes qw(sleep usleep time);
use Sys::Hostname;
use Errno;
use IO::Socket::IP;
use IO::Select;
use IO::Socket::SSL;
use YAML::Syck;
use MIME::Base64;
use File::Copy;
use Scalar::Util qw(looks_like_number);

# For turning off SSL session cache
use Readonly;
Readonly my $SSL_SESS_CACHE_OFF => 0x0000;

my %overheadflags = (
    A => "auth_token", # Authentication token
    O => "auth_ok", # Authentication OK
    F => "auth_failed", # Authentication FAILED

    E => 'error_message', # Server to client error message

    C => "close_all_connections",
    D => "discard_message",
    G => "forward_message",
    I => "set_interclacks_mode", # value: true/false, disables 'G' and 'U'
    L => "lock_for_sync", # value: true/false, only available in interclacks client mode
    M => "informal_message", # informal message, no further operation on it
    N => "no_logging",
    S => "shutdown_service", # value: positive number (number in seconds before shutdown). If interclacks clients are present, should be high
                             # enough to flush all buffers to them

    T => 'timestamp',        # Used before KEYSYNC to compensate for time drift between different systems
    U => "return_to_sender",
    Z => "no_flags", # Only sent when no other flags are set
);

BEGIN {
    {
        # We need to add some extra function to IO::Socket::SSL so we can track the client ID
        # on both TCP and Unix Domain Sockets
        no strict 'refs'; ## no critic (TestingAndDebugging::ProhibitNoStrict)
        *{"IO::Socket::SSL::_setClientID"} = sub {
            my ($self, $cid) = @_;
    
            ${*$self}{'__client_id'} = $cid; ## no critic (References::ProhibitDoubleSigils)
            return;
        };
        
        *{"IO::Socket::SSL::_getClientID"} = sub {
            my ($self) = @_;
    
            return ${*$self}{'__client_id'} || ''; ## no critic (References::ProhibitDoubleSigils)
        };

    }
    
}

sub new($class, $isDebugging, $configfile) {

    my $self = bless {}, $class;

    $self->{isDebugging} = $isDebugging;
    $self->{configfile} = $configfile;

    $self->{timeoffset} = 0;

    if(defined($ENV{CLACKS_SIMULATED_TIME_OFFSET})) {
        $self->{timeoffset} = 0 + $ENV{CLACKS_SIMULATED_TIME_OFFSET};
        print "****** RUNNING WITH A SIMULATED TIME OFFSET OF ", $self->{timeoffset}, " seconds ******\n";
    }

    $self->{cache} = {};

    return $self;
}

sub init($self) {
    # Dummy function for backward compatibility
    carp("Deprecated call to init(), you can remove that function from your code");
    return;
}

sub run($self) {
    if(!defined($self->{initHasRun}) || !$self->{initHasRun}) {
        $self->_init();
    }

    while($self->{keepRunning}) {
        # Check for shutdown time
        if($self->{shutdowntime} && $self->{shutdowntime} < time) {
            print STDERR "Shutdown time has arrived!\n";
            $self->{keepRunning} = 0;
        }

        $self->runOnce();

        if($self->{workCount}) {
            $self->{usleep} = 0;
        } elsif($self->{usleep} < $self->{config}->{throttle}->{maxsleep}) {
            $self->{usleep} += $self->{config}->{throttle}->{step};
        }
        if($self->{usleep}) {
            sleep($self->{usleep} / 1000);
        }
    }

    $self->runShutdown();

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

            next;
        }

        my $cachetime = $clackscachetime{$key};
        my $accesstime = $now;
        if(defined($clackscacheaccesstime{$key})) {
            $accesstime = $clackscacheaccesstime{$key};
        }
        $cache{$key} = {
            data => '',
            cachetime => $cachetime,
            accesstime => $accesstime,
            deleted => 0,
        };
    }

    my $converted = chr(0) . 'CLACKSV3' . Dump(\%cache) . chr(0) . 'CLACKSV3';
    $self->_writeBinFile($fname, $converted);

    print "...upgrade complete.\n";

    return true;
}

sub _addInterclacksLink($self) {
    my $now = $self->_getTime();

    my $mcid;
    if(defined($self->{config}->{master}->{socket})) {
        $mcid = 'unixdomainsocket:interclacksmaster';
    } else {
        $mcid = $self->{config}->{master}->{ip}->[0] . ':' . $self->{config}->{master}->{port};
    }
    if(!defined($self->{clients}->{$mcid}) && $self->{nextinterclackscheck} < $now) {
        $self->{nextinterclackscheck} = $now + $self->{config}->{interclacksreconnecttimeout} + int(rand(10));

        print "Connect to master\n";
        my $msocket;

        if(defined($self->{config}->{master}->{socket})) {
            $msocket = IO::Socket::UNIX->new(
                Peer => $self->{config}->{master}->{socket}->[0],
                Type => SOCK_STREAM,
            );
        } else {
            $msocket = IO::Socket::IP->new(
                PeerHost => $self->{config}->{master}->{ip}->[0],
                PeerPort => $self->{config}->{master}->{port},
                Type => SOCK_STREAM,
                Timeout => 5,
            );
        }
        if(!defined($msocket)) {
            print STDERR "Can't connect to MASTER via interclacks!\n";
        } else {
            print "connected to master\n";

            if(ref $msocket 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($msocket,
                                                           SSL_verify_mode => SSL_VERIFY_NONE,
                );
                if(!$encrypted) {
                    print "startSSL failed: ", $SSL_ERROR, "\n";
                    next;
                }
            }

            $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,
                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}}) {
        my $clientsocket = $tcpsocket->accept;
        if(defined($clientsocket)) {
            $clientsocket->blocking(0);
            my ($cid, $chost, $cport);
            if(ref $tcpsocket eq 'IO::Socket::UNIX') {
                $chost = 'unixdomainsocket';
                $cport = $now . ':' . int(rand(1_000_000));
            } else {
                ($chost, $cport) = ($clientsocket->peerhost, $clientsocket->peerport);
            }
            print "Got a new client $chost:$cport!\n";
            $cid = "$chost:$cport";
            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)
                                                            },
                );
                if(!$encrypted) {
                    print "startSSL failed: ", $SSL_ERROR, "\n";
                    next;
                }
            }

            $clientsocket->blocking(0);
            #binmode($clientsocket, ':bytes');
            #$clientsocket->{clacks_cid} = $cid;
            my %tmp = (
                buffer  => '',
                charbuffer => [],
                listening => {},
                socket => $clientsocket,
                lastping => $now,
                mirror => 0,
                outbuffer => "CLACKS PageCamel $VERSION\r\n" .
                             "OVERHEAD M Authentication required\r\n",  # Informal message
                clientinfo => 'UNKNOWN',
                client_timeoffset => 0,
                host => $chost,
                port => $cport,
                interclacks => 0,
                interclacksclient => 0,
                lastinterclacksping => 0,
                lastmessage => $now,
                authtimeout => $now + $self->{config}->{authtimeout},
                authok => 0,
                failtime => 0,
                outmessages => [],
                inmessages => [],
                inmessagedelay => 0,
                outmessagedelay => 0,
                permissions => {
                    read => 0,
                    write => 0,
                    manage => 0,
                    interclacks => 0,
                },
            );
            if(0 && $self->{isDebugging}) {
                $tmp{authok} = 1;
                $tmp{outbuffer} .= "OVERHEAD M debugmode_auth_not_really_required\r\n"