File Coverage

File:blib/lib/CGI/ACL.pm
Coverage:97.3%

linestmtbrancondsubpodtimecode
1package 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
14
14
14
1224894
23
use 5.006_001;
12
14
14
14
14
1720
54602
45
use autodie qw(:all);
13
14
14
14
14
79000
13
336
use warnings;
14
14
14
14
14
21
27
125
use strict;
15
16# namespace::clean removes imported helper names from the public method list
17
14
14
14
14
2877
96704
44
use namespace::clean;
18
19
14
14
14
14
4369
10
351
use Carp;
20
14
14
14
14
3127
35907
370
use Net::CIDR;
21
14
14
14
14
3767
655948
310
use Object::Configure;
22
14
14
14
14
53
13
217
use Params::Get;
23
14
14
14
14
27
10
253
use Readonly;
24
14
14
14
14
3284
16326
30
use Regexp::Common qw(net);
25
14
14
14
14
18545
12
358
use Scalar::Util qw(blessed);
26
14
14
14
14
30
9
18292
use Socket;
27
28# ── Compile-time constants ─────────────────────────────────────────────────────
29
30# Maximum seconds to wait for a DNS reverse lookup on non-Windows platforms.
31Readonly my $DNS_TIMEOUT  => 10;
32
33# Sentinel value stored in deny_countries to mean "deny every country".
34Readonly my $WILDCARD     => q{*};
35
36# Fallback client address when REMOTE_ADDR is absent (e.g. CLI or unit tests).
37Readonly 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.
41Readonly 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 - 64
=head1 NAME

CGI::ACL - Decide whether to allow a client to run a CGI script

=head1 VERSION

Version 0.08

=cut
65
66our $VERSION = '0.08';
67
68 - 145
=head1 SYNOPSIS

Provides access control for CGI scripts based on IP address, CIDR block,
geographic country, and cloud-provider origin.

    use CGI::Lingua;
    use CGI::ACL;

    # Allow only UK visitors from a specific subnet
    my $acl = CGI::ACL->new()
        ->deny_country('*')
        ->allow_country('GB')
        ->allow_ip('192.0.2.0/24');

    if ($acl->all_denied(lingua => CGI::Lingua->new(supported => ['en']))) {
        print "Access denied.\n";
        exit;
    }

The module optionally integrates with L<CGI::Lingua> for country detection.
Runtime configuration is supported via L<Object::Configure>.

=head1 SUBROUTINES/METHODS

=head2 new

Creates and returns a new CGI::ACL object.

When called on an existing object it returns a shallow clone of that object,
optionally overriding fields with the supplied arguments.

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 USAGE

    # 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
