client-side ALPN support

.github/workflows/main.yml

@@ -51,6 +51,8 @@ jobs:
       run: |
         echo "debian" $(cat /etc/debian_version)
         echo "Mail::IMAPTalk" $(cpanm --info Mail::IMAPTalk)
+        echo "IO::Socket::SSL" $(cpanm --info IO::Socket::SSL)
+        echo "Net::SSLeay" $(cpanm --info Net::SSLeay)
         /usr/cyrus/libexec/master -V
         /usr/cyrus/sbin/cyr_buildinfo
     - name: update jmap test suite

cassandane/Cassandane/Cyrus/ALPN.pm

@@ -0,0 +1,244 @@
+#!/usr/bin/perl
+#
+#  Copyright (c) 2011-2024 FastMail Pty Ltd. All rights reserved.
+#
+#  Redistribution and use in source and binary forms, with or without
+#  modification, are permitted provided that the following conditions
+#  are met:
+#
+#  1. Redistributions of source code must retain the above copyright
+#     notice, this list of conditions and the following disclaimer.
+#
+#  2. Redistributions in binary form must reproduce the above copyright
+#     notice, this list of conditions and the following disclaimer in
+#     the documentation and/or other materials provided with the
+#     distribution.
+#
+#  3. The name "Fastmail Pty Ltd" must not be used to
+#     endorse or promote products derived from this software without
+#     prior written permission. For permission or any legal
+#     details, please contact
+#      FastMail Pty Ltd
+#      PO Box 234
+#      Collins St West 8007
+#      Victoria
+#      Australia
+#
+#  4. Redistributions of any form whatsoever must retain the following
+#     acknowledgment:
+#     "This product includes software developed by Fastmail Pty. Ltd."
+#
+#  FASTMAIL PTY LTD DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE,
+#  INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY  AND FITNESS, IN NO
+#  EVENT SHALL OPERA SOFTWARE AUSTRALIA BE LIABLE FOR ANY SPECIAL, INDIRECT
+#  OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF
+#  USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER
+#  TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE
+#  OF THIS SOFTWARE.
+#
+
+package Cassandane::Cyrus::ALPN;
+use strict;
+use warnings;
+use Cwd qw(abs_path);
+use Data::Dumper;
+
+use lib '.';
+use base qw(Cassandane::Cyrus::TestCase);
+use Cassandane::Util::Log;
+
+sub new
+{
+    my $class = shift;
+
+    my $config = Cassandane::Config->default()->clone();
+    $config->set(tls_server_cert => '@basedir@/conf/certs/cert.pem',
+                 tls_server_key => '@basedir@/conf/certs/key.pem');
+
+    my $self = $class->SUPER::new({
+        config => $config,
+        install_certificates => 1,
+        services => [ 'imap', 'imaps' ],
+    }, @_);
+
+    $self->needs('dependency', 'openssl');
+    $self->needs('dependency', 'openssl_alpn');
+
+    return $self;
+}
+
+sub set_up
+{
+    my ($self) = @_;
+    $self->SUPER::set_up();
+}
+
+sub tear_down
+{
+    my ($self) = @_;
+    $self->SUPER::tear_down();
+}
+
+sub do_imap_starttls
+{
+    my ($self, $talk, $alpn_map) = @_;
+    my $ca_file = abs_path("data/certs/cacert.pem");
+
+    my $starttls_tag = $talk->{CmdId};
+
+    $talk->_imap_cmd('starttls', 0, 'starttls');
+
+    die $talk->get_last_error()
+        if $talk->get_last_completion_response() ne 'ok';
+
+    IO::Socket::SSL->start_SSL($talk->{Socket},
+                               SSL_ca_file => $ca_file,
+                               SSL_verifycn_scheme => 'none',
+                               SSL_alpn_protocols => $alpn_map,
+    );
+
+    if (ref $talk->{Socket} ne 'IO::Socket::SSL') {
+        # STARTTLS failed! Rummage inside Mail::IMAPTalk to put it back into
+        # a sane state, because the tag having two responses confuses it
+
+        # make it read the tagged "NO Starttls negotiation failed" response
+        $talk->{CmdId} = $starttls_tag;
+        my ($no, $msg) = $talk->_parse_response({}, {});
+        die "uh oh, response '$no' wasn't 'no'" if $no ne 'no';
+
+        # make get_last_completion_response() work
+        $talk->{LastRespCode} = $no;
+
+        # throw an exception here by default, eval the call if you want
+        # to handle the failure and keep using the plaintext session
+        die $msg;
+    }
+}
+
+sub expect_alpn_protocol
+{
+    my ($self, $protocol) = @_;
+
+    return if !$self->{instance}->{have_syslog_replacement};
+
+    my @lines = $self->{instance}->getsyslog(qr{starttls: \S+ with cipher});
+    $self->assert_num_equals(1, scalar @lines);
+
+    if ($protocol) {
+        $self->assert_matches(qr{; application protocol = $protocol},
+                              $lines[0]);
+    }
+    else {
+        $self->assert_does_not_match(qr{; application protocol =},
+                                     $lines[0]);
+    }
+}
+
+sub test_imap_none
+{
+    my ($self) = @_;
+
+    # get a pristine connection
+    $self->{store}->disconnect();
+    my $talk = $self->{store}->get_client(NoLogin => 1);
+
+    $self->do_imap_starttls($talk, undef);
+
+    $talk->login('cassandane', 'secret');
+    $self->assert_str_equals('ok', $talk->get_last_completion_response());
+
+    $talk->select("INBOX");
+    $self->assert_str_equals('ok', $talk->get_last_completion_response());
+
+    $self->expect_alpn_protocol(undef);
+}
+
+sub test_imap_good
+{
+    my ($self) = @_;
+
+    # get a pristine connection
+    $self->{store}->disconnect();
+    my $talk = $self->{store}->get_client(NoLogin => 1);
+
+    $self->do_imap_starttls($talk, [ 'imap' ]);
+
+    $talk->login('cassandane', 'secret');
+    $self->assert_str_equals('ok', $talk->get_last_completion_response());
+
+    $talk->select("INBOX");
+    $self->assert_str_equals('ok', $talk->get_last_completion_response());
+
+    $self->expect_alpn_protocol('imap');
+}
+
+sub test_imap_bad
+{
+    my ($self) = @_;
+
+    # get a pristine connection
+    $self->{store}->disconnect();
+    my $talk = $self->{store}->get_client(NoLogin => 1);
+
+    eval {
+        $self->do_imap_starttls($talk, [ 'bogus' ]);
+    };
+
+    my $e = $@;
+    $self->assert_not_null($e);
+    $self->assert_matches(qr{Starttls negotiation failed}, $e);
+    $self->assert_str_equals('no', $talk->get_last_completion_response());
+}
+
+sub test_imaps_none
+{
+    my ($self) = @_;
+
+    my $imaps = $self->{instance}->get_service('imaps');
+    my $store = $imaps->create_store(username => 'cassandane');
+    my $talk = $store->get_client(OverrideALPN => undef);
+
+    $talk->select("INBOX");
+    $self->assert_str_equals('ok', $talk->get_last_completion_response());
+
+    $self->expect_alpn_protocol(undef);
+}
+
+sub test_imaps_good
+{
+    my ($self) = @_;
+
+    my $imaps = $self->{instance}->get_service('imaps');
+    my $store = $imaps->create_store(username => 'cassandane');
+    my $talk = $store->get_client(); # correct ALPN map is the default
+
+    $talk->select("INBOX");
+    $self->assert_str_equals('ok', $talk->get_last_completion_response());
+
+    $self->expect_alpn_protocol('imap');
+}
+
+sub test_imaps_bad
+{
+    my ($self) = @_;
+
+    my $imaps = $self->{instance}->get_service('imaps');
+    my $store = $imaps->create_store(username => 'cassandane');
+    my $talk = eval {
+        $store->get_client(OverrideALPN => [ 'bogus' ]);
+    };
+    my $e = $@;
+
+    $self->assert_not_null($e);
+
+    # depending on the openssl version, we might get a sensible
+    # error message, or an opaque reference to "1120".
+    #
+    # https://github.com/openssl/openssl/issues/24300
+    my $pat = qr{(?: tlsv1\salert\sno\sapplication\sprotocol
+                  |  ssl3_read_bytes:reason\(1120\)
+                 )}x;
+    $self->assert_matches($pat, $e);
+}
+
+1;

