| File: | blib/lib/CGI/ACL.pm |
| Coverage: | 81.5% |
| line | stmt | bran | cond | sub | pod | time | code |
|---|---|---|---|---|---|---|---|
| 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 | 17 17 | 1186221 22 | use 5.014; # Socket::getaddrinfo/getnameinfo require Socket 2.000 (Perl 5.14) | ||||
| 9 | 17 17 17 | 27 10 119 | use strict; | ||||
| 10 | 17 17 17 | 22 15 344 | use warnings; | ||||
| 11 | 17 17 17 | 1417 55661 35 | use autodie qw(:all); | ||||
| 12 | |||||||
| 13 | # namespace::clean removes imported helper names from the public method list | ||||||
| 14 | 17 17 17 | 84450 91526 37 | use namespace::clean; | ||||
| 15 | |||||||
| 16 | 17 17 17 | 4665 10 317 | use Carp; | ||||
| 17 | 17 17 17 | 2841 37057 399 | use Net::CIDR; | ||||
| 18 | 17 17 17 | 3525 823895 268 | use Object::Configure; | ||||
| 19 | 17 17 17 | 41 15 223 | use Params::Get; | ||||
| 20 | 17 17 17 | 31 10 251 | use Readonly; | ||||
| 21 | 17 17 17 | 2790 16284 31 | use Regexp::Common qw(net); | ||||
| 22 | 17 17 17 | 18968 11 387 | use Scalar::Util qw(blessed); | ||||
| 23 | 17 17 17 | 29 40 322 | use Socket qw(AF_INET SOCK_STREAM inet_aton inet_ntoa); | ||||
| 24 | 17 17 17 | 2638 55784 40 | 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 - 82 | =head1 NAME CGI::ACL - Decide whether to allow a client to run a CGI script =head1 VERSION Version 0.10 =cut | ||||||
| 83 | |||||||
| 84 | our $VERSION = '0.10'; | ||||||
| 85 | |||||||
| 86 - 357 | =head1 SYNOPSIS
CGI::ACL controls who can run your CGI script. You build a set of rules
and then call C<all_denied()> on every request. If it returns C<1>,
send an error response or redirect; if it returns C<0>, allow the request.
Rules can be stacked in any order using method chaining. An unrestricted
object (no rules added) allows everything.
=head2 Block all cloud-hosted visitors
The simplest use case -- no country list or lingua object needed.
use CGI::ACL;
my $acl = CGI::ACL->new()->deny_cloud();
if ($acl->all_denied()) {
print "Content-Type: text/plain\n\n";
print "Automated cloud traffic is not permitted.\n";
exit;
}
=head2 Allow only specific IP addresses or CIDR ranges
Localhost is NOT automatically allowed once any restriction is set.
Add it explicitly if your script is called from the same machine.
use CGI::ACL;
my $acl = CGI::ACL->new()
->allow_ip('127.0.0.1') # local machine
->allow_ip('203.0.113.0/24') # office CIDR block
->allow_ip('2001:db8::1'); # single IPv6 address
if ($acl->all_denied()) {
print "Content-Type: text/plain\n\n";
print "Your IP address is not on the allow list.\n";
exit;
}
=head2 Block visitors from specific countries
Deny mode: allow everyone except the listed countries.
use CGI::Lingua;
use CGI::ACL;
my $lingua = CGI::Lingua->new(supported => ['en']);
my $acl = CGI::ACL->new()
->deny_country('CN')
->deny_country(country => ['RU', 'KP']);
if ($acl->all_denied(lingua => $lingua)) {
print "Content-Type: text/plain\n\n";
print "Access from your country is not permitted.\n";
exit;
}
=head2 Allow only specific countries (allowlist)
Default-deny mode: block everyone except the listed countries.
Use C<deny_all_countries()> to turn on default-deny, then list
each permitted country with C<allow_country()>.
use CGI::Lingua;
use CGI::ACL;
my $lingua = CGI::Lingua->new(supported => ['en', 'de', 'fr']);
my $acl = CGI::ACL->new()
->deny_all_countries()
->allow_country('GB')
->allow_country('US')
->allow_country('DE');
if ($acl->all_denied(lingua => $lingua)) {
print "Content-Type: text/plain\n\n";
print "This service is available in GB, US, and DE only.\n";
exit;
}
=head2 Production-grade: IP allowlist + country allowlist + cloud block
Combine all three rule types. Rules are evaluated in this fixed order:
cloud check, IP check, country check.
use CGI::Lingua;
use CGI::ACL;
my $lingua = CGI::Lingua->new(supported => ['en']);
my $acl = CGI::ACL->new()
->deny_cloud() # block AWS, GCP, Azure, etc.
->allow_ip('127.0.0.1') # always allow localhost
->allow_ip('198.51.100.0/24') # corporate network
->deny_all_countries() # default-deny all countries...
->allow_country('GB') # ...except UK
->allow_country('US'); # ...and US
if ($acl->all_denied(lingua => $lingua)) {
print "Content-Type: text/plain\n\n";
print "Access denied.\n";
exit;
}
=head2 Sharing a base ACL across routes with cloning
Call C<new()> on an existing object to get an independent copy.
Changing the copy does not affect the original.
use CGI::ACL;
# Shared base: block cloud for all routes
my $base_acl = CGI::ACL->new()->deny_cloud();
# Admin route: additionally restrict to a single IP
my $admin_acl = $base_acl->new()->allow_ip('198.51.100.1');
if ($admin_acl->all_denied()) {
print "Content-Type: text/plain\n\n";
print "Admin access denied.\n";
exit;
}
The module optionally integrates with L<CGI::Lingua> for country detection.
Runtime configuration is supported via L<Object::Configure>.
=head1 COMMON PITFALLS
The following mistakes are easy to make. Read this section before filing
a bug report.
=head2 allow_country alone has no effect
C<allow_country()> only restricts access when default-deny mode is active.
Default-deny mode is activated by C<deny_country('*')> or
C<deny_all_countries()>. Without it, C<allow_country()> is silently
ignored and everyone is still allowed.
# WRONG -- this allows everyone; allow_country is ignored
my $acl = CGI::ACL->new()->allow_country('US');
# RIGHT -- deny all countries first, then add permitted ones
my $acl = CGI::ACL->new()->deny_all_countries()->allow_country('US');
=head2 deny_cloud overrides allow_ip
Cloud detection has the highest priority. An IP address that is listed
in C<allow_ip()> is still blocked if its reverse DNS resolves to a cloud
provider hostname. This is intentional: cloud IPs can be reassigned, so
the rDNS check is more reliable than the IP address alone.
# This STILL blocks the IP if it is a cloud host
my $acl = CGI::ACL->new()
->deny_cloud()
->allow_ip('198.51.100.5'); # blocked if rDNS says EC2
=head2 Localhost is not automatically allowed
Once any restriction is set, C<127.0.0.1> is subject to the same rules
as any other address. If you need to allow local access (for example,
a health-check endpoint), add it explicitly.
my $acl = CGI::ACL->new()
->allow_ip('127.0.0.1') # must be explicit
->deny_all_countries()
->allow_country('US');
=head2 Forgetting the lingua argument
When country restrictions are active and C<all_denied()> is called without
a C<lingua> argument, the module emits a C<carp> warning and denies the
request. Always pass a C<CGI::Lingua> object when country rules are in use.
# WRONG -- will carp and deny every request
my $acl = CGI::ACL->new()->deny_all_countries()->allow_country('US');
$acl->all_denied();
# RIGHT
my $lingua = CGI::Lingua->new(supported => ['en']);
$acl->all_denied(lingua => $lingua);
=head2 VPN and proxy users bypass IP and country checks
A visitor who connects through a VPN, Tor exit node, or anonymous proxy
will appear to come from the proxy's IP address and country, not their
own. CGI::ACL has no way to detect this. Cloud blocking provides some
mitigation for VPS-based proxies.
=head2 Country codes are case-insensitive but stored lowercase
C<deny_country('BR')> and C<deny_country('br')> are equivalent. All
country codes are stored in lowercase. C<CGI::Lingua::country()> may
return either case; C<all_denied()> normalises it with C<lc()> before
comparing.
=head2 The DNS result cache is not shared between CGI requests
In traditional CGI (one process per request), the per-object DNS cache
is destroyed at the end of every request. The cache is only useful in
persistent-process setups such as FastCGI, mod_perl, or Plack servers,
where the same C<CGI::ACL> object survives across many requests.
=head1 SUBROUTINES/METHODS
=head2 new
Creates and returns a new CGI::ACL object.
When called on an existing object it returns a deep clone of that object,
optionally overriding public fields with the supplied arguments. The public
data hashes (C<allowed_ips>, C<deny_countries>, C<allow_countries>) are
copied so that mutations to the clone do not affect the original.
Derived/private keys (C<_cidrlist>, C<_cloud_cache>) are always cleared;
they are rebuilt from the cloned public state on the next C<all_denied()>
call.
B<Security note:> private C<_*> keys are stripped from all constructor
arguments, including those supplied via environment variables or a config
file. Accepting C<_cloud_cache> entries from outside the process would
allow an attacker with environment-variable access to pre-seed the DNS
result cache and bypass C<deny_cloud()> for specific IP addresses.
Constructor arguments may also be supplied via environment variables of the
form C<CGI__ACL__E<lt>fieldE<gt>> or via a config file; see L<Object::Configure>
for details.
=head3 EXAMPLE
# No restrictions (allow all by default)
my $acl = CGI::ACL->new();
# Pre-seeded allow list
my $acl = CGI::ACL->new(allowed_ips => { '127.0.0.1' => 1 });
# Clone an existing ACL and add a restriction
my $acl2 = $acl->new(deny_cloud => 1);
=head3 API SPECIFICATION
=head4 Input
# Compatible with Params::Validate::Strict:
{
allowed_ips => { type => 'hashref', optional => 1 },
deny_countries => { type => 'hashref', optional => 1 },
allow_countries => { type => 'hashref', optional => 1 },
deny_cloud => { type => 'boolean', optional => 1 },
}
=head4 Output
# Compatible with Return::Set:
{ type => 'object', isa => 'CGI::ACL' }
# or undef when called as CGI::ACL::new() instead of CGI::ACL->new()
=head3 MESSAGES
=over 4
=item C<< CGI::ACL use ->new() not ::new() to instantiate >>
B<Severity:> carp (warning).
B<Cause:> C<CGI::ACL::new(...)> was called as a plain function instead of
as a class method.
B<Action:> Change the call to C<< CGI::ACL->new(...) >>.
=back
=cut | ||||||
| 358 | |||||||
| 359 | sub new { | ||||||
| 360 | 403 | 1 | 14921354 | my $class = shift; | |||
| 361 | |||||||
| 362 | # Parse arguments uniformly (hashref, named pairs, or no args) | ||||||
| 363 | 403 | 682 | my $params = Params::Get::get_params(undef, \@_); | ||||
| 364 | |||||||
| 365 | # Handle the rare case of being called as a plain function: CGI::ACL::new() | ||||||
| 366 | 403 | 4203 | if(!defined($class)) { | ||||
| 367 | 3 | 5 | Carp::carp(__PACKAGE__ . ': use ->new() not ::new() to instantiate'); | ||||
| 368 | 3 | 473 | 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 | 23 | 477 | $params //= {}; | ||||
| 373 | 23 23 | 17 32 | my %copy = %{$class}; | ||||
| 374 | 23 | 36 | for my $key (qw(allowed_ips deny_countries allow_countries)) { | ||||
| 375 | 69 21 | 81 26 | $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 | 23 | 20 | delete $copy{_cidrlist}; | ||||
| 379 | 23 | 22 | 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 | 2 | 3 | my %safe_params = map { $_ => $params->{$_} } | ||||
| 388 | 10 | 16 | grep { !/\A_/xms } | ||||
| 389 | 23 23 | 22 29 | keys %{$params}; | ||||
| 390 | 23 | 73 | return bless { %copy, %safe_params }, ref($class); | ||||
| 391 | } | ||||||
| 392 | |||||||
| 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 | 377 | 551 | my $cfg = Object::Configure::configure($class, $params); | ||||
| 397 | 376 394 376 | 801781 625 420 | delete $cfg->{$_} for grep { /\A_/xms } keys %{$cfg}; | ||||
| 398 | 376 | 934 | return bless $cfg, $class; | ||||
| 399 | } | ||||||
| 400 | |||||||
| 401 - 492 | =head2 allow_ip
Adds an IPv4/IPv6 address or CIDR block to the set of explicitly permitted
clients. When C<allowed_ips> is non-empty, any client address not matched
by an entry in the set is denied (subject to C<deny_cloud> taking precedence).
=head3 EXAMPLE
use CGI::ACL;
# Single address
my $acl = CGI::ACL->new()->allow_ip('203.0.113.5');
# Named parameter
my $acl = CGI::ACL->new()->allow_ip(ip => '203.0.113.5');
# CIDR block
my $acl = CGI::ACL->new()->allow_ip(ip => '192.0.2.0/24');
# Method chaining
my $acl = CGI::ACL->new()
->allow_ip('192.0.2.1')
->allow_ip('10.0.0.0/8');
=head3 ARGUMENTS
=over 4
=item ip (required)
A string containing an IPv4 address, an IPv6 address, or a CIDR block
(e.g. C<10.0.0.0/8>). The format is validated before storage;
syntactically invalid values are rejected with a carp warning and the
object is returned unchanged.
=back
=head3 RETURNS
The object itself, to allow method chaining.
=head3 SIDE EFFECTS
On the first call (even if the supplied address is invalid), initialises
C<< $self->{allowed_ips} >> to an empty hashref so that C<all_denied()>
treats the ACL as having IP restrictions configured. This ensures
fail-closed behaviour: an ACL whose only C<allow_ip()> calls all supplied
invalid addresses denies all traffic rather than allowing it.
On a successful (valid) call, also invalidates the internal CIDR lookup
cache so the next call to C<all_denied()> rebuilds it with the new entry.
=head3 API SPECIFICATION
=head4 Input
# Compatible with Params::Validate::Strict:
{
ip => { type => 'string', regex => qr/\S+/, required => 1 },
}
=head4 Output
# Compatible with Return::Set:
{ type => 'object', isa => 'CGI::ACL' }
=head3 MESSAGES
=over 4
=item C<Usage: allow_ip($ip_address)>
B<Severity:> carp (warning).
B<Cause:> Called with no argument, with a non-hash reference, or without
supplying the C<ip> key.
B<Action:> Pass a scalar IP/CIDR string: C<allow_ip('192.0.2.1')> or
C<allow_ip(ip =E<gt> '192.0.2.1')>.
=item C<< allow_ip: 'X' is not a valid IP address or CIDR block >>
B<Severity:> carp (warning).
B<Cause:> The supplied string does not parse as a syntactically valid IPv4
address, IPv6 address, or CIDR block. The value (truncated to 60 chars in
the message) was not stored. C<$self->{allowed_ips}> is still initialised
so the ACL remains in fail-closed mode.
B<Action:> Check the supplied string for typos. Use dotted-quad notation
for IPv4 (e.g. C<192.0.2.1>), colon-hex for IPv6 (e.g. C<2001:db8::1>),
or slash-notation for CIDR (e.g. C<10.0.0.0/8>).
=back
=cut | ||||||
| 493 | |||||||
| 494 | sub allow_ip { | ||||||
| 495 | 285 | 1 | 5929 | my $self = shift; | |||
| 496 | |||||||
| 497 | # Guard 1: reject non-hash, non-scalar references (e.g. scalar ref passed by mistake) | ||||||
| 498 | 285 | 831 | my $ref = ref($_[0]); | ||||
| 499 | 285 | 633 | if($ref && $ref ne 'HASH') { | ||||
| 500 | 8 | 10 | Carp::carp('Usage: allow_ip($ip_address)'); | ||||
| 501 | 8 | 1190 | return $self; | ||||
| 502 | } | ||||||
| 503 | |||||||
| 504 | # Guard 2: require a non-undef 'ip' value (missing key or empty call) | ||||||
| 505 | 277 | 352 | my $ip = @_ ? Params::Get::get_params('ip', @_)->{'ip'} : undef; | ||||
| 506 | 277 | 2722 | unless(defined $ip) { | ||||
| 507 | 5 | 482 | Carp::carp('Usage: allow_ip($ip_address)'); | ||||
| 508 | 5 | 803 | 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 | 272 | 434 | $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 | 272 | 484 | my ($base) = $ip =~ /\A([^\/]+)/; | ||||
| 524 | 272 | 869 | 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 | 16 | 956 | my $display = length($ip) > 60 ? substr($ip, 0, 60) . '...' : $ip; | ||||
| 533 | 16 | 35 | Carp::carp("allow_ip: '$display' is not a valid IP address or CIDR block"); | ||||
| 534 | 16 | 2759 | return $self; | ||||
| 535 | } | ||||||
| 536 | |||||||
| 537 | # Happy path: store the validated address and invalidate the memoised CIDR list | ||||||
| 538 | 256 | 4263 | $self->{allowed_ips}->{$ip} = 1; | ||||
| 539 | 256 | 173 | delete $self->{_cidrlist}; | ||||
| 540 | 256 | 282 | return $self; | ||||
| 541 | } | ||||||
| 542 | |||||||
| 543 | # ── deny_country ─────────────────────────────────────────────────────────────── | ||||||
| 544 | |||||||
| 545 - 622 | =head2 deny_country
Adds one or more countries to the deny list. Countries are identified by
their ISO 3166-1 alpha-2 codes (case-insensitive).
Passing the special value C<'*'> (wildcard) switches to default-deny mode:
all countries are denied unless they also appear in the allow list set by
C<allow_country()>.
=head3 EXAMPLE
use CGI::ACL;
# Deny a single country
my $acl = CGI::ACL->new()->deny_country('BR');
# Deny a list of countries
my $acl = CGI::ACL->new()->deny_country(country => ['BR', 'CN', 'RU']);
# Default-deny all countries (use with allow_country to whitelist)
my $acl = CGI::ACL->new()->deny_country('*')->allow_country('US');
=head3 ARGUMENTS
=over 4
=item country (required)
A scalar ISO code, the wildcard C<'*'>, or an array reference of ISO codes.
=back
=head3 RETURNS
The object itself, to allow method chaining.
=head3 SIDE EFFECTS
Updates C<< $self->{deny_countries} >>.
=head3 NOTES
C<allow_country()> has no effect unless C<deny_country('*')> has been called
first. Calling C<allow_country()> alone (without the wildcard deny) does
not restrict access.
=head3 API SPECIFICATION
=head4 Input
# Compatible with Params::Validate::Strict:
{
country => {
type => 'string' | 'arrayref',
required => 1,
},
}
=head4 Output
# Compatible with Return::Set:
{ type => 'object', isa => 'CGI::ACL' }
=head3 MESSAGES
=over 4
=item C<Usage: deny_country($country)>
B<Severity:> carp (warning).
B<Cause:> Called with no argument, with a non-hash/non-array reference, or
without supplying the C<country> key.
B<Action:> Pass a scalar ISO code or arrayref:
C<deny_country('BR')> or C<deny_country(country =E<gt> ['BR','CN'])>.
=back
=cut | ||||||
| 623 | |||||||
| 624 | sub deny_country { | ||||||
| 625 | 154 | 1 | 4231 | my $self = shift; | |||
| 626 | |||||||
| 627 | # Guard 1: reject references that are neither hashes nor arrays | ||||||
| 628 | 154 | 201 | my $ref = ref($_[0]); | ||||
| 629 | 154 | 475 | if($ref && $ref ne 'HASH' && $ref ne 'ARRAY') { | ||||
| 630 | 7 | 8 | Carp::carp('Usage: deny_country($country)'); | ||||
| 631 | 7 | 1128 | return $self; | ||||
| 632 | } | ||||||
| 633 | |||||||
| 634 | # Guard 2: require a non-undef 'country' value | ||||||
| 635 | 147 | 215 | my $c = @_ ? Params::Get::get_params('country', @_)->{'country'} : undef; | ||||
| 636 | 147 | 1618 | unless(defined $c) { | ||||
| 637 | 3 | 5 | Carp::carp('Usage: deny_country($country)'); | ||||
| 638 | 3 | 510 | return $self; | ||||
| 639 | } | ||||||
| 640 | |||||||
| 641 | # Guard 3: an empty arrayref is a no-op — do not create deny_countries = {} | ||||||
| 642 | 144 12 | 203 26 | return $self if ref($c) eq 'ARRAY' && !@{$c}; | ||||
| 643 | |||||||
| 644 | # Happy path: store the country code(s) in the deny set | ||||||
| 645 | 142 | 435 | _set_countries($self->{deny_countries} //= {}, $c); | ||||
| 646 | 142 | 219 | return $self; | ||||
| 647 | } | ||||||
| 648 | |||||||
| 649 | # ── allow_country ────────────────────────────────────────────────────────────── | ||||||
| 650 | |||||||
| 651 - 724 | =head2 allow_country
Adds one or more countries to the explicit permit list. This is meaningful
only when C<deny_country('*')> has been called first; without the wildcard
deny, this method has no observable effect on access decisions.
=head3 EXAMPLE
use CGI::ACL;
# Allow only the UK and US
my $acl = CGI::ACL->new()
->deny_country('*')
->allow_country(country => ['GB', 'US']);
# Single country as positional argument
my $acl = CGI::ACL->new()->deny_country('*')->allow_country('US');
=head3 ARGUMENTS
=over 4
=item country (required)
A scalar ISO code or an array reference of ISO codes.
=back
=head3 RETURNS
The object itself, to allow method chaining.
=head3 SIDE EFFECTS
Updates C<< $self->{allow_countries} >>.
=head3 NOTES
Call C<deny_country('*')> before this method; otherwise all traffic is
already allowed by the default-allow rule and the permit list is never
consulted.
=head3 API SPECIFICATION
=head4 Input
# Compatible with Params::Validate::Strict:
{
country => {
type => 'string' | 'arrayref',
required => 1,
},
}
=head4 Output
# Compatible with Return::Set:
{ type => 'object', isa => 'CGI::ACL' }
=head3 MESSAGES
=over 4
=item C<Usage: allow_country($country)>
B<Severity:> carp (warning).
B<Cause:> Called with no argument, with a non-hash/non-array reference, or
without supplying the C<country> key.
B<Action:> Pass a scalar ISO code or arrayref:
C<allow_country('US')> or C<allow_country(country =E<gt> ['GB','US'])>.
=back
=cut | ||||||
| 725 | |||||||
| 726 | sub allow_country { | ||||||
| 727 | 89 | 1 | 1299 | my $self = shift; | |||
| 728 | |||||||
| 729 | # Guard 1: reject references that are neither hashes nor arrays | ||||||
| 730 | 89 | 91 | my $ref = ref($_[0]); | ||||
| 731 | 89 | 250 | if($ref && $ref ne 'HASH' && $ref ne 'ARRAY') { | ||||
| 732 | 5 | 7 | Carp::carp('Usage: allow_country($country)'); | ||||
| 733 | 5 | 792 | return $self; | ||||
| 734 | } | ||||||
| 735 | |||||||
| 736 | # Guard 2: require a non-undef 'country' value | ||||||
| 737 | 84 | 129 | my $c = @_ ? Params::Get::get_params('country', @_)->{'country'} : undef; | ||||
| 738 | 84 | 820 | unless(defined $c) { | ||||
| 739 | 3 | 5 | Carp::carp('Usage: allow_country($country)'); | ||||
| 740 | 3 | 496 | return $self; | ||||
| 741 | } | ||||||
| 742 | |||||||
| 743 | # Guard 3: an empty arrayref is a no-op — do not create allow_countries = {} | ||||||
| 744 | 81 9 | 112 18 | return $self if ref($c) eq 'ARRAY' && !@{$c}; | ||||
| 745 | |||||||
| 746 | # Happy path: store the country code(s) in the permit set | ||||||
| 747 | 79 | 210 | _set_countries($self->{allow_countries} //= {}, $c); | ||||
| 748 | 79 | 109 | return $self; | ||||
| 749 | } | ||||||
| 750 | |||||||
| 751 | # ── deny_cloud ───────────────────────────────────────────────────────────────── | ||||||
| 752 | |||||||
| 753 - 817 | =head2 deny_cloud
Enables blocking of requests that originate from major cloud-hosting
providers. Detection is performed via verified reverse DNS: the client
IP is looked up, the resulting hostname is forward-confirmed to prevent
spoofing, and the confirmed hostname is matched against a list of
provider-specific patterns.
Covered providers (as of this release): AWS EC2, Google Cloud Compute,
Microsoft Azure, DigitalOcean, Linode/Akamai, Hetzner, OVH.
B<Important:> C<deny_cloud> takes precedence over C<allow_ip>. An IP
that is explicitly permitted via C<allow_ip()> is still denied if its
reverse DNS resolves to a cloud provider hostname.
=head3 EXAMPLE
use CGI::ACL;
my $acl = CGI::ACL->new()->deny_cloud();
if ($acl->all_denied()) {
print "Cloud-hosted clients are not permitted.\n";
exit;
}
=head3 ARGUMENTS
None.
=head3 RETURNS
The object itself, to allow method chaining.
=head3 SIDE EFFECTS
Sets C<< $self->{deny_cloud} >> to C<1>.
=head3 NOTES
IPv4 and IPv6 clients are both subject to the cloud check. A client with
no reverse DNS record, or whose forward confirmation fails, is treated as
a non-cloud host and allowed through the cloud check (though it may still
be denied by other rules).
DNS lookups are performed synchronously. On non-Windows platforms a
C<$DNS_TIMEOUT>-second alarm is used to prevent indefinite blocking.
=head3 API SPECIFICATION
=head4 Input
# No parameters accepted.
{}
=head4 Output
# Compatible with Return::Set:
{ type => 'object', isa => 'CGI::ACL' }
=head3 MESSAGES
This method emits no messages.
=cut | ||||||
| 818 | |||||||
| 819 | sub deny_cloud { | ||||||
| 820 | 82 | 1 | 813 | my $self = shift; | |||
| 821 | |||||||
| 822 | # Mark cloud-origin blocking as active | ||||||
| 823 | 82 | 157 | $self->{deny_cloud} = 1; | ||||
| 824 | 82 | 130 | return $self; | ||||
| 825 | } | ||||||
| 826 | |||||||
| 827 | # ── deny_all_countries ───────────────────────────────────────────────────────── | ||||||
| 828 | |||||||
| 829 - 889 | =head2 deny_all_countries
Convenience method equivalent to C<deny_country('*')>. Switches the ACL
into default-deny mode for country checks: every country is denied unless
it also appears in the permit list added by C<allow_country()>.
This is the idiomatic way to build an allowlist-only country policy without
spelling out the wildcard literal.
=head3 EXAMPLE
use CGI::ACL;
# Allow only the UK and US; deny every other country
my $acl = CGI::ACL->new()
->deny_all_countries()
->allow_country('GB')
->allow_country('US');
if ($acl->all_denied(lingua => $lingua)) {
print "Your country is not permitted.\n";
exit;
}
=head3 ARGUMENTS
None.
=head3 RETURNS
The object itself, to allow method chaining.
=head3 SIDE EFFECTS
Sets C<< $self->{deny_countries}{'*'} >> to C<1>, activating default-deny
mode. C<allow_country()> calls made before or after this method both take
effect - evaluation order is irrelevant because all data is applied at
C<all_denied()> call time.
=head3 NOTES
C<allow_country()> has no restrictive effect unless this method (or
C<deny_country('*')>) has also been called.
=head3 API SPECIFICATION
=head4 Input
# No parameters accepted.
{}
=head4 Output
# Compatible with Return::Set:
{ type => 'object', isa => 'CGI::ACL' }
=head3 MESSAGES
This method emits no messages.
=cut | ||||||
| 890 | |||||||
| 891 | sub deny_all_countries { | ||||||
| 892 | 14 | 1 | 24 | 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 | 14 | 58 | _set_countries($self->{deny_countries} //= {}, $WILDCARD); | ||||
| 897 | 14 | 30 | return $self; | ||||
| 898 | } | ||||||
| 899 | |||||||
| 900 | # ── all_denied ───────────────────────────────────────────────────────────────── | ||||||
| 901 | |||||||
| 902 - 1066 | =head2 all_denied
Evaluates every active restriction against the current client and returns
C<1> (deny) or C<0> (allow).
The evaluation order is:
=over 4
=item 1.
If B<no> restrictions are configured at all, return C<0> (allow).
=item 2.
Validate C<REMOTE_ADDR> as a syntactically correct IPv4 or IPv6 address.
If it is missing or malformed, return C<1> (deny).
=item 3.
If C<deny_cloud> is set, perform a verified reverse-DNS lookup. If the
hostname matches a cloud provider, return C<1> (deny) immediately,
regardless of C<allowed_ips>. If the IP is not a cloud host and no
other restrictions are active, return C<0> (allow).
=item 4.
If C<allowed_ips> is set, check the client address against the exact-match
hash and then the CIDR list. Return C<0> (allow) on a match.
=item 5.
If country restrictions are set, resolve the client's country via the
C<lingua> argument. Apply default-deny or default-allow country logic.
If no lingua is provided, emit a warning and return C<1> (deny).
=back
Note that localhost (C<127.0.0.1>) is B<not> automatically allowed once
any restriction is configured; call C<allow_ip('127.0.0.1')> explicitly.
=head3 EXAMPLE
use CGI::Lingua;
use CGI::ACL;
my $acl = CGI::ACL->new()->allow_ip('8.35.80.39');
if ($acl->all_denied()) {
print "You are not allowed to view this site.\n";
exit;
}
# Country check
my $acl2 = CGI::ACL->new()
->deny_country('*')
->allow_country('US');
if ($acl2->all_denied(lingua => CGI::Lingua->new(supported => ['en']))) {
print "US-only site.\n";
exit;
}
=head3 ARGUMENTS
=over 4
=item lingua (optional)
A L<CGI::Lingua> object (or any object with a C<country()> method returning
an ISO 3166-1 alpha-2 code or C<undef>). Required when country restrictions
are active; ignored otherwise.
=back
=head3 RETURNS
C<1> if access is denied, C<0> if access is allowed.
=head3 SIDE EFFECTS
May populate or update C<< $self->{_cidrlist} >> (the memoised CIDR lookup
structure) and C<< $self->{_cloud_cache} >> (the per-object DNS result
cache, keyed by IP address string) as performance optimisations.
=head3 API SPECIFICATION
=head4 Input
# Compatible with Params::Validate::Strict:
{
lingua => { type => 'object', optional => 1 },
}
=head4 Output
# Compatible with Return::Set:
{ type => 'string', regex => qr/^[01]$/ }
=head3 MESSAGES
=over 4
=item C<Usage: all_denied($lingua)>
B<Severity:> carp (warning).
B<Cause:> Country restrictions are active (C<deny_country> or
C<allow_country> was called) but no C<lingua> argument was supplied.
B<Action:> Pass a C<CGI::Lingua> object:
C<all_denied(lingua =E<gt> $lingua)>.
=back
=head3 PSEUDOCODE
IF no restrictions configured THEN
RETURN 0 (allow -- fast path)
raw := REMOTE_ADDR // '127.0.0.1'
-- \A and \z anchors (not ^ / $): \z never matches before a trailing \n
IF raw not matched by /\A IPv4-or-IPv6 \z/ THEN
RETURN 1 (deny -- bad or injected address)
-- Detaint: extract addr via character-class capture so the value
-- is clean under Perl -T taint mode for all downstream callers
addr := capture [0-9A-Fa-f:.]+ from raw
IF deny_cloud is set THEN
consult per-object cache keyed by addr (TTL 300 s)
IF cache miss THEN
is_cloud := _is_cloud_host(addr) [DNS; may throw]
IF no error THEN cache result END IF
END IF
IF is_cloud THEN RETURN 1 (deny -- cloud host)
IF no meaningful further restrictions THEN RETURN 0 (allow)
-- "meaningful" = allowed_ips ≠∅ OR deny_countries ≠∅
-- allow_countries alone is not meaningful (never changes the decision)
END IF
IF allowed_ips is set THEN
IF addr matches exact-match entry THEN RETURN 0 (allow)
IF addr falls inside any CIDR range THEN RETURN 0 (allow)
END IF
IF deny_countries is set THEN
-- Premise: allow_countries alone is vacuous (always returns 0 in
-- non-wildcard mode); if only allow_countries was set, earlier guards
-- already returned 0. This condition is therefore necessary and sufficient.
IF no lingua supplied THEN carp; RETURN 1 (deny)
IF lingua is not a blessed object THEN carp; RETURN 1 (deny)
country := lingua->country() [wrapped in eval]
IF country is falsy (undef / "" / "0") THEN RETURN 1 (deny)
country := lc(country)
-- Transitive reduction: deny_countries is provably non-nil here.
IF wildcard (*) in deny_countries THEN
IF country in allow_countries THEN RETURN 0 (allow)
ELSE RETURN 1 (deny)
ELSE
IF country in deny_countries THEN RETURN 1 (deny)
ELSE RETURN 0 (allow)
END IF
END IF
RETURN 1 (deny -- no rule permitted the request)
=cut | ||||||
| 1067 | |||||||
| 1068 | sub all_denied { | ||||||
| 1069 | 504 | 1 | 11859260 | 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 | 504 | 1006 | if( | ||||
| 1077 | (!defined($self->{allowed_ips})) && | ||||||
| 1078 | (!defined($self->{deny_countries})) && | ||||||
| 1079 | (!$self->{deny_cloud}) | ||||||
| 1080 | ) { | ||||||
| 1081 | 21 | 57 | 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 | 483 | 569 | 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 | 483 | 1712 | 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 | 437 | 4002 | my ($addr) = $raw =~ /\A([0-9A-Fa-f:.]+)\z/; | ||||
| 1097 | 437 | 431 | return 1 unless defined $addr; # unreachable; belt-and-suspenders | ||||
| 1098 | |||||||
| 1099 | # ── Cloud check (highest precedence; overrides allow_ip) ──────────────── | ||||||
| 1100 | 437 | 851 | 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 | 112 | 156 | my $cached = $self->{_cloud_cache} && $self->{_cloud_cache}{$addr}; | ||||
| 1105 | 112 | 78 | my ($is_cloud, $dns_error); | ||||
| 1106 | 112 | 149 | if($cached && $cached->{expires} > time()) { | ||||
| 1107 | 7 | 7 | $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 | 105 105 | 68 145 | $is_cloud = eval { _is_cloud_host($addr) }; | ||||
| 1112 | 105 | 415 | $dns_error = $@; | ||||
| 1113 | 105 | 77 | 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 | 105 | 108 | unless($dns_error) { | ||||
| 1117 | 97 | 146 | $self->{_cloud_cache}{$addr} = { | ||||
| 1118 | result => $is_cloud, | ||||||
| 1119 | expires => time() + $CLOUD_CACHE_TTL, | ||||||
| 1120 | }; | ||||||
| 1121 | } | ||||||
| 1122 | } | ||||||
| 1123 | 112 | 957 | 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 — | ||||||
| 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 | 84 | 286 | || $self->{deny_countries}; | ||||
| 1135 | } | ||||||
| 1136 | |||||||
| 1137 | # ── IP / CIDR allow-list check ────────────────────────────────────────── | ||||||
| 1138 | 355 | 763 | if($self->{allowed_ips}) { | ||||
| 1139 | # Check for an exact-match entry first (fast path) | ||||||
| 1140 | 174 | 431 | return 0 if $self->{allowed_ips}->{$addr}; | ||||
| 1141 | |||||||
| 1142 | # Build and memoise the CIDR lookup structure on first use. | ||||||
| 1143 | # Wrap in eval: Net::CIDR dies on non-IP strings (injection attempts). | ||||||
| 1144 | 108 | 119 | if(!$self->{_cidrlist}) { | ||||
| 1145 | 78 | 52 | my @cidrlist; | ||||
| 1146 | 78 78 | 48 99 | for my $block (keys %{$self->{allowed_ips}}) { | ||||
| 1147 | 181 181 | 551177 238 | eval { @cidrlist = Net::CIDR::cidradd($block, @cidrlist) }; | ||||
| 1148 | } | ||||||
| 1149 | 78 | 17889 | $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 | 108 108 108 | 79 67 544 | my $in_cidr = eval { Net::CIDR::cidrlookup($addr, @{$self->{_cidrlist}}) }; | ||||
| 1155 | 108 | 14537 | 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 sufficient | ||||||
| 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 | 259 | 263 | 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 | 197 | 297 | my $lingua = @_ ? Params::Get::get_params('lingua', @_)->{'lingua'} : undef; | ||||
| 1170 | |||||||
| 1171 | 197 | 2271 | unless($lingua) { | ||||
| 1172 | # Country restrictions active but no lingua was provided | ||||||
| 1173 | 8 | 12 | Carp::carp('Usage: all_denied($lingua)'); | ||||
| 1174 | 8 | 1404 | return 1; | ||||
| 1175 | } | ||||||
| 1176 | |||||||
| 1177 | # Reject non-objects to avoid "can't call method on non-ref" crashes | ||||||
| 1178 | 189 | 311 | unless(blessed($lingua)) { | ||||
| 1179 | 7 | 34 | Carp::carp('all_denied: lingua must be a blessed object'); | ||||
| 1180 | 7 | 1142 | return 1; | ||||
| 1181 | } | ||||||
| 1182 | |||||||
| 1183 | # Resolve and normalise the client's country code. | ||||||
| 1184 | # Wrap in eval: the object may not implement country(). | ||||||
| 1185 | 182 182 | 131 247 | my $country_val = eval { $lingua->country() }; | ||||
| 1186 | 182 7 7 | 30673149 4 26 | if($@) { undef $@; return 1 } # method missing or threw — deny | ||||
| 1187 | 175 | 211 | my $country = $country_val or return 1; # undef/falsy => unknown country => deny | ||||
| 1188 | 165 | 261 | $country = lc $country; | ||||
| 1189 | |||||||
| 1190 | # Default-deny mode: deny_countries contains the wildcard sentinel. | ||||||
| 1191 | # Premise: deny_countries is defined (proved above); no redundant && guard needed. | ||||||
| 1192 | 165 | 310 | if($self->{deny_countries}->{$WILDCARD}) { | ||||
| 1193 | 104 | 722 | 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 | 61 | 363 | return $self->{deny_countries}->{$country} ? 1 : 0; | ||||
| 1201 | } | ||||||
| 1202 | |||||||
| 1203 | # Fall-through: no rule allowed the request; deny | ||||||
| 1204 | 62 | 228 | 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. | ||||||
| 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). | ||||||
| 1218 | # | ||||||
| 1219 | # Side effects: Modifies the caller-supplied hashref. | ||||||
| 1220 | # | ||||||
| 1221 | # Notes: Keys are forced to lower case for case-insensitive comparison. | ||||||
| 1222 | sub _set_countries :Protected { | ||||||
| 1223 | 0 | my ($hashref, $value) = @_; | |||||
| 1224 | |||||||
| 1225 | # Handle both a single country code and a list reference. | ||||||
| 1226 | # Skip undef elements to avoid "uninitialised value" warnings. | ||||||
| 1227 | 0 | if(ref($value) eq 'ARRAY') { | |||||
| 1228 | 0 0 0 | $hashref->{lc $_} = 1 for grep { defined } @{$value}; | |||||
| 1229 | } else { | ||||||
| 1230 | 0 | $hashref->{lc $value} = 1; | |||||
| 1231 | } | ||||||
| 1232 | 0 | return; | |||||
| 1233 | 17 17 17 | 16278 14 235 | } | ||||
| 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 | ||||||
| 1239 | # matching the confirmed hostname against @CLOUD_PATTERNS. | ||||||
| 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. | ||||||
| 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. | ||||||
| 1251 | sub _is_cloud_host :Protected { | ||||||
| 1252 | 0 | 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 | 0 | return 0 if $ip =~ $PRIVATE_IP_RE; | |||||
| 1258 | |||||||
| 1259 | # Attempt a verified reverse DNS lookup; returns undef on failure | ||||||
| 1260 | 0 | 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 | 0 | return 0 if length($hostname) > 253; | |||||
| 1266 | |||||||
| 1267 | # Compare the confirmed hostname against every known cloud pattern | ||||||
| 1268 | 0 | for my $pattern (@CLOUD_PATTERNS) { | |||||
| 1269 | 0 | return 1 if $hostname =~ $pattern; | |||||
| 1270 | } | ||||||
| 1271 | 0 | return 0; | |||||
| 1272 | 17 17 17 | 2330 14 94 | } | ||||
| 1273 | |||||||
| 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 { | ||||||
| 1297 | 0 | my ($ip) = @_; | |||||
| 1298 | |||||||
| 1299 | # Determine address family and produce the packed binary address | ||||||
| 1300 | 0 | my ($family, $packed); | |||||
| 1301 | 0 | if($ip =~ /:/) { | |||||
| 1302 | # IPv6: use inet_pton which handles all valid IPv6 formats | ||||||
| 1303 | 0 | $family = Socket::AF_INET6; | |||||
| 1304 | 0 | $packed = Socket::inet_pton(Socket::AF_INET6, $ip) or return; | |||||
| 1305 | } else { | ||||||
| 1306 | # IPv4: inet_aton handles dotted-quad addresses | ||||||
| 1307 | 0 | $family = AF_INET; | |||||
| 1308 | 0 | $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 | 0 | my $canonical = ($family == AF_INET) | |||||
| 1314 | ? inet_ntoa($packed) | ||||||
| 1315 | : Socket::inet_ntop(Socket::AF_INET6, $packed); | ||||||
| 1316 | |||||||
| 1317 | 0 | my ($hostname, @forward_ips); | |||||
| 1318 | |||||||
| 1319 | 0 | if($^O ne 'MSWin32') { | |||||
| 1320 | # Non-Windows: guard against indefinitely-blocking DNS calls | ||||||
| 1321 | 0 0 | local $SIG{ALRM} = sub { die "DNS timeout: $ip" }; | |||||
| 1322 | 0 | my $old_alarm = alarm($DNS_TIMEOUT) // 0; | |||||
| 1323 | 0 | eval { | |||||
| 1324 | # Step 1: reverse lookup (IP -> hostname) | ||||||
| 1325 | 0 | $hostname = gethostbyaddr($packed, $family); | |||||
| 1326 | 0 | if($hostname) { | |||||
| 1327 | # Step 2: forward lookup (hostname -> IP list) | ||||||
| 1328 | 0 | @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 | 0 | alarm($old_alarm); | |||||
| 1333 | }; | ||||||
| 1334 | # Belt-and-suspenders: restore the previous alarm whether eval threw or not | ||||||
| 1335 | 0 | alarm($old_alarm); | |||||
| 1336 | 0 | return if $@ || !$hostname; | |||||
| 1337 | } else { | ||||||
| 1338 | # Windows: no alarm support; perform lookups synchronously | ||||||
| 1339 | 0 | $hostname = gethostbyaddr($packed, $family) or return; | |||||
| 1340 | |||||||
| 1341 | # Forward lookup to confirm the hostname maps back to the original IP | ||||||
| 1342 | 0 | @forward_ips = _rdns_forward($hostname, $family); | |||||
| 1343 | } | ||||||
| 1344 | |||||||
| 1345 | # Step 3: the hostname is only trusted if a forward record confirms the IP | ||||||
| 1346 | 0 0 | return (grep { $_ eq $canonical } @forward_ips) ? $hostname : undef; | |||||
| 1347 | 17 17 17 | 3249 14 94 | } | ||||
| 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 | 12 | 16219 | my ($hostname, $family) = @_; | ||||
| 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 | 12 | 50 | if($family == AF_INET) { | ||||
| 1376 | 9 0 | 67860 0 | my @addrs = map { inet_ntoa($_) } (gethostbyname($hostname))[4 .. -1]; | ||||
| 1377 | 9 | 39 | return @addrs if @addrs; | ||||
| 1378 | 9 | 73061 | my $packed = inet_aton($hostname); | ||||
| 1379 | 9 | 60 | return $packed ? (inet_ntoa($packed)) : (); | ||||
| 1380 | } | ||||||
| 1381 | |||||||
| 1382 | # IPv6 path: use getaddrinfo to resolve AAAA records | ||||||
| 1383 | 3 | 8 | my ($err, @addrs) = Socket::getaddrinfo( | ||||
| 1384 | $hostname, undef, | ||||||
| 1385 | { family => $family, socktype => SOCK_STREAM }, | ||||||
| 1386 | ); | ||||||
| 1387 | 3 | 22 | return () if $err; | ||||
| 1388 | |||||||
| 1389 | # Convert each opaque sockaddr to a numeric IP string | ||||||
| 1390 | 2 | 1 | my @ips; | ||||
| 1391 | 2 | 3 | for my $addr_info (@addrs) { | ||||
| 1392 | my ($e, $host) = Socket::getnameinfo( | ||||||
| 1393 | 2 | 3 | $addr_info->{addr}, Socket::NI_NUMERICHOST, | ||||
| 1394 | ); | ||||||
| 1395 | 2 | 12 | push @ips, $host unless $e; | ||||
| 1396 | } | ||||||
| 1397 | 2 | 3 | return @ips; | ||||
| 1398 | } | ||||||
| 1399 | |||||||
| 1400 - 1644 | =head1 AUTHOR
Nigel Horne, C<< <njh at nigelhorne.com> >>
=head1 BUGS
Please report any bugs or feature requests to
C<bug-cgi-acl at rt.cpan.org>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=CGI-ACL>.
A VPN or proxy will most likely bypass IP-based access control.
=head1 SEE ALSO
=over 4
=item * L<CGI::Lingua>
=item * L<Configure an Object at Runtime|Object::Configure>
=item * L<Net::CIDR>
=item * L<Test Dashboard|https://nigelhorne.github.io/CGI-ACL/coverage/>
=back
=head1 SUPPORT
perldoc CGI::ACL
=over 4
=item * MetaCPAN: L<https://metacpan.org/release/CGI-ACL>
=item * RT: L<https://rt.cpan.org/NoAuth/Bugs.html?Dist=CGI-ACL>
=item * CPANTS: L<http://cpants.cpanauthors.org/dist/CGI-ACL>
=item * CPAN Testers: L<http://matrix.cpantesters.org/?dist=CGI-ACL>
=back
=head1 LIMITATIONS
=over 4
=item *
A VPN or anonymous proxy will likely bypass IP-based access control and may
defeat country detection as well.
=item *
Country detection relies on L<CGI::Lingua> and its underlying GeoIP database,
which must be updated regularly. GeoIP databases are never fully accurate;
satellite and mobile networks in particular can be misattributed.
=item *
Cloud detection depends on provider-maintained reverse-DNS records. A cloud
host whose PTR record does not follow its provider's naming convention will
not be detected. Conversely, a legitimate host whose PTR record accidentally
matches a cloud pattern could be falsely denied.
=item *
DNS lookups are synchronous. On non-Windows platforms a C<$DNS_TIMEOUT>-second
alarm prevents indefinite blocking, but under high resolver load that latency
can still affect every request for an uncached IP. For persistent processes
(FastCGI, mod_perl) the built-in per-object cache (C<$CLOUD_CACHE_TTL> seconds)
mitigates this significantly.
=item *
The per-object DNS result cache is neither shared between processes nor
persistent across objects. Under a pre-forking server each worker child
maintains an independent cache.
=item *
Private methods (C<_is_cloud_host>, C<_verified_rdns>, C<_rdns_forward>,
C<_set_countries>) are not enforced as private with
C<Sub::Private> because this module's white-box test suite (C<t/function.t>,
C<t/extended_tests.t>, etc.) calls them directly by fully-qualified name to
exercise specific code paths. The C<namespace::clean> pragma removes them
from the object's method dispatch table, and the C<_> naming convention
signals their internal nature.
=item *
Windows platforms do not support C<alarm()>-based timeouts. DNS lookups on
Windows block synchronously for as long as the OS resolver takes.
=item *
An optional rate-limiting feature (to block brute-force attacks) has not yet
been implemented. It would require persistent shared state (e.g. Redis or an
in-memory cache) beyond this module's current dependency set.
=back
=head1 FORMAL SPECIFICATION
=head2 new
──────────────── ACLState ────────────────────────────────────────
allowed_ips : IP_Str ⇸ Bool
deny_countries : Country ⇸ Bool
allow_countries: Country ⇸ Bool
deny_cloud : Bool
_cidrlist : [CIDR_Str]? -- memoised; cleared on allow_ip
_cloud_cache : IP_Str ⇸ {result: Bool, expires: Nat}?
──────────────────────────────────────────────────────────────────
─────────────── New ──────────────────────────────────────────────
class : ClassName ∪ ACLState
params : ACLState?
─────────────────────────────────────────────────────────────────
-- strip_private: removes keys whose names begin with '_'
blessed(class) ⟹
result! = bless( deepcopy(class) ∪ strip_private(params),
ref(class) ) -- clone
¬blessed(class) ⟹
result! = bless( strip_private(configure(class, params)),
class )
──────────────────────────────────────────────────────────────────
=head2 allow_ip
─────────────── AllowIP ──────────────────────────────────────────
ΔACL
ip? : IP_Str -- must satisfy valid_ip(ip?)
─────────────────────────────────────────────────────────────────
allowed_ips' = allowed_ipsâ‚€ // {} -- initialised on every call
valid_ip(ip?) ⟹
allowed_ips' = allowed_ips' ∪ { ip? ↦ 1 }
_cidrlist' = ∅ -- cache invalidated
¬valid_ip(ip?) ⟹
allowed_ips' = allowed_ips' -- only initialisation, no entry
_cidrlist' = _cidrlist
deny_countries' = deny_countries
allow_countries' = allow_countries
deny_cloud' = deny_cloud
──────────────────────────────────────────────────────────────────
=head2 deny_country
─────────────── DenyCountry ─────────────────────────────────────
ΔACL
country? : ISO_Code ∪ {'*'} ∪ seq ISO_Code
─────────────────────────────────────────────────────────────────
country? ∈ seq ISO_Code ⟹
deny_countries' = deny_countries ∪
{ lc(c) ↦ 1 | c ∈ country? }
country? ∉ seq ISO_Code ⟹
deny_countries' = deny_countries ∪ { lc(country?) ↦ 1 }
allow_countries' = allow_countries
allowed_ips' = allowed_ips
deny_cloud' = deny_cloud
──────────────────────────────────────────────────────────────────
=head2 allow_country
─────────────── AllowCountry ────────────────────────────────────
ΔACL
country? : ISO_Code ∪ seq ISO_Code
─────────────────────────────────────────────────────────────────
country? ∈ seq ISO_Code ⟹
allow_countries' = allow_countries ∪
{ lc(c) ↦ 1 | c ∈ country? }
country? ∉ seq ISO_Code ⟹
allow_countries' = allow_countries ∪ { lc(country?) ↦ 1 }
deny_countries' = deny_countries
allowed_ips' = allowed_ips
deny_cloud' = deny_cloud
──────────────────────────────────────────────────────────────────
=head2 deny_cloud
─────────────── DenyCloud ───────────────────────────────────────
ΔACL
─────────────────────────────────────────────────────────────────
deny_cloud' = 1
allowed_ips' = allowed_ips
deny_countries' = deny_countries
allow_countries'= allow_countries
_cidrlist' = _cidrlist
──────────────────────────────────────────────────────────────────
=head2 deny_all_countries
─────────────── DenyAllCountries ────────────────────────────────
ΔACL
─────────────────────────────────────────────────────────────────
deny_countries' = deny_countries ∪ { '*' ↦ 1 }
allow_countries' = allow_countries
allowed_ips' = allowed_ips
deny_cloud' = deny_cloud
──────────────────────────────────────────────────────────────────
=head2 all_denied
──────────────────────── AllDenied ──────────────────────────────
ΞACL -- state unchanged (modulo cache)
addr : IPv4 ∪ IPv6 -- REMOTE_ADDR or DEFAULT_ADDR
lingua? : Lingua -- country resolver (optional)
result! : {0, 1} -- 0 = allow, 1 = deny
─────────────────────────────────────────────────────────────────
no_restrictions(self) ⟹ result! = 0
¬valid_ip(addr) ⟹ result! = 1
deny_cloud = 1 ∧ is_cloud(addr) ⟹ result! = 1
deny_cloud = 1 ∧ ¬is_cloud(addr)
∧ allowed_ips = ∅ ∧ deny_countries = ∅ ⟹ result! = 0
-- allow_countries is intentionally absent: it never changes the result
-- without deny_countries('*'), so it is not a meaningful restriction.
addr ∈ dom(allowed_ips) ⟹ result! = 0
cidr_match(addr, allowed_ips) ⟹ result! = 0
deny_countries ≠∅ ∧ lingua? = ∅ ⟹ result! = 1
-- allow_countries alone is vacuous; only deny_countries triggers the check.
lingua?.country() = undef ⟹ result! = 1
deny_countries('*') = 1
∧ allow_countries(lc(lingua?.country())) = 1 ⟹ result! = 0
deny_countries('*') = 1
∧ allow_countries(lc(lingua?.country())) ≠1 ⟹ result! = 1
deny_countries('*') ≠1
∧ deny_countries(lc(lingua?.country())) = 1 ⟹ result! = 1
deny_countries('*') ≠1
∧ deny_countries(lc(lingua?.country())) ≠1 ⟹ result! = 0
──────────────────────────────────────────────────────────────────
=head1 LICENSE AND COPYRIGHT
Copyright 2017-2026 Nigel Horne.
Usage is subject to the GPL2 licence terms.
If you use it,
please let me know.
=cut | ||||||
| 1645 | |||||||
| 1646 | 1; | ||||||