fix: check the hostname of each OpenStack endpoint's certificate

.github/cpanfile

@@ -1,6 +1,7 @@
 requires 'OpenStack::Client', '1.0006';
 requires 'YAML::XS';
 requires 'JSON';
+requires 'LWP::UserAgent';
 requires 'Moo';
 requires 'Moo::Role';
 

Changes

@@ -2,6 +2,18 @@ OpenStack::MetaAPI Changes
 
 {{$NEXT}}
 
+  [ Security ]
+  - Check the hostname of the TLS certificate of each OpenStack endpoint.
+    OpenStack::Client makes its user agents with verify_hostname => 0, so
+    the X-Auth-Token of every request went to whichever server answered.
+    new() now gives OpenStack::Client::Auth the new class
+    OpenStack::MetaAPI::UserAgent as package_ua, which leaves the check to
+    LWP: on, unless PERL_LWP_SSL_VERIFY_HOSTNAME=0. If that variable is
+    not set, HTTPS_CA_FILE or HTTPS_CA_DIR also turns it off. A caller that
+    builds its own auth object passes package_ua => 'OpenStack::MetaAPI::UserAgent'
+    to get the same. A cloud with a self-signed certificate now needs
+    PERL_LWP_SSL_CA_FILE, or PERL_LWP_SSL_VERIFY_HOSTNAME=0.
+
 0.004     2026-09-10 20:02:40-06:00 America/Denver
 
   [ New features ]

Makefile.PL