cassandane/Cassandane/Cyrus/TestCase.pm

@@ -795,49 +795,42 @@ sub _setup_http_service_objects
 {
     my ($self) = @_;
 
-    # nothing to do if no http service
-    require Mail::JMAPTalk;
-    require Net::CalDAVTalk;
-    require Net::CardDAVTalk;
-
+    # nothing to do if no http or https service
     my $service = $self->{instance}->get_service("http");
+    $service ||= $self->{instance}->get_service("https");
     return if !$service;
 
+    my %common_args = (
+        user => 'cassandane',
+        password => 'pass',
+        host => $service->host(),
+        port => $service->port(),
+        scheme => ($service->is_ssl() ? 'https' : 'http'),
+    );
+
     if ($self->{instance}->{config}->get_bit('httpmodules', 'carddav')) {
         require Net::CardDAVTalk;
         $self->{carddav} = Net::CardDAVTalk->new(
-            user => 'cassandane',
-            password => 'pass',
-            host => $service->host(),
-            port => $service->port(),
-            scheme => 'http',
+            %common_args,
             url => '/',
             expandurl => 1,
         );
     }
     if ($self->{instance}->{config}->get_bit('httpmodules', 'caldav')) {
         require Net::CalDAVTalk;
         $self->{caldav} = Net::CalDAVTalk->new(
-            user => 'cassandane',
-            password => 'pass',
-            host => $service->host(),
-            port => $service->port(),
-            scheme => 'http',
+            %common_args,
             url => '/',
             expandurl => 1,
         );
         $self->{caldav}->UpdateAddressSet("Test User",
-                                            "cassandane\@example.com");
+                                          "cassandane\@example.com");
     }
     if ($self->{instance}->{config}->get_bit('httpmodules', 'jmap')) {
         require Mail::JMAPTalk;
         $ENV{DEBUGJMAP} = 1;
         $self->{jmap} = Mail::JMAPTalk->new(
-            user => 'cassandane',
-            password => 'pass',
-            host => $service->host(),
-            port => $service->port(),
-            scheme => 'http',
+            %common_args,
             url => '/jmap/',
         );
     }

