File Coverage

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

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
1114160
22
use 5.006_001;
12
14
14
14
14
2365
80440
30
use autodie qw(:all);
13
14
14
14
14
99425
11
222
use warnings;
14
14
14
14
14
26
14
114
use strict;
15
16# namespace::clean removes imported helper names from the public method list
17
14
14
14
14
2549
90977
35
use namespace::clean;
18
19
14
14
14
14
4147
9
304
use Carp;
20
14
14
14
14
2957
35265
335
use Net::CIDR;
21
14
14
14
14
3392
583822
212
use Object::Configure;
22
14
14
14
14
31
9
179
use Params::Get;
23
14
14
14
14
17
11
254
use Readonly;
24
14
14
14
14
2958
15588
23
use Regexp::Common qw(net);
25
14
14
14
14
18053
7
264
use Scalar::Util qw(blessed);
26
14
14
14
14
20
10
16911
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
18424676
        my $class = shift;
149
150        # Parse arguments uniformly (hashref, named pairs, or no args)
151
189
270
        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
1785
        if(!defined($class)) {
155
2
3
                Carp::carp(__PACKAGE__ . ': use ->new() not ::new() to instantiate');
156
2
357
                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
25
                $params ||= {};
161
9
9
5
20
                my %copy = %{$class};
162
9
9
                for my $key (qw(allowed_ips deny_countries allow_countries)) {
163
27
11
100
27
12
                        $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
9
                delete $copy{_cidrlist};
167
9
9
5
23
                return bless { %copy, %{$params} }, ref($class);
168        }
169
170        # Merge any config-file or environment-variable overrides
171
178
220
        $params = Object::Configure::configure($class, $params);
172
173
177
492096
        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
2889
        my $self = shift;
255
256        # Reject non-hash, non-scalar references (e.g. a scalar ref passed by mistake)
257
98
100
100
156
        if(ref($_[0]) && ref($_[0]) ne 'HASH') {
258
6
8
                Carp::carp('Usage: allow_ip($ip_address)');
259
6
929
                return $self;
260        }
261
262        # Normalise positional, named, and hashref calling conventions
263
92
271
        my %params;
264
92
100
100
126
        if(ref($_[0]) eq 'HASH') {
265
3
3
0
11
                %params = %{$_[0]};
266        } elsif(@_ % 2 == 0) {
267
8
8
                %params = @_;
268        } else {
269
81
76
                $params{ip} = shift;
270        }
271
272        # Store the address and invalidate the memoised CIDR list
273
92
100
85
        if(defined(my $ip = $params{ip})) {
274
88
134
                $self->{allowed_ips}->{$ip} = 1;
275
88
68
                delete $self->{_cidrlist};
276        } else {
277
4
5
                Carp::carp('Usage: allow_ip($ip_address)');
278        }
279
92
757
        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
4881
        my $self = shift;
365
366        # Reject references that are neither hashes nor arrays
367
85
100
75
146
        if(ref($_[0]) && ref($_[0]) ne 'HASH' && ref($_[0]) ne 'ARRAY') {
368
5
7
                Carp::carp('Usage: deny_country($country)');
369
5
757
                return $self;
370        }
371
372        # Normalise positional, named, and hashref calling conventions
373
80
211
        my %params;
374
80
100
100
118
        if(ref($_[0]) eq 'HASH') {
375
4
4
3
10
                %params = %{$_[0]};
376        } elsif(@_ % 2 == 0) {
377
11
15
                %params = @_;
378        } else {
379
65
61
                $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
86
        if(defined(my $c = $params{country})) {
385
78
9
100
100
87
17
                return $self if ref($c) eq 'ARRAY' && !@{$c};
386
77
100
191
                _set_countries($self->{deny_countries} ||= {}, $c);
387        } else {
388
2
3
                Carp::carp('Usage: deny_country($country)');
389        }
390
79
447
        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
1385
        my $self = shift;
472
473        # Reject references that are neither hashes nor arrays
474
57
100
75
78
        if(ref($_[0]) && ref($_[0]) ne 'HASH' && ref($_[0]) ne 'ARRAY') {
475
3
5
                Carp::carp('Usage: allow_country($country)');
476
3
428
                return $self;
477        }
478
479        # Normalise positional, named, and hashref calling conventions
480
54
119
        my %params;
481
54
100
100
74
        if(ref($_[0]) eq 'HASH') {
482
3
3
1
4
                %params = %{$_[0]};
483        } elsif(@_ % 2 == 0) {
484
8
6
                %params = @_;
485        } else {
486
43
40
                $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
65
        if(defined(my $c = $params{country})) {
492
52
6
100
100
67
10
                return $self if ref($c) eq 'ARRAY' && !@{$c};
493
51
100
86
                _set_countries($self->{allow_countries} ||= {}, $c);
494        } else {
495
2
2
                Carp::carp('Usage: allow_country($country)');
496        }
497
53
389
        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
992
        my $self = shift;
570
571        # Mark cloud-origin blocking as active
572
38
59
        $self->{deny_cloud} = 1;
573
38
75
        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
2499087
        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
518
        if(
699                (!defined($self->{allowed_ips}))    &&
700                (!defined($self->{deny_countries})) &&
701                (!$self->{deny_cloud})              &&
702                (!defined($self->{allow_countries}))
703        ) {
704
10
34
                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
312
        my $addr = $ENV{REMOTE_ADDR} // $DEFAULT_ADDR;
710
711        # Reject addresses that are not syntactically valid IPv4 or IPv6
712
249
100
100
962
        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
3553
        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
35
41
                my $is_cloud = eval { _is_cloud_host($addr) };
720
51
100
100
717
                return 1 if !$@ && $is_cloud;
721
722                # Non-cloud and no other restrictions: allow
723                return 0 unless $self->{allowed_ips}
724                             || $self->{deny_countries}
725
33
100
100
108
                             || $self->{allow_countries};
726        }
727
728        # ── IP / CIDR allow-list check ──────────────────────────────────────────
729
199
100
181
        if($self->{allowed_ips}) {
730                # Check for an exact-match entry first (fast path)
731
95
100
215
                return 0 if $self->{allowed_ips}->{$addr};
732
733                # Build and memoise the CIDR lookup structure on first use.
734                # Wrap in eval: Net::CIDR dies on non-IP strings (injection attempts).
735
55
100
47
                if(!$self->{_cidrlist}) {
736
39
29
                        my @cidrlist;
737
39
39
18
43
                        for my $block (keys %{$self->{allowed_ips}}) {
738
45
45
2403
57
                                eval { @cidrlist = Net::CIDR::cidradd($block, @cidrlist) };
739                        }
740
39
10517
                        $self->{_cidrlist} = \@cidrlist;
741                }
742
743                # Check whether the address falls inside any allowed CIDR range.
744                # Wrap in eval in case the list was built from partly-invalid entries.
745
55
55
55
32
34
72
                my $in_cidr = eval { Net::CIDR::cidrlookup($addr, @{$self->{_cidrlist}}) };
746
55
100
7408
                return 0 if $in_cidr;
747        }
748
749        # ── Country check ───────────────────────────────────────────────────────
750
139
100
100
204
        if($self->{deny_countries} || $self->{allow_countries}) {
751                # Parse the lingua argument (positional, named, or hashref)
752
115
73
                my %params;
753
115
100
100
158
                if(ref($_[0]) eq 'HASH') {
754
1
1
1
1
                        %params = %{$_[0]};
755                } elsif(@_ % 2 == 0) {
756
111
104
                        %params = @_;
757                } else {
758
3
4
                        $params{lingua} = shift;
759                }
760
761
115
100
126
                if(my $lingua = $params{lingua}) {
762                        # Reject non-objects to avoid "can't call method on non-ref" crashes
763
110
100
171
                        unless(blessed($lingua)) {
764
1
11
                                Carp::carp('all_denied: lingua must be a blessed object');
765
1
594
                                return 1;
766                        }
767                        # Resolve and normalise the client's country code.
768                        # Wrap in eval: the object may not implement country().
769
109
109
75
149
                        my $country_val = eval { $lingua->country() };
770
109
100
147461833
                        return 1 if $@;    # method missing or threw — treat as unknown
771
108
100
153
                        if(my $country = $country_val) {
772
102
95
                                $country = lc $country;
773
774                                # Default-deny mode: deny_countries contains the wildcard
775
102
100
100
339
                                if($self->{deny_countries} && $self->{deny_countries}->{$WILDCARD}) {
776
67
100
100
862
                                        return ($self->{allow_countries} && $self->{allow_countries}->{$country})
777                                                ? 0   # country is explicitly permitted
778                                                : 1;  # not in the permit list; deny
779                                }
780
781                                # Default-allow mode: deny only explicitly listed countries
782
35
100
100
302
                                return ($self->{deny_countries} && $self->{deny_countries}->{$country})
783                                        ? 1   # country is explicitly denied
784                                        : 0;  # not in the deny list; allow
785                        }
786                        # country() returned undef: country is unknown; deny access
787                } else {
788                        # Country restrictions active but no lingua was provided
789
5
12
                        Carp::carp('Usage: all_denied($lingua)');
790                }
791        }
792
793        # Fall-through: no rule allowed the request; deny
794
35
1306
        return 1;
795}
796
797# ── Internal helpers ──────────────────────────────────────────────────────────
798
799# _set_countries
800#
801# Purpose:    Shared logic for deny_country() and allow_country().  Inserts one
802#             or more lowercased country codes into the supplied hashref.
803#
804# Entry:      $hashref  - the target hash (already initialised by caller)
805#             $value    - a scalar country code OR an arrayref of codes
806#
807# Exit:       Returns nothing (modifies $hashref in place).
808#
809# Side effects: Modifies the caller-supplied hashref.
810#
811# Notes:      Keys are forced to lower case for case-insensitive comparison.
812sub _set_countries {
813
133
133
5410
        my ($hashref, $value) = @_;
814
815        # Handle both a single country code and a list reference.
816        # Skip undef elements to avoid "uninitialised value" warnings.
817
133
100
121
        if(ref($value) eq 'ARRAY') {
818
15
63
15
20
74
18
                $hashref->{lc $_} = 1 for grep { defined } @{$value};
819        } else {
820
118
112
                $hashref->{lc $value} = 1;
821        }
822
133
87
        return;
823}
824
825# _is_cloud_host
826#
827# Purpose:    Determines whether a given IP address belongs to a major cloud
828#             provider by performing a verified reverse-DNS lookup and then
829#             matching the confirmed hostname against @CLOUD_PATTERNS.
830#
831# Entry:      $ip - a validated IPv4 or IPv6 address string.
832#
833# Exit:       Returns 1 (cloud host) or 0 (not a cloud host / no PTR record).
834#
835# Side effects: Performs DNS lookups; may block for up to $DNS_TIMEOUT seconds
836#               on non-Windows platforms.
837#
838# Notes:      An IP with no PTR record, or whose forward confirmation fails,
839#             returns 0 (not cloud).  This is the safe default because
840#             legitimate cloud providers consistently set rDNS records.
841sub _is_cloud_host {
842
71
71
24766
        my $ip = $_[0];
843
844        # Attempt a verified reverse DNS lookup; returns undef on failure
845
71
100
107
        my $hostname = _verified_rdns($ip) or return 0;
846
847        # Compare the confirmed hostname against every known cloud pattern
848
43
316
        for my $pattern (@CLOUD_PATTERNS) {
849
189
100
783
                return 1 if $hostname =~ $pattern;
850        }
851
11
70
        return 0;
852}
853
854# _verified_rdns
855#
856# Purpose:    Performs a two-step DNS verification to prevent rDNS spoofing:
857#               1. Reverse lookup: IP -> hostname
858#               2. Forward confirmation: hostname -> [IPs]; IP must appear
859#
860# Entry:      $ip - a syntactically valid IPv4 or IPv6 address string.
861#
862# Exit:       Returns the confirmed hostname string on success, undef otherwise.
863#             undef is returned when:
864#               - $ip cannot be packed (invalid address)
865#               - no PTR record exists
866#               - forward lookup does not include the original IP
867#               - DNS lookup times out (non-Windows only)
868#
869# Side effects: Performs two DNS round-trips; installs and restores a temporary
870#               SIGALRM handler on non-Windows platforms.
871#
872# Notes:      On non-Windows platforms a $DNS_TIMEOUT-second alarm is set to
873#             prevent CGI workers from blocking indefinitely on slow resolvers.
874#             alarm(0) is called inside the eval to close the race window
875#             between eval exit and the outer alarm(0) call.
876sub _verified_rdns {
877
19
19
72572
        my $ip = $_[0];
878
879        # Determine address family and produce the packed binary address
880
19
50
        my ($family, $packed);
881
19
100
24
        if($ip =~ /:/o) {
882                # IPv6: use inet_pton which handles all valid IPv6 formats
883
3
2
                $family = Socket::AF_INET6;
884
3
100
10
                $packed = Socket::inet_pton(Socket::AF_INET6, $ip) or return;
885        } else {
886                # IPv4: inet_aton handles dotted-quad addresses
887
16
8
                $family = AF_INET;
888
16
100
31599
                $packed = inet_aton($ip) or return;
889        }
890
891        # Normalise the IP to canonical form for reliable string comparison.
892        # This handles abbreviated IPv6 forms such as '::1' vs '0:0:...:1'.
893
14
100
33
        my $canonical = ($family == AF_INET)
894                ? inet_ntoa($packed)
895                : Socket::inet_ntop(Socket::AF_INET6, $packed);
896
897
14
10
        my ($hostname, @forward_ips);
898
899
14
50
15
        if($^O ne 'MSWin32') {
900                # Non-Windows: guard against indefinitely-blocking DNS calls
901
14
2
2
91
37
                local $SIG{ALRM} = sub { die "DNS timeout: $ip" };
902
14
18
                alarm($DNS_TIMEOUT);
903
14
59
                eval {
904                        # Step 1: reverse lookup (IP -> hostname)
905
14
878654
                        $hostname = gethostbyaddr($packed, $family);
906
14
100
42
                        if($hostname) {
907                                # Step 2: forward lookup (hostname -> IP list)
908
7
9
                                @forward_ips = _rdns_forward($hostname, $family);
909                        }
910                        # Cancel the alarm inside the eval to avoid a post-eval race
911
12
41
                        alarm(0);
912                };
913                # Belt-and-suspenders: ensure the alarm is always cancelled
914
14
1310
                alarm(0);
915
14
100
100
130
                return if $@ || !$hostname;
916        } else {
917                # Windows: no alarm support; perform lookups synchronously
918
0
0
0
                $hostname = gethostbyaddr($packed, $family) or return;
919
920                # Forward lookup to confirm the hostname maps back to the original IP
921
0
0
                @forward_ips = _rdns_forward($hostname, $family);
922        }
923
924        # Step 3: the hostname is only trusted if a forward record confirms the IP
925
5
4
100
5
9
        return (grep { $_ eq $canonical } @forward_ips) ? $hostname : undef;
926}
927
928# _rdns_forward
929#
930# Purpose:    Resolves a hostname to a list of IP address strings for use in
931#             the forward-confirmation step of _verified_rdns().
932#
933# Entry:      $hostname - the fully-qualified domain name to resolve.
934#             $family   - address family: AF_INET or Socket::AF_INET6.
935#
936# Exit:       Returns a list of IP address strings (may be empty on failure).
937#
938# Side effects: Performs a DNS A or AAAA lookup.
939#
940# Notes:      For IPv4 uses the classic inet_aton/inet_ntoa chain.
941#             For IPv6 uses Socket::getaddrinfo and Socket::getnameinfo
942#             (available since Perl 5.14 / Socket 1.99).
943sub _rdns_forward {
944
12
12
14490
        my ($hostname, $family) = @_;
945
946        # IPv4 path: resolve A record and convert each packed address to a string
947
12
100
19
        if($family == AF_INET) {
948
5
16
                return map  { inet_ntoa($_)  }
949
9
29
                       grep { defined        }
950
9
9
8
120158
                       map  { inet_aton($_)  }
951                       ($hostname);
952        }
953
954        # IPv6 path: use getaddrinfo to resolve AAAA records
955
3
5
        my ($err, @addrs) = Socket::getaddrinfo(
956                $hostname, undef,
957                { family => $family, socktype => SOCK_STREAM },
958        );
959
3
100
8
        return () if $err;
960
961        # Convert each opaque sockaddr to a numeric IP string
962
2
1
        my @ips;
963
2
2
        for my $addr_info (@addrs) {
964                my ($e, $host) = Socket::getnameinfo(
965
2
3
                        $addr_info->{addr}, Socket::NI_NUMERICHOST,
966                );
967
2
100
8
                push @ips, $host unless $e;
968        }
969
2
2
        return @ips;
970}
971
972=encoding utf-8
973
974 - 1138
=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
1139
11401;