TER1 (Statement): 98.98%
TER2 (Branch): 97.06%
TER3 (LCSAJ): 100.0% (49/49)
Approximate LCSAJ segments: 103
● 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: # TODO: Add deny_all_countries() so operators can easily allow only a few countries. 9: # TODO: Add optional rate-limiter to block brute-force attacks. 10: 11: use 5.006_001; 12: use autodie qw(:all); 13: use warnings; 14: use strict; 15: 16: # namespace::clean removes imported helper names from the public method list 17: use namespace::clean; 18: 19: use Carp; 20: use Net::CIDR; 21: use Object::Configure; 22: use Params::Get; 23: use Readonly; 24: use Regexp::Common qw(net); 25: use Scalar::Util qw(blessed); 26: use Socket; 27: 28: # ── Compile-time constants ───────────────────────────────────────────────────── 29: 30: # Maximum seconds to wait for a DNS reverse lookup on non-Windows platforms. 31: Readonly my $DNS_TIMEOUT => 10; 32: 33: # Sentinel value stored in deny_countries to mean "deny every country". 34: Readonly my $WILDCARD => q{*}; 35: 36: # Fallback client address when REMOTE_ADDR is absent (e.g. CLI or unit tests). 37: Readonly my $DEFAULT_ADDR => '127.0.0.1'; 38: 39: # Compiled regexes that identify cloud-provider reverse-DNS hostnames. 40: # _is_cloud_host() iterates this list; to add a provider, append a qr// here. 41: Readonly my @CLOUD_PATTERNS => ( 42: qr/\.compute(?:-\d+)?\.amazonaws\.com$/i, # AWS EC2 43: qr/\.bc\.googleusercontent\.com$/i, # Google Cloud Compute 44: qr/\.cloudapp\.net$/i, # Microsoft Azure 45: qr/\.azure\.com$/i, # Microsoft Azure (general) 46: qr/digitalocean/i, # DigitalOcean 47: qr/\.members\.linode\.com$/i, # Linode / Akamai 48: qr/hetzner/i, # Hetzner Cloud 49: qr/your-server\.de$/i, # Hetzner (legacy dedicated) 50: qr/\.ovh\.net$/i, # OVH Cloud 51: qr/^ip-\d+-\d+-\d+-\d+\.eu$/i, # OVH European IP range 52: ); 53: 54: # ── Version ──────────────────────────────────────────────────────────────────── 55: 56: =head1 NAME 57: 58: CGI::ACL - Decide whether to allow a client to run a CGI script 59: 60: =head1 VERSION 61: 62: Version 0.08 63: 64: =cut 65: 66: our $VERSION = '0.08'; 67: 68: =head1 SYNOPSIS 69: 70: Provides access control for CGI scripts based on IP address, CIDR block, 71: geographic country, and cloud-provider origin. 72: 73: use CGI::Lingua; 74: use CGI::ACL; 75: 76: # Allow only UK visitors from a specific subnet 77: my $acl = CGI::ACL->new() 78: ->deny_country('*') 79: ->allow_country('GB') 80: ->allow_ip('192.0.2.0/24'); 81: 82: if ($acl->all_denied(lingua => CGI::Lingua->new(supported => ['en']))) { 83: print "Access denied.\n"; 84: exit; 85: } 86: 87: The module optionally integrates with L<CGI::Lingua> for country detection. 88: Runtime configuration is supported via L<Object::Configure>. 89: 90: =head1 SUBROUTINES/METHODS 91: 92: =head2 new 93: 94: Creates and returns a new CGI::ACL object. 95: 96: When called on an existing object it returns a shallow clone of that object, 97: optionally overriding fields with the supplied arguments. 98: 99: Constructor arguments may also be supplied via environment variables of the 100: form C<CGI__ACL__E<lt>fieldE<gt>> or via a config file; see L<Object::Configure> 101: for details. 102: 103: =head3 USAGE 104: 105: # No restrictions (allow all by default) 106: my $acl = CGI::ACL->new(); 107: 108: # Pre-seeded allow list 109: my $acl = CGI::ACL->new(allowed_ips => { '127.0.0.1' => 1 }); 110: 111: # Clone an existing ACL and add a restriction 112: my $acl2 = $acl->new(deny_cloud => 1); 113: 114: =head3 API SPECIFICATION 115: 116: =head4 Input 117: 118: # Compatible with Params::Validate::Strict: 119: { 120: allowed_ips => { type => 'hashref', optional => 1 }, 121: deny_countries => { type => 'hashref', optional => 1 }, 122: allow_countries => { type => 'hashref', optional => 1 }, 123: deny_cloud => { type => 'boolean', optional => 1 }, 124: } 125: 126: =head4 Output 127: 128: # Compatible with Return::Set: 129: { type => 'object', isa => 'CGI::ACL' } 130: # or undef when called as CGI::ACL::new() instead of CGI::ACL->new() 131: 132: =head3 MESSAGES 133: 134: =over 4 135: 136: =item C<< CGI::ACL use ->new() not ::new() to instantiate >> 137: 138: B<Severity:> carp (warning). 139: B<Cause:> C<CGI::ACL::new(...)> was called as a plain function instead of 140: as a class method. 141: B<Action:> Change the call to C<< CGI::ACL->new(...) >>. 142: 143: =back 144: 145: =cut 146: 147: sub new { ●148 → 154 → 171●148 → 154 → 0 148: my $class = shift; 149: 150: # Parse arguments uniformly (hashref, named pairs, or no args) 151: my $params = Params::Get::get_params(undef, @_); 152: 153: # Handle the rare case of being called as a plain function: CGI::ACL::new() 154: if(!defined($class)) { 155: Carp::carp(__PACKAGE__ . ': use ->new() not ::new() to instantiate'); 156: return; 157: } elsif(blessed($class)) { 158: # Called on an existing object: return a clone with deep-copied sub-hashes 159: # so that mutations to the clone do not affect the original. 160: $params ||= {}; 161: my %copy = %{$class}; 162: for my $key (qw(allowed_ips deny_countries allow_countries)) { 163: $copy{$key} = { %{$copy{$key}} } if ref($copy{$key}) eq 'HASH'; 164: } 165: # The CIDR cache depends on allowed_ips; invalidate so it is rebuilt fresh.Mutants (Total: 1, Killed: 1, Survived: 0)
166: delete $copy{_cidrlist};
167: return bless { %copy, %{$params} }, ref($class); 168: } 169: 170: # Merge any config-file or environment-variable overrides ●171 → 173 → 0 171: $params = Object::Configure::configure($class, $params); 172: 173: return bless $params, $class; 174: } 175: 176: # ── allow_ip ─────────────────────────────────────────────────────────────────── 177: 178: =head2 allow_ip 179: 180: Adds an IPv4/IPv6 address or CIDR block to the set of explicitly permitted 181: clients. When C<allowed_ips> is non-empty, any client address not matched 182: by an entry in the set is denied (subject to C<deny_cloud> taking precedence). 183: 184: =head3 USAGE 185: 186: use CGI::ACL; 187: 188: # Single address 189: my $acl = CGI::ACL->new()->allow_ip('203.0.113.5'); 190: 191: # Named parameter 192: my $acl = CGI::ACL->new()->allow_ip(ip => '203.0.113.5'); 193: 194: # CIDR block 195: my $acl = CGI::ACL->new()->allow_ip(ip => '192.0.2.0/24'); 196: 197: # Method chaining 198: my $acl = CGI::ACL->new() 199: ->allow_ip('192.0.2.1') 200: ->allow_ip('10.0.0.0/8'); 201: 202: =head3 ARGUMENTS 203: 204: =over 4 205: 206: =item ip (required) 207: 208: A string containing an IPv4 address, an IPv6 address, or a CIDR block 209: (e.g. C<10.0.0.0/8>). The value is stored verbatim; invalid addresses 210: will be silently ignored during lookup. 211: 212: =back 213: 214: =head3 RETURNS 215: 216: The object itself, to allow method chaining. 217: 218: =head3 SIDE EFFECTS 219: 220: Invalidates the internal CIDR lookup cache so the next call to 221: C<all_denied()> will rebuild it with the new entry included. 222: 223: =head3 API SPECIFICATION 224: 225: =head4 Input 226: 227: # Compatible with Params::Validate::Strict: 228: { 229: ip => { type => 'string', regex => qr/\S+/, required => 1 }, 230: } 231: 232: =head4 Output 233: 234: # Compatible with Return::Set: 235: { type => 'object', isa => 'CGI::ACL' } 236: 237: =head3 MESSAGES 238: 239: =over 4 240: 241: =item C<Usage: allow_ip($ip_address)> 242: 243: B<Severity:> carp (warning). 244: B<Cause:> Called with no argument, with a non-hash reference, or without 245: supplying the C<ip> key. 246: B<Action:> Pass a scalar IP/CIDR string: C<allow_ip('192.0.2.1')> or 247: C<allow_ip(ip =E<gt> '192.0.2.1')>. 248: 249: =back 250: 251: =cut 252: 253: sub allow_ip { ●254 → 257 → 263●254 → 257 → 0 254: my $self = shift; 255: 256: # Reject non-hash, non-scalar references (e.g. a scalar ref passed by mistake) 257: if(ref($_[0]) && ref($_[0]) ne 'HASH') { 258: Carp::carp('Usage: allow_ip($ip_address)'); 259: return $self; 260: } 261: 262: # Normalise positional, named, and hashref calling conventions ●263 → 264 → 273●263 → 264 → 0 263: my %params; 264: if(ref($_[0]) eq 'HASH') { 265: %params = %{$_[0]};Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_166_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomesMutants (Total: 1, Killed: 1, Survived: 0)
266: } elsif(@_ % 2 == 0) { 267: %params = @_;
Mutants (Total: 2, Killed: 2, Survived: 0)
268: } else { 269: $params{ip} = shift; 270: } 271: 272: # Store the address and invalidate the memoised CIDR list
Mutants (Total: 1, Killed: 1, Survived: 0)
●273 → 273 → 279●273 → 273 → 0 273: if(defined(my $ip = $params{ip})) { 274: $self->{allowed_ips}->{$ip} = 1;
Mutants (Total: 1, Killed: 1, Survived: 0)
275: delete $self->{_cidrlist}; 276: } else { 277: Carp::carp('Usage: allow_ip($ip_address)'); 278: } ●279 → 279 → 0 279: return $self; 280: } 281:
Mutants (Total: 1, Killed: 1, Survived: 0)
282: # ── deny_country ─────────────────────────────────────────────────────────────── 283: 284: =head2 deny_country 285: 286: Adds one or more countries to the deny list. Countries are identified by 287: their ISO 3166-1 alpha-2 codes (case-insensitive).
Mutants (Total: 2, Killed: 2, Survived: 0)
288: 289: Passing the special value C<'*'> (wildcard) switches to default-deny mode: 290: all countries are denied unless they also appear in the allow list set by 291: C<allow_country()>. 292: 293: =head3 USAGE 294: 295: use CGI::ACL; 296: 297: # Deny a single country 298: my $acl = CGI::ACL->new()->deny_country('BR'); 299: 300: # Deny a list of countries 301: my $acl = CGI::ACL->new()->deny_country(country => ['BR', 'CN', 'RU']); 302: 303: # Default-deny all countries (use with allow_country to whitelist) 304: my $acl = CGI::ACL->new()->deny_country('*')->allow_country('US'); 305: 306: =head3 ARGUMENTS 307: 308: =over 4 309: 310: =item country (required) 311: 312: A scalar ISO code, the wildcard C<'*'>, or an array reference of ISO codes. 313: 314: =back 315: 316: =head3 RETURNS 317: 318: The object itself, to allow method chaining. 319: 320: =head3 SIDE EFFECTS 321: 322: Updates C<< $self->{deny_countries} >>. 323: 324: =head3 NOTES 325: 326: C<allow_country()> has no effect unless C<deny_country('*')> has been called 327: first. Calling C<allow_country()> alone (without the wildcard deny) does 328: not restrict access. 329: 330: =head3 API SPECIFICATION 331: 332: =head4 Input 333: 334: # Compatible with Params::Validate::Strict: 335: { 336: country => { 337: type => 'string' | 'arrayref', 338: required => 1, 339: }, 340: } 341: 342: =head4 Output 343: 344: # Compatible with Return::Set: 345: { type => 'object', isa => 'CGI::ACL' } 346: 347: =head3 MESSAGES 348: 349: =over 4 350: 351: =item C<Usage: deny_country($country)> 352: 353: B<Severity:> carp (warning). 354: B<Cause:> Called with no argument, with a non-hash/non-array reference, or 355: without supplying the C<country> key. 356: B<Action:> Pass a scalar ISO code or arrayref: 357: C<deny_country('BR')> or C<deny_country(country =E<gt> ['BR','CN'])>. 358: 359: =back 360: 361: =cut 362: 363: sub deny_country { ●364 → 367 → 373●364 → 367 → 0 364: my $self = shift; 365: 366: # Reject references that are neither hashes nor arrays 367: if(ref($_[0]) && ref($_[0]) ne 'HASH' && ref($_[0]) ne 'ARRAY') { 368: Carp::carp('Usage: deny_country($country)'); 369: return $self; 370: } 371: 372: # Normalise positional, named, and hashref calling conventions ●373 → 374 → 384●373 → 374 → 0 373: my %params; 374: if(ref($_[0]) eq 'HASH') { 375: %params = %{$_[0]};
Mutants (Total: 1, Killed: 1, Survived: 0)
376: } elsif(@_ % 2 == 0) { 377: %params = @_;
Mutants (Total: 2, Killed: 2, Survived: 0)
378: } else { 379: $params{country} = shift; 380: } 381: 382: # Add the country or list of countries to the deny set.
Mutants (Total: 1, Killed: 1, Survived: 0)
383: # An empty arrayref is a no-op — do not create deny_countries = {}. ●384 → 384 → 390●384 → 384 → 0 384: if(defined(my $c = $params{country})) {
Mutants (Total: 1, Killed: 1, Survived: 0)
385: return $self if ref($c) eq 'ARRAY' && !@{$c}; 386: _set_countries($self->{deny_countries} ||= {}, $c); 387: } else { 388: Carp::carp('Usage: deny_country($country)'); 389: } ●390 → 390 → 0 390: return $self; 391: }
Mutants (Total: 1, Killed: 1, Survived: 0)
392: 393: # ── allow_country ────────────────────────────────────────────────────────────── 394: 395: =head2 allow_country 396:
Mutants (Total: 2, Killed: 2, Survived: 0)
397: Adds one or more countries to the explicit permit list. This is meaningful 398: only when C<deny_country('*')> has been called first; without the wildcard 399: deny, this method has no observable effect on access decisions. 400: 401: =head3 USAGE 402: 403: use CGI::ACL; 404: 405: # Allow only the UK and US 406: my $acl = CGI::ACL->new() 407: ->deny_country('*') 408: ->allow_country(country => ['GB', 'US']); 409: 410: # Single country as positional argument 411: my $acl = CGI::ACL->new()->deny_country('*')->allow_country('US'); 412: 413: =head3 ARGUMENTS 414: 415: =over 4 416: 417: =item country (required) 418: 419: A scalar ISO code or an array reference of ISO codes. 420: 421: =back 422: 423: =head3 RETURNS 424: 425: The object itself, to allow method chaining. 426: 427: =head3 SIDE EFFECTS 428: 429: Updates C<< $self->{allow_countries} >>. 430: 431: =head3 NOTES 432: 433: Call C<deny_country('*')> before this method; otherwise all traffic is 434: already allowed by the default-allow rule and the permit list is never 435: consulted. 436: 437: =head3 API SPECIFICATION 438: 439: =head4 Input 440: 441: # Compatible with Params::Validate::Strict: 442: { 443: country => { 444: type => 'string' | 'arrayref', 445: required => 1, 446: }, 447: } 448: 449: =head4 Output 450: 451: # Compatible with Return::Set: 452: { type => 'object', isa => 'CGI::ACL' } 453: 454: =head3 MESSAGES 455: 456: =over 4 457: 458: =item C<Usage: allow_country($country)> 459: 460: B<Severity:> carp (warning). 461: B<Cause:> Called with no argument, with a non-hash/non-array reference, or 462: without supplying the C<country> key. 463: B<Action:> Pass a scalar ISO code or arrayref: 464: C<allow_country('US')> or C<allow_country(country =E<gt> ['GB','US'])>. 465: 466: =back 467: 468: =cut 469: 470: sub allow_country { ●471 → 474 → 480●471 → 474 → 0 471: my $self = shift; 472: 473: # Reject references that are neither hashes nor arrays 474: if(ref($_[0]) && ref($_[0]) ne 'HASH' && ref($_[0]) ne 'ARRAY') { 475: Carp::carp('Usage: allow_country($country)'); 476: return $self; 477: } 478: 479: # Normalise positional, named, and hashref calling conventions ●480 → 481 → 491●480 → 481 → 0 480: my %params;
Mutants (Total: 1, Killed: 1, Survived: 0)
481: if(ref($_[0]) eq 'HASH') { 482: %params = %{$_[0]};
Mutants (Total: 2, Killed: 2, Survived: 0)
483: } elsif(@_ % 2 == 0) { 484: %params = @_; 485: } else { 486: $params{country} = shift; 487: }
Mutants (Total: 1, Killed: 1, Survived: 0)
488: 489: # Add the country or list of countries to the permit set.
Mutants (Total: 1, Killed: 1, Survived: 0)
490: # An empty arrayref is a no-op — do not create allow_countries = {}. ●491 → 491 → 497●491 → 491 → 0 491: if(defined(my $c = $params{country})) { 492: return $self if ref($c) eq 'ARRAY' && !@{$c}; 493: _set_countries($self->{allow_countries} ||= {}, $c); 494: } else { 495: Carp::carp('Usage: allow_country($country)'); 496: }
Mutants (Total: 1, Killed: 1, Survived: 0)
●497 → 497 → 0 497: return $self; 498: } 499: 500: # ── deny_cloud ───────────────────────────────────────────────────────────────── 501:
Mutants (Total: 2, Killed: 2, Survived: 0)
502: =head2 deny_cloud 503: 504: Enables blocking of requests that originate from major cloud-hosting 505: providers. Detection is performed via verified reverse DNS: the client 506: IP is looked up, the resulting hostname is forward-confirmed to prevent 507: spoofing, and the confirmed hostname is matched against a list of 508: provider-specific patterns. 509: 510: Covered providers (as of this release): AWS EC2, Google Cloud Compute, 511: Microsoft Azure, DigitalOcean, Linode/Akamai, Hetzner, OVH. 512: 513: B<Important:> C<deny_cloud> takes precedence over C<allow_ip>. An IP 514: that is explicitly permitted via C<allow_ip()> is still denied if its 515: reverse DNS resolves to a cloud provider hostname. 516: 517: =head3 USAGE 518: 519: use CGI::ACL; 520: 521: my $acl = CGI::ACL->new()->deny_cloud(); 522: 523: if ($acl->all_denied()) { 524: print "Cloud-hosted clients are not permitted.\n"; 525: exit; 526: } 527: 528: =head3 ARGUMENTS 529: 530: None. 531: 532: =head3 RETURNS 533: 534: The object itself, to allow method chaining. 535: 536: =head3 SIDE EFFECTS 537: 538: Sets C<< $self->{deny_cloud} >> to C<1>. 539: 540: =head3 NOTES 541: 542: IPv4 and IPv6 clients are both subject to the cloud check. A client with 543: no reverse DNS record, or whose forward confirmation fails, is treated as 544: a non-cloud host and allowed through the cloud check (though it may still 545: be denied by other rules). 546: 547: DNS lookups are performed synchronously. On non-Windows platforms a 548: C<$DNS_TIMEOUT>-second alarm is used to prevent indefinite blocking. 549: 550: =head3 API SPECIFICATION 551: 552: =head4 Input 553: 554: # No parameters accepted. 555: {} 556: 557: =head4 Output 558: 559: # Compatible with Return::Set: 560: { type => 'object', isa => 'CGI::ACL' } 561: 562: =head3 MESSAGES 563: 564: This method emits no messages. 565: 566: =cut 567: 568: sub deny_cloud { 569: my $self = shift; 570: 571: # Mark cloud-origin blocking as active 572: $self->{deny_cloud} = 1; 573: return $self; 574: } 575: 576: # ── all_denied ───────────────────────────────────────────────────────────────── 577:
Mutants (Total: 2, Killed: 2, Survived: 0)
578: =head2 all_denied 579: 580: Evaluates every active restriction against the current client and returns 581: C<1> (deny) or C<0> (allow). 582: 583: The evaluation order is: 584: 585: =over 4 586: 587: =item 1. 588: 589: If B<no> restrictions are configured at all, return C<0> (allow). 590: 591: =item 2. 592: 593: Validate C<REMOTE_ADDR> as a syntactically correct IPv4 or IPv6 address. 594: If it is missing or malformed, return C<1> (deny). 595: 596: =item 3. 597: 598: If C<deny_cloud> is set, perform a verified reverse-DNS lookup. If the 599: hostname matches a cloud provider, return C<1> (deny) immediately, 600: regardless of C<allowed_ips>. If the IP is not a cloud host and no 601: other restrictions are active, return C<0> (allow). 602: 603: =item 4. 604: 605: If C<allowed_ips> is set, check the client address against the exact-match 606: hash and then the CIDR list. Return C<0> (allow) on a match. 607: 608: =item 5. 609: 610: If country restrictions are set, resolve the client's country via the 611: C<lingua> argument. Apply default-deny or default-allow country logic. 612: If no lingua is provided, emit a warning and return C<1> (deny). 613: 614: =back 615: 616: Note that localhost (C<127.0.0.1>) is B<not> automatically allowed once 617: any restriction is configured; call C<allow_ip('127.0.0.1')> explicitly. 618: 619: =head3 USAGE 620: 621: use CGI::Lingua; 622: use CGI::ACL; 623: 624: my $acl = CGI::ACL->new()->allow_ip('8.35.80.39'); 625: 626: if ($acl->all_denied()) { 627: print "You are not allowed to view this site.\n"; 628: exit; 629: } 630: 631: # Country check 632: my $acl2 = CGI::ACL->new() 633: ->deny_country('*') 634: ->allow_country('US'); 635: 636: if ($acl2->all_denied(lingua => CGI::Lingua->new(supported => ['en']))) { 637: print "US-only site.\n"; 638: exit; 639: } 640: 641: =head3 ARGUMENTS 642: 643: =over 4 644: 645: =item lingua (optional) 646: 647: A L<CGI::Lingua> object (or any object with a C<country()> method returning 648: an ISO 3166-1 alpha-2 code or C<undef>). Required when country restrictions 649: are active; ignored otherwise. 650: 651: =back 652: 653: =head3 RETURNS 654: 655: C<1> if access is denied, C<0> if access is allowed. 656: 657: =head3 SIDE EFFECTS 658: 659: May populate or update C<< $self->{_cidrlist} >> (the memoised CIDR lookup 660: structure) as a performance optimisation. 661: 662: =head3 API SPECIFICATION 663: 664: =head4 Input 665: 666: # Compatible with Params::Validate::Strict: 667: { 668: lingua => { type => 'object', optional => 1 }, 669: } 670: 671: =head4 Output 672: 673: # Compatible with Return::Set: 674: { type => 'string', regex => qr/^[01]$/ } 675: 676: =head3 MESSAGES 677: 678: =over 4 679: 680: =item C<Usage: all_denied($lingua)> 681: 682: B<Severity:> carp (warning). 683: B<Cause:> Country restrictions are active (C<deny_country> or 684: C<allow_country> was called) but no C<lingua> argument was supplied. 685: B<Action:> Pass a C<CGI::Lingua> object: 686: C<all_denied(lingua =E<gt> $lingua)>. 687: 688: =back 689: 690: =cut 691: 692: sub all_denied { ●693 → 698 → 709●693 → 698 → 0 693: my $self = shift; 694: 695: # Fast-path: if no restrictions are configured at all, allow immediately. 696: # This guard must list every restriction type; missing one means that 697: # restriction silently has no effect when used alone. 698: if( 699: (!defined($self->{allowed_ips})) && 700: (!defined($self->{deny_countries})) && 701: (!$self->{deny_cloud}) && 702: (!defined($self->{allow_countries}))
Mutants (Total: 1, Killed: 1, Survived: 0)
703: ) { 704: return 0; 705: } 706: 707: # Determine the client address, falling back to localhost when absent. 708: # Use // (defined-or) not || to avoid treating "0" or "" as absent.
Mutants (Total: 2, Killed: 2, Survived: 0)
●709 → 716 → 729●709 → 716 → 0 709: my $addr = $ENV{REMOTE_ADDR} // $DEFAULT_ADDR; 710: 711: # Reject addresses that are not syntactically valid IPv4 or IPv6 712: return 1 unless $addr =~ /^$RE{net}{IPv4}$/o 713: || $addr =~ /^$RE{net}{IPv6}$/o; 714: 715: # ── Cloud check (highest precedence; overrides allow_ip) ────────────────
716: if($self->{deny_cloud}) { 717: # Deny if the IP resolves to a cloud provider hostname. 718: # Wrap in eval: DNS failures must not kill the CGI process; fail safe. 719: my $is_cloud = eval { _is_cloud_host($addr) };Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_715_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_715_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: 1, Killed: 1, Survived: 0)
720: return 1 if !$@ && $is_cloud; 721:
Mutants (Total: 2, Killed: 2, Survived: 0)
722: # Non-cloud and no other restrictions: allow 723: return 0 unless $self->{allowed_ips} 724: || $self->{deny_countries}
Mutants (Total: 2, Killed: 2, Survived: 0)
725: || $self->{allow_countries}; 726: } 727: 728: # ── IP / CIDR allow-list check ────────────────────────────────────────── ●729 → 729 → 750●729 → 729 → 0 729: if($self->{allowed_ips}) { 730: # Check for an exact-match entry first (fast path)
Mutants (Total: 1, Killed: 1, Survived: 0)
731: return 0 if $self->{allowed_ips}->{$addr}; 732:
Mutants (Total: 2, Killed: 2, Survived: 0)
733: # Build and memoise the CIDR lookup structure on first use. 734: # Wrap in eval: Net::CIDR dies on non-IP strings (injection attempts). 735: if(!$self->{_cidrlist}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
736: my @cidrlist; 737: for my $block (keys %{$self->{allowed_ips}}) { 738: eval { @cidrlist = Net::CIDR::cidradd($block, @cidrlist) }; 739: } 740: $self->{_cidrlist} = \@cidrlist; 741: } 742: 743: # Check whether the address falls inside any allowed CIDR range. 744: # Wrap in eval in case the list was built from partly-invalid entries.
Mutants (Total: 2, Killed: 2, Survived: 0)
745: my $in_cidr = eval { Net::CIDR::cidrlookup($addr, @{$self->{_cidrlist}}) }; 746: return 0 if $in_cidr; 747: } 748:
Mutants (Total: 1, Killed: 1, Survived: 0)
749: # ── Country check ─────────────────────────────────────────────────────── ●750 → 750 → 794●750 → 750 → 0 750: if($self->{deny_countries} || $self->{allow_countries}) { 751: # Parse the lingua argument (positional, named, or hashref)
Mutants (Total: 1, Killed: 1, Survived: 0)
752: my %params; 753: if(ref($_[0]) eq 'HASH') {
Mutants (Total: 1, Killed: 1, Survived: 0)
754: %params = %{$_[0]}; 755: } elsif(@_ % 2 == 0) { 756: %params = @_; 757: } else { 758: $params{lingua} = shift; 759: }
Mutants (Total: 1, Killed: 1, Survived: 0)
760: 761: if(my $lingua = $params{lingua}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
762: # Reject non-objects to avoid "can't call method on non-ref" crashes 763: unless(blessed($lingua)) { 764: Carp::carp('all_denied: lingua must be a blessed object'); 765: return 1;
Mutants (Total: 1, Killed: 1, Survived: 0)
766: } 767: # Resolve and normalise the client's country code. 768: # Wrap in eval: the object may not implement country(). 769: my $country_val = eval { $lingua->country() }; 770: return 1 if $@; # method missing or threw — treat as unknown 771: if(my $country = $country_val) { 772: $country = lc $country; 773: 774: # Default-deny mode: deny_countries contains the wildcard 775: if($self->{deny_countries} && $self->{deny_countries}->{$WILDCARD}) { 776: return ($self->{allow_countries} && $self->{allow_countries}->{$country}) 777: ? 0 # country is explicitly permitted 778: : 1; # not in the permit list; deny 779: } 780: 781: # Default-allow mode: deny only explicitly listed countries 782: return ($self->{deny_countries} && $self->{deny_countries}->{$country}) 783: ? 1 # country is explicitly denied 784: : 0; # not in the deny list; allow
Mutants (Total: 2, Killed: 2, Survived: 0)
785: } 786: # country() returned undef: country is unknown; deny access 787: } else { 788: # Country restrictions active but no lingua was provided 789: Carp::carp('Usage: all_denied($lingua)'); 790: } 791: } 792: 793: # Fall-through: no rule allowed the request; deny ●794 → 794 → 0 794: return 1; 795: } 796: 797: # ── Internal helpers ────────────────────────────────────────────────────────── 798: 799: # _set_countries 800: # 801: # Purpose: Shared logic for deny_country() and allow_country(). Inserts one 802: # or more lowercased country codes into the supplied hashref. 803: # 804: # Entry: $hashref - the target hash (already initialised by caller) 805: # $value - a scalar country code OR an arrayref of codes 806: #
Mutants (Total: 1, Killed: 1, Survived: 0)
807: # Exit: Returns nothing (modifies $hashref in place). 808: # 809: # Side effects: Modifies the caller-supplied hashref. 810: # 811: # Notes: Keys are forced to lower case for case-insensitive comparison. 812: sub _set_countries { ●813 → 817 → 822●813 → 817 → 0 813: my ($hashref, $value) = @_; 814: 815: # Handle both a single country code and a list reference. 816: # Skip undef elements to avoid "uninitialised value" warnings. 817: if(ref($value) eq 'ARRAY') { 818: $hashref->{lc $_} = 1 for grep { defined } @{$value}; 819: } else { 820: $hashref->{lc $value} = 1; 821: } ●822 → 822 → 0 822: return; 823: } 824: 825: # _is_cloud_host 826: # 827: # Purpose: Determines whether a given IP address belongs to a major cloud 828: # provider by performing a verified reverse-DNS lookup and then 829: # matching the confirmed hostname against @CLOUD_PATTERNS. 830: # 831: # Entry: $ip - a validated IPv4 or IPv6 address string. 832: # 833: # Exit: Returns 1 (cloud host) or 0 (not a cloud host / no PTR record). 834: # 835: # Side effects: Performs DNS lookups; may block for up to $DNS_TIMEOUT seconds 836: # on non-Windows platforms. 837: # 838: # Notes: An IP with no PTR record, or whose forward confirmation fails,
Mutants (Total: 2, Killed: 2, Survived: 0)
839: # returns 0 (not cloud). This is the safe default because 840: # legitimate cloud providers consistently set rDNS records.
Mutants (Total: 2, Killed: 2, Survived: 0)
841: sub _is_cloud_host { ●842 → 848 → 851●842 → 848 → 0 842: my $ip = $_[0]; 843: 844: # Attempt a verified reverse DNS lookup; returns undef on failure 845: my $hostname = _verified_rdns($ip) or return 0; 846: 847: # Compare the confirmed hostname against every known cloud pattern 848: for my $pattern (@CLOUD_PATTERNS) { 849: return 1 if $hostname =~ $pattern; 850: } ●851 → 851 → 0 851: return 0; 852: } 853: 854: # _verified_rdns 855: # 856: # Purpose: Performs a two-step DNS verification to prevent rDNS spoofing: 857: # 1. Reverse lookup: IP -> hostname 858: # 2. Forward confirmation: hostname -> [IPs]; IP must appear 859: # 860: # Entry: $ip - a syntactically valid IPv4 or IPv6 address string. 861: # 862: # Exit: Returns the confirmed hostname string on success, undef otherwise. 863: # undef is returned when: 864: # - $ip cannot be packed (invalid address) 865: # - no PTR record exists 866: # - forward lookup does not include the original IP 867: # - DNS lookup times out (non-Windows only) 868: # 869: # Side effects: Performs two DNS round-trips; installs and restores a temporary 870: # SIGALRM handler on non-Windows platforms.
871: # 872: # Notes: On non-Windows platforms a $DNS_TIMEOUT-second alarm is set to 873: # prevent CGI workers from blocking indefinitely on slow resolvers. 874: # alarm(0) is called inside the eval to close the race window 875: # between eval exit and the outer alarm(0) call. 876: sub _verified_rdns { ●877 → 881 → 893●877 → 881 → 0 877: my $ip = $_[0]; 878: 879: # Determine address family and produce the packed binary address 880: my ($family, $packed); 881: if($ip =~ /:/o) { 882: # IPv6: use inet_pton which handles all valid IPv6 formatsMutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_870_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes883: $family = Socket::AF_INET6; 884: $packed = Socket::inet_pton(Socket::AF_INET6, $ip) or return; 885: } else { 886: # IPv4: inet_aton handles dotted-quad addresses 887: $family = AF_INET; 888: $packed = inet_aton($ip) or return;Mutants (Total: 1, Killed: 0, Survived: 1)
- NUM_BOUNDARY_882_27_!=: 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' );889: } 890: 891: # Normalise the IP to canonical form for reliable string comparison. 892: # This handles abbreviated IPv6 forms such as '::1' vs '0:0:...:1'. ●893 → 899 → 925●893 → 899 → 0 893: my $canonical = ($family == AF_INET) 894: ? inet_ntoa($packed) 895: : Socket::inet_ntop(Socket::AF_INET6, $packed);Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_888_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes896: 897: my ($hostname, @forward_ips); 898: 899: if($^O ne 'MSWin32') { 900: # Non-Windows: guard against indefinitely-blocking DNS calls 901: local $SIG{ALRM} = sub { die "DNS timeout: $ip" }; 902: alarm($DNS_TIMEOUT); 903: eval { 904: # Step 1: reverse lookup (IP -> hostname) 905: $hostname = gethostbyaddr($packed, $family); 906: if($hostname) { 907: # Step 2: forward lookup (hostname -> IP list) 908: @forward_ips = _rdns_forward($hostname, $family); 909: } 910: # Cancel the alarm inside the eval to avoid a post-eval race 911: alarm(0); 912: }; 913: # Belt-and-suspenders: ensure the alarm is always cancelled 914: alarm(0); 915: return if $@ || !$hostname; 916: } else { 917: # Windows: no alarm support; perform lookups synchronously 918: $hostname = gethostbyaddr($packed, $family) or return; 919: 920: # Forward lookup to confirm the hostname maps back to the original IP 921: @forward_ips = _rdns_forward($hostname, $family); 922: } 923: 924: # Step 3: the hostname is only trusted if a forward record confirms the IP ●925 → 925 → 0 925: return (grep { $_ eq $canonical } @forward_ips) ? $hostname : undef; 926: } 927: 928: # _rdns_forward 929: # 930: # Purpose: Resolves a hostname to a list of IP address strings for use in 931: # the forward-confirmation step of _verified_rdns(). 932: # 933: # Entry: $hostname - the fully-qualified domain name to resolve. 934: # $family - address family: AF_INET or Socket::AF_INET6. 935: # 936: # Exit: Returns a list of IP address strings (may be empty on failure). 937: # 938: # Side effects: Performs a DNS A or AAAA lookup.Mutants (Total: 1, Killed: 0, Survived: 1)
- COND_INV_895_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes939: # 940: # Notes: For IPv4 uses the classic inet_aton/inet_ntoa chain. 941: # For IPv6 uses Socket::getaddrinfo and Socket::getnameinfo 942: # (available since Perl 5.14 / Socket 1.99). 943: sub _rdns_forward { ●944 → 947 → 955●944 → 947 → 0 944: my ($hostname, $family) = @_; 945: 946: # IPv4 path: resolve A record and convert each packed address to a string 947: if($family == AF_INET) { 948: return map { inet_ntoa($_) } 949: grep { defined } 950: map { inet_aton($_) } 951: ($hostname); 952: } 953: 954: # IPv6 path: use getaddrinfo to resolve AAAA records ●955 → 963 → 969●955 → 963 → 0 955: my ($err, @addrs) = Socket::getaddrinfo( 956: $hostname, undef, 957: { family => $family, socktype => SOCK_STREAM }, 958: ); 959: return () if $err; 960:Mutants (Total: 2, Killed: 0, Survived: 2)
- NUM_BOUNDARY_938_13_!=: 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' );- COND_INV_938_2: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes961: # Convert each opaque sockaddr to a numeric IP string 962: my @ips; 963: for my $addr_info (@addrs) { 964: my ($e, $host) = Socket::getnameinfo( 965: $addr_info->{addr}, Socket::NI_NUMERICHOST, 966: ); 967: push @ips, $host unless $e; 968: } ●969 → 969 → 0 969: return @ips; 970: } 971: 972: =encoding utf-8 973: 974: =head1 AUTHOR 975: 976: Nigel Horne, C<< <njh at nigelhorne.com> >> 977: 978: =head1 BUGS 979: 980: Please report any bugs or feature requests to 981: C<bug-cgi-acl at rt.cpan.org>, or through the web interface at 982: L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CGI-ACL>. 983: 984: A VPN or proxy will most likely bypass IP-based access control. 985: 986: =head1 SEE ALSO 987: 988: =over 4 989: 990: =item * L<CGI::Lingua> 991: 992: =item * L<Configure an Object at Runtime|Object::Configure> 993: 994: =item * L<Net::CIDR> 995: 996: =item * L<Test Dashboard|https://nigelhorne.github.io/CGI-ACL/coverage/> 997: 998: =back 999: 1000: =head1 SUPPORT 1001: 1002: perldoc CGI::ACL 1003: 1004: =over 4 1005: 1006: =item * MetaCPAN: L<https://metacpan.org/release/CGI-ACL> 1007: 1008: =item * RT: L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=CGI-ACL> 1009: 1010: =item * CPANTS: L<http://cpants.cpanauthors.org/dist/CGI-ACL> 1011: 1012: =item * CPAN Testers: L<http://matrix.cpantesters.org/?dist=CGI-ACL> 1013: 1014: =back 1015: 1016: =head2 FORMAL SPECIFICATION 1017: 1018: =head3 new 1019: 1020: ──────────────── ACLState ──────────────────────────────────────── 1021: allowed_ips : IP_Str ⇸ Bool 1022: deny_countries : Country ⇸ Bool 1023: allow_countries: Country ⇸ Bool 1024: deny_cloud : Bool 1025: _cidrlist : [CIDR_Str]? -- memoised; cleared on allow_ip 1026: ────────────────────────────────────────────────────────────────── 1027: 1028: ─────────────── New ────────────────────────────────────────────── 1029: class : ClassName ∪ ACLState 1030: params : ACLState? 1031: ───────────────────────────────────────────────────────────────── 1032: blessed(class) ⟹ 1033: result! = bless( class ∪ params, ref(class) ) -- clone 1034: ¬blessed(class) ⟹ 1035: result! = bless( configure(class, params), class ) 1036: ────────────────────────────────────────────────────────────────── 1037: 1038: =head3 allow_ip 1039: 1040: ─────────────── AllowIP ────────────────────────────────────────── 1041: ΔACL 1042: ip? : IP_Str 1043: ───────────────────────────────────────────────────────────────── 1044: allowed_ips' = allowed_ips ∪ { ip? ↦ 1 } 1045: _cidrlist' = ∅ -- cache invalidated 1046: deny_countries' = deny_countries 1047: allow_countries' = allow_countries 1048: deny_cloud' = deny_cloud 1049: ────────────────────────────────────────────────────────────────── 1050: 1051: =head3 deny_country 1052: 1053: ─────────────── DenyCountry ───────────────────────────────────── 1054: ΔACL 1055: country? : ISO_Code ∪ {'*'} ∪ seq ISO_Code 1056: ───────────────────────────────────────────────────────────────── 1057: country? ∈ seq ISO_Code ⟹ 1058: deny_countries' = deny_countries ∪ 1059: { lc(c) ↦ 1 | c ∈ country? } 1060: country? ∉ seq ISO_Code ⟹ 1061: deny_countries' = deny_countries ∪ { lc(country?) ↦ 1 } 1062: allow_countries' = allow_countries 1063: allowed_ips' = allowed_ips 1064: deny_cloud' = deny_cloud 1065: ────────────────────────────────────────────────────────────────── 1066: 1067: =head3 allow_country 1068: 1069: ─────────────── AllowCountry ──────────────────────────────────── 1070: ΔACL 1071: country? : ISO_Code ∪ seq ISO_Code 1072: ───────────────────────────────────────────────────────────────── 1073: country? ∈ seq ISO_Code ⟹ 1074: allow_countries' = allow_countries ∪ 1075: { lc(c) ↦ 1 | c ∈ country? } 1076: country? ∉ seq ISO_Code ⟹ 1077: allow_countries' = allow_countries ∪ { lc(country?) ↦ 1 } 1078: deny_countries' = deny_countries 1079: allowed_ips' = allowed_ips 1080: deny_cloud' = deny_cloud 1081: ────────────────────────────────────────────────────────────────── 1082: 1083: =head3 deny_cloud 1084: 1085: ─────────────── DenyCloud ─────────────────────────────────────── 1086: ΔACL 1087: ───────────────────────────────────────────────────────────────── 1088: deny_cloud' = 1 1089: allowed_ips' = allowed_ips 1090: deny_countries' = deny_countries 1091: allow_countries'= allow_countries 1092: _cidrlist' = _cidrlist 1093: ────────────────────────────────────────────────────────────────── 1094: 1095: =head3 all_denied 1096: 1097: ──────────────────────── AllDenied ────────────────────────────── 1098: ΞACL -- state unchanged (modulo cache) 1099: addr : IPv4 ∪ IPv6 -- REMOTE_ADDR or DEFAULT_ADDR 1100: lingua? : Lingua -- country resolver (optional) 1101: result! : {0, 1} -- 0 = allow, 1 = deny 1102: ───────────────────────────────────────────────────────────────── 1103: no_restrictions(self) ⟹ result! = 0 1104: 1105: ¬valid_ip(addr) ⟹ result! = 1 1106: 1107: deny_cloud = 1 ∧ is_cloud(addr) ⟹ result! = 1 1108: deny_cloud = 1 ∧ ¬is_cloud(addr) 1109: ∧ allowed_ips = ∅ ∧ deny_countries = ∅ 1110: ∧ allow_countries = ∅ ⟹ result! = 0 1111: 1112: addr ∈ dom(allowed_ips) ⟹ result! = 0 1113: cidr_match(addr, allowed_ips) ⟹ result! = 0 1114: 1115: (deny_countries ≠∅ ∨ allow_countries ≠∅) 1116: ∧ lingua? = ∅ ⟹ result! = 1 -- no lingua supplied 1117: lingua?.country() = undef ⟹ result! = 1 -- unknown country 1118: 1119: deny_countries($WILDCARD) = 1 1120: ∧ allow_countries(lc(lingua?.country())) = 1 ⟹ result! = 0 1121: deny_countries($WILDCARD) = 1 1122: ∧ allow_countries(lc(lingua?.country())) ≠1 ⟹ result! = 1 1123: 1124: deny_countries($WILDCARD) ≠1 1125: ∧ deny_countries(lc(lingua?.country())) = 1 ⟹ result! = 1 1126: deny_countries($WILDCARD) ≠1 1127: ∧ deny_countries(lc(lingua?.country())) ≠1 ⟹ result! = 0 1128: ────────────────────────────────────────────────────────────────── 1129: 1130: =head1 LICENSE AND COPYRIGHT 1131: 1132: Copyright 2017-2026 Nigel Horne. 1133: 1134: Usage is subject to the GPL2 licence terms. 1135: If you use it, 1136: please let me know. 1137: 1138: =cut 1139: 1140: 1;Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_960_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_960_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' );