cassandane/Cassandane/IMAPMessageStore.pm

@@ -97,6 +97,10 @@ sub connect
 
     if ($self->{ssl}) {
         my $ca_file = abs_path("data/certs/cacert.pem");
+        my $alpn_map = exists $params{OverrideALPN}
+                     ? delete $params{OverrideALPN}
+                     : [ 'imap' ];
+
         # XXX https://github.com/noxxi/p5-io-socket-ssl/issues/121
         # XXX With newer IO::Socket::SSL, hostname verification fails
         # XXX because our hostname is an IP address and the certificate
@@ -111,6 +115,7 @@ sub connect
                       UseSSL => $self->{ssl},
                       SSL_ca_file => $ca_file,
                       SSL_verifycn_scheme => 'none',
+                      SSL_alpn_protocols => $alpn_map,
                       UseBlocking => 1,  # must be blocking for SSL
                       Pedantic => 1,
                       PreserveINBOX => 1,

cassandane/Cassandane/Service.pm

@@ -108,6 +108,15 @@ sub set_port
     return $self->{_listener}->set_port($port);
 }
 
+sub is_ssl
+{
+    my ($self) = @_;
+
+    # assume '-s' service argument indicates SSL and its absense
+    # indicates plaintext
+    return scalar grep { $_ eq '-s' } @{$self->{argv}};
+}
+
 # Return a hash of parameters suitable for passing
 # to MessageStoreFactory::create.
 sub store_params

cassandane/Cassandane/ServiceFactory.pm

@@ -60,29 +60,23 @@ sub create
     }
 
     # try and guess some service-specific defaults
-    if ($name =~ m/imaps/)
+    if ($name =~ m/imap(s?)/)
     {
-        return Cassandane::IMAPService->new(
-                                argv => ['imapd', '-s'],
-                                %params);
-    }
-    elsif ($name =~ m/imap/)
-    {
-        return Cassandane::IMAPService->new(
-                                argv => ['imapd'],
-                                %params);
+        my @argv = 'imapd';
+        push @argv, '-s' if $1;
+        return Cassandane::IMAPService->new(argv => \@argv, %params);
     }
     elsif ($name =~ m/sync/)
     {
         return Cassandane::Service->new(
                                 argv => ['imapd'],
                                 %params);
     }
-    elsif ($name =~ m/http/)
+    elsif ($name =~ m/http(s?)/)
     {
-        return Cassandane::Service->new(
-                                argv => ['httpd'],
-                                %params);
+        my @argv = 'httpd';
+        push @argv, '-s' if $1;
+        return Cassandane::Service->new(argv => \@argv, %params);
     }
     elsif ($name =~ m/lmtp/)
     {