lib/PublicInbox/MboxReader.pm

   1 # Copyright (C) 2020-2021 all contributors <meta@public-inbox.org>
   2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   3
   4 # reader for mbox variants we support
   5 package PublicInbox::MboxReader;
   6 use strict;
   7 use v5.10.1;
   8 use Data::Dumper;
   9 $Data::Dumper::Useqq = 1; # should've been the default, for bad data
  10
  11 my $from_strict =
  12         qr/^From \S+ +\S+ \S+ +\S+ [^\n:]+:[^\n:]+:[^\n:]+ [^\n:]+\n/sm;
  13
  14 # cf: https://doc.dovecot.org/configuration_manual/mail_location/mbox/
  15 my %status2kw = (F => 'flagged', A => 'answered', R => 'seen', T => 'draft');
  16 # O (old/non-recent), and D (deleted) aren't in JMAP,
  17 # so probably won't be supported by us.
  18 sub mbox_keywords {
  19         my $eml = $_[-1];
  20         my $s = "@{[$eml->header_raw('X-Status'),$eml->header_raw('Status')]}";
  21         my %kw;
  22         $s =~ s/([FART])/$kw{$status2kw{$1}} = 1/sge;
  23         [ sort(keys %kw) ];
  24 }
  25
  26 sub _mbox_from {
  27         my ($mbfh, $from_re, $eml_cb, @arg) = @_;
  28         my $buf = '';
  29         my @raw;
  30         while (defined(my $r = read($mbfh, $buf, 65536, length($buf)))) {
  31                 if ($r == 0) { # close here to check for "curl --fail"
  32                         close($mbfh) or die "error closing mbox: \$?=$? $!";
  33                         @raw = ($buf);
  34                 } else {
  35                         @raw = split(/$from_strict/mos, $buf, -1);
  36                         next if scalar(@raw) == 0;
  37                         $buf = pop(@raw); # last bit may be incomplete
  38                 }
  39                 @raw = grep /[^ \t\r\n]/s, @raw; # skip empty messages
  40                 while (defined(my $raw = shift @raw)) {
  41                         $raw =~ s/^\r?\n\z//ms;
  42                         $raw =~ s/$from_re/$1/gms;
  43                         my $eml = PublicInbox::Eml->new(\$raw);
  44                         $eml_cb->($eml, @arg);
  45                 }
  46                 return if $r == 0; # EOF
  47         }
  48         die "error reading mboxo/mboxrd handle: $!";
  49 }
  50
  51 sub mboxrd {
  52         my (undef, $mbfh, $eml_cb, @arg) = @_;
  53         _mbox_from($mbfh, qr/^>(>*From )/ms, $eml_cb, @arg);
  54 }
  55
  56 sub mboxo {
  57         my (undef, $mbfh, $eml_cb, @arg) = @_;
  58         _mbox_from($mbfh, qr/^>(From )/ms, $eml_cb, @arg);
  59 }
  60
  61 sub _cl_body {
  62         my ($mbfh, $bref, $cl) = @_;
  63         my $body = substr($$bref, 0, $cl, '');
  64         my $need = $cl - length($body);
  65         if ($need > 0) {
  66                 $mbfh or die "E: needed $need bytes after EOF";
  67                 defined(my $r = read($mbfh, $body, $need, length($body))) or
  68                         die "E: read error: $!\n";
  69                 $r == $need or die "E: read $r of $need bytes\n";
  70         }
  71         \$body;
  72 }
  73
  74 sub _extract_hdr {
  75         my ($ref) = @_;
  76         if (index($$ref, "\r\n") < 0 && (my $pos = index($$ref, "\n\n")) >= 0) {
  77                 # likely on *nix
  78                 \substr($$ref, 0, $pos + 2, ''); # sv_chop on $$ref
  79         } elsif ($$ref =~ /\r?\n\r?\n/s) {
  80                 \substr($$ref, 0, $+[0], ''); # sv_chop on $$ref
  81         } else {
  82                 undef
  83         }
  84 }
  85
  86 sub _mbox_cl ($$$;@) {
  87         my ($mbfh, $uxs_from, $eml_cb, @arg) = @_;
  88         my $buf = '';
  89         while (defined(my $r = read($mbfh, $buf, 65536, length($buf)))) {
  90                 if ($r == 0) { # detect "curl --fail"
  91                         close($mbfh) or
  92                                 die "error closing mboxcl/mboxcl2: \$?=$? $!";
  93                         undef $mbfh;
  94                 }
  95                 while (my $hdr = _extract_hdr(\$buf)) {
  96                         $$hdr =~ s/\A[\r\n]*From [^\n]*\n//s or
  97                                 die "E: no 'From ' line in:\n", Dumper($hdr);
  98                         my $eml = PublicInbox::Eml->new($hdr);
  99                         my @cl = $eml->header_raw('Content-Length');
 100                         my $n = scalar(@cl);
 101                         $n == 0 and die "E: Content-Length missing in:\n",
 102                                         Dumper($eml->as_string);
 103                         $n == 1 or die "E: multiple ($n) Content-Length in:\n",
 104                                         Dumper($eml->as_string);
 105                         $cl[0] =~ /\A[0-9]+\z/ or die
 106                                 "E: Content-Length `$cl[0]' invalid\n",
 107                                         Dumper($eml->as_string);
 108                         if (($eml->{bdy} = _cl_body($mbfh, \$buf, $cl[0]))) {
 109                                 $uxs_from and
 110                                         ${$eml->{bdy}} =~ s/^>From /From /sgm;
 111                         }
 112                         $eml_cb->($eml, @arg);
 113                 }
 114                 if ($r == 0) {
 115                         $buf =~ /[^ \r\n\t]/ and
 116                                 warn "W: leftover at end of mboxcl/mboxcl2:\n",
 117                                         Dumper(\$buf);
 118                         return;
 119                 }
 120         }
 121         die "error reading mboxcl/mboxcl2 handle: $!";
 122 }
 123
 124 sub mboxcl {
 125         my (undef, $mbfh, $eml_cb, @arg) = @_;
 126         _mbox_cl($mbfh, 1, $eml_cb, @arg);
 127 }
 128
 129 sub mboxcl2 {
 130         my (undef, $mbfh, $eml_cb, @arg) = @_;
 131         _mbox_cl($mbfh, undef, $eml_cb, @arg);
 132 }
 133
 134 sub new { bless \(my $x), __PACKAGE__ }
 135
 136 sub reads {
 137         my $ifmt = $_[-1];
 138         $ifmt =~ /\Ambox(?:rd|cl|cl2|o)\z/ ? __PACKAGE__->can($ifmt) : undef
 139 }
 140
 141 # all of these support -c for stdout and -d for decompression,
 142 # mutt is commonly distributed with hooks for gz, bz2 and xz, at least
 143 # { foo => '' } means "--foo" is passed to the command-line,
 144 # otherwise { foo => '--bar' } passes "--bar"
 145 my %zsfx2cmd = (
 146         gz => [ qw(GZIP pigz gzip), { rsyncable => '' } ],
 147         bz2 => [ 'bzip2', {} ],
 148         xz => [ 'xz', {} ],
 149         # don't add new entries here unless MUA support is widely available
 150 );
 151
 152 sub zsfx ($) {
 153         my ($pathname) = @_;
 154         my $allow = join('|', keys %zsfx2cmd);
 155         $pathname =~ /\.($allow)\z/ ? $1 : undef;
 156 }
 157
 158 sub zsfx2cmd ($$$) {
 159         my ($zsfx, $decompress, $lei) = @_;
 160         my $x = $zsfx2cmd{$zsfx} // die "BUG: no support for suffix=.$zsfx";
 161         my @info = @$x;
 162         my $cmd_opt = pop @info;
 163         my @cmd = (undef, $decompress ? qw(-dc) : qw(-c));
 164         require PublicInbox::Spawn;
 165         for my $exe (@info) {
 166                 # I think respecting client's ENV{GZIP} is OK, not sure
 167                 # about ENV overrides for other, less-common compressors
 168                 if ($exe eq uc($exe)) {
 169                         $exe = $lei->{env}->{$exe} or next;
 170                 }
 171                 $cmd[0] = PublicInbox::Spawn::which($exe) and last;
 172         }
 173         $cmd[0] // die join(' or ', @info)." missing for .$zsfx";
 174         # push @cmd, @{$cmd_opt->{-default}} if $cmd_opt->{-default};
 175         for my $bool (qw(rsyncable)) {
 176                 my $switch = $cmd_opt->{rsyncable} // next;
 177                 push @cmd, '--'.($switch || $bool);
 178         }
 179         for my $key (qw(rsyncable)) { # support compression level?
 180                 my $switch = $cmd_opt->{$key} // next;
 181                 my $val = $lei->{opt}->{$key} // next;
 182                 push @cmd, $switch, $val;
 183         }
 184         \@cmd;
 185 }
 186
 187 sub zsfxcat ($$$) {
 188         my ($in, $zsfx, $lei) = @_;
 189         my $cmd = zsfx2cmd($zsfx, 1, $lei);
 190         PublicInbox::Spawn::popen_rd($cmd, undef, { 0 => $in, 2 => $lei->{2} });
 191 }
 192
 193 1;