TER1 (Statement): 98.50%
TER2 (Branch): 96.15%
TER3 (LCSAJ): 100.0% (49/49)
Approximate LCSAJ segments: 105
● 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)) {Mutants (Total: 1, Killed: 1, Survived: 0)
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. 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') {
Mutants (Total: 1, Killed: 1, Survived: 0)
258: Carp::carp('Usage: allow_ip($ip_address)'); 259: return $self;
Mutants (Total: 2, Killed: 2, Survived: 0)
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') {
Mutants (Total: 1, Killed: 1, Survived: 0)
265: %params = %{$_[0]}; 266: } elsif(@_ % 2 == 0) {
Mutants (Total: 1, Killed: 1, Survived: 0)
267: %params = @_; 268: } else { 269: $params{ip} = shift; 270: } 271: 272: # Store the address and invalidate the memoised CIDR list ●273 → 273 → 279●273 → 273 → 0 273: if(defined(my $ip = $params{ip})) {
Mutants (Total: 1, Killed: 1, Survived: 0)
274: $self->{allowed_ips}->{$ip} = 1; 275: delete $self->{_cidrlist}; 276: } else { 277: Carp::carp('Usage: allow_ip($ip_address)'); 278: } ●279 → 279 → 0 279: return $self;
Mutants (Total: 2, Killed: 2, Survived: 0)
280: } 281: 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). 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') {
Mutants (Total: 1, Killed: 1, Survived: 0)
368: Carp::carp('Usage: deny_country($country)'); 369: return $self;
Mutants (Total: 2, Killed: 2, Survived: 0)
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') {
Mutants (Total: 1, Killed: 1, Survived: 0)
375: %params = %{$_[0]}; 376: } elsif(@_ % 2 == 0) {
Mutants (Total: 1, Killed: 1, Survived: 0)
377: %params = @_; 378: } else { 379: $params{country} = shift; 380: } 381: 382: # Add the country or list of countries to the deny set. 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};
Mutants (Total: 2, Killed: 2, Survived: 0)
386: _set_countries($self->{deny_countries} ||= {}, $c); 387: } else { 388: Carp::carp('Usage: deny_country($country)'); 389: } ●390 → 390 → 0 390: return $self;
Mutants (Total: 2, Killed: 2, Survived: 0)
391: } 392: 393: # ── allow_country ────────────────────────────────────────────────────────────── 394: 395: =head2 allow_country 396: 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') {
Mutants (Total: 1, Killed: 1, Survived: 0)
475: Carp::carp('Usage: allow_country($country)'); 476: return $self;
Mutants (Total: 2, Killed: 2, Survived: 0)
477: } 478: 479: # Normalise positional, named, and hashref calling conventions ●480 → 481 → 491●480 → 481 → 0 480: my %params; 481: if(ref($_[0]) eq 'HASH') {
Mutants (Total: 1, Killed: 1, Survived: 0)
482: %params = %{$_[0]}; 483: } elsif(@_ % 2 == 0) {
Mutants (Total: 1, Killed: 1, Survived: 0)
484: %params = @_; 485: } else { 486: $params{country} = shift; 487: } 488: 489: # Add the country or list of countries to the permit set. 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})) {
Mutants (Total: 1, Killed: 1, Survived: 0)
492: return $self if ref($c) eq 'ARRAY' && !@{$c};
Mutants (Total: 2, Killed: 2, Survived: 0)
493: _set_countries($self->{allow_countries} ||= {}, $c); 494: } else { 495: Carp::carp('Usage: allow_country($country)'); 496: } ●497 → 497 → 0 497: return $self;
Mutants (Total: 2, Killed: 2, Survived: 0)
498: } 499: 500: # ── deny_cloud ───────────────────────────────────────────────────────────────── 501: 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;
Mutants (Total: 2, Killed: 2, Survived: 0)
574: } 575: 576: # ── all_denied ───────────────────────────────────────────────────────────────── 577: 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(
Mutants (Total: 1, Killed: 1, Survived: 0)
699: (!defined($self->{allowed_ips})) && 700: (!defined($self->{deny_countries})) && 701: (!$self->{deny_cloud}) && 702: (!defined($self->{allow_countries})) 703: ) { 704: return 0;
Mutants (Total: 2, Killed: 2, Survived: 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. ●709 → 716 → 733●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
Mutants (Total: 2, Killed: 2, Survived: 0)
713: || $addr =~ /^$RE{net}{IPv6}$/o; 714: 715: # ── Cloud check (highest precedence; overrides allow_ip) ──────────────── 716: if($self->{deny_cloud}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
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) }; 720: my $error = $@; 721: if($@ =~ /^DNS timeout: /) {
Mutants (Total: 1, Killed: 1, Survived: 0)
722: undef $@; 723: } 724: return 1 if !$error && $is_cloud;
Mutants (Total: 2, Killed: 2, Survived: 0)
725: 726: # Non-cloud and no other restrictions: allow 727: return 0 unless $self->{allowed_ips}
Mutants (Total: 2, Killed: 2, Survived: 0)
728: || $self->{deny_countries} 729: || $self->{allow_countries}; 730: } 731: 732: # ── IP / CIDR allow-list check ────────────────────────────────────────── ●733 → 733 → 754●733 → 733 → 0 733: if($self->{allowed_ips}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
734: # Check for an exact-match entry first (fast path) 735: return 0 if $self->{allowed_ips}->{$addr};
Mutants (Total: 2, Killed: 2, Survived: 0)
736: 737: # Build and memoise the CIDR lookup structure on first use. 738: # Wrap in eval: Net::CIDR dies on non-IP strings (injection attempts). 739: if(!$self->{_cidrlist}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
740: my @cidrlist; 741: for my $block (keys %{$self->{allowed_ips}}) { 742: eval { @cidrlist = Net::CIDR::cidradd($block, @cidrlist) }; 743: } 744: $self->{_cidrlist} = \@cidrlist; 745: } 746: 747: # Check whether the address falls inside any allowed CIDR range. 748: # Wrap in eval in case the list was built from partly-invalid entries. 749: my $in_cidr = eval { Net::CIDR::cidrlookup($addr, @{$self->{_cidrlist}}) }; 750: return 0 if $in_cidr;
Mutants (Total: 2, Killed: 2, Survived: 0)
751: } 752: 753: # ── Country check ─────────────────────────────────────────────────────── ●754 → 754 → 798●754 → 754 → 0 754: if($self->{deny_countries} || $self->{allow_countries}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
755: # Parse the lingua argument (positional, named, or hashref) 756: my %params; 757: if(ref($_[0]) eq 'HASH') {
Mutants (Total: 1, Killed: 1, Survived: 0)
758: %params = %{$_[0]}; 759: } elsif(@_ % 2 == 0) {
Mutants (Total: 1, Killed: 1, Survived: 0)
760: %params = @_; 761: } else { 762: $params{lingua} = shift; 763: } 764: 765: if(my $lingua = $params{lingua}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
766: # Reject non-objects to avoid "can't call method on non-ref" crashes 767: unless(blessed($lingua)) {
Mutants (Total: 1, Killed: 1, Survived: 0)
768: Carp::carp('all_denied: lingua must be a blessed object'); 769: return 1;
Mutants (Total: 2, Killed: 2, Survived: 0)
770: } 771: # Resolve and normalise the client's country code. 772: # Wrap in eval: the object may not implement country(). 773: my $country_val = eval { $lingua->country() }; 774: return 1 if $@; # method missing or threw — treat as unknown
Mutants (Total: 2, Killed: 2, Survived: 0)
775: if(my $country = $country_val) {
Mutants (Total: 1, Killed: 1, Survived: 0)
776: $country = lc $country; 777: 778: # Default-deny mode: deny_countries contains the wildcard 779: if($self->{deny_countries} && $self->{deny_countries}->{$WILDCARD}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
780: return ($self->{allow_countries} && $self->{allow_countries}->{$country}) 781: ? 0 # country is explicitly permitted 782: : 1; # not in the permit list; deny 783: } 784: 785: # Default-allow mode: deny only explicitly listed countries 786: return ($self->{deny_countries} && $self->{deny_countries}->{$country}) 787: ? 1 # country is explicitly denied 788: : 0; # not in the deny list; allow 789: } 790: # country() returned undef: country is unknown; deny access 791: } else { 792: # Country restrictions active but no lingua was provided 793: Carp::carp('Usage: all_denied($lingua)'); 794: } 795: } 796: 797: # Fall-through: no rule allowed the request; deny ●798 → 798 → 0 798: return 1;
Mutants (Total: 2, Killed: 2, Survived: 0)
799: } 800: 801: # ── Internal helpers ────────────────────────────────────────────────────────── 802: 803: # _set_countries 804: # 805: # Purpose: Shared logic for deny_country() and allow_country(). Inserts one 806: # or more lowercased country codes into the supplied hashref. 807: # 808: # Entry: $hashref - the target hash (already initialised by caller) 809: # $value - a scalar country code OR an arrayref of codes 810: # 811: # Exit: Returns nothing (modifies $hashref in place). 812: # 813: # Side effects: Modifies the caller-supplied hashref. 814: # 815: # Notes: Keys are forced to lower case for case-insensitive comparison. 816: sub _set_countries { ●817 → 821 → 826●817 → 821 → 0 817: my ($hashref, $value) = @_; 818: 819: # Handle both a single country code and a list reference. 820: # Skip undef elements to avoid "uninitialised value" warnings. 821: if(ref($value) eq 'ARRAY') {
Mutants (Total: 1, Killed: 1, Survived: 0)
822: $hashref->{lc $_} = 1 for grep { defined } @{$value}; 823: } else { 824: $hashref->{lc $value} = 1; 825: } ●826 → 826 → 0 826: return; 827: } 828: 829: # _is_cloud_host 830: # 831: # Purpose: Determines whether a given IP address belongs to a major cloud 832: # provider by performing a verified reverse-DNS lookup and then 833: # matching the confirmed hostname against @CLOUD_PATTERNS. 834: # 835: # Entry: $ip - a validated IPv4 or IPv6 address string. 836: # 837: # Exit: Returns 1 (cloud host) or 0 (not a cloud host / no PTR record). 838: # 839: # Side effects: Performs DNS lookups; may block for up to $DNS_TIMEOUT seconds 840: # on non-Windows platforms. 841: # 842: # Notes: An IP with no PTR record, or whose forward confirmation fails, 843: # returns 0 (not cloud). This is the safe default because 844: # legitimate cloud providers consistently set rDNS records. 845: sub _is_cloud_host { ●846 → 852 → 855●846 → 852 → 0 846: my $ip = $_[0]; 847: 848: # Attempt a verified reverse DNS lookup; returns undef on failure 849: my $hostname = _verified_rdns($ip) or return 0; 850: 851: # Compare the confirmed hostname against every known cloud pattern 852: for my $pattern (@CLOUD_PATTERNS) { 853: return 1 if $hostname =~ $pattern;
Mutants (Total: 2, Killed: 2, Survived: 0)
854: } ●855 → 855 → 0 855: return 0;
Mutants (Total: 2, Killed: 2, Survived: 0)
856: } 857: 858: # _verified_rdns 859: # 860: # Purpose: Performs a two-step DNS verification to prevent rDNS spoofing: 861: # 1. Reverse lookup: IP -> hostname 862: # 2. Forward confirmation: hostname -> [IPs]; IP must appear 863: # 864: # Entry: $ip - a syntactically valid IPv4 or IPv6 address string. 865: # 866: # Exit: Returns the confirmed hostname string on success, undef otherwise. 867: # undef is returned when: 868: # - $ip cannot be packed (invalid address) 869: # - no PTR record exists 870: # - forward lookup does not include the original IP 871: # - DNS lookup times out (non-Windows only) 872: # 873: # Side effects: Performs two DNS round-trips; installs and restores a temporary 874: # SIGALRM handler on non-Windows platforms. 875: # 876: # Notes: On non-Windows platforms a $DNS_TIMEOUT-second alarm is set to 877: # prevent CGI workers from blocking indefinitely on slow resolvers. 878: # alarm(0) is called inside the eval to close the race window 879: # between eval exit and the outer alarm(0) call. 880: sub _verified_rdns { ●881 → 885 → 897●881 → 885 → 0 881: my $ip = $_[0]; 882: 883: # Determine address family and produce the packed binary address 884: my ($family, $packed); 885: if($ip =~ /:/o) {
Mutants (Total: 1, Killed: 1, Survived: 0)
886: # IPv6: use inet_pton which handles all valid IPv6 formats 887: $family = Socket::AF_INET6; 888: $packed = Socket::inet_pton(Socket::AF_INET6, $ip) or return; 889: } else { 890: # IPv4: inet_aton handles dotted-quad addresses 891: $family = AF_INET; 892: $packed = inet_aton($ip) or return; 893: } 894: 895: # Normalise the IP to canonical form for reliable string comparison. 896: # This handles abbreviated IPv6 forms such as '::1' vs '0:0:...:1'. ●897 → 903 → 929●897 → 903 → 0 897: my $canonical = ($family == AF_INET)
Mutants (Total: 1, Killed: 1, Survived: 0)
898: ? inet_ntoa($packed) 899: : Socket::inet_ntop(Socket::AF_INET6, $packed); 900: 901: my ($hostname, @forward_ips); 902: 903: if($^O ne 'MSWin32') {
Mutants (Total: 1, Killed: 1, Survived: 0)
904: # Non-Windows: guard against indefinitely-blocking DNS calls 905: local $SIG{ALRM} = sub { die "DNS timeout: $ip" }; 906: my $old_alarm = alarm($DNS_TIMEOUT) || 0; 907: eval { 908: # Step 1: reverse lookup (IP -> hostname) 909: $hostname = gethostbyaddr($packed, $family); 910: if($hostname) {
Mutants (Total: 1, Killed: 1, Survived: 0)
911: # Step 2: forward lookup (hostname -> IP list) 912: @forward_ips = _rdns_forward($hostname, $family); 913: } 914: # Cancel the alarm inside the eval to avoid a post-eval race 915: alarm($old_alarm); 916: }; 917: # Ensure the alarm is always cancelled 918: alarm($old_alarm); 919: return if $@ || !$hostname; 920: } else { 921: # Windows: no alarm support; perform lookups synchronously 922: $hostname = gethostbyaddr($packed, $family) or return; 923: 924: # Forward lookup to confirm the hostname maps back to the original IP 925: @forward_ips = _rdns_forward($hostname, $family); 926: } 927: 928: # Step 3: the hostname is only trusted if a forward record confirms the IP ●929 → 929 → 0 929: return (grep { $_ eq $canonical } @forward_ips) ? $hostname : undef; 930: } 931: 932: # _rdns_forward 933: # 934: # Purpose: Resolves a hostname to a list of IP address strings for use in 935: # the forward-confirmation step of _verified_rdns(). 936: # 937: # Entry: $hostname - the fully-qualified domain name to resolve. 938: # $family - address family: AF_INET or Socket::AF_INET6. 939: # 940: # Exit: Returns a list of IP address strings (may be empty on failure). 941: # 942: # Side effects: Performs a DNS A or AAAA lookup. 943: # 944: # Notes: For IPv4 uses the classic inet_aton/inet_ntoa chain. 945: # For IPv6 uses Socket::getaddrinfo and Socket::getnameinfo 946: # (available since Perl 5.14 / Socket 1.99). 947: sub _rdns_forward { ●948 → 951 → 959●948 → 951 → 0 948: my ($hostname, $family) = @_; 949: 950: # IPv4 path: resolve A record and convert each packed address to a string 951: if($family == AF_INET) {
Mutants (Total: 2, Killed: 2, Survived: 0)
952: return map { inet_ntoa($_) } 953: grep { defined } 954: map { inet_aton($_) } 955: ($hostname); 956: } 957: 958: # IPv6 path: use getaddrinfo to resolve AAAA records ●959 → 967 → 973●959 → 967 → 0 959: my ($err, @addrs) = Socket::getaddrinfo( 960: $hostname, undef, 961: { family => $family, socktype => SOCK_STREAM }, 962: ); 963: return () if $err; 964: 965: # Convert each opaque sockaddr to a numeric IP string 966: my @ips; 967: for my $addr_info (@addrs) { 968: my ($e, $host) = Socket::getnameinfo( 969: $addr_info->{addr}, Socket::NI_NUMERICHOST, 970: ); 971: push @ips, $host unless $e; 972: } ●973 → 973 → 0 973: return @ips;
Mutants (Total: 2, Killed: 2, Survived: 0)
974: } 975: 976: =encoding utf-8 977: 978: =head1 AUTHOR 979: 980: Nigel Horne, C<< <njh at nigelhorne.com> >> 981: 982: =head1 BUGS 983: 984: Please report any bugs or feature requests to 985: C<bug-cgi-acl at rt.cpan.org>, or through the web interface at 986: L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CGI-ACL>. 987: 988: A VPN or proxy will most likely bypass IP-based access control. 989: 990: =head1 SEE ALSO 991: 992: =over 4 993: 994: =item * L<CGI::Lingua> 995: 996: =item * L<Configure an Object at Runtime|Object::Configure> 997: 998: =item * L<Net::CIDR> 999: 1000: =item * L<Test Dashboard|https://nigelhorne.github.io/CGI-ACL/coverage/> 1001: 1002: =back 1003: 1004: =head1 SUPPORT 1005: 1006: perldoc CGI::ACL 1007: 1008: =over 4 1009: 1010: =item * MetaCPAN: L<https://metacpan.org/release/CGI-ACL> 1011: 1012: =item * RT: L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=CGI-ACL> 1013: 1014: =item * CPANTS: L<http://cpants.cpanauthors.org/dist/CGI-ACL> 1015: 1016: =item * CPAN Testers: L<http://matrix.cpantesters.org/?dist=CGI-ACL> 1017: 1018: =back 1019: 1020: =head2 FORMAL SPECIFICATION 1021: 1022: =head3 new 1023: 1024: ──────────────── ACLState ──────────────────────────────────────── 1025: allowed_ips : IP_Str ⇸ Bool 1026: deny_countries : Country ⇸ Bool 1027: allow_countries: Country ⇸ Bool 1028: deny_cloud : Bool 1029: _cidrlist : [CIDR_Str]? -- memoised; cleared on allow_ip 1030: ────────────────────────────────────────────────────────────────── 1031: 1032: ─────────────── New ────────────────────────────────────────────── 1033: class : ClassName ∪ ACLState 1034: params : ACLState? 1035: ───────────────────────────────────────────────────────────────── 1036: blessed(class) ⟹ 1037: result! = bless( class ∪ params, ref(class) ) -- clone 1038: ¬blessed(class) ⟹ 1039: result! = bless( configure(class, params), class ) 1040: ────────────────────────────────────────────────────────────────── 1041: 1042: =head3 allow_ip 1043: 1044: ─────────────── AllowIP ────────────────────────────────────────── 1045: ΔACL 1046: ip? : IP_Str 1047: ───────────────────────────────────────────────────────────────── 1048: allowed_ips' = allowed_ips ∪ { ip? ↦ 1 } 1049: _cidrlist' = ∅ -- cache invalidated 1050: deny_countries' = deny_countries 1051: allow_countries' = allow_countries 1052: deny_cloud' = deny_cloud 1053: ────────────────────────────────────────────────────────────────── 1054: 1055: =head3 deny_country 1056: 1057: ─────────────── DenyCountry ───────────────────────────────────── 1058: ΔACL 1059: country? : ISO_Code ∪ {'*'} ∪ seq ISO_Code 1060: ───────────────────────────────────────────────────────────────── 1061: country? ∈ seq ISO_Code ⟹ 1062: deny_countries' = deny_countries ∪ 1063: { lc(c) ↦ 1 | c ∈ country? } 1064: country? ∉ seq ISO_Code ⟹ 1065: deny_countries' = deny_countries ∪ { lc(country?) ↦ 1 } 1066: allow_countries' = allow_countries 1067: allowed_ips' = allowed_ips 1068: deny_cloud' = deny_cloud 1069: ────────────────────────────────────────────────────────────────── 1070: 1071: =head3 allow_country 1072: 1073: ─────────────── AllowCountry ──────────────────────────────────── 1074: ΔACL 1075: country? : ISO_Code ∪ seq ISO_Code 1076: ───────────────────────────────────────────────────────────────── 1077: country? ∈ seq ISO_Code ⟹ 1078: allow_countries' = allow_countries ∪ 1079: { lc(c) ↦ 1 | c ∈ country? } 1080: country? ∉ seq ISO_Code ⟹ 1081: allow_countries' = allow_countries ∪ { lc(country?) ↦ 1 } 1082: deny_countries' = deny_countries 1083: allowed_ips' = allowed_ips 1084: deny_cloud' = deny_cloud 1085: ────────────────────────────────────────────────────────────────── 1086: 1087: =head3 deny_cloud 1088: 1089: ─────────────── DenyCloud ─────────────────────────────────────── 1090: ΔACL 1091: ───────────────────────────────────────────────────────────────── 1092: deny_cloud' = 1 1093: allowed_ips' = allowed_ips 1094: deny_countries' = deny_countries 1095: allow_countries'= allow_countries 1096: _cidrlist' = _cidrlist 1097: ────────────────────────────────────────────────────────────────── 1098: 1099: =head3 all_denied 1100: 1101: ──────────────────────── AllDenied ────────────────────────────── 1102: ΞACL -- state unchanged (modulo cache) 1103: addr : IPv4 ∪ IPv6 -- REMOTE_ADDR or DEFAULT_ADDR 1104: lingua? : Lingua -- country resolver (optional) 1105: result! : {0, 1} -- 0 = allow, 1 = deny 1106: ───────────────────────────────────────────────────────────────── 1107: no_restrictions(self) ⟹ result! = 0 1108: 1109: ¬valid_ip(addr) ⟹ result! = 1 1110: 1111: deny_cloud = 1 ∧ is_cloud(addr) ⟹ result! = 1 1112: deny_cloud = 1 ∧ ¬is_cloud(addr) 1113: ∧ allowed_ips = ∅ ∧ deny_countries = ∅ 1114: ∧ allow_countries = ∅ ⟹ result! = 0 1115: 1116: addr ∈ dom(allowed_ips) ⟹ result! = 0 1117: cidr_match(addr, allowed_ips) ⟹ result! = 0 1118: 1119: (deny_countries ≠∅ ∨ allow_countries ≠∅) 1120: ∧ lingua? = ∅ ⟹ result! = 1 -- no lingua supplied 1121: lingua?.country() = undef ⟹ result! = 1 -- unknown country 1122: 1123: deny_countries($WILDCARD) = 1 1124: ∧ allow_countries(lc(lingua?.country())) = 1 ⟹ result! = 0 1125: deny_countries($WILDCARD) = 1 1126: ∧ allow_countries(lc(lingua?.country())) ≠1 ⟹ result! = 1 1127: 1128: deny_countries($WILDCARD) ≠1 1129: ∧ deny_countries(lc(lingua?.country())) = 1 ⟹ result! = 1 1130: deny_countries($WILDCARD) ≠1 1131: ∧ deny_countries(lc(lingua?.country())) ≠1 ⟹ result! = 0 1132: ────────────────────────────────────────────────────────────────── 1133: 1134: =head1 LICENSE AND COPYRIGHT 1135: 1136: Copyright 2017-2026 Nigel Horne. 1137: 1138: Usage is subject to the GPL2 licence terms. 1139: If you use it, 1140: please let me know. 1141: 1142: =cut 1143: 1144: 1;