alpaca mitigations

cassandane/Cassandane/Cyrus/Alpaca.pm

@@ -0,0 +1,379 @@
+#!/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::Alpaca;
+use strict;
+use warnings;
+use Cwd qw(abs_path);
+use Data::Dumper;
+
+use lib '.';
+use base qw(Cassandane::Cyrus::TestCase);
+use Cassandane::Util::Log;
+use Cassandane::Util::Socket;
+
+sub new
+{
+    my $class = shift;
+    return $class->SUPER::new({}, @_);
+}
+
+sub set_up
+{
+    my ($self) = @_;
+    $self->SUPER::set_up();
+}
+
+sub tear_down
+{
+    my ($self) = @_;
+    $self->SUPER::tear_down();
+}
+
+sub imap_cmd_with_tag
+{
+    my ($talk, $tag, @args) = @_;
+
+    die "not a Mail::IMAPTalk object" if ref $talk ne 'Mail::IMAPTalk';
+
+    # save some internal state
+    my $saved_CmdId = $talk->{CmdId};
+
+    # override next tag with the tag we want to use
+    $talk->{CmdId} = $tag;
+
+    my $ret;
+    {
+        # suppress an expected warning from _imap_cmd because CmdId
+        # (probably) isn't numeric
+        local $SIG{__WARN__} = sub {
+            if ($_[0] !~ m/^Argument "\Q$tag\E" isn't numeric /) {
+                warn @_;
+            }
+        };
+        $ret = $talk->_imap_cmd(@args);
+    }
+
+    # restore internal state
+    $talk->{CmdId} = $saved_CmdId;
+
+    return $ret;
+}
+
+sub test_consecutive_syntax_errors_drop_connection
+{
+    my ($self) = @_;
+
+    $self->{store}->disconnect();
+    my $sock = create_client_socket($self->{store}->{address_family},
+                                    $self->{store}->{host},
+                                    $self->{store}->{port});
+
+    # 50 lines of just "bogus \r\n", that is the tag 'bogus' and a space
+    # but no command, which cyrus will reject with "bogus BAD Null command"
+    my @request = ('bogus ') x 50;
+    foreach my $line (@request) {
+        $sock->send("$line\015\012") or die "send: $!";
+        last if not $sock->connected();
+    }
+
+    # if the connection hasn't been dropped already, send a logout so the
+    # test doesn't hang
+    $sock->send(". logout\015\012") if $sock->connected();
+
+    my @response;
+    while (defined(my $line = $sock->getline())) {
+        $line =~ s/\015?\012//;
+        push @response, $line;
+    }
+
+    # double check that our request contained more lines than cyrus'
+    # syntax error limit of 10
+    $self->assert_num_gt(10, scalar @request);
+
+    # cyrus should have dropped the connection before we sent all the lines
+    $self->assert_num_lt(scalar @request, scalar @response);
+
+    # should have gotten as many BAD responses as cyrus's limit
+    $self->assert_num_equals(10, scalar grep { m/BAD/ } @response);
+
+    # snarky last response back from the server
+    $self->assert_matches(qr{This is an IMAP server}, $response[-1]);
+}
+
+sub test_html_tag_dont_reflect1
+{
+    my ($self) = @_;
+
+    my $talk = $self->{store}->get_client();
+
+    # mimic a HTTP connection sending request content that contains a line
+    # that parses such that the tag is a chunk of javacript and the command
+    # is something that will provoke a tagged response, causing us to reflect
+    # the script back to the client.
+    # we'll say "BAD Invalid tag" for trivial forms of this such as
+    # <script>attack()</script> just because () are not valid characters in
+    # tags, but it's possible to invoke a javascript function without
+    # parentheses, and it's probably possible to do so without any whitespace
+    # or atom-specials at all
+    #
+    # https://portswigger.net/research/xss-without-parentheses-and-semi-colons
+    my $saw_untagged_bad = 0;
+    imap_cmd_with_tag($talk, '<script>do_attack</script>',
+                             { IdleResponse => 1 },
+                             'noop', 0,
+                             { 'bad' => sub { $saw_untagged_bad++ } });
+
+    # the only acceptable response to this is an untagged BAD or BYE!
+    # any tagged response will reflect an attacker-supplied payload to
+    # the victim
+    $self->assert_num_equals(1, $saw_untagged_bad);
+}
+
+sub test_html_tag_dont_reflect2
+{
+    my ($self) = @_;
+
+    my $talk = $self->{store}->get_client();
+
+    # as above, but with no command!
+    my $saw_untagged_bad = 0;
+    imap_cmd_with_tag($talk, '<script>do_attack</script>',
+                             { IdleResponse => 1 },
+                             '', 0,
+                             { 'bad' => sub { $saw_untagged_bad++ } });
+
+    # the only acceptable response to this is an untagged BAD or BYE!
+    # any tagged response will reflect an attacker-supplied payload to
+    # the victim
+    $self->assert_num_equals(1, $saw_untagged_bad);
+}
+
+sub test_http_headers_bad
+{
+    my ($self) = @_;
+
+    my $talk = $self->{store}->get_client();
+
+    # mimic a HTTP connection sending "key: value\r\n" headers.
+    # make sure one that looks like a valid imap command can't be used
+    # to reset any consecutive error counter, by rejecting the tag
+    my $saw_untagged_bad = 0;
+    imap_cmd_with_tag($talk, 'Accept:',
+                             { IdleResponse => 1 },
+                             'noop', 0,
+                             { 'bad' => sub { $saw_untagged_bad++ } });
+
+    $self->assert_num_equals(1, $saw_untagged_bad);
+}
+
+sub test_http_request_drop_connection
+{
+    my ($self) = @_;
+
+    $self->{store}->disconnect();
+    my $sock = create_client_socket($self->{store}->{address_family},
+                                    $self->{store}->{host},
+                                    $self->{store}->{port});
+
+    my @request = split /\n/, << 'FIN';
+POST /some/url HTTP/1.1
+Host: www.example.com
+User-Agent: Mozilla/5.0 (redacted) Gecko/20100101 Firefox/130.0
+Accept: */*
+Accept-Language: en-US,en;q=0.5
+Accept-Encoding: gzip, deflate
+Content-Type: application/x-www-form-urlencoded
+Content-Length: 15
+Origin: http://www.example.com
+DNT: 1
+Connection: keep-alive
+Referer: http://www.example.com/
+Cookie: chocolate=chips
+
+foo=bar&baz=qux
+FIN
+    foreach my $line (@request) {
+        $sock->send("$line\015\012") or die "send: $!";
+        last if not $sock->connected();
+    }
+
+    # if the connection hasn't been dropped already, send a logout so the
+    # test doesn't hang
+    $sock->send(". logout\015\012") if $sock->connected();
+
+    my @response;
+    while (defined(my $line = $sock->getline())) {
+        $line =~ s/\015?\012//;
+        push @response, $line;
+    }
+
+    # double check that our request contained more lines than cyrus'
+    # syntax error limit of 10
+    $self->assert_num_gt(10, scalar @request);
+
+    # cyrus should have dropped the connection before we sent all the lines
+    $self->assert_num_lt(scalar @request, scalar @response);
+
+    # cyrus should have dropped the connection at the POST in first line
+    $self->assert_num_equals(0, scalar grep { m/^\* BAD/ } @response);
+
+    # snarky last response back from the server
+    $self->assert_matches(qr{This is an IMAP server}, $response[-1]);
+}
+
+sub test_http_post_drop_connection1
+{
+    my ($self) = @_;
+
+    # get a pristine connection
+    $self->{store}->disconnect();
+    my $talk = $self->{store}->get_client(NoLogin => 1);
+
+    # consume initial capabilities response
+    my ($ok, $capability) = $talk->_parse_response('', { IdleResponse => 1 });
+    $self->assert_str_equals('ok', $ok);
+    $self->assert_str_equals('capability', $capability);
+
+    # mimic a HTTP client sending "POST / HTTP/1.1\r\n" command,
+    # expect "* BYE This is an IMAP server" and disconnect
+    # throws "IMAPTalk: Connection was unexpectedly closed by host"
+    eval {
+        imap_cmd_with_tag($talk, 'POST',
+                                 '/', 0, '/',
+                                 'HTTP/1.1');
+    };
+    # XXX can't see the real exception text cause cass obscures it,
+    # XXX but there should have at least been some exception
+    $self->assert_not_null($@);
+    $self->assert_str_equals('This is an IMAP server',
+                             $talk->get_response_code('bye'));
+
+    # should be back to unconnected state
+    $self->assert_num_equals(0, $talk->state());
+}
+
+sub test_http_post_drop_connection2
+{
+    my ($self) = @_;
+
+    # get a pristine connection
+    $self->{store}->disconnect();
+    my $talk = $self->{store}->get_client(NoLogin => 1);
+
+    # consume initial capabilities response
+    my ($ok, $capability) = $talk->_parse_response('', { IdleResponse => 1 });
+    $self->assert_str_equals('ok', $ok);
+    $self->assert_str_equals('capability', $capability);
+
+    # as above, but mimic a HTTP connection trying sneak a POST request
+    # past by requesting a resource whose name is a valid IMAP command
+    # which accepts an argument, e.g. "POST authenticate HTTP/1.1\r\n"
+    eval {
+        imap_cmd_with_tag($talk, 'POST',
+                                 'authenticate', 0, 'authenticate',
+                                 'HTTP/1.1');
+    };
+    # XXX can't see the real exception text cause cass obscures it,
+    # XXX but there should have at least been some exception
+    $self->assert_not_null($@);
+    $self->assert_str_equals('This is an IMAP server',
+                             $talk->get_response_code('bye'));
+
+    # should be back to unconnected state
+    $self->assert_num_equals(0, $talk->state());
+}
+
+sub test_http_post_drop_connection3
+    :TLS :needs_dependency_openssl
+{
+    my ($self) = @_;
+
+    # get a pristine connection
+    $self->{store}->disconnect();
+    my $talk = $self->{store}->get_client(NoLogin => 1);
+
+    # first command after STARTTLS should be treated same as first command
+    $talk->_imap_cmd('starttls', 0, 'starttls');
+    $self->assert_str_equals('ok', $talk->get_last_completion_response());
+    my $ca_file = abs_path("data/certs/cacert.pem");
+    IO::Socket::SSL->start_SSL($talk->{Socket},
+                               SSL_ca_file => $ca_file,
+                               SSL_verifycn_scheme => 'none',
+    );
+    $self->assert_str_equals('IO::Socket::SSL', ref $talk->{Socket});
+
+    # mimic a HTTP client sending "POST / HTTP/1.1\r\n" command,
+    # expect "* BYE This is an IMAP server" and disconnect
+    # throws "IMAPTalk: Connection was unexpectedly closed by host"
+    eval {
+        imap_cmd_with_tag($talk, 'POST',
+                                 '/', 0, '/',
+                                 'HTTP/1.1');
+    };
+    # XXX can't see the real exception text cause cass obscures it,
+    # XXX but there should have at least been some exception
+    $self->assert_not_null($@);
+    $self->assert_str_equals('This is an IMAP server',
+                             $talk->get_response_code('bye'));
+
+    # should be back to unconnected state
+    $self->assert_num_equals(0, $talk->state());
+}
+
+sub test_imap_http_methods_ok
+{
+    my ($self) = @_;
+
+    # get a normal, already logged in IMAP connection
+    my $talk = $self->{store}->get_client();
+
+    my @http_methods = qw(
+        ACL BIND LOCK MKCALENDAR MKCOL PATCH POST
+        PROPFIND PROPPATCH PUT REPORT SEARCH UNBIND
+    );
+
+    # HTTP method names are not forbidden tags during a normal IMAP session
+    foreach my $meth (@http_methods) {
+        imap_cmd_with_tag($talk, $meth, 'noop', 0, 'noop');
+        $self->assert_str_equals('ok', $talk->get_last_completion_response());
+    }
+}
+
+1;