@@ -18,6 +18,7 @@ my %WriteMakefileArgs = (
   "NAME" => "OpenStack::MetaAPI",
   "PREREQ_PM" => {
     "JSON" => 0,
+    "LWP::UserAgent" => 0,
     "Moo" => 0,
     "Moo::Role" => 0,
     "OpenStack::Client" => "1.0006",

dist.ini

@@ -38,6 +38,7 @@ push_to = gh HEAD:refs/heads/released ; also push to released branch
 ;[Prereqs / RuntimeRecommends]
 [Prereqs / RuntimeRequires]
 OpenStack::Client           = 1.0006
+LWP::UserAgent              = 0
 YAML::XS                    = 0
 JSON                        = 0
 Moo                         = 0

lib/OpenStack/MetaAPI.pm

@@ -4,8 +4,9 @@ use strict;
 use warnings;
 
 use MIME::Base64              ();
-use OpenStack::Client::Auth    ();
-use OpenStack::MetaAPI::Routes ();
+use OpenStack::Client::Auth       ();
+use OpenStack::MetaAPI::Routes    ();
+use OpenStack::MetaAPI::UserAgent ();
 use Scalar::Util qw/blessed weaken/;
 
 use Moo;
@@ -65,8 +66,12 @@ around BUILDARGS => sub {
       && ref $args[0] eq 'HASH'
       && blessed($args[0]->{'auth'});
 
-    # automagically build the OpenStack::Client::Auth from existing args
-    return {auth => OpenStack::Client::Auth->new(@args)};
+    # OpenStack::Client turns off the check of the server's hostname unless
+    # its user agent class puts it back.  See OpenStack::MetaAPI::UserAgent.
+    my ($endpoint, %args) = @args;
+    $args{package_ua} //= 'OpenStack::MetaAPI::UserAgent';
+
+    return {auth => OpenStack::Client::Auth->new($endpoint, %args)};
 };
 
 sub create_vm {
@@ -263,6 +268,10 @@ Feel free to report issues to the Bug Tracker or contribute.
 Create one OpenStack::MetaAPI object.
 For now all arguments passed to C<new> are used to create one L<OpenStack::Client::Auth>.
 
+Its user agent checks the hostname of each server it talks to, unless you pass
+another C<package_ua>.  See L<OpenStack::MetaAPI::UserAgent>, which also tells
+what to do when you build the auth object yourself.
+
 =head2 $api->flavors( [ %filter ] )
 
 List all flavors from the compute service. [view synopsis for some sample usage]

lib/OpenStack/MetaAPI/UserAgent.pm

@@ -0,0 +1,68 @@
+package OpenStack::MetaAPI::UserAgent;
+
+use strict;
+use warnings;
+
+use parent 'LWP::UserAgent';
+
+# ABSTRACT: an LWP::UserAgent that leaves TLS hostname verification to LWP
+
+# VERSION: generated by DZP::OurPkgVersion
+
+sub new {
+    my ($class, %opts) = @_;
+
+    # A copy, so that the caller's hash keeps what it passed.
+    my %ssl_opts = %{$opts{ssl_opts} // {}};
+    delete $ssl_opts{verify_hostname};
+    $opts{ssl_opts} = \%ssl_opts;
+
+    return $class->SUPER::new(%opts);
+}
+
+1;
+
+__END__
+
+=for test_synopsis
+my ($endpoint, %auth_args);
+
+=head1 SYNOPSIS
+
+    # OpenStack::MetaAPI uses this class unless you name another one.
+    my $api = OpenStack::MetaAPI->new($endpoint, %auth_args);
+
+    # An auth object that you build yourself has to be given it.
+    my $auth = OpenStack::Client::Auth->new(
+        $endpoint, %auth_args,
+        package_ua => 'OpenStack::MetaAPI::UserAgent',
+    );
+    my $api_from_auth = OpenStack::MetaAPI->new({auth => $auth});
+
+=head1 DESCRIPTION
+
+L<OpenStack::Client> makes each of its user agents with
+
+    ssl_opts => { verify_hostname => 0 }
+
+and no argument changes that.  So without this class, every request goes to
+whichever server answers for the endpoint, with the C<X-Auth-Token> of the
+session in its headers.
+
+This class removes C<verify_hostname> from the C<ssl_opts> it is given, and
+passes everything else to L<LWP::UserAgent>.  LWP then decides, as it does for
+any user agent: the check is on, unless the environment variable
+C<PERL_LWP_SSL_VERIFY_HOSTNAME> is set to 0.  If C<PERL_LWP_SSL_VERIFY_HOSTNAME>
+is not set, the older variables C<HTTPS_CA_FILE> and C<HTTPS_CA_DIR> also turn
+the check off, for compatibility with L<Crypt::SSLeay>.  To trust a private
+certificate authority, set C<PERL_LWP_SSL_CA_FILE> or C<PERL_LWP_SSL_CA_PATH>.  To change
+anything else, subclass this class and give yours as C<package_ua>.
+
+=head1 METHODS
+
+=head2 new( %opts )
+
+Returns a new user agent, as L<LWP::UserAgent/new> does, from C<%opts> with
+C<verify_hostname> taken out of C<ssl_opts>.
+
+=cut

t/useragent.t

@@ -0,0 +1,83 @@
+#!/usr/bin/env perl
+
+use strict;
+use warnings;
+
+use Test2::Bundle::Extended;
+use Test2::Plugin::NoWarnings;
+use Test::MockModule;
+
+use OpenStack::Client            ();
+use OpenStack::Client::Auth      ();
+use OpenStack::MetaAPI           ();
+use OpenStack::MetaAPI::UserAgent ();
+
+# LWP reads these when a user agent is made without verify_hostname.  HTTPS_CA_*
+# turn the check off, for compatibility with Crypt::SSLeay.
+local %ENV = %ENV;
+delete @ENV{qw{PERL_LWP_SSL_VERIFY_HOSTNAME HTTPS_CA_FILE HTTPS_CA_DIR}};
+
+my $ENDPOINT = 'https://keystone.test.test:5000/v3';
+
+subtest 'OpenStack::Client alone turns the check off' => sub {
+    my $client = OpenStack::Client->new($ENDPOINT);
+    is $client->{ua}->ssl_opts('verify_hostname'), 0,
+      'which is the reason this class exists';
+};
+
+subtest 'new() leaves the decision to LWP' => sub {
+    my %ssl_opts = (verify_hostname => 0, SSL_ca_file => '/bogus/ca.pem');
+    my $ua = OpenStack::MetaAPI::UserAgent->new(ssl_opts => \%ssl_opts);
+
+    isa_ok $ua, 'LWP::UserAgent';
+    is $ua->ssl_opts('verify_hostname'), 1,
+      'verify_hostname => 0 is dropped, and LWP turns the check on';
+    is $ua->ssl_opts('SSL_ca_file'), '/bogus/ca.pem',
+      'the other ssl_opts reach LWP';
+    is \%ssl_opts, {verify_hostname => 0, SSL_ca_file => '/bogus/ca.pem'},
+      "the caller's hash is not changed";
+
+    is(OpenStack::MetaAPI::UserAgent->new->ssl_opts('verify_hostname'), 1,
+        'with no ssl_opts at all, the check is on');
+
+    local $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME} = 0;
+    is(OpenStack::MetaAPI::UserAgent->new(ssl_opts => {verify_hostname => 1})
+          ->ssl_opts('verify_hostname'),
+        0, 'PERL_LWP_SSL_VERIFY_HOSTNAME=0 turns it off');
+};
+
+subtest 'HTTPS_CA_FILE turns the check off, as the POD says' => sub {
+    local $ENV{HTTPS_CA_FILE} = '/bogus/ca.pem';
+    is(OpenStack::MetaAPI::UserAgent->new->ssl_opts('verify_hostname'), 0,
+        'without PERL_LWP_SSL_VERIFY_HOSTNAME');
+
+    local $ENV{PERL_LWP_SSL_VERIFY_HOSTNAME} = 1;
+    is(OpenStack::MetaAPI::UserAgent->new->ssl_opts('verify_hostname'), 1,
+        'PERL_LWP_SSL_VERIFY_HOSTNAME=1 wins over it');
+};
+
+subtest 'OpenStack::Client with this class checks the hostname' => sub {
+    my $client = OpenStack::Client->new($ENDPOINT,
+        package_ua => 'OpenStack::MetaAPI::UserAgent');
+    isa_ok $client->{ua}, 'OpenStack::MetaAPI::UserAgent';
+    is $client->{ua}->ssl_opts('verify_hostname'), 1, 'the check is on';
+};
+
+subtest 'OpenStack::MetaAPI->new gives the auth object this class' => sub {
+    my @got;
+    my $mock = Test::MockModule->new('OpenStack::Client::Auth');
+    $mock->redefine(new => sub { shift; @got = @_; return bless {}, 'Test::Auth' });
+
+    OpenStack::MetaAPI->new($ENDPOINT, username => 'u', version => 3);
+    my ($endpoint, %args) = @got;
+    is $endpoint, $ENDPOINT, 'the endpoint is passed first, as before';
+    is \%args,
+      {username => 'u', version => 3, package_ua => 'OpenStack::MetaAPI::UserAgent'},
+      'package_ua defaults to this class, and the other arguments are unchanged';
+
+    OpenStack::MetaAPI->new($ENDPOINT, package_ua => 'LWP::UserAgent');
+    ($endpoint, %args) = @got;
+    is $args{package_ua}, 'LWP::UserAgent', 'a package_ua that the caller names wins';
+};
+
+done_testing;