146
147sub new {
148
189
189
1
17789449
        my $class = shift;
149
150        # Parse arguments uniformly (hashref, named pairs, or no args)
151
189
413
        my $params = Params::Get::get_params(undef, @_);
152
153        # Handle the rare case of being called as a plain function: CGI::ACL::new()
154
189
100
100
2151
        if(!defined($class)) {
155
2
4
                Carp::carp(__PACKAGE__ . ': use ->new() not ::new() to instantiate');
156
2
491
                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
9
100
23
                $params ||= {};
161
9
9
7
14
                my %copy = %{$class};
162
9
14
                for my $key (qw(allowed_ips deny_countries allow_countries)) {
163
27
11
100
36
18
                        $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
9
10
                delete $copy{_cidrlist};
167
9
9
9
22
                return bless { %copy, %{$params} }, ref($class);
168        }
169
170        # Merge any config-file or environment-variable overrides
171
178
369
        $params = Object::Configure::configure($class, $params);
172
173
177
525974
        return bless $params, $class;
174}
175
176# ── allow_ip ───────────────────────────────────────────────────────────────────
177
178 - 251
=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 USAGE

    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 value is stored verbatim; invalid addresses
will be silently ignored during lookup.

=back

=head3 RETURNS

The object itself, to allow method chaining.

=head3 SIDE EFFECTS

Invalidates the internal CIDR lookup cache so the next call to
C<all_denied()> will rebuild it with the new entry included.

=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')>.

=back

=cut
252
253sub allow_ip {
254
98
98
1
3745
        my $self = shift;
255
256        # Reject non-hash, non-scalar references (e.g. a scalar ref passed by mistake)
257
98
100
100
202
        if(ref($_[0]) && ref($_[0]) ne 'HASH') {
258
6
9
                Carp::carp('Usage: allow_ip($ip_address)');
259
6
1139
                return $self;
260        }
261
262        # Normalise positional, named, and hashref calling conventions
263
92
320
        my %params;
264
92
100
100
165
        if(ref($_[0]) eq 'HASH') {
265
3
3
5
3
                %params = %{$_[0]};
266        } elsif(@_ % 2 == 0) {
267
8
15
                %params = @_;
268        } else {
269
81
109
                $params{ip} = shift;
270        }
271
272        # Store the address and invalidate the memoised CIDR list
273
92
100
113
        if(defined(my $ip = $params{ip})) {
274
88
198
                $self->{allowed_ips}->{$ip} = 1;
275
88
78
                delete $self->{_cidrlist};
276        } else {
277
4
7
                Carp::carp('Usage: allow_ip($ip_address)');
278        }
279
92
898
        return $self;
280}
281
282# ── deny_country ───────────────────────────────────────────────────────────────
283
284 - 361
=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 USAGE

    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
362
363sub deny_country {
364
85
85
1
5944
        my $self = shift;
365
366        # Reject references that are neither hashes nor arrays
367
85
100
75
203
        if(ref($_[0]) && ref($_[0]) ne 'HASH' && ref($_[0]) ne 'ARRAY') {
368
5
7
                Carp::carp('Usage: deny_country($country)');
369
5
810
                return $self;
370        }
371
372        # Normalise positional, named, and hashref calling conventions
373
80
268
        my %params;
374
80
100
100
177
        if(ref($_[0]) eq 'HASH') {
375
4
4
4
13
                %params = %{$_[0]};
376        } elsif(@_ % 2 == 0) {
377
11
16
                %params = @_;
378        } else {
379
65
84
                $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
80
100
117
        if(defined(my $c = $params{country})) {
385
78
9
100
100
121
21
                return $self if ref($c) eq 'ARRAY' && !@{$c};
386
77
100
267
                _set_countries($self->{deny_countries} ||= {}, $c);
387        } else {
388
2
2
                Carp::carp('Usage: deny_country($country)');
389        }
390
79
545
        return $self;
391}
392
393# ── allow_country ──────────────────────────────────────────────────────────────
394
395 - 468
=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 USAGE

    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
469
470sub allow_country {
471
57
57
1
1465
        my $self = shift;
472
473        # Reject references that are neither hashes nor arrays
474
57
100
75
94
        if(ref($_[0]) && ref($_[0]) ne 'HASH' && ref($_[0]) ne 'ARRAY') {
475
3
5
                Carp::carp('Usage: allow_country($country)');
476
3
479
                return $self;
477        }
478
479        # Normalise positional, named, and hashref calling conventions
480
54
150
        my %params;
481
54
100
100
129
        if(ref($_[0]) eq 'HASH') {
482
3
3
4
4
                %params = %{$_[0]};
483        } elsif(@_ % 2 == 0) {
484
8
21
                %params = @_;
485        } else {
486
43
61
                $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
54
100
72
        if(defined(my $c = $params{country})) {
492
52
6
100
100
83
13
                return $self if ref($c) eq 'ARRAY' && !@{$c};
493
51
100
115
                _set_countries($self->{allow_countries} ||= {}, $c);
494        } else {
495
2
3
                Carp::carp('Usage: allow_country($country)');
496        }
497
53
417
        return $self;
498}
499
500# ── deny_cloud ─────────────────────────────────────────────────────────────────
501
502 - 566
=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 USAGE

    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
567
568sub deny_cloud {
569
38
38
1
1048
        my $self = shift;
570
571        # Mark cloud-origin blocking as active
572
38
79
        $self->{deny_cloud} = 1;
573
38
69
        return $self;
574}
575
576# ── all_denied ─────────────────────────────────────────────────────────────────
577
578 - 690
=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 USAGE

    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) as a performance optimisation.

=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

=cut
691
692sub all_denied {
693
259
259
1
1687895
        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
259
100
100
778
        if(
699                (!defined($self->{allowed_ips}))    &&
700                (!defined($self->{deny_countries})) &&
701                (!$self->{deny_cloud})              &&
702                (!defined($self->{allow_countries}))
703        ) {
704
10
40
                return 0;
705        }
706
707        # Determine the client address, falling back to localhost when absent.
708        # Use // (defined-or) not || to avoid treating "0" or "" as absent.
709
249
67
430
        my $addr = $ENV{REMOTE_ADDR} // $DEFAULT_ADDR;
710
711        # Reject addresses that are not syntactically valid IPv4 or IPv6
712
249
100
100
1290
        return 1 unless $addr =~ /^$RE{net}{IPv4}$/o
713                     || $addr =~ /^$RE{net}{IPv6}$/o;
714
715        # ── Cloud check (highest precedence; overrides allow_ip) ────────────────
716
232
100
4262
        if($self->{deny_cloud}) {
717                # Deny if the IP resolves to a cloud provider hostname.
718                # Wrap in eval: DNS failures must not kill the CGI process; fail safe.
719
51
51
34
61
                my $is_cloud = eval { _is_cloud_host($addr) };
720
51
215
                my $error = $@;
721
51
50
82
                if($@ =~ /^DNS timeout: /) {
722
0
0
                        undef $@;
723                }
724
51
100
100
160
                return 1 if !$error && $is_cloud;
725
726                # Non-cloud and no other restrictions: allow
727                return 0 unless $self->{allowed_ips}
728                             || $self->{deny_countries}
729
33
100
100
140
                             || $self->{allow_countries};
730        }
731
732        # ── IP / CIDR allow-list check ──────────────────────────────────────────
733
199
100
267
        if($self->{allowed_ips}) {
734                # Check for an exact-match entry first (fast path)
735
95
100
303
                return 0 if $self->{allowed_ips}->{$addr};
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
55
100
83
                if(!$self->{_cidrlist}) {
740
39
27
                        my @cidrlist;
741
39
39
37
62
                        for my $block (keys %{$self->{allowed_ips}}) {
742
45
45
1089
131
                                eval { @cidrlist = Net::CIDR::cidradd($block, @cidrlist) };
743                        }
744
39
10596
                        $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
55
55
55
41
45
97
                my $in_cidr = eval { Net::CIDR::cidrlookup($addr, @{$self->{_cidrlist}}) };
750
55
100
7968
                return 0 if $in_cidr;
751        }
752
753        # ── Country check ───────────────────────────────────────────────────────
754
139
100
100
308
        if($self->{deny_countries} || $self->{allow_countries}) {
755                # Parse the lingua argument (positional, named, or hashref)
756
115
93
                my %params;
757
115
100
100
280
                if(ref($_[0]) eq 'HASH') {
758
1
1
1
1
                        %params = %{$_[0]};
759                } elsif(@_ % 2 == 0) {
760
111
154
                        %params = @_;
761                } else {
762
3
4
                        $params{lingua} = shift;
763                }
764
765
115
100
193
                if(my $lingua = $params{lingua}) {
766                        # Reject non-objects to avoid "can't call method on non-ref" crashes
767
110
100
207
                        unless(blessed($lingua)) {
768
1
17
                                Carp::carp('all_denied: lingua must be a blessed object');
769
1
144
                                return 1;
770                        }
771                        # Resolve and normalise the client's country code.
772                        # Wrap in eval: the object may not implement country().
773
109
109
126
224
                        my $country_val = eval { $lingua->country() };
774
109
100
143155707
                        return 1 if $@;    # method missing or threw — treat as unknown
775
108
100
227
                        if(my $country = $country_val) {
776
102
130
                                $country = lc $country;
777
778                                # Default-deny mode: deny_countries contains the wildcard
779
102
100
100
798
                                if($self->{deny_countries} && $self->{deny_countries}->{$WILDCARD}) {
780
67
100
100
1428
                                        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
35
100
100
498
                                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
5
8
                        Carp::carp('Usage: all_denied($lingua)');
794                }
795        }
796
797        # Fall-through: no rule allowed the request; deny
798
35
1100
        return 1;
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.
816sub _set_countries {
817
133
133
5544
        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
133
100
134
        if(ref($value) eq 'ARRAY') {
822
15
63
15
24
89
27
                $hashref->{lc $_} = 1 for grep { defined } @{$value};
823        } else {
824
118
154
                $hashref->{lc $value} = 1;
825        }
826
133
108
        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.
845sub _is_cloud_host {
846
71
71
26969
        my $ip = $_[0];
847
848        # Attempt a verified reverse DNS lookup; returns undef on failure
849
71
100
128
        my $hostname = _verified_rdns($ip) or return 0;
850
851        # Compare the confirmed hostname against every known cloud pattern
852
43
336
        for my $pattern (@CLOUD_PATTERNS) {
853
189
100
799
                return 1 if $hostname =~ $pattern;
854        }
855
11
56
        return 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.
880sub _verified_rdns {
881
19
19
78265
        my $ip = $_[0];
882
883        # Determine address family and produce the packed binary address
884
19
70
        my ($family, $packed);
885
19
100
39
        if($ip =~ /:/o) {
886                # IPv6: use inet_pton which handles all valid IPv6 formats
887
3
2
                $family = Socket::AF_INET6;
888
3
100
9
                $packed = Socket::inet_pton(Socket::AF_INET6, $ip) or return;
889        } else {
890                # IPv4: inet_aton handles dotted-quad addresses
891
16
20
                $family = AF_INET;
892
16
100
9232
                $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
14
100
56
        my $canonical = ($family == AF_INET)
898                ? inet_ntoa($packed)
899                : Socket::inet_ntop(Socket::AF_INET6, $packed);
900
901
14
16
        my ($hostname, @forward_ips);
902
903
14
50
30
        if($^O ne 'MSWin32') {
904                # Non-Windows: guard against indefinitely-blocking DNS calls
905
14
2
2
143
43
                local $SIG{ALRM} = sub { die "DNS timeout: $ip" };
906
14
50
67
                my $old_alarm = alarm($DNS_TIMEOUT) || 0;
907
14
116
                eval {
908                        # Step 1: reverse lookup (IP -> hostname)
909
14
730191
                        $hostname = gethostbyaddr($packed, $family);
910
14
100
80
                        if($hostname) {
911                                # Step 2: forward lookup (hostname -> IP list)
912
7
16
                                @forward_ips = _rdns_forward($hostname, $family);
913                        }
914                        # Cancel the alarm inside the eval to avoid a post-eval race
915
12
53
                        alarm($old_alarm);
916                };
917                # Ensure the alarm is always cancelled
918
14
24
                alarm($old_alarm);
919
14
100
100
219
                return if $@ || !$hostname;
920        } else {
921                # Windows: no alarm support; perform lookups synchronously
922
0
0
0
                $hostname = gethostbyaddr($packed, $family) or return;
923
924                # Forward lookup to confirm the hostname maps back to the original IP
925
0
0
                @forward_ips = _rdns_forward($hostname, $family);
926        }
927
928        # Step 3: the hostname is only trusted if a forward record confirms the IP
929
5
4
100
7
13
        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).
947sub _rdns_forward {
948
12
12
17424
        my ($hostname, $family) = @_;
949
950        # IPv4 path: resolve A record and convert each packed address to a string
951
12
100
42
        if($family == AF_INET) {
952
5
18
                return map  { inet_ntoa($_)  }
953
9
44
                       grep { defined        }
954
9
9
13
108938
                       map  { inet_aton($_)  }
955                       ($hostname);
956        }
957
958        # IPv6 path: use getaddrinfo to resolve AAAA records
959
3
6
        my ($err, @addrs) = Socket::getaddrinfo(
960                $hostname, undef,
961                { family => $family, socktype => SOCK_STREAM },
962        );
963
3
100
9
        return () if $err;
964
965        # Convert each opaque sockaddr to a numeric IP string
966
2
3
        my @ips;
967
2
3
        for my $addr_info (@addrs) {
968                my ($e, $host) = Socket::getnameinfo(
969
2
3
                        $addr_info->{addr}, Socket::NI_NUMERICHOST,
970                );
971
2
100
12
                push @ips, $host unless $e;
972        }
973
2
2
        return @ips;
974}
975
976=encoding utf-8
977
978 - 1142
=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

=head2 FORMAL SPECIFICATION

=head3 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
    â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€

    â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€ New ──────────────────────────────────────────────
      class  : ClassName ∪ ACLState
      params : ACLState?
      â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€
      blessed(class) ⟹
        result! = bless( class ∪ params, ref(class) )   -- clone
      Â¬blessed(class) ⟹
        result! = bless( configure(class, params), class )
    â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€

=head3 allow_ip

    â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€ AllowIP ──────────────────────────────────────────
      Î”ACL
      ip? : IP_Str
      â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€
      allowed_ips' = allowed_ips ∪ { ip? ↦ 1 }
      _cidrlist'   = ∅          -- cache invalidated
      deny_countries' = deny_countries
      allow_countries' = allow_countries
      deny_cloud'     = deny_cloud
    â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€

=head3 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
    â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€

=head3 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
    â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€

=head3 deny_cloud

    â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€ DenyCloud ───────────────────────────────────────
      Î”ACL
      â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€
      deny_cloud'     = 1
      allowed_ips'    = allowed_ips
      deny_countries' = deny_countries
      allow_countries'= allow_countries
      _cidrlist'      = _cidrlist
    â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€â”€

=head3 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 = ∅
        âˆ§ allow_countries = ∅            âŸ¹ result! = 0

      addr ∈ dom(allowed_ips) ⟹ result! = 0
      cidr_match(addr, allowed_ips) ⟹ result! = 0

      (deny_countries ≠ ∅ ∨ allow_countries ≠ ∅)
        âˆ§ lingua? = ∅ ⟹ result! = 1      -- no lingua supplied
      lingua?.country() = undef ⟹ result! = 1   -- unknown country

      deny_countries($WILDCARD) = 1
        âˆ§ allow_countries(lc(lingua?.country())) = 1 ⟹ result! = 0
      deny_countries($WILDCARD) = 1
        âˆ§ allow_countries(lc(lingua?.country())) ≠ 1 ⟹ result! = 1

      deny_countries($WILDCARD) ≠ 1
        âˆ§ deny_countries(lc(lingua?.country())) = 1 ⟹ result! = 1
      deny_countries($WILDCARD) ≠ 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
1143
11441;