t/httpd-unix.t
t/httpd.t
t/hval.t
+t/imap.t
t/imapd-tls.t
t/imapd.t
t/import.t
$self->msg_more(' BODYSTRUCTURE '.fetch_body($eml, 1));
$want->{BODY} and
$self->msg_more(' BODY '.fetch_body($eml));
-
+ if (my $partial = delete $want->{-partial}) {
+ partial_emit($self, $partial, $eml);
+ }
$self->msg_more(")\r\n");
}
\(join('', @$l, "$tag OK List complete\r\n"));
}
+sub eml_index_offs_i { # PublicInbox::Eml::each_part callback
+ my ($p, $all) = @_;
+ my ($eml, undef, $idx) = @$p;
+ if ($idx && lc($eml->ct->{type}) eq 'multipart') {
+ $eml->{imap_bdy} = $eml->{bdy} // \'';
+ }
+ $all->{$idx} = $eml; # $idx => Eml
+}
+
+# prepares an index for BODY[$SECTION_IDX] fetches
+sub eml_body_idx ($$) {
+ my ($eml, $section_idx) = @_;
+ my $idx = $eml->{imap_all_parts} //= do {
+ my $all = {};
+ $eml->each_part(\&eml_index_offs_i, $all, 0, 1);
+ # top-level of multipart, BODY[0] not allowed (nz-number)
+ delete $all->{0};
+ $all;
+ };
+ $idx->{$section_idx};
+}
+
+# BODY[($SECTION_IDX)?(.$SECTION_NAME)?]<$offset.$bytes>
+sub partial_body {
+ my ($eml, $section_idx, $section_name) = @_;
+ if (defined $section_idx) {
+ $eml = eml_body_idx($eml, $section_idx) or return;
+ }
+ if (defined $section_name) {
+ if ($section_name eq 'MIME') {
+ # RFC 3501 6.4.5 states:
+ # The MIME part specifier MUST be prefixed
+ # by one or more numeric part specifiers
+ return unless defined $section_idx;
+ return $eml->header_obj->as_string . "\r\n";
+ }
+ my $bdy = $eml->{bdy} // $eml->{imap_bdy} // \'';
+ $eml = PublicInbox::Eml->new($$bdy);
+ if ($section_name eq 'TEXT') {
+ return $eml->body_raw;
+ } elsif ($section_name eq 'HEADER') {
+ return $eml->header_obj->as_string . "\r\n";
+ } else {
+ die "BUG: bad section_name=$section_name";
+ }
+ }
+ ${$eml->{bdy} // $eml->{imap_bdy} // \''};
+}
+
+# similar to what's in PublicInbox::Eml::re_memo, but doesn't memoize
+# to avoid OOM with malicious users
+sub hdrs_regexp ($) {
+ my ($hdrs) = @_;
+ my $names = join('|', map { "\Q$_" } split(/[ \t]+/, $hdrs));
+ qr/^(?:$names):[ \t]*[^\n]*\r?\n # 1st line
+ # continuation lines:
+ (?:[^:\n]*?[ \t]+[^\n]*\r?\n)*
+ /ismx;
+}
+
+# BODY[($SECTION_IDX.)?HEADER.FIELDS.NOT ($HDRS)]<$offset.$bytes>
+sub partial_hdr_not {
+ my ($eml, $section_idx, $hdrs) = @_;
+ if (defined $section_idx) {
+ $eml = eml_body_idx($eml, $section_idx) or return;
+ }
+ my $str = $eml->header_obj->as_string;
+ my $re = hdrs_regexp($hdrs);
+ $str =~ s/$re//g;
+ $str .= "\r\n";
+}
+
+# BODY[($SECTION_IDX.)?HEADER.FIELDS ($HDRS)]<$offset.$bytes>
+sub partial_hdr_get {
+ my ($eml, $section_idx, $hdrs) = @_;
+ if (defined $section_idx) {
+ $eml = eml_body_idx($eml, $section_idx) or return;
+ }
+ my $str = $eml->header_obj->as_string;
+ my $re = hdrs_regexp($hdrs);
+ join('', ($str =~ m/($re)/g), "\r\n");
+}
+
+sub partial_prepare ($$$) {
+ my ($partial, $want, $att) = @_;
+
+ # recombine [ "BODY[1.HEADER.FIELDS", "(foo", "bar)]" ]
+ # back to: "BODY[1.HEADER.FIELDS (foo bar)]"
+ return unless $att =~ /\ABODY(?:\.PEEK)?\[/s;
+ until (rindex($att, ']') >= 0) {
+ my $next = shift @$want or return;
+ $att .= ' ' . uc($next);
+ }
+ if ($att =~ /\ABODY(?:\.PEEK)?\[
+ ([0-9]+(?:\.[0-9]+)*)? # 1 - section_idx
+ (?:\.(HEADER|MIME|TEXT))? # 2 - section_name
+ \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 3, 4
+ $partial->{$att} = [ \&partial_body, $1, $2, $3, $4 ];
+ } elsif ($att =~ /\ABODY(?:\.PEEK)?\[
+ (?:([0-9]+(?:\.[0-9]+)*)\.)? # 1 - section_idx
+ (?:HEADER\.FIELDS(\.NOT)?)\x20 # 2
+ \(([A-Z0-9\-\x20]+)\) # 3 - hdrs
+ \](?:<([0-9]+)(?:\.([0-9]+))?>)?\z/sx) { # 4 5
+ $partial->{$att} = [ $2 ? \&partial_hdr_not
+ : \&partial_hdr_get,
+ $1, $3, $4, $5 ];
+ } else {
+ undef;
+ }
+}
+
+sub partial_emit ($$$) {
+ my ($self, $partial, $eml) = @_;
+ for my $k (sort keys %$partial) {
+ my ($cb, @args) = @{$partial->{$k}};
+ my ($offset, $len) = splice(@args, -2);
+ # $cb is partial_body|partial_hdr_get|partial_hdr_not
+ my $str = $cb->($eml, @args) // '';
+ if (defined $offset) {
+ if (defined $len) {
+ $str = substr($str, $offset, $len);
+ $k =~ s/\.$len>\z/>/ or warn
+"BUG: unable to remove `.$len>' from `$k'";
+ } else {
+ $str = substr($str, $offset);
+ $len = length($str);
+ }
+ } else {
+ $len = length($str);
+ }
+ $self->msg_more(" $k {$len}\r\n");
+ $self->msg_more($str);
+ }
+}
+
sub cmd_uid_fetch ($$$;@) {
my ($self, $tag, $range, @want) = @_;
my $ibx = $self->{ibx} or return "$tag BAD No mailbox selected\r\n";
if ($want[0] =~ s/\A\(//s) {
$want[-1] =~ s/\)\z//s or return "$tag BAD no rparen\r\n";
}
- my %want = map {;
- my $x = $FETCH_ATT{uc($_)} or return "$tag BAD param: $_\r\n";
- %$x;
- } @want;
+ my (%partial, %want);
+ while (defined(my $att = shift @want)) {
+ $att = uc($att);
+ my $x = $FETCH_ATT{$att};
+ if ($x) {
+ %want = (%want, %$x);
+ } elsif (!partial_prepare(\%partial, \@want, $att)) {
+ return "$tag BAD param: $att\r\n";
+ }
+ }
+ $want{-partial} = \%partial if scalar keys %partial;
my ($beg, $end);
my $msgs = [];
if ($range =~ /\A([0-9]+):([0-9]+)\z/s) {
--- /dev/null
+#!perl -w
+# Copyright (C) 2020 all contributors <meta@public-inbox.org>
+# License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
+use strict;
+use Test::More;
+use PublicInbox::IMAP;
+{
+ my $partial_prepare = \&PublicInbox::IMAP::partial_prepare;
+ my $x = {};
+ my $r = $partial_prepare->($x, [], my $p = 'BODY.PEEK[9]');
+ ok($r, $p);
+ $r = $partial_prepare->($x, [], $p = 'BODY.PEEK[9]<5>');
+ ok($r, $p);
+ $r = $partial_prepare->($x, [], $p = 'BODY.PEEK[9]<5.1>');
+ ok($r, $p);
+ $r = $partial_prepare->($x, [], $p = 'BODY[1.1]');
+ ok($r, $p);
+ $r = $partial_prepare->($x, [], $p = 'BODY[HEADER.FIELDS (DATE FROM)]');
+ ok($r, $p);
+ $r = $partial_prepare->($x, [], $p = 'BODY[HEADER.FIELDS.NOT (TO)]');
+ ok($r, $p);
+ $r = $partial_prepare->($x, [], $p = 'BODY[HEDDER.FIELDS.NOT (TO)]');
+ ok(!$r, "rejected misspelling $p");
+ $r = $partial_prepare->($x, [], $p = 'BODY[1.1.HEADER.FIELDS (TO)]');
+ ok($r, $p);
+ my $partial_body = \&PublicInbox::IMAP::partial_body;
+ my $partial_hdr_get = \&PublicInbox::IMAP::partial_hdr_get;
+ my $partial_hdr_not = \&PublicInbox::IMAP::partial_hdr_not;
+ is_deeply($x, {
+ 'BODY.PEEK[9]' => [ $partial_body, 9, undef, undef, undef ],
+ 'BODY.PEEK[9]<5>' => [ $partial_body, 9, undef, 5, undef ],
+ 'BODY.PEEK[9]<5.1>' => [ $partial_body, 9, undef, 5, 1 ],
+ 'BODY[1.1]' => [ $partial_body, '1.1', undef, undef, undef ],
+ 'BODY[HEADER.FIELDS (DATE FROM)]' => [ $partial_hdr_get,
+ undef, 'DATE FROM', undef, undef ],
+ 'BODY[HEADER.FIELDS.NOT (TO)]' => [ $partial_hdr_not,
+ undef, 'TO', undef, undef ],
+ 'BODY[1.1.HEADER.FIELDS (TO)]' => [ $partial_hdr_get,
+ '1.1', 'TO', undef, undef ],
+ }, 'structure matches expected');
+}
+
+done_testing;
$ret = $mic->fetch_hash($r, 'FLAGS') or BAIL_OUT "FETCH $@";
is_deeply($ret->{1}->{FLAGS}, '', 'no flags');
+ $ret = $mic->fetch_hash($r, 'BODY[1]') or BAIL_OUT "FETCH $@";
+ like($ret->{1}->{'BODY[1]'}, qr/\AThis is a test message/, 'BODY[1]');
+
+ $ret = $mic->fetch_hash($r, 'BODY[1]<1>') or BAIL_OUT "FETCH $@";
+ like($ret->{1}->{'BODY[1]<1>'}, qr/\Ahis is a test message/,
+ 'BODY[1]<1>');
+
+ $ret = $mic->fetch_hash($r, 'BODY[1]<2.3>') or BAIL_OUT "FETCH $@";
+ is($ret->{1}->{'BODY[1]<2>'}, "is ", 'BODY[1]<2.3>');
+ $ret = $mic->bodypart_string($r, 1, 3, 2) or
+ BAIL_OUT "bodypart_string $@";
+ is($ret, "is ", 'bodypart string');
+
+ $ret = $mic->fetch_hash($r, 'BODY[HEADER.FIELDS.NOT (Message-ID)]')
+ or BAIL_OUT "FETCH $@";
+ $ret = $ret->{1}->{'BODY[HEADER.FIELDS.NOT (MESSAGE-ID)]'};
+ unlike($ret, qr/message-id/i, 'Message-ID excluded');
+ like($ret, qr/\r\n\r\n\z/s, 'got header end');
+
+ $ret = $mic->fetch_hash($r, 'BODY[HEADER.FIELDS (Message-ID)]')
+ or BAIL_OUT "FETCH $@";
+ is($ret->{1}->{'BODY[HEADER.FIELDS (MESSAGE-ID)]'},
+ 'Message-ID: <testmessage@example.com>'."\r\n\r\n",
+ 'got only Message-ID');
+
my $bs = $mic->get_bodystructure($r) or BAIL_OUT("bodystructure: $@");
ok($bs, 'got a bodystructure');
is(lc($bs->bodytype), 'text', '->bodytype');
ok($bs, 'BODYSTRUCTURE ok for deeply nested');
$ret = $mic->fetch_hash($uidnext, 'BODY') or BAIL_OUT "FETCH $@";
ok($ret->{$uidnext}->{BODY}, 'got something in BODY');
-});
+
+ # this matches dovecot behavior
+ $ret = $mic->fetch_hash($uidnext, 'BODY[1]') or BAIL_OUT "FETCH $@";
+ is($ret->{$uidnext}->{'BODY[1]'},
+ "testing embedded message harder\r\n", 'BODY[1]');
+ $ret = $mic->fetch_hash($uidnext, 'BODY[2]') or BAIL_OUT "FETCH $@";
+ like($ret->{$uidnext}->{'BODY[2]'},
+ qr/\ADate: Sat, 18 Apr 2020 22:20:20 /, 'BODY[2]');
+
+ $ret = $mic->fetch_hash($uidnext, 'BODY[2.1.1]') or BAIL_OUT "FETCH $@";
+ is($ret->{$uidnext}->{'BODY[2.1.1]'},
+ "testing embedded message\r\n", 'BODY[2.1.1]');
+
+ $ret = $mic->fetch_hash($uidnext, 'BODY[2.1.2]') or BAIL_OUT "FETCH $@";
+ like($ret->{$uidnext}->{'BODY[2.1.2]'}, qr/\AFrom: /,
+ 'BODY[2.1.2] tip matched');
+ like($ret->{$uidnext}->{'BODY[2.1.2]'},
+ # trailing CRLF may vary depending on MIME parser
+ qr/done_testing;(?:\r\n){1,2}\z/,
+ 'BODY[2.1.2] tail matched');
+
+ $ret = $mic->fetch_hash($uidnext, 'BODY[2.HEADER]') or
+ BAIL_OUT "2.HEADER $@";
+ like($ret->{$uidnext}->{'BODY[2.HEADER]'},
+ qr/\ADate: Sat, 18 Apr 2020 22:20:20 /,
+ '2.HEADER of message/rfc822');
+
+ $ret = $mic->fetch_hash($uidnext, 'BODY[2.MIME]') or
+ BAIL_OUT "2.MIME $@";
+ is($ret->{$uidnext}->{'BODY[2.MIME]'}, <<EOF, 'BODY[2.MIME]');
+Content-Type: message/rfc822\r
+Content-Disposition: attachment; filename="embed2x\.eml"\r
+\r
+EOF
+}); # each_inbox
$td->kill;
$td->join;