TER1 (Statement): 82.82%
TER2 (Branch): 73.21%
TER3 (LCSAJ): 100.0% (18/18)
Approximate LCSAJ segments: 113
● Covered — this LCSAJ path was executed during testing.
● Not covered — this LCSAJ path was never executed. These are the paths to focus on.
Multiple dots on a line indicate that multiple control-flow paths begin at that line. Hovering over any dot shows:
start → end → jump
Uncovered paths show [NOT COVERED] in the tooltip.
1: package CGI::ACL; 2: 3: # Author Nigel Horne: njh@nigelhorne.com 4: # Copyright (C) 2017-2026, Nigel Horne 5: # 6: # Usage is subject to licence terms. 7: 8: use 5.014; # Socket::getaddrinfo/getnameinfo require Socket 2.000 (Perl 5.14) 9: use strict; 10: use warnings; 11: use autodie qw(:all); 12: 13: # namespace::clean removes imported helper names from the public method list 14: use namespace::clean; 15: 16: use Carp; 17: use Net::CIDR; 18: use Object::Configure; 19: use Params::Get; 20: use Readonly; 21: use Regexp::Common qw(net); 22: use Scalar::Util qw(blessed); 23: use Socket qw(AF_INET SOCK_STREAM inet_aton inet_ntoa); 24: use Sub::Protected; 25: 26: # ── Compile-time constants ───────────────────────────────────────────────────── 27: 28: # Maximum seconds to wait for a DNS reverse lookup on non-Windows platforms. 29: Readonly my $DNS_TIMEOUT => 10; 30: 31: # Seconds to cache a cloud-lookup result per IP in the per-object cache. 32: # Matches a typical short DNS TTL; balances freshness against resolver load. 33: Readonly my $CLOUD_CACHE_TTL => 300; 34: 35: # Sentinel value stored in deny_countries to mean "deny every country". 36: Readonly my $WILDCARD => q{*}; 37: 38: # Fallback client address when REMOTE_ADDR is absent (e.g. CLI or unit tests). 39: Readonly my $DEFAULT_ADDR => '127.0.0.1'; 40: 41: # Compiled regex for IP ranges that can never belong to a cloud provider: 42: # IPv4 loopback, RFC 1918 private blocks, link-local, and their IPv6 equivalents. 43: # Used by _is_cloud_host() to skip DNS entirely for these addresses. 44: Readonly my $PRIVATE_IP_RE => qr{ 45: ^(?: 46: 127\. | # IPv4 loopback (127.0.0.0/8) 47: 10\. | # RFC 1918 class A (10.0.0.0/8) 48: 192\.168\. | # RFC 1918 class C (192.168.0.0/16) 49: 172\.(?:1[6-9]|2[0-9]|3[01])\. | # RFC 1918 class B (172.16.0.0/12) 50: 169\.254\. # IPv4 link-local (169.254.0.0/16) 51: ) 52: | ^::1$ # IPv6 loopback 53: | ^f[cd][0-9a-f]{2}: # IPv6 unique local (fc00::/7) 54: | ^fe[89ab][0-9a-f]: # IPv6 link-local (fe80::/10) 55: }xi; 56: 57: # Compiled regexes that identify cloud-provider reverse-DNS hostnames. 58: # _is_cloud_host() iterates this list; to add a provider, append a qr// here. 59: Readonly my @CLOUD_PATTERNS => ( 60: qr/\.compute(?:-\d+)?\.amazonaws\.com$/i, # AWS EC2 61: qr/\.bc\.googleusercontent\.com$/i, # Google Cloud Compute 62: qr/\.cloudapp\.net$/i, # Microsoft Azure 63: qr/\.azure\.com$/i, # Microsoft Azure (general) 64: qr/digitalocean/i, # DigitalOcean 65: qr/\.members\.linode\.com$/i, # Linode / Akamai 66: qr/hetzner/i, # Hetzner Cloud 67: qr/your-server\.de$/i, # Hetzner (legacy dedicated) 68: qr/\.ovh\.net$/i, # OVH Cloud 69: qr/^ip-\d{1,3}-\d{1,3}-\d{1,3}-\d{1,3}\.eu$/i, # OVH European IP range 70: ); 71: 72: =encoding utf-8 73: 74: =head1 NAME 75: 76: CGI::ACL - Decide whether to allow a client to run a CGI script 77: 78: =head1 VERSION 79: 80: Version 0.10 81: 82: =cut 83: 84: our $VERSION = '0.10'; 85: 86: =head1 SYNOPSIS 87: 88: CGI::ACL controls who can run your CGI script. You build a set of rules 89: and then call C<all_denied()> on every request. If it returns C<1>, 90: send an error response or redirect; if it returns C<0>, allow the request. 91: 92: Rules can be stacked in any order using method chaining. An unrestricted 93: object (no rules added) allows everything. 94: 95: =head2 Block all cloud-hosted visitors 96: 97: The simplest use case -- no country list or lingua object needed. 98: 99: use CGI::ACL; 100: 101: my $acl = CGI::ACL->new()->deny_cloud(); 102: 103: if ($acl->all_denied()) { 104: print "Content-Type: text/plain\n\n"; 105: print "Automated cloud traffic is not permitted.\n"; 106: exit; 107: } 108: 109: =head2 Allow only specific IP addresses or CIDR ranges 110: 111: Localhost is NOT automatically allowed once any restriction is set. 112: Add it explicitly if your script is called from the same machine. 113: 114: use CGI::ACL; 115: 116: my $acl = CGI::ACL->new() 117: ->allow_ip('127.0.0.1') # local machine 118: ->allow_ip('203.0.113.0/24') # office CIDR block 119: ->allow_ip('2001:db8::1'); # single IPv6 address 120: 121: if ($acl->all_denied()) { 122: print "Content-Type: text/plain\n\n"; 123: print "Your IP address is not on the allow list.\n"; 124: exit; 125: } 126: 127: =head2 Block visitors from specific countries 128: 129: Deny mode: allow everyone except the listed countries. 130: 131: use CGI::Lingua; 132: use CGI::ACL; 133: 134: my $lingua = CGI::Lingua->new(supported => ['en']); 135: 136: my $acl = CGI::ACL->new() 137: ->deny_country('CN') 138: ->deny_country(country => ['RU', 'KP']); 139: 140: if ($acl->all_denied(lingua => $lingua)) { 141: print "Content-Type: text/plain\n\n"; 142: print "Access from your country is not permitted.\n"; 143: exit; 144: } 145: 146: =head2 Allow only specific countries (allowlist) 147: 148: Default-deny mode: block everyone except the listed countries. 149: Use C<deny_all_countries()> to turn on default-deny, then list 150: each permitted country with C<allow_country()>. 151: 152: use CGI::Lingua; 153: use CGI::ACL; 154: 155: my $lingua = CGI::Lingua->new(supported => ['en', 'de', 'fr']); 156: 157: my $acl = CGI::ACL->new() 158: ->deny_all_countries() 159: ->allow_country('GB') 160: ->allow_country('US') 161: ->allow_country('DE'); 162: 163: if ($acl->all_denied(lingua => $lingua)) { 164: print "Content-Type: text/plain\n\n"; 165: print "This service is available in GB, US, and DE only.\n"; 166: exit; 167: } 168: 169: =head2 Production-grade: IP allowlist + country allowlist + cloud block 170: 171: Combine all three rule types. Rules are evaluated in this fixed order: 172: cloud check, IP check, country check. 173: 174: use CGI::Lingua; 175: use CGI::ACL; 176: 177: my $lingua = CGI::Lingua->new(supported => ['en']); 178: 179: my $acl = CGI::ACL->new() 180: ->deny_cloud() # block AWS, GCP, Azure, etc. 181: ->allow_ip('127.0.0.1') # always allow localhost 182: ->allow_ip('198.51.100.0/24') # corporate network 183: ->deny_all_countries() # default-deny all countries... 184: ->allow_country('GB') # ...except UK 185: ->allow_country('US'); # ...and US 186: 187: if ($acl->all_denied(lingua => $lingua)) { 188: print "Content-Type: text/plain\n\n"; 189: print "Access denied.\n"; 190: exit; 191: } 192: 193: =head2 Sharing a base ACL across routes with cloning 194: 195: Call C<new()> on an existing object to get an independent copy. 196: Changing the copy does not affect the original. 197: 198: use CGI::ACL; 199: 200: # Shared base: block cloud for all routes 201: my $base_acl = CGI::ACL->new()->deny_cloud(); 202: 203: # Admin route: additionally restrict to a single IP 204: my $admin_acl = $base_acl->new()->allow_ip('198.51.100.1'); 205: 206: if ($admin_acl->all_denied()) { 207: print "Content-Type: text/plain\n\n"; 208: print "Admin access denied.\n"; 209: exit; 210: } 211: 212: The module optionally integrates with L<CGI::Lingua> for country detection. 213: Runtime configuration is supported via L<Object::Configure>. 214: 215: =head1 COMMON PITFALLS 216: 217: The following mistakes are easy to make. Read this section before filing 218: a bug report. 219: 220: =head2 allow_country alone has no effect 221: 222: C<allow_country()> only restricts access when default-deny mode is active. 223: Default-deny mode is activated by C<deny_country('*')> or 224: C<deny_all_countries()>. Without it, C<allow_country()> is silently 225: ignored and everyone is still allowed. 226: 227: # WRONG -- this allows everyone; allow_country is ignored 228: my $acl = CGI::ACL->new()->allow_country('US'); 229: 230: # RIGHT -- deny all countries first, then add permitted ones 231: my $acl = CGI::ACL->new()->deny_all_countries()->allow_country('US'); 232: 233: =head2 deny_cloud overrides allow_ip 234: 235: Cloud detection has the highest priority. An IP address that is listed 236: in C<allow_ip()> is still blocked if its reverse DNS resolves to a cloud 237: provider hostname. This is intentional: cloud IPs can be reassigned, so 238: the rDNS check is more reliable than the IP address alone. 239: 240: # This STILL blocks the IP if it is a cloud host 241: my $acl = CGI::ACL->new() 242: ->deny_cloud() 243: ->allow_ip('198.51.100.5'); # blocked if rDNS says EC2 244: 245: =head2 Localhost is not automatically allowed 246: 247: Once any restriction is set, C<127.0.0.1> is subject to the same rules 248: as any other address. If you need to allow local access (for example, 249: a health-check endpoint), add it explicitly. 250: 251: my $acl = CGI::ACL->new() 252: ->allow_ip('127.0.0.1') # must be explicit 253: ->deny_all_countries() 254: ->allow_country('US'); 255: 256: =head2 Forgetting the lingua argument 257: 258: When country restrictions are active and C<all_denied()> is called without 259: a C<lingua> argument, the module emits a C<carp> warning and denies the 260: request. Always pass a C<CGI::Lingua> object when country rules are in use. 261: 262: # WRONG -- will carp and deny every request 263: my $acl = CGI::ACL->new()->deny_all_countries()->allow_country('US'); 264: $acl->all_denied(); 265: 266: # RIGHT 267: my $lingua = CGI::Lingua->new(supported => ['en']); 268: $acl->all_denied(lingua => $lingua); 269: 270: =head2 VPN and proxy users bypass IP and country checks 271: 272: A visitor who connects through a VPN, Tor exit node, or anonymous proxy 273: will appear to come from the proxy's IP address and country, not their 274: own. CGI::ACL has no way to detect this. Cloud blocking provides some 275: mitigation for VPS-based proxies. 276: 277: =head2 Country codes are case-insensitive but stored lowercase 278: 279: C<deny_country('BR')> and C<deny_country('br')> are equivalent. All 280: country codes are stored in lowercase. C<CGI::Lingua::country()> may 281: return either case; C<all_denied()> normalises it with C<lc()> before 282: comparing. 283: 284: =head2 The DNS result cache is not shared between CGI requests 285: 286: In traditional CGI (one process per request), the per-object DNS cache 287: is destroyed at the end of every request. The cache is only useful in 288: persistent-process setups such as FastCGI, mod_perl, or Plack servers, 289: where the same C<CGI::ACL> object survives across many requests. 290: 291: =head1 SUBROUTINES/METHODS 292: 293: =head2 new 294: 295: Creates and returns a new CGI::ACL object. 296: 297: When called on an existing object it returns a deep clone of that object, 298: optionally overriding public fields with the supplied arguments. The public 299: data hashes (C<allowed_ips>, C<deny_countries>, C<allow_countries>) are 300: copied so that mutations to the clone do not affect the original. 301: Derived/private keys (C<_cidrlist>, C<_cloud_cache>) are always cleared; 302: they are rebuilt from the cloned public state on the next C<all_denied()> 303: call. 304: 305: B<Security note:> private C<_*> keys are stripped from all constructor 306: arguments, including those supplied via environment variables or a config 307: file. Accepting C<_cloud_cache> entries from outside the process would 308: allow an attacker with environment-variable access to pre-seed the DNS 309: result cache and bypass C<deny_cloud()> for specific IP addresses. 310: 311: Constructor arguments may also be supplied via environment variables of the 312: form C<CGI__ACL__E<lt>fieldE<gt>> or via a config file; see L<Object::Configure> 313: for details. 314: 315: =head3 EXAMPLE 316: 317: # No restrictions (allow all by default) 318: my $acl = CGI::ACL->new(); 319: 320: # Pre-seeded allow list 321: my $acl = CGI::ACL->new(allowed_ips => { '127.0.0.1' => 1 }); 322: 323: # Clone an existing ACL and add a restriction 324: my $acl2 = $acl->new(deny_cloud => 1); 325: 326: =head3 API SPECIFICATION 327: 328: =head4 Input 329: 330: # Compatible with Params::Validate::Strict: 331: { 332: allowed_ips => { type => 'hashref', optional => 1 }, 333: deny_countries => { type => 'hashref', optional => 1 }, 334: allow_countries => { type => 'hashref', optional => 1 }, 335: deny_cloud => { type => 'boolean', optional => 1 }, 336: } 337: 338: =head4 Output 339: 340: # Compatible with Return::Set: 341: { type => 'object', isa => 'CGI::ACL' } 342: # or undef when called as CGI::ACL::new() instead of CGI::ACL->new() 343: 344: =head3 MESSAGES 345: 346: =over 4 347: 348: =item C<< CGI::ACL use ->new() not ::new() to instantiate >> 349: 350: B<Severity:> carp (warning). 351: B<Cause:> C<CGI::ACL::new(...)> was called as a plain function instead of 352: as a class method. 353: B<Action:> Change the call to C<< CGI::ACL->new(...) >>. 354: 355: =back 356: 357: =cut 358: 359: sub new { ●360 → 366 → 396 360: my $class = shift; 361: 362: # Parse arguments uniformly (hashref, named pairs, or no args) 363: my $params = Params::Get::get_params(undef, \@_); 364: 365: # Handle the rare case of being called as a plain function: CGI::ACL::new() 366: if(!defined($class)) { 367: Carp::carp(__PACKAGE__ . ': use ->new() not ::new() to instantiate'); 368: return; 369: } elsif(blessed($class)) { 370: # Called on an existing object: return a clone with deep-copied sub-hashes 371: # so that mutations to the clone do not affect the original. 372: $params //= {}; 373: my %copy = %{$class}; 374: for my $key (qw(allowed_ips deny_countries allow_countries)) { 375: $copy{$key} = { %{$copy{$key}} } if ref($copy{$key}) eq 'HASH'; 376: } 377: # Clear derived caches; they will be rebuilt fresh from the cloned state. 378: delete $copy{_cidrlist};Mutants (Total: 1, Killed: 1, Survived: 0)
379: delete $copy{_cloud_cache}; 380: 381: # Strip private/derived keys from caller-supplied params before merging. 382: # Accepting _cloud_cache would let a caller pre-seed the DNS result cache 383: # to permanently suppress cloud detection for a targeted IP address. 384: # Accepting _cidrlist would inject a fabricated CIDR lookup structure. 385: # Public keys (deny_cloud, allowed_ips, deny_countries, allow_countries) 386: # are intentionally preserved so clone overrides still work. 387: my %safe_params = map { $_ => $params->{$_} } 388: grep { !/\A_/xms } 389: keys %{$params}; 390: return bless { %copy, %safe_params }, ref($class); 391: } 392:
Mutants (Total: 2, Killed: 2, Survived: 0)
393: # Merge any config-file or environment-variable overrides, then strip any 394: # private/cache keys that may have arrived via CGI__ACL__* env vars or a 395: # config file. Private state must be derived at runtime, not supplied externally. 396: my $cfg = Object::Configure::configure($class, $params);
Mutants (Total: 2, Killed: 2, Survived: 0)
397: delete $cfg->{$_} for grep { /\A_/xms } keys %{$cfg}; 398: return bless $cfg, $class; 399: } 400: 401: =head2 allow_ip 402: 403: Adds an IPv4/IPv6 address or CIDR block to the set of explicitly permitted 404: clients. When C<allowed_ips> is non-empty, any client address not matched 405: by an entry in the set is denied (subject to C<deny_cloud> taking precedence). 406: 407: =head3 EXAMPLE 408: 409: use CGI::ACL; 410: 411: # Single address 412: my $acl = CGI::ACL->new()->allow_ip('203.0.113.5'); 413: 414: # Named parameter 415: my $acl = CGI::ACL->new()->allow_ip(ip => '203.0.113.5'); 416: 417: # CIDR block 418: my $acl = CGI::ACL->new()->allow_ip(ip => '192.0.2.0/24'); 419: 420: # Method chaining 421: my $acl = CGI::ACL->new() 422: ->allow_ip('192.0.2.1') 423: ->allow_ip('10.0.0.0/8'); 424: 425: =head3 ARGUMENTS 426: 427: =over 4 428: 429: =item ip (required) 430: 431: A string containing an IPv4 address, an IPv6 address, or a CIDR block 432: (e.g. C<10.0.0.0/8>). The format is validated before storage; 433: syntactically invalid values are rejected with a carp warning and the 434: object is returned unchanged. 435: 436: =back 437: 438: =head3 RETURNS 439: 440: The object itself, to allow method chaining. 441: 442: =head3 SIDE EFFECTS 443: 444: On the first call (even if the supplied address is invalid), initialises 445: C<< $self->{allowed_ips} >> to an empty hashref so that C<all_denied()> 446: treats the ACL as having IP restrictions configured. This ensures 447: fail-closed behaviour: an ACL whose only C<allow_ip()> calls all supplied 448: invalid addresses denies all traffic rather than allowing it. 449: 450: On a successful (valid) call, also invalidates the internal CIDR lookup 451: cache so the next call to C<all_denied()> rebuilds it with the new entry. 452: 453: =head3 API SPECIFICATION 454: 455: =head4 Input 456: 457: # Compatible with Params::Validate::Strict: 458: { 459: ip => { type => 'string', regex => qr/\S+/, required => 1 }, 460: } 461: 462: =head4 Output 463: 464: # Compatible with Return::Set: 465: { type => 'object', isa => 'CGI::ACL' } 466: 467: =head3 MESSAGES 468: 469: =over 4 470: 471: =item C<Usage: allow_ip($ip_address)> 472: 473: B<Severity:> carp (warning). 474: B<Cause:> Called with no argument, with a non-hash reference, or without 475: supplying the C<ip> key. 476: B<Action:> Pass a scalar IP/CIDR string: C<allow_ip('192.0.2.1')> or 477: C<allow_ip(ip =E<gt> '192.0.2.1')>. 478: 479: =item C<< allow_ip: 'X' is not a valid IP address or CIDR block >> 480: 481: B<Severity:> carp (warning). 482: B<Cause:> The supplied string does not parse as a syntactically valid IPv4 483: address, IPv6 address, or CIDR block. The value (truncated to 60 chars in 484: the message) was not stored. C<$self->{allowed_ips}> is still initialised 485: so the ACL remains in fail-closed mode. 486: B<Action:> Check the supplied string for typos. Use dotted-quad notation 487: for IPv4 (e.g. C<192.0.2.1>), colon-hex for IPv6 (e.g. C<2001:db8::1>), 488: or slash-notation for CIDR (e.g. C<10.0.0.0/8>). 489: 490: =back 491: 492: =cut
Mutants (Total: 1, Killed: 1, Survived: 0)
493: 494: sub allow_ip {
Mutants (Total: 2, Killed: 2, Survived: 0)
●495 → 499 → 505 495: my $self = shift; 496: 497: # Guard 1: reject non-hash, non-scalar references (e.g. scalar ref passed by mistake) 498: my $ref = ref($_[0]); 499: if($ref && $ref ne 'HASH') {
Mutants (Total: 1, Killed: 1, Survived: 0)
500: Carp::carp('Usage: allow_ip($ip_address)'); 501: return $self;
Mutants (Total: 2, Killed: 2, Survived: 0)
502: } 503: 504: # Guard 2: require a non-undef 'ip' value (missing key or empty call) ●505 → 506 → 517 505: my $ip = @_ ? Params::Get::get_params('ip', @_)->{'ip'} : undef; 506: unless(defined $ip) { 507: Carp::carp('Usage: allow_ip($ip_address)');
Mutants (Total: 2, Killed: 2, Survived: 0)
508: return $self; 509: } 510: 511: # Initialise allowed_ips before format validation so that the early-return 512: # guard in all_denied() sees the ACL as "has IP restrictions" even when every 513: # supplied address turns out to be invalid. Without this, an ACL that only 514: # received invalid IPs would appear restriction-free and allow all traffic 515: # (fail-open). With an empty hashref, the guard skips its fast path and the 516: # IP check finds no match → all_denied returns 1 (deny — fail-closed). ●517 → 524 → 538 517: $self->{allowed_ips} //= {}; 518: 519: # Validate format before storage: extract the base address (stripping any 520: # prefix length) and confirm it is a syntactically valid IPv4 or IPv6 address. 521: # Rejecting invalid strings prevents memory accumulation in persistent processes 522: # and eliminates the O(n) eval overhead per cidradd on bad entries. 523: my ($base) = $ip =~ /\A([^\/]+)/; 524: unless( 525: defined($base) && ( 526: $base =~ /\A$RE{net}{IPv4}\z/o || 527: $base =~ /\A$RE{net}{IPv6}\z/o 528: ) 529: ) { 530: # Truncate the offending value in the message to prevent log flooding 531: # when an attacker supplies a very long string (e.g. 64 KiB garbage). 532: my $display = length($ip) > 60 ? substr($ip, 0, 60) . '...' : $ip; 533: Carp::carp("allow_ip: '$display' is not a valid IP address or CIDR block"); 534: return $self; 535: } 536: 537: # Happy path: store the validated address and invalidate the memoised CIDR list 538: $self->{allowed_ips}->{$ip} = 1; 539: delete $self->{_cidrlist}; 540: return $self; 541: } 542: 543: # ── deny_country ─────────────────────────────────────────────────────────────── 544: 545: =head2 deny_country 546: 547: Adds one or more countries to the deny list. Countries are identified by 548: their ISO 3166-1 alpha-2 codes (case-insensitive). 549: 550: Passing the special value C<'*'> (wildcard) switches to default-deny mode: 551: all countries are denied unless they also appear in the allow list set by 552: C<allow_country()>. 553: 554: =head3 EXAMPLE 555: 556: use CGI::ACL; 557: 558: # Deny a single country 559: my $acl = CGI::ACL->new()->deny_country('BR'); 560: 561: # Deny a list of countries 562: my $acl = CGI::ACL->new()->deny_country(country => ['BR', 'CN', 'RU']); 563: 564: # Default-deny all countries (use with allow_country to whitelist) 565: my $acl = CGI::ACL->new()->deny_country('*')->allow_country('US'); 566: 567: =head3 ARGUMENTS 568: 569: =over 4 570: 571: =item country (required) 572: 573: A scalar ISO code, the wildcard C<'*'>, or an array reference of ISO codes. 574: 575: =back 576: 577: =head3 RETURNS 578: 579: The object itself, to allow method chaining. 580: 581: =head3 SIDE EFFECTS 582: 583: Updates C<< $self->{deny_countries} >>. 584: 585: =head3 NOTES 586: 587: C<allow_country()> has no effect unless C<deny_country('*')> has been called 588: first. Calling C<allow_country()> alone (without the wildcard deny) does 589: not restrict access. 590: 591: =head3 API SPECIFICATION 592: 593: =head4 Input 594: 595: # Compatible with Params::Validate::Strict: 596: { 597: country => { 598: type => 'string' | 'arrayref', 599: required => 1, 600: }, 601: } 602: 603: =head4 Output 604: 605: # Compatible with Return::Set: 606: { type => 'object', isa => 'CGI::ACL' } 607: 608: =head3 MESSAGES 609: 610: =over 4 611: 612: =item C<Usage: deny_country($country)>
Mutants (Total: 1, Killed: 1, Survived: 0)
613: 614: B<Severity:> carp (warning).
Mutants (Total: 2, Killed: 2, Survived: 0)
615: B<Cause:> Called with no argument, with a non-hash/non-array reference, or 616: without supplying the C<country> key. 617: B<Action:> Pass a scalar ISO code or arrayref: 618: C<deny_country('BR')> or C<deny_country(country =E<gt> ['BR','CN'])>. 619:
Mutants (Total: 1, Killed: 1, Survived: 0)
620: =back 621:
Mutants (Total: 2, Killed: 2, Survived: 0)
622: =cut 623: 624: sub deny_country { ●625 → 629 → 635 625: my $self = shift;
Mutants (Total: 2, Killed: 2, Survived: 0)
626: 627: # Guard 1: reject references that are neither hashes nor arrays 628: my $ref = ref($_[0]); 629: if($ref && $ref ne 'HASH' && $ref ne 'ARRAY') {
Mutants (Total: 2, Killed: 2, Survived: 0)
630: Carp::carp('Usage: deny_country($country)'); 631: return $self; 632: } 633: 634: # Guard 2: require a non-undef 'country' value ●635 → 636 → 642 635: my $c = @_ ? Params::Get::get_params('country', @_)->{'country'} : undef; 636: unless(defined $c) { 637: Carp::carp('Usage: deny_country($country)'); 638: return $self; 639: } 640: 641: # Guard 3: an empty arrayref is a no-op — do not create deny_countries = {} 642: return $self if ref($c) eq 'ARRAY' && !@{$c}; 643: 644: # Happy path: store the country code(s) in the deny set 645: _set_countries($self->{deny_countries} //= {}, $c); 646: return $self; 647: } 648: 649: # ── allow_country ────────────────────────────────────────────────────────────── 650: 651: =head2 allow_country 652: 653: Adds one or more countries to the explicit permit list. This is meaningful 654: only when C<deny_country('*')> has been called first; without the wildcard 655: deny, this method has no observable effect on access decisions. 656: 657: =head3 EXAMPLE 658: 659: use CGI::ACL; 660: 661: # Allow only the UK and US 662: my $acl = CGI::ACL->new() 663: ->deny_country('*') 664: ->allow_country(country => ['GB', 'US']); 665: 666: # Single country as positional argument 667: my $acl = CGI::ACL->new()->deny_country('*')->allow_country('US'); 668: 669: =head3 ARGUMENTS 670: 671: =over 4 672: 673: =item country (required) 674: 675: A scalar ISO code or an array reference of ISO codes. 676: 677: =back 678: 679: =head3 RETURNS 680: 681: The object itself, to allow method chaining. 682: 683: =head3 SIDE EFFECTS 684: 685: Updates C<< $self->{allow_countries} >>. 686: 687: =head3 NOTES 688: 689: Call C<deny_country('*')> before this method; otherwise all traffic is 690: already allowed by the default-allow rule and the permit list is never 691: consulted. 692: 693: =head3 API SPECIFICATION 694: 695: =head4 Input 696: 697: # Compatible with Params::Validate::Strict: 698: { 699: country => { 700: type => 'string' | 'arrayref', 701: required => 1, 702: }, 703: } 704: 705: =head4 Output 706: 707: # Compatible with Return::Set: 708: { type => 'object', isa => 'CGI::ACL' } 709: 710: =head3 MESSAGES 711: 712: =over 4 713: 714: =item C<Usage: allow_country($country)> 715: 716: B<Severity:> carp (warning). 717: B<Cause:> Called with no argument, with a non-hash/non-array reference, or 718: without supplying the C<country> key. 719: B<Action:> Pass a scalar ISO code or arrayref: 720: C<allow_country('US')> or C<allow_country(country =E<gt> ['GB','US'])>. 721: 722: =back 723: 724: =cut 725: 726: sub allow_country { ●727 → 731 → 737 727: my $self = shift; 728: 729: # Guard 1: reject references that are neither hashes nor arrays 730: my $ref = ref($_[0]);
Mutants (Total: 1, Killed: 1, Survived: 0)
731: if($ref && $ref ne 'HASH' && $ref ne 'ARRAY') { 732: Carp::carp('Usage: allow_country($country)');
Mutants (Total: 2, Killed: 2, Survived: 0)
733: return $self; 734: } 735: 736: # Guard 2: require a non-undef 'country' value ●737 → 738 → 744 737: my $c = @_ ? Params::Get::get_params('country', @_)->{'country'} : undef;
Mutants (Total: 1, Killed: 1, Survived: 0)
738: unless(defined $c) { 739: Carp::carp('Usage: allow_country($country)');
Mutants (Total: 2, Killed: 2, Survived: 0)
740: return $self; 741: } 742: 743: # Guard 3: an empty arrayref is a no-op — do not create allow_countries = {}
744: return $self if ref($c) eq 'ARRAY' && !@{$c}; 745: 746: # Happy path: store the country code(s) in the permit set 747: _set_countries($self->{allow_countries} //= {}, $c);Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_743_2: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_743_2: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );Mutants (Total: 2, Killed: 2, Survived: 0)
748: return $self; 749: } 750: 751: # ── deny_cloud ───────────────────────────────────────────────────────────────── 752: 753: =head2 deny_cloud 754: 755: Enables blocking of requests that originate from major cloud-hosting 756: providers. Detection is performed via verified reverse DNS: the client 757: IP is looked up, the resulting hostname is forward-confirmed to prevent 758: spoofing, and the confirmed hostname is matched against a list of 759: provider-specific patterns. 760: 761: Covered providers (as of this release): AWS EC2, Google Cloud Compute, 762: Microsoft Azure, DigitalOcean, Linode/Akamai, Hetzner, OVH. 763: 764: B<Important:> C<deny_cloud> takes precedence over C<allow_ip>. An IP 765: that is explicitly permitted via C<allow_ip()> is still denied if its 766: reverse DNS resolves to a cloud provider hostname. 767: 768: =head3 EXAMPLE 769: 770: use CGI::ACL; 771: 772: my $acl = CGI::ACL->new()->deny_cloud(); 773: 774: if ($acl->all_denied()) { 775: print "Cloud-hosted clients are not permitted.\n"; 776: exit; 777: } 778: 779: =head3 ARGUMENTS 780: 781: None. 782: 783: =head3 RETURNS 784: 785: The object itself, to allow method chaining. 786: 787: =head3 SIDE EFFECTS 788: 789: Sets C<< $self->{deny_cloud} >> to C<1>. 790: 791: =head3 NOTES 792: 793: IPv4 and IPv6 clients are both subject to the cloud check. A client with 794: no reverse DNS record, or whose forward confirmation fails, is treated as 795: a non-cloud host and allowed through the cloud check (though it may still 796: be denied by other rules). 797: 798: DNS lookups are performed synchronously. On non-Windows platforms a 799: C<$DNS_TIMEOUT>-second alarm is used to prevent indefinite blocking. 800: 801: =head3 API SPECIFICATION 802: 803: =head4 Input 804: 805: # No parameters accepted. 806: {} 807: 808: =head4 Output 809: 810: # Compatible with Return::Set: 811: { type => 'object', isa => 'CGI::ACL' } 812: 813: =head3 MESSAGES 814: 815: This method emits no messages. 816: 817: =cut 818: 819: sub deny_cloud { 820: my $self = shift; 821: 822: # Mark cloud-origin blocking as active 823: $self->{deny_cloud} = 1; 824: return $self; 825: } 826: 827: # ── deny_all_countries ───────────────────────────────────────────────────────── 828: 829: =head2 deny_all_countries 830: 831: Convenience method equivalent to C<deny_country('*')>. Switches the ACL 832: into default-deny mode for country checks: every country is denied unless 833: it also appears in the permit list added by C<allow_country()>. 834: 835: This is the idiomatic way to build an allowlist-only country policy without
Mutants (Total: 2, Killed: 2, Survived: 0)
836: spelling out the wildcard literal. 837: 838: =head3 EXAMPLE 839: 840: use CGI::ACL; 841: 842: # Allow only the UK and US; deny every other country 843: my $acl = CGI::ACL->new() 844: ->deny_all_countries() 845: ->allow_country('GB') 846: ->allow_country('US'); 847: 848: if ($acl->all_denied(lingua => $lingua)) { 849: print "Your country is not permitted.\n"; 850: exit; 851: } 852: 853: =head3 ARGUMENTS 854: 855: None. 856: 857: =head3 RETURNS 858: 859: The object itself, to allow method chaining. 860: 861: =head3 SIDE EFFECTS 862: 863: Sets C<< $self->{deny_countries}{'*'} >> to C<1>, activating default-deny 864: mode. C<allow_country()> calls made before or after this method both take 865: effect - evaluation order is irrelevant because all data is applied at 866: C<all_denied()> call time. 867: 868: =head3 NOTES 869: 870: C<allow_country()> has no restrictive effect unless this method (or 871: C<deny_country('*')>) has also been called. 872: 873: =head3 API SPECIFICATION 874: 875: =head4 Input 876: 877: # No parameters accepted. 878: {} 879: 880: =head4 Output 881: 882: # Compatible with Return::Set: 883: { type => 'object', isa => 'CGI::ACL' } 884: 885: =head3 MESSAGES 886: 887: This method emits no messages. 888: 889: =cut 890: 891: sub deny_all_countries { 892: my $self = shift; 893: 894: # Sugar for deny_country('*'): sets the wildcard sentinel that switches 895: # all_denied() into default-deny mode for country checks. 896: _set_countries($self->{deny_countries} //= {}, $WILDCARD); 897: return $self; 898: } 899: 900: # ── all_denied ───────────────────────────────────────────────────────────────── 901: 902: =head2 all_denied 903: 904: Evaluates every active restriction against the current client and returns 905: C<1> (deny) or C<0> (allow). 906: 907: The evaluation order is: 908: 909: =over 4 910: 911: =item 1. 912: 913: If B<no> restrictions are configured at all, return C<0> (allow). 914: 915: =item 2. 916: 917: Validate C<REMOTE_ADDR> as a syntactically correct IPv4 or IPv6 address. 918: If it is missing or malformed, return C<1> (deny). 919:
Mutants (Total: 2, Killed: 2, Survived: 0)
920: =item 3. 921: 922: If C<deny_cloud> is set, perform a verified reverse-DNS lookup. If the 923: hostname matches a cloud provider, return C<1> (deny) immediately, 924: regardless of C<allowed_ips>. If the IP is not a cloud host and no 925: other restrictions are active, return C<0> (allow). 926: 927: =item 4. 928: 929: If C<allowed_ips> is set, check the client address against the exact-match 930: hash and then the CIDR list. Return C<0> (allow) on a match. 931: 932: =item 5. 933: 934: If country restrictions are set, resolve the client's country via the 935: C<lingua> argument. Apply default-deny or default-allow country logic. 936: If no lingua is provided, emit a warning and return C<1> (deny). 937: 938: =back 939: 940: Note that localhost (C<127.0.0.1>) is B<not> automatically allowed once 941: any restriction is configured; call C<allow_ip('127.0.0.1')> explicitly. 942: 943: =head3 EXAMPLE 944: 945: use CGI::Lingua; 946: use CGI::ACL; 947: 948: my $acl = CGI::ACL->new()->allow_ip('8.35.80.39'); 949: 950: if ($acl->all_denied()) { 951: print "You are not allowed to view this site.\n"; 952: exit; 953: } 954: 955: # Country check 956: my $acl2 = CGI::ACL->new() 957: ->deny_country('*') 958: ->allow_country('US'); 959: 960: if ($acl2->all_denied(lingua => CGI::Lingua->new(supported => ['en']))) { 961: print "US-only site.\n"; 962: exit; 963: } 964: 965: =head3 ARGUMENTS 966: 967: =over 4 968: 969: =item lingua (optional) 970: 971: A L<CGI::Lingua> object (or any object with a C<country()> method returning 972: an ISO 3166-1 alpha-2 code or C<undef>). Required when country restrictions 973: are active; ignored otherwise. 974: 975: =back 976: 977: =head3 RETURNS 978: 979: C<1> if access is denied, C<0> if access is allowed. 980: 981: =head3 SIDE EFFECTS 982: 983: May populate or update C<< $self->{_cidrlist} >> (the memoised CIDR lookup 984: structure) and C<< $self->{_cloud_cache} >> (the per-object DNS result 985: cache, keyed by IP address string) as performance optimisations. 986: 987: =head3 API SPECIFICATION 988: 989: =head4 Input 990: 991: # Compatible with Params::Validate::Strict: 992: { 993: lingua => { type => 'object', optional => 1 }, 994: } 995: 996: =head4 Output 997: 998: # Compatible with Return::Set: 999: { type => 'string', regex => qr/^[01]$/ } 1000: 1001: =head3 MESSAGES 1002: 1003: =over 4 1004: 1005: =item C<Usage: all_denied($lingua)> 1006: 1007: B<Severity:> carp (warning). 1008: B<Cause:> Country restrictions are active (C<deny_country> or 1009: C<allow_country> was called) but no C<lingua> argument was supplied. 1010: B<Action:> Pass a C<CGI::Lingua> object: 1011: C<all_denied(lingua =E<gt> $lingua)>. 1012: 1013: =back 1014: 1015: =head3 PSEUDOCODE 1016: 1017: IF no restrictions configured THEN 1018: RETURN 0 (allow -- fast path) 1019: 1020: raw := REMOTE_ADDR // '127.0.0.1' 1021: -- \A and \z anchors (not ^ / $): \z never matches before a trailing \n 1022: IF raw not matched by /\A IPv4-or-IPv6 \z/ THEN 1023: RETURN 1 (deny -- bad or injected address) 1024: -- Detaint: extract addr via character-class capture so the value 1025: -- is clean under Perl -T taint mode for all downstream callers 1026: addr := capture [0-9A-Fa-f:.]+ from raw 1027: 1028: IF deny_cloud is set THEN 1029: consult per-object cache keyed by addr (TTL 300 s) 1030: IF cache miss THEN 1031: is_cloud := _is_cloud_host(addr) [DNS; may throw] 1032: IF no error THEN cache result END IF 1033: END IF 1034: IF is_cloud THEN RETURN 1 (deny -- cloud host) 1035: IF no meaningful further restrictions THEN RETURN 0 (allow) 1036: -- "meaningful" = allowed_ips ≠∅ OR deny_countries ≠∅ 1037: -- allow_countries alone is not meaningful (never changes the decision) 1038: END IF 1039: 1040: IF allowed_ips is set THEN 1041: IF addr matches exact-match entry THEN RETURN 0 (allow) 1042: IF addr falls inside any CIDR range THEN RETURN 0 (allow) 1043: END IF 1044: 1045: IF deny_countries is set THEN 1046: -- Premise: allow_countries alone is vacuous (always returns 0 in 1047: -- non-wildcard mode); if only allow_countries was set, earlier guards 1048: -- already returned 0. This condition is therefore necessary and sufficient. 1049: IF no lingua supplied THEN carp; RETURN 1 (deny) 1050: IF lingua is not a blessed object THEN carp; RETURN 1 (deny) 1051: country := lingua->country() [wrapped in eval] 1052: IF country is falsy (undef / "" / "0") THEN RETURN 1 (deny) 1053: country := lc(country) 1054: -- Transitive reduction: deny_countries is provably non-nil here. 1055: IF wildcard (*) in deny_countries THEN 1056: IF country in allow_countries THEN RETURN 0 (allow) 1057: ELSE RETURN 1 (deny) 1058: ELSE 1059: IF country in deny_countries THEN RETURN 1 (deny) 1060: ELSE RETURN 0 (allow) 1061: END IF 1062: END IF 1063: 1064: RETURN 1 (deny -- no rule permitted the request) 1065: 1066: =cut 1067: 1068: sub all_denied { ●1069 → 1076 → 1086 1069: my $self = shift; 1070: 1071: # Fast-path: if no meaningful restrictions are configured, allow immediately. 1072: # allow_countries is intentionally omitted: it only has effect when paired 1073: # with deny_countries('*'). Including it would cause allow_country() alone 1074: # to trigger a country lookup that then denies on undef — contradicting the 1075: # documented "allow_country alone has no effect" behaviour. 1076: if( 1077: (!defined($self->{allowed_ips})) && 1078: (!defined($self->{deny_countries})) && 1079: (!$self->{deny_cloud}) 1080: ) { 1081: return 0; 1082: } 1083: 1084: # Determine the client address, falling back to localhost when absent. 1085: # Use // (defined-or) not || to avoid treating "0" or "" as absent. ●1086 → 1100 → 1138 1086: my $raw = $ENV{REMOTE_ADDR} // $DEFAULT_ADDR; 1087: 1088: # Reject addresses that are not syntactically valid IPv4 or IPv6. 1089: # Use \A and \z (not ^ and $): \z is the absolute end-of-string anchor 1090: # and never matches before a trailing \n as $ does in Perl. 1091: return 1 unless $raw =~ /\A$RE{net}{IPv4}\z/o || $raw =~ /\A$RE{net}{IPv6}\z/o; 1092: 1093: # Detaint: format is proved above; extract via a character-class capture. 1094: # All IP/IPv6 chars are [0-9A-Fa-f:.]; the capture eliminates taint so that 1095: # $addr never propagates a tainted value to callers that are -T sensitive. 1096: my ($addr) = $raw =~ /\A([0-9A-Fa-f:.]+)\z/; 1097: return 1 unless defined $addr; # unreachable; belt-and-suspenders 1098: 1099: # ── Cloud check (highest precedence; overrides allow_ip) ──────────────── 1100: if($self->{deny_cloud}) { 1101: # Consult the per-object cache before performing any DNS round-trips. 1102: # The cache stores {result, expires} keyed by IP address string. 1103: # This eliminates repeated DNS queries for the same IP within the TTL. 1104: my $cached = $self->{_cloud_cache} && $self->{_cloud_cache}{$addr}; 1105: my ($is_cloud, $dns_error); 1106: if($cached && $cached->{expires} > time()) { 1107: $is_cloud = $cached->{result}; 1108: } else { 1109: # Cache miss: perform the verified reverse-DNS lookup. 1110: # Wrap in eval: DNS failures must not kill the CGI process; fail safe. 1111: $is_cloud = eval { _is_cloud_host($addr) }; 1112: $dns_error = $@; 1113: undef $@; # we have captured the error; clear $@ so callers are not confused 1114: 1115: # Only cache definitive answers; errors are retried on the next request. 1116: unless($dns_error) { 1117: $self->{_cloud_cache}{$addr} = { 1118: result => $is_cloud, 1119: expires => time() + $CLOUD_CACHE_TTL, 1120: }; 1121: } 1122: } 1123: return 1 if !$dns_error && $is_cloud; 1124: 1125: # Non-cloud and no other meaningful restrictions: allow immediately. 1126: # Premise: allow_country alone (without deny_country('*')) never changes 1127: # the access decision — it always allows. 1128: # Premise: the early-return guard excludes allow_countries for this reason. 1129: # Conclusion: after the cloud check passes, apply the same principle —
Mutants (Total: 1, Killed: 1, Survived: 0)
1130: # allow_countries alone is not a "meaningful further restriction". 1131: # Including it here would cause deny_cloud()->allow_country('X') without 1132: # a lingua argument to carp and deny, contradicting documented semantics. 1133: return 0 unless $self->{allowed_ips} 1134: || $self->{deny_countries};
Mutants (Total: 2, Killed: 2, Survived: 0)
1135: } 1136: 1137: # ── IP / CIDR allow-list check ────────────────────────────────────────── ●1138 → 1138 → 1166 1138: if($self->{allowed_ips}) { 1139: # Check for an exact-match entry first (fast path) 1140: return 0 if $self->{allowed_ips}->{$addr}; 1141: 1142: # Build and memoise the CIDR lookup structure on first use.
Mutants (Total: 2, Killed: 2, Survived: 0)
1143: # Wrap in eval: Net::CIDR dies on non-IP strings (injection attempts). 1144: if(!$self->{_cidrlist}) { 1145: my @cidrlist; 1146: for my $block (keys %{$self->{allowed_ips}}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
1147: eval { @cidrlist = Net::CIDR::cidradd($block, @cidrlist) }; 1148: } 1149: $self->{_cidrlist} = \@cidrlist; 1150: } 1151: 1152: # Check whether the address falls inside any allowed CIDR range.
1153: # Wrap in eval in case the list was built from partly-invalid entries. 1154: my $in_cidr = eval { Net::CIDR::cidrlookup($addr, @{$self->{_cidrlist}}) }; 1155: return 0 if $in_cidr; 1156: } 1157: 1158: # ── Country check ─────────────────────────────────────────────────────── 1159: # Premise: allow_countries alone (without deny_countries) always produces 0. 1160: # Premise: if only allow_countries is set, the early-return guard or the 1161: # cloud fast-path has already returned 0 before we get here. 1162: # Conclusion: deny_countries being non-empty is the necessary and sufficientMutants (Total: 4, Killed: 1, Survived: 3)
- NUM_BOUNDARY_1152_36_<: Numeric boundary flip > to <
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_1152_36_>=: Numeric boundary flip > to >=
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );- NUM_BOUNDARY_1152_36_<=: Numeric boundary flip > to <=
HIGH: Likely missing edge-case test (boundary value)🧪 Suggested Test# Boundary test suggestion is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );1163: # condition for the country check to have any effect — allow_countries 1164: # alone is vacuous here. Removing it from the condition eliminates 1165: # an unnecessary lingua lookup and carps for that edge case. ●1166 → 1166 → 1204 1166: if($self->{deny_countries}) { 1167: # Premise: we are inside this block iff deny_countries is defined and non-empty. 1168: # Transitive reduction: all inner $self->{deny_countries} && guards are redundant. 1169: my $lingua = @_ ? Params::Get::get_params('lingua', @_)->{'lingua'} : undef;Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_1162_4: Invert condition unless to if
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 2, Killed: 2, Survived: 0)
1170: 1171: unless($lingua) { 1172: # Country restrictions active but no lingua was provided 1173: Carp::carp('Usage: all_denied($lingua)'); 1174: return 1; 1175: } 1176: 1177: # Reject non-objects to avoid "can't call method on non-ref" crashes 1178: unless(blessed($lingua)) { 1179: Carp::carp('all_denied: lingua must be a blessed object');
Mutants (Total: 2, Killed: 2, Survived: 0)
1180: return 1; 1181: } 1182: 1183: # Resolve and normalise the client's country code. 1184: # Wrap in eval: the object may not implement country().
Mutants (Total: 1, Killed: 1, Survived: 0)
1185: my $country_val = eval { $lingua->country() }; 1186: if($@) { undef $@; return 1 } # method missing or threw — deny
Mutants (Total: 2, Killed: 2, Survived: 0)
1187: my $country = $country_val or return 1; # undef/falsy => unknown country => deny 1188: $country = lc $country; 1189: 1190: # Default-deny mode: deny_countries contains the wildcard sentinel.
Mutants (Total: 1, Killed: 1, Survived: 0)
1191: # Premise: deny_countries is defined (proved above); no redundant && guard needed. 1192: if($self->{deny_countries}->{$WILDCARD}) { 1193: return ($self->{allow_countries} && $self->{allow_countries}->{$country}) 1194: ? 0 # country is explicitly permitted 1195: : 1; # not in the permit list; deny 1196: } 1197: 1198: # Default-allow mode: deny only explicitly listed countries. 1199: # Premise: deny_countries is defined and non-wildcard. 1200: return $self->{deny_countries}->{$country} ? 1 : 0; 1201: }
Mutants (Total: 2, Killed: 2, Survived: 0)
1202: 1203: # Fall-through: no rule allowed the request; deny 1204: return 1; 1205: } 1206: 1207: # ── Internal helpers ────────────────────────────────────────────────────────── 1208: 1209: # _set_countries 1210: # 1211: # Purpose: Shared logic for deny_country() and allow_country(). Inserts one 1212: # or more lowercased country codes into the supplied hashref.
Mutants (Total: 1, Killed: 1, Survived: 0)
1213: # 1214: # Entry: $hashref - the target hash (already initialised by caller) 1215: # $value - a scalar country code OR an arrayref of codes 1216: # 1217: # Exit: Returns nothing (modifies $hashref in place).
Mutants (Total: 1, Killed: 1, Survived: 0)
1218: # 1219: # Side effects: Modifies the caller-supplied hashref. 1220: #
Mutants (Total: 2, Killed: 2, Survived: 0)
1221: # Notes: Keys are forced to lower case for case-insensitive comparison. 1222: sub _set_countries :Protected { ●1223 → 1227 → 1232 1223: my ($hashref, $value) = @_; 1224:
Mutants (Total: 1, Killed: 1, Survived: 0)
1225: # Handle both a single country code and a list reference. 1226: # Skip undef elements to avoid "uninitialised value" warnings.
Mutants (Total: 2, Killed: 2, Survived: 0)
1227: if(ref($value) eq 'ARRAY') { 1228: $hashref->{lc $_} = 1 for grep { defined } @{$value}; 1229: } else { 1230: $hashref->{lc $value} = 1; 1231: } 1232: return;
Mutants (Total: 3, Killed: 3, Survived: 0)
1233: } 1234: 1235: # _is_cloud_host 1236: # 1237: # Purpose: Determines whether a given IP address belongs to a major cloud 1238: # provider by performing a verified reverse-DNS lookup and then
Mutants (Total: 1, Killed: 1, Survived: 0)
1239: # matching the confirmed hostname against @CLOUD_PATTERNS.
Mutants (Total: 2, Killed: 2, Survived: 0)
1240: # 1241: # Entry: $ip - a validated IPv4 or IPv6 address string. 1242: # 1243: # Exit: Returns 1 (cloud host) or 0 (not a cloud host / no PTR record). 1244: # 1245: # Side effects: Performs DNS lookups; may block for up to $DNS_TIMEOUT seconds 1246: # on non-Windows platforms.
Mutants (Total: 2, Killed: 2, Survived: 0)
1247: # 1248: # Notes: An IP with no PTR record, or whose forward confirmation fails, 1249: # returns 0 (not cloud). This is the safe default because 1250: # legitimate cloud providers consistently set rDNS records.
Mutants (Total: 2, Killed: 2, Survived: 0)
1251: sub _is_cloud_host :Protected { ●1252 → 1268 → 1271 1252: my ($ip) = @_; 1253: 1254: # Private, loopback, and link-local addresses are never cloud provider IPs. 1255: # Skipping DNS for these eliminates the most common source of timeouts in 1256: # development environments and internal-network deployments. 1257: return 0 if $ip =~ $PRIVATE_IP_RE; 1258: 1259: # Attempt a verified reverse DNS lookup; returns undef on failure 1260: my $hostname = _verified_rdns($ip) or return 0; 1261: 1262: # RFC 1035 §3.1: FQDNs are at most 253 characters. Reject longer strings 1263: # before running all cloud patterns; protocol-invalid hostnames are never 1264: # genuine cloud provider names, and the check costs one integer comparison. 1265: return 0 if length($hostname) > 253; 1266: 1267: # Compare the confirmed hostname against every known cloud pattern 1268: for my $pattern (@CLOUD_PATTERNS) { 1269: return 1 if $hostname =~ $pattern; 1270: } 1271: return 0; 1272: } 1273:
Mutants (Total: 1, Killed: 1, Survived: 0)
1274: # _verified_rdns 1275: # 1276: # Purpose: Performs a two-step DNS verification to prevent rDNS spoofing: 1277: # 1. Reverse lookup: IP -> hostname 1278: # 2. Forward confirmation: hostname -> [IPs]; IP must appear 1279: # 1280: # Entry: $ip - a syntactically valid IPv4 or IPv6 address string. 1281: # 1282: # Exit: Returns the confirmed hostname string on success, undef otherwise. 1283: # undef is returned when: 1284: # - $ip cannot be packed (invalid address) 1285: # - no PTR record exists 1286: # - forward lookup does not include the original IP 1287: # - DNS lookup times out (non-Windows only) 1288: # 1289: # Side effects: Performs two DNS round-trips; installs and restores a temporary 1290: # SIGALRM handler on non-Windows platforms. 1291: # 1292: # Notes: On non-Windows platforms a $DNS_TIMEOUT-second alarm is set to 1293: # prevent CGI workers from blocking indefinitely on slow resolvers. 1294: # alarm(0) is called inside the eval to close the race window 1295: # between eval exit and the outer alarm(0) call. 1296: sub _verified_rdns :Protected {
Mutants (Total: 2, Killed: 2, Survived: 0)
●1297 → 1301 → 1313 1297: my ($ip) = @_; 1298: 1299: # Determine address family and produce the packed binary address
Mutants (Total: 3, Killed: 3, Survived: 0)
1300: my ($family, $packed);
Mutants (Total: 3, Killed: 3, Survived: 0)
1301: if($ip =~ /:/) {
Mutants (Total: 2, Killed: 2, Survived: 0)
1302: # IPv6: use inet_pton which handles all valid IPv6 formats 1303: $family = Socket::AF_INET6; 1304: $packed = Socket::inet_pton(Socket::AF_INET6, $ip) or return; 1305: } else { 1306: # IPv4: inet_aton handles dotted-quad addresses 1307: $family = AF_INET; 1308: $packed = inet_aton($ip) or return; 1309: } 1310: 1311: # Normalise the IP to canonical form for reliable string comparison. 1312: # This handles abbreviated IPv6 forms such as '::1' vs '0:0:...:1'. ●1313 → 1319 → 1346 1313: my $canonical = ($family == AF_INET) 1314: ? inet_ntoa($packed) 1315: : Socket::inet_ntop(Socket::AF_INET6, $packed); 1316: 1317: my ($hostname, @forward_ips); 1318: 1319: if($^O ne 'MSWin32') { 1320: # Non-Windows: guard against indefinitely-blocking DNS calls 1321: local $SIG{ALRM} = sub { die "DNS timeout: $ip" }; 1322: my $old_alarm = alarm($DNS_TIMEOUT) // 0; 1323: eval { 1324: # Step 1: reverse lookup (IP -> hostname) 1325: $hostname = gethostbyaddr($packed, $family); 1326: if($hostname) {
Mutants (Total: 2, Killed: 2, Survived: 0)
1327: # Step 2: forward lookup (hostname -> IP list) 1328: @forward_ips = _rdns_forward($hostname, $family); 1329: } 1330: # Restore the previous alarm inside the eval to close the 1331: # race window between eval exit and the outer alarm() call. 1332: alarm($old_alarm); 1333: };
Mutants (Total: 2, Killed: 2, Survived: 0)
1334: # Belt-and-suspenders: restore the previous alarm whether eval threw or not 1335: alarm($old_alarm);
Mutants (Total: 2, Killed: 2, Survived: 0)
1336: return if $@ || !$hostname; 1337: } else { 1338: # Windows: no alarm support; perform lookups synchronously 1339: $hostname = gethostbyaddr($packed, $family) or return; 1340: 1341: # Forward lookup to confirm the hostname maps back to the original IP 1342: @forward_ips = _rdns_forward($hostname, $family); 1343: } 1344: 1345: # Step 3: the hostname is only trusted if a forward record confirms the IP 1346: return (grep { $_ eq $canonical } @forward_ips) ? $hostname : undef; 1347: } 1348: 1349: # _rdns_forward 1350: # 1351: # Purpose: Resolves a hostname to a list of IP address strings for use in 1352: # the forward-confirmation step of _verified_rdns(). 1353: # 1354: # Entry: $hostname - the fully-qualified domain name to resolve. 1355: # $family - address family: AF_INET or Socket::AF_INET6. 1356: # 1357: # Exit: Returns a list of IP address strings (may be empty on failure). 1358: # 1359: # Side effects: Performs a DNS A or AAAA lookup. 1360: # 1361: # Notes: For IPv4 uses the classic inet_aton/inet_ntoa chain. 1362: # For IPv6 uses Socket::getaddrinfo and Socket::getnameinfo 1363: # (available since Perl 5.14 / Socket 1.99). 1364: sub _rdns_forward { ●1365 → 1375 → 1383 1365: my ($hostname, $family) = @_;
Mutants (Total: 1, Killed: 1, Survived: 0)
1366: 1367: # IPv4 path: resolve ALL A records and convert each packed address to a string. 1368: # gethostbyname() returns the full address list; inet_aton() silently discards 1369: # every record after the first. Returning the complete set prevents false-negative 1370: # forward confirmation when the confirming IP is not the first result from the 1371: # resolver (which is common for cloud providers with multiple A records per PTR). 1372: # Some resolver configurations (and test environments) do not return results 1373: # when gethostbyname() is called with a dotted-quad string; fall back to 1374: # inet_aton() in that case, which always handles dotted-quads directly. 1375: if($family == AF_INET) { 1376: my @addrs = map { inet_ntoa($_) } (gethostbyname($hostname))[4 .. -1]; 1377: return @addrs if @addrs;
Mutants (Total: 1, Killed: 1, Survived: 0)
1378: my $packed = inet_aton($hostname); 1379: return $packed ? (inet_ntoa($packed)) : (); 1380: } 1381: 1382: # IPv6 path: use getaddrinfo to resolve AAAA records ●1383 → 1391 → 1397 1383: my ($err, @addrs) = Socket::getaddrinfo(
Mutants (Total: 1, Killed: 1, Survived: 0)
1384: $hostname, undef, 1385: { family => $family, socktype => SOCK_STREAM }, 1386: ); 1387: return () if $err; 1388: 1389: # Convert each opaque sockaddr to a numeric IP string 1390: my @ips;
Mutants (Total: 1, Killed: 1, Survived: 0)
1391: for my $addr_info (@addrs) { 1392: my ($e, $host) = Socket::getnameinfo( 1393: $addr_info->{addr}, Socket::NI_NUMERICHOST, 1394: ); 1395: push @ips, $host unless $e; 1396: } 1397: return @ips; 1398: } 1399: 1400: =head1 AUTHOR 1401: 1402: Nigel Horne, C<< <njh at nigelhorne.com> >> 1403: 1404: =head1 BUGS 1405: 1406: Please report any bugs or feature requests to 1407: C<bug-cgi-acl at rt.cpan.org>, or through the web interface at 1408: L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CGI-ACL>. 1409: 1410: A VPN or proxy will most likely bypass IP-based access control.
Mutants (Total: 2, Killed: 2, Survived: 0)
1411: 1412: =head1 SEE ALSO 1413: 1414: =over 4 1415: 1416: =item * L<CGI::Lingua> 1417: 1418: =item * L<Configure an Object at Runtime|Object::Configure> 1419: 1420: =item * L<Net::CIDR> 1421: 1422: =item * L<Test Dashboard|https://nigelhorne.github.io/CGI-ACL/coverage/> 1423: 1424: =back 1425: 1426: =head1 SUPPORT 1427: 1428: perldoc CGI::ACL 1429: 1430: =over 4 1431: 1432: =item * MetaCPAN: L<https://metacpan.org/release/CGI-ACL> 1433: 1434: =item * RT: L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=CGI-ACL> 1435: 1436: =item * CPANTS: L<http://cpants.cpanauthors.org/dist/CGI-ACL> 1437: 1438: =item * CPAN Testers: L<http://matrix.cpantesters.org/?dist=CGI-ACL> 1439:
Mutants (Total: 2, Killed: 2, Survived: 0)
1440: =back 1441:
1442: =head1 LIMITATIONS 1443:Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_1441_3: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes🧪 Suggested Test# Boolean branch test suggestion ok( !func(INPUT), 'Verify boolean branch behaviour' );- RETURN_UNDEF_1441_3: Replace return expression with undef
LOW: Mutation survived, but impact may be minor🧪 Suggested Test# Return value assertion is( func(INPUT), EXPECTED, 'Verify correct return value' );Mutants (Total: 2, Killed: 2, Survived: 0)
1444: =over 4 1445: 1446: =item * 1447: 1448: A VPN or anonymous proxy will likely bypass IP-based access control and may 1449: defeat country detection as well. 1450: 1451: =item * 1452: 1453: Country detection relies on L<CGI::Lingua> and its underlying GeoIP database, 1454: which must be updated regularly. GeoIP databases are never fully accurate; 1455: satellite and mobile networks in particular can be misattributed. 1456: 1457: =item * 1458: 1459: Cloud detection depends on provider-maintained reverse-DNS records. A cloud 1460: host whose PTR record does not follow its provider's naming convention will 1461: not be detected. Conversely, a legitimate host whose PTR record accidentally
Mutants (Total: 2, Killed: 2, Survived: 0)
1462: matches a cloud pattern could be falsely denied. 1463: 1464: =item * 1465: 1466: DNS lookups are synchronous. On non-Windows platforms a C<$DNS_TIMEOUT>-second 1467: alarm prevents indefinite blocking, but under high resolver load that latency 1468: can still affect every request for an uncached IP. For persistent processes 1469: (FastCGI, mod_perl) the built-in per-object cache (C<$CLOUD_CACHE_TTL> seconds) 1470: mitigates this significantly. 1471: 1472: =item * 1473: 1474: The per-object DNS result cache is neither shared between processes nor 1475: persistent across objects. Under a pre-forking server each worker child 1476: maintains an independent cache. 1477: 1478: =item * 1479: 1480: Private methods (C<_is_cloud_host>, C<_verified_rdns>, C<_rdns_forward>, 1481: C<_set_countries>) are not enforced as private with 1482: C<Sub::Private> because this module's white-box test suite (C<t/function.t>, 1483: C<t/extended_tests.t>, etc.) calls them directly by fully-qualified name to 1484: exercise specific code paths. The C<namespace::clean> pragma removes them 1485: from the object's method dispatch table, and the C<_> naming convention 1486: signals their internal nature. 1487: 1488: =item * 1489: 1490: Windows platforms do not support C<alarm()>-based timeouts. DNS lookups on 1491: Windows block synchronously for as long as the OS resolver takes. 1492: 1493: =item * 1494: 1495: An optional rate-limiting feature (to block brute-force attacks) has not yet 1496: been implemented. It would require persistent shared state (e.g. Redis or an 1497: in-memory cache) beyond this module's current dependency set. 1498: 1499: =back 1500: 1501: =head1 FORMAL SPECIFICATION 1502: 1503: =head2 new 1504: 1505: ──────────────── ACLState ──────────────────────────────────────── 1506: allowed_ips : IP_Str ⇸ Bool 1507: deny_countries : Country ⇸ Bool 1508: allow_countries: Country ⇸ Bool 1509: deny_cloud : Bool 1510: _cidrlist : [CIDR_Str]? -- memoised; cleared on allow_ip 1511: _cloud_cache : IP_Str ⇸ {result: Bool, expires: Nat}? 1512: ────────────────────────────────────────────────────────────────── 1513: 1514: ─────────────── New ────────────────────────────────────────────── 1515: class : ClassName ∪ ACLState 1516: params : ACLState? 1517: ───────────────────────────────────────────────────────────────── 1518: -- strip_private: removes keys whose names begin with '_' 1519: blessed(class) ⟹ 1520: result! = bless( deepcopy(class) ∪ strip_private(params), 1521: ref(class) ) -- clone 1522: ¬blessed(class) ⟹ 1523: result! = bless( strip_private(configure(class, params)), 1524: class ) 1525: ────────────────────────────────────────────────────────────────── 1526: 1527: =head2 allow_ip 1528: 1529: ─────────────── AllowIP ────────────────────────────────────────── 1530: ΔACL 1531: ip? : IP_Str -- must satisfy valid_ip(ip?) 1532: ───────────────────────────────────────────────────────────────── 1533: allowed_ips' = allowed_ips₀ // {} -- initialised on every call 1534: valid_ip(ip?) ⟹ 1535: allowed_ips' = allowed_ips' ∪ { ip? ↦ 1 } 1536: _cidrlist' = ∅ -- cache invalidated 1537: ¬valid_ip(ip?) ⟹ 1538: allowed_ips' = allowed_ips' -- only initialisation, no entry 1539: _cidrlist' = _cidrlist 1540: deny_countries' = deny_countries 1541: allow_countries' = allow_countries 1542: deny_cloud' = deny_cloud 1543: ────────────────────────────────────────────────────────────────── 1544: 1545: =head2 deny_country 1546: 1547: ─────────────── DenyCountry ───────────────────────────────────── 1548: ΔACL 1549: country? : ISO_Code ∪ {'*'} ∪ seq ISO_Code 1550: ───────────────────────────────────────────────────────────────── 1551: country? ∈ seq ISO_Code ⟹ 1552: deny_countries' = deny_countries ∪ 1553: { lc(c) ↦ 1 | c ∈ country? } 1554: country? ∉ seq ISO_Code ⟹ 1555: deny_countries' = deny_countries ∪ { lc(country?) ↦ 1 } 1556: allow_countries' = allow_countries 1557: allowed_ips' = allowed_ips 1558: deny_cloud' = deny_cloud 1559: ────────────────────────────────────────────────────────────────── 1560: 1561: =head2 allow_country 1562: 1563: ─────────────── AllowCountry ──────────────────────────────────── 1564: ΔACL 1565: country? : ISO_Code ∪ seq ISO_Code 1566: ───────────────────────────────────────────────────────────────── 1567: country? ∈ seq ISO_Code ⟹ 1568: allow_countries' = allow_countries ∪ 1569: { lc(c) ↦ 1 | c ∈ country? } 1570: country? ∉ seq ISO_Code ⟹ 1571: allow_countries' = allow_countries ∪ { lc(country?) ↦ 1 } 1572: deny_countries' = deny_countries 1573: allowed_ips' = allowed_ips 1574: deny_cloud' = deny_cloud 1575: ────────────────────────────────────────────────────────────────── 1576: 1577: =head2 deny_cloud 1578: 1579: ─────────────── DenyCloud ─────────────────────────────────────── 1580: ΔACL 1581: ───────────────────────────────────────────────────────────────── 1582: deny_cloud' = 1 1583: allowed_ips' = allowed_ips 1584: deny_countries' = deny_countries 1585: allow_countries'= allow_countries 1586: _cidrlist' = _cidrlist 1587: ────────────────────────────────────────────────────────────────── 1588: 1589: =head2 deny_all_countries 1590: 1591: ─────────────── DenyAllCountries ──────────────────────────────── 1592: ΔACL 1593: ───────────────────────────────────────────────────────────────── 1594: deny_countries' = deny_countries ∪ { '*' ↦ 1 } 1595: allow_countries' = allow_countries 1596: allowed_ips' = allowed_ips 1597: deny_cloud' = deny_cloud 1598: ────────────────────────────────────────────────────────────────── 1599: 1600: =head2 all_denied 1601: 1602: ──────────────────────── AllDenied ────────────────────────────── 1603: ΞACL -- state unchanged (modulo cache) 1604: addr : IPv4 ∪ IPv6 -- REMOTE_ADDR or DEFAULT_ADDR 1605: lingua? : Lingua -- country resolver (optional) 1606: result! : {0, 1} -- 0 = allow, 1 = deny 1607: ───────────────────────────────────────────────────────────────── 1608: no_restrictions(self) ⟹ result! = 0 1609: 1610: ¬valid_ip(addr) ⟹ result! = 1 1611: 1612: deny_cloud = 1 ∧ is_cloud(addr) ⟹ result! = 1 1613: deny_cloud = 1 ∧ ¬is_cloud(addr) 1614: ∧ allowed_ips = ∅ ∧ deny_countries = ∅ ⟹ result! = 0 1615: -- allow_countries is intentionally absent: it never changes the result 1616: -- without deny_countries('*'), so it is not a meaningful restriction. 1617: 1618: addr ∈ dom(allowed_ips) ⟹ result! = 0 1619: cidr_match(addr, allowed_ips) ⟹ result! = 0 1620: 1621: deny_countries ≠∅ ∧ lingua? = ∅ ⟹ result! = 1 1622: -- allow_countries alone is vacuous; only deny_countries triggers the check. 1623: lingua?.country() = undef ⟹ result! = 1 1624: 1625: deny_countries('*') = 1 1626: ∧ allow_countries(lc(lingua?.country())) = 1 ⟹ result! = 0 1627: deny_countries('*') = 1 1628: ∧ allow_countries(lc(lingua?.country())) ≠1 ⟹ result! = 1 1629: 1630: deny_countries('*') ≠1 1631: ∧ deny_countries(lc(lingua?.country())) = 1 ⟹ result! = 1 1632: deny_countries('*') ≠1 1633: ∧ deny_countries(lc(lingua?.country())) ≠1 ⟹ result! = 0 1634: ────────────────────────────────────────────────────────────────── 1635: 1636: =head1 LICENSE AND COPYRIGHT 1637: 1638: Copyright 2017-2026 Nigel Horne. 1639: 1640: Usage is subject to the GPL2 licence terms. 1641: If you use it, 1642: please let me know. 1643: 1644: =cut 1645: 1646: 1;