view release on metacpan or  search on metacpan

lib/CGI/ACL.pm  view on Meta::CPAN

	}

	# Add the country or list of countries to the permit set.
	# An empty arrayref is a no-op — do not create allow_countries = {}.
	if(defined(my $c = $params{country})) {
		return $self if ref($c) eq 'ARRAY' && !@{$c};
		_set_countries($self->{allow_countries} ||= {}, $c);
	} else {
		Carp::carp('Usage: allow_country($country)');
	}
	return $self;
}

# ── deny_cloud ─────────────────────────────────────────────────────────────────

=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

sub deny_cloud {
	my $self = shift;

	# Mark cloud-origin blocking as active
	$self->{deny_cloud} = 1;
	return $self;
}

# ── all_denied ─────────────────────────────────────────────────────────────────

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

lib/CGI/ACL.pm  view on Meta::CPAN

#               1. Reverse lookup: IP -> hostname
#               2. Forward confirmation: hostname -> [IPs]; IP must appear
#
# Entry:      $ip - a syntactically valid IPv4 or IPv6 address string.
#
# Exit:       Returns the confirmed hostname string on success, undef otherwise.
#             undef is returned when:
#               - $ip cannot be packed (invalid address)
#               - no PTR record exists
#               - forward lookup does not include the original IP
#               - DNS lookup times out (non-Windows only)
#
# Side effects: Performs two DNS round-trips; installs and restores a temporary
#               SIGALRM handler on non-Windows platforms.
#
# Notes:      On non-Windows platforms a $DNS_TIMEOUT-second alarm is set to
#             prevent CGI workers from blocking indefinitely on slow resolvers.
#             alarm(0) is called inside the eval to close the race window
#             between eval exit and the outer alarm(0) call.
sub _verified_rdns {
	my $ip = $_[0];

	# Determine address family and produce the packed binary address
	my ($family, $packed);
	if($ip =~ /:/o) {
		# IPv6: use inet_pton which handles all valid IPv6 formats
		$family = Socket::AF_INET6;
		$packed = Socket::inet_pton(Socket::AF_INET6, $ip) or return;
	} else {
		# IPv4: inet_aton handles dotted-quad addresses
		$family = AF_INET;
		$packed = inet_aton($ip) or return;
	}

	# Normalise the IP to canonical form for reliable string comparison.
	# This handles abbreviated IPv6 forms such as '::1' vs '0:0:...:1'.
	my $canonical = ($family == AF_INET)
		? inet_ntoa($packed)
		: Socket::inet_ntop(Socket::AF_INET6, $packed);

	my ($hostname, @forward_ips);

	if($^O ne 'MSWin32') {
		# Non-Windows: guard against indefinitely-blocking DNS calls
		local $SIG{ALRM} = sub { die "DNS timeout: $ip" };
		alarm($DNS_TIMEOUT);
		eval {
			# Step 1: reverse lookup (IP -> hostname)
			$hostname = gethostbyaddr($packed, $family);
			if($hostname) {
				# Step 2: forward lookup (hostname -> IP list)
				@forward_ips = _rdns_forward($hostname, $family);
			}
			# Cancel the alarm inside the eval to avoid a post-eval race
			alarm(0);
		};
		# Belt-and-suspenders: ensure the alarm is always cancelled
		alarm(0);
		return if $@ || !$hostname;
	} else {
		# Windows: no alarm support; perform lookups synchronously
		$hostname = gethostbyaddr($packed, $family) or return;

		# Forward lookup to confirm the hostname maps back to the original IP
		@forward_ips = _rdns_forward($hostname, $family);
	}

	# Step 3: the hostname is only trusted if a forward record confirms the IP
	return (grep { $_ eq $canonical } @forward_ips) ? $hostname : undef;
}

# _rdns_forward
#
# Purpose:    Resolves a hostname to a list of IP address strings for use in
#             the forward-confirmation step of _verified_rdns().
#
# Entry:      $hostname - the fully-qualified domain name to resolve.
#             $family   - address family: AF_INET or Socket::AF_INET6.
#
# Exit:       Returns a list of IP address strings (may be empty on failure).
#
# Side effects: Performs a DNS A or AAAA lookup.
#
# Notes:      For IPv4 uses the classic inet_aton/inet_ntoa chain.
#             For IPv6 uses Socket::getaddrinfo and Socket::getnameinfo
#             (available since Perl 5.14 / Socket 1.99).
sub _rdns_forward {
	my ($hostname, $family) = @_;

	# IPv4 path: resolve A record and convert each packed address to a string
	if($family == AF_INET) {
		return map  { inet_ntoa($_)  }
		       grep { defined        }
		       map  { inet_aton($_)  }
		       ($hostname);
	}

	# IPv6 path: use getaddrinfo to resolve AAAA records
	my ($err, @addrs) = Socket::getaddrinfo(
		$hostname, undef,
		{ family => $family, socktype => SOCK_STREAM },
	);
	return () if $err;

	# Convert each opaque sockaddr to a numeric IP string
	my @ips;
	for my $addr_info (@addrs) {
		my ($e, $host) = Socket::getnameinfo(
			$addr_info->{addr}, Socket::NI_NUMERICHOST,
		);
		push @ips, $host unless $e;
	}
	return @ips;
}

=encoding utf-8

=head1 AUTHOR

Nigel Horne, C<< <njh at nigelhorne.com> >>