test: add unit coverage for Phase 1 modules (cloudflare, messenger, rblcheck, servercheck, serverstats)

.github/tests/unit/cloudflare.t

@@ -0,0 +1,173 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+use FindBin qw($Bin);
+use Test::More;
+use lib "$Bin/../lib";
+
+BEGIN {
+    # Stub LWP::UserAgent so CloudFlare.pm can be loaded on hosts (incl. CI
+    # runners) without libwww-perl installed. Each subtest still injects its
+    # own behaviour via `local *LWP::UserAgent::method = sub { ... }`.
+    $INC{'LWP/UserAgent.pm'} = __FILE__;
+    no strict 'refs';
+    *{'LWP::UserAgent::new'}    = sub { my $c = shift; bless {}, $c };
+    *{'LWP::UserAgent::post'}   = sub { die 'LWP::UserAgent::post must be stubbed by the active subtest' };
+    *{'LWP::UserAgent::delete'} = sub { die 'LWP::UserAgent::delete must be stubbed by the active subtest' };
+}
+
+use TestBootstrap ();
+
+{
+    package Local::FakeCFResponse;
+
+    sub new { my ($class, %args) = @_; return bless \%args, $class }
+    sub is_success  { return $_[0]->{is_success}  }
+    sub content     { return $_[0]->{content}     }
+    sub status_line { return $_[0]->{status_line} // 'fake-status' }
+}
+
+sub load_cloudflare {
+    my (%config) = @_;
+    $config{DEBUG}    //= 0;
+    $config{URLGET}   //= 1;
+    $config{CF_BLOCK} //= 'block';
+    $config{CF_CPANEL} //= 0;
+    TestBootstrap::reload_module_with_config('ConfigServer::CloudFlare', \%config);
+    return;
+}
+
+subtest 'checktarget classifies countries, CIDR ranges, and bare IPs' => sub {
+    load_cloudflare();
+
+    is(ConfigServer::CloudFlare::checktarget('US'),          'country',  'two-letter token is treated as a country code');
+    is(ConfigServer::CloudFlare::checktarget('192.0.2.0/24'), 'ip_range', '/24 CIDR is treated as an ip_range target');
+    is(ConfigServer::CloudFlare::checktarget('192.0.0.0/16'), 'ip_range', '/16 CIDR is treated as an ip_range target');
+    is(ConfigServer::CloudFlare::checktarget('192.0.2.10'),  'ip',       'plain IPv4 falls through to the ip target');
+    is(ConfigServer::CloudFlare::checktarget('2001:db8::1'), 'ip',       'plain IPv6 falls through to the ip target');
+};
+
+subtest 'getscope parses DOMAIN, DISABLE, and ANY directives from csf.cloudflare' => sub {
+    load_cloudflare(CF_CPANEL => 0);
+
+    no warnings qw(redefine once);
+    local *ConfigServer::CloudFlare::slurp = sub {
+        return (
+            '# example csf.cloudflare contents',
+            'DOMAIN:example.com:USER:alice:ACCOUNT:alice@example.com:APIKEY:key-alice',
+            'DOMAIN:any:USER:bob:ACCOUNT:bob@example.com:APIKEY:key-bob',
+            'DISABLE:carol',
+            'ANY:bob',
+            '',
+        );
+    };
+
+    my $scope = ConfigServer::CloudFlare::getscope();
+
+    is($scope->{domain}{'example.com'}{user},    'alice',              'DOMAIN line records the owning user');
+    is($scope->{domain}{'example.com'}{account}, 'alice@example.com',  'DOMAIN line records the cloudflare account');
+    is($scope->{domain}{'example.com'}{apikey},  'key-alice',          'DOMAIN line records the cloudflare API key');
+    is($scope->{user}{alice}{domain}{'example.com'}, 'example.com',    'user->domain mapping is populated from DOMAIN lines');
+    is($scope->{user}{bob}{any}, 1, 'a DOMAIN line with the special "any" name flags the user as catch-all');
+};
+
+subtest 'block POSTs JSON-encoded rule body and returns the new rule id on success' => sub {
+    load_cloudflare(CF_BLOCK => 'block');
+
+    my %posted;
+    no warnings qw(redefine once);
+    local *LWP::UserAgent::new = sub { return bless {}, shift };
+    local *LWP::UserAgent::post = sub {
+        my ($self, $url, %rest) = @_;
+        $posted{url}     = $url;
+        $posted{content} = $rest{Content};
+        return Local::FakeCFResponse->new(
+            is_success => 1,
+            content    => '{"result":{"id":"rule-block-1"}}',
+        );
+    };
+
+    my ($id, $status) = ConfigServer::CloudFlare::block('192.0.2.10');
+
+    is($id, 'rule-block-1', 'success path returns the new rule id from the parsed JSON response');
+    is($status, 'CloudFlare: block ip 192.0.2.10', 'success path returns a human-readable status string');
+    is($posted{url}, 'https://api.cloudflare.com/client/v4/user/firewall/access_rules/rules', 'POST hits the access_rules endpoint');
+    like($posted{content}, qr/"target"\s*:\s*"ip"/,            'JSON body declares the ip target for a bare IPv4');
+    like($posted{content}, qr/"value"\s*:\s*"192\.0\.2\.10"/,  'JSON body carries the requested IP value');
+    like($posted{content}, qr/"mode"\s*:\s*"block"/,           'JSON body propagates the configured CF_BLOCK mode');
+};
+
+subtest 'block reports the status line when the upstream request fails' => sub {
+    load_cloudflare(CF_BLOCK => 'block');
+
+    no warnings qw(redefine once);
+    local *LWP::UserAgent::new  = sub { return bless {}, shift };
+    local *LWP::UserAgent::post = sub {
+        return Local::FakeCFResponse->new(
+            is_success  => 0,
+            content     => '{"errors":[{"code":1000}]}',
+            status_line => '500 Internal Server Error',
+        );
+    };
+
+    my @result = ConfigServer::CloudFlare::block('192.0.2.10');
+
+    is(scalar @result, 1, 'failure path returns a single error string instead of (id, status)');
+    is($result[0], 'CloudFlare: [192.0.2.10] block failed: 500 Internal Server Error', 'error string includes the IP and the upstream status line');
+};
+
+subtest 'whitelist tags the rule with the whitelist mode and notes' => sub {
+    load_cloudflare();
+
+    my $body;
+    no warnings qw(redefine once);
+    local *LWP::UserAgent::new  = sub { return bless {}, shift };
+    local *LWP::UserAgent::post = sub {
+        my ($self, $url, %rest) = @_;
+        $body = $rest{Content};
+        return Local::FakeCFResponse->new(
+            is_success => 1,
+            content    => '{"result":{"id":"rule-allow-1"}}',
+        );
+    };
+
+    my ($id, $status) = ConfigServer::CloudFlare::whitelist('US');
+
+    is($id, 'rule-allow-1',                              'whitelist returns the new rule id on success');
+    is($status, 'CloudFlare: whitelisted country US',    'whitelist status string includes the target classification');
+    like($body, qr/"mode"\s*:\s*"whitelist"/,            'whitelist body sets mode=whitelist regardless of CF_BLOCK');
+    like($body, qr/"target"\s*:\s*"country"/,            'whitelist body classifies a two-letter token as country');
+};
+
+subtest 'remove returns an id-not-found error when no id is supplied and lookup is empty' => sub {
+    load_cloudflare();
+
+    no warnings qw(redefine once);
+    local *ConfigServer::CloudFlare::getid = sub { return '' };
+
+    my $status = ConfigServer::CloudFlare::remove('192.0.2.10', 'block', '');
+
+    is($status, 'CloudFlare: [192.0.2.10] remove failed: id not found', 'missing rule id surfaces a clear error from remove()');
+};
+
+subtest 'remove issues DELETE and reports success when an explicit id is given' => sub {
+    load_cloudflare();
+
+    my %deleted;
+    no warnings qw(redefine once);
+    local *LWP::UserAgent::new    = sub { return bless {}, shift };
+    local *LWP::UserAgent::delete = sub {
+        my ($self, $url, %rest) = @_;
+        $deleted{url} = $url;
+        return Local::FakeCFResponse->new(is_success => 1, content => '{}');
+    };
+
+    my $status = ConfigServer::CloudFlare::remove('192.0.2.10', 'block', 'rule-123');
+
+    is($status, 'CloudFlare: removed ip 192.0.2.10', 'remove returns a human-readable success status');
+    is($deleted{url}, 'https://api.cloudflare.com/client/v4/user/firewall/access_rules/rules/rule-123', 'DELETE targets the rule id endpoint');
+};
+
+done_testing;

.github/tests/unit/messenger.t

@@ -0,0 +1,165 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+use FindBin qw($Bin);
+use Test::More;
+use lib "$Bin/../lib";
+
+use TestBootstrap ();
+
+{
+    package Local::FakeMessengerClient;
+
+    sub new {
+        my ($class, $payload) = @_;
+        return bless { buf => [ split //, $payload ] }, $class;
+    }
+
+    sub read {
+        my $self = shift;
+        # Caller passes: $client->read($char, 1)
+        # $_[0] aliases the caller's $char, $_[1] aliases the length argument.
+        if (@{ $self->{buf} }) {
+            $_[0] = shift @{ $self->{buf} };
+        } else {
+            $_[0] = "\n";
+        }
+        return 1;
+    }
+}
+
+sub load_messenger {
+    my (%config) = @_;
+    $config{IPV6}         //= 0;
+    $config{MESSENGER6}   //= 0;
+    $config{RECAPTCHA_NAT} //= '';
+    $config{DEBUG}        //= 0;
+    TestBootstrap::reload_module_with_config('ConfigServer::Messenger', \%config);
+    return;
+}
+
+# Override ConfigServer::GetEthDev so init(1) can run without probing real
+# network interfaces. Callers wrap a `local` block around their init() call.
+sub _stub_getethdev {
+    no warnings qw(redefine once);
+    *ConfigServer::GetEthDev::new  = sub { return bless {}, 'ConfigServer::GetEthDev' };
+    *ConfigServer::GetEthDev::ipv4 = sub { return () };
+    *ConfigServer::GetEthDev::ipv6 = sub { return () };
+    return;
+}
+
+subtest 'module exposes the documented public surface and a numeric VERSION' => sub {
+    load_messenger();
+
+    ok(ConfigServer::Messenger->can('init'),        'init() is part of the public API');
+    ok(ConfigServer::Messenger->can('start'),       'start() is part of the public API');
+    ok(ConfigServer::Messenger->can('messengerv2'), 'messengerv2() is callable as a class/package method');
+    ok(defined $ConfigServer::Messenger::VERSION,   '$VERSION is defined at package level');
+    cmp_ok($ConfigServer::Messenger::VERSION, '>=', 3.00,
+        '$VERSION is at or above the documented 3.x baseline');
+};
+
+subtest 'init returns a blessed instance for version 2 without touching ssl directories' => sub {
+    load_messenger();
+
+    my $obj = ConfigServer::Messenger->init(2);
+
+    isa_ok($obj, 'ConfigServer::Messenger', 'init returns a Messenger object for the v2 (TEXT) flavor');
+    can_ok($obj, 'start');
+};
+
+subtest 'init(1) returns a blessed instance once GetEthDev is stubbed out' => sub {
+    load_messenger();
+
+    no warnings qw(redefine once);
+    local *ConfigServer::GetEthDev::new  = sub { return bless {}, 'ConfigServer::GetEthDev' };
+    local *ConfigServer::GetEthDev::ipv4 = sub { return () };
+    local *ConfigServer::GetEthDev::ipv6 = sub { return () };
+
+    my $obj = ConfigServer::Messenger->init(1);
+
+    isa_ok($obj, 'ConfigServer::Messenger', 'init(1) returns a Messenger object for the v1 (HTTP/HTTPS) flavor');
+};
+
+subtest 'init(3) returns a blessed instance without dying on mkdir failures' => sub {
+    load_messenger();
+
+    my $obj = eval { ConfigServer::Messenger->init(3) };
+    is($@, '', 'init(3) does not throw when /var/lib/csf/ssl is not writable');
+    isa_ok($obj, 'ConfigServer::Messenger', 'init(3) returns a Messenger object for the v3 (HTTPS-CT) flavor');
+};
+
+subtest 'init(1) tolerates a populated RECAPTCHA_NAT list with spaces and multiple entries' => sub {
+    load_messenger(RECAPTCHA_NAT => '192.168.1.1, 10.0.0.1, 172.16.0.5');
+
+    no warnings qw(redefine once);
+    local *ConfigServer::GetEthDev::new  = sub { return bless {}, 'ConfigServer::GetEthDev' };
+    local *ConfigServer::GetEthDev::ipv4 = sub { return () };
+    local *ConfigServer::GetEthDev::ipv6 = sub { return () };
+
+    my $obj = eval { ConfigServer::Messenger->init(1) };
+    is($@, '', 'init(1) does not die when RECAPTCHA_NAT carries a comma-separated IP list with whitespace');
+    isa_ok($obj, 'ConfigServer::Messenger', 'init(1) still returns a Messenger object with RECAPTCHA_NAT populated');
+};
+
+subtest 'init(1) tolerates the MESSENGER6 + IPV6 combination' => sub {
+    load_messenger(MESSENGER6 => 1, IPV6 => 1);
+
+    no warnings qw(redefine once);
+    local *ConfigServer::GetEthDev::new  = sub { return bless {}, 'ConfigServer::GetEthDev' };
+    local *ConfigServer::GetEthDev::ipv4 = sub { return () };
+    local *ConfigServer::GetEthDev::ipv6 = sub { return () };
+
+    my $obj = eval { ConfigServer::Messenger->init(1) };
+    is($@, '', 'init(1) does not die when MESSENGER6 and IPV6 are both enabled');
+    isa_ok($obj, 'ConfigServer::Messenger', 'init(1) returns a Messenger object on an IPv6-enabled config');
+};
+
+subtest '_read_request_line returns an LF-terminated request line without the trailing newline' => sub {
+    load_messenger();
+
+    my $client = Local::FakeMessengerClient->new("GET / HTTP/1.0\n");
+    my $line = ConfigServer::Messenger::_read_request_line($client);
+
+    is($line, 'GET / HTTP/1.0', 'trailing LF is chomped off the returned line');
+};
+
+subtest '_read_request_line strips a trailing CR when the request uses CRLF' => sub {
+    load_messenger();
+
+    my $client = Local::FakeMessengerClient->new("GET /resource HTTP/1.1\r\n");
+    my $line = ConfigServer::Messenger::_read_request_line($client);
+
+    is($line, 'GET /resource HTTP/1.1', 'CRLF terminator is reduced to a bare request line');
+};
+
+subtest '_read_request_line stops reading once MAX_LINE_LENGTH bytes have been consumed' => sub {
+    load_messenger();
+
+    my $payload = ('A' x 5000) . "\n";
+    my $client = Local::FakeMessengerClient->new($payload);
+    my $line = ConfigServer::Messenger::_read_request_line($client);
+
+    ok(length($line) > ConfigServer::Messenger::MAX_LINE_LENGTH(),
+        'overlong request lines exit the read loop without consuming the entire payload');
+    ok(length($line) <= ConfigServer::Messenger::MAX_LINE_LENGTH() + 1,
+        'read stops within one byte of the documented MAX_LINE_LENGTH cap');
+    unlike($line, qr/\n/, 'returned line never contains an embedded newline');
+};
+
+subtest '_read_request_line accepts a line of exactly MAX_LINE_LENGTH bytes terminated by LF' => sub {
+    load_messenger();
+
+    my $max     = ConfigServer::Messenger::MAX_LINE_LENGTH();
+    my $payload = ('C' x $max) . "\n";
+    my $client  = Local::FakeMessengerClient->new($payload);
+
+    my $line = ConfigServer::Messenger::_read_request_line($client);
+
+    is(length($line), $max, 'a line exactly at MAX_LINE_LENGTH is read in full and the LF chomped');
+    is($line, 'C' x $max,    'the returned line is exactly the bytes that were provided');
+};
+
+done_testing;