lib/PublicInbox/Mbox.pm

   1 # Copyright (C) 2015-2018 all contributors <meta@public-inbox.org>
   2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   3
   4 # Streaming interface for formatting messages as an mboxrd.
   5 # Used by the web interface
   6 package PublicInbox::Mbox;
   7 use strict;
   8 use warnings;
   9 use PublicInbox::MID qw/mid_clean mid_escape/;
  10 use PublicInbox::Hval qw/to_filename/;
  11 use Email::Simple;
  12 use Email::MIME::Encode;
  13
  14 sub subject_fn ($) {
  15         my ($simple) = @_;
  16         my $fn = $simple->header('Subject');
  17         return 'no-subject' unless defined($fn);
  18
  19         # no need for full Email::MIME, here
  20         if ($fn =~ /=\?/) {
  21                 eval { $fn = Encode::decode('MIME-Header', $fn) };
  22                 $fn = 'no-subject' if $@;
  23         }
  24         $fn =~ s/^re:\s+//i;
  25         $fn = to_filename($fn);
  26         $fn eq '' ? 'no-subject' : $fn;
  27 }
  28
  29 sub mb_stream {
  30         my ($more) = @_;
  31         bless $more, 'PublicInbox::Mbox';
  32 }
  33
  34 # called by PSGI server as body response
  35 sub getline {
  36         my ($more) = @_; # self
  37         my ($ctx, $id, $prev, $next, $cur) = @$more;
  38         if ($cur) { # first
  39                 pop @$more;
  40                 return msg_str($ctx, $cur);
  41         }
  42         $cur = $next or return;
  43         my $ibx = $ctx->{-inbox};
  44         $next = $ibx->search->next_by_mid($ctx->{mid}, \$id, \$prev);
  45         @$more = ($ctx, $id, $prev, $next); # $next may be undef, here
  46         my $mref = $ibx->msg_by_smsg($cur) or return;
  47         msg_str($ctx, Email::Simple->new($mref));
  48 }
  49
  50 sub close {} # noop
  51
  52 sub emit_raw {
  53         my ($ctx) = @_;
  54         my $mid = $ctx->{mid};
  55         my $ibx = $ctx->{-inbox};
  56         my $first;
  57         my $more;
  58         if (my $srch = $ibx->search) {
  59                 my ($id, $prev);
  60                 my $smsg = $srch->next_by_mid($mid, \$id, \$prev) or return;
  61                 my $mref = $ibx->msg_by_smsg($smsg) or return;
  62                 $first = Email::Simple->new($mref);
  63                 my $next = $srch->next_by_mid($mid, \$id, \$prev);
  64                 # $more is for ->getline
  65                 $more = [ $ctx, $id, $prev, $next, $first ] if $next;
  66         } else {
  67                 my $mref = $ibx->msg_by_mid($mid) or return;
  68                 $first = Email::Simple->new($mref);
  69         }
  70         return unless defined $first;
  71         my $fn = subject_fn($first);
  72         my @hdr = ('Content-Type');
  73         if ($ibx->{obfuscate}) {
  74                 # obfuscation is stupid, but maybe scrapers are, too...
  75                 push @hdr, 'application/mbox';
  76                 $fn .= '.mbox';
  77         } else {
  78                 push @hdr, 'text/plain';
  79                 $fn .= '.txt';
  80         }
  81         push @hdr, 'Content-Disposition', "inline; filename=$fn";
  82         [ 200, \@hdr, $more ? mb_stream($more) : [ msg_str($ctx, $first) ] ];
  83 }
  84
  85 sub msg_str {
  86         my ($ctx, $simple, $mid) = @_; # Email::Simple object
  87         my $header_obj = $simple->header_obj;
  88
  89         # drop potentially confusing headers, ssoma already should've dropped
  90         # Lines and Content-Length
  91         foreach my $d (qw(Lines Bytes Content-Length Status)) {
  92                 $header_obj->header_set($d);
  93         }
  94         my $ibx = $ctx->{-inbox};
  95         my $base = $ibx->base_url($ctx->{env});
  96         $mid = $ctx->{mid} unless defined $mid;
  97         $mid = mid_escape($mid);
  98         my @append = (
  99                 'Archived-At', "<$base$mid/>",
 100                 'List-Archive', "<$base>",
 101                 'List-Post', "<mailto:$ibx->{-primary_address}>",
 102         );
 103         my $crlf = $simple->crlf;
 104         my $buf = "From mboxrd\@z Thu Jan  1 00:00:00 1970\n" .
 105                         $header_obj->as_string;
 106         for (my $i = 0; $i < @append; $i += 2) {
 107                 my $k = $append[$i];
 108                 my $v = $append[$i + 1];
 109                 my @v = $header_obj->header($k);
 110                 foreach (@v) {
 111                         if ($v eq $_) {
 112                                 $v = undef;
 113                                 last;
 114                         }
 115                 }
 116                 $buf .= "$k: $v$crlf" if defined $v;
 117         }
 118         $buf .= $crlf;
 119
 120         # mboxrd quoting style
 121         # ref: http://www.qmail.org/man/man5/mbox.html
 122         my $body = $simple->body;
 123         $body =~ s/^(>*From )/>$1/gm;
 124         $buf .= $body;
 125         $buf .= "\n";
 126 }
 127
 128 sub thread_mbox {
 129         my ($ctx, $srch, $sfx) = @_;
 130         eval { require IO::Compress::Gzip };
 131         return sub { need_gzip(@_) } if $@;
 132         my $mid = $ctx->{mid};
 133         my $msgs = $srch->get_thread($mid, 0);
 134         return [404, [qw(Content-Type text/plain)], []] if !@$msgs;
 135         my $prev = $msgs->[-1]->{num};
 136         my $i = 0;
 137         my $cb = sub {
 138                 while (1) {
 139                         if (my $smsg = $msgs->[$i++]) {
 140                                 return $smsg;
 141                         }
 142                         # refill result set
 143                         $msgs = $srch->get_thread($mid, $prev);
 144                         return unless @$msgs;
 145                         $prev = $msgs->[-1]->{num};
 146                         $i = 0;
 147                 }
 148         };
 149         PublicInbox::MboxGz->response($ctx, $cb, $msgs->[0]->subject);
 150 }
 151
 152 sub emit_range {
 153         my ($ctx, $range) = @_;
 154
 155         my $query;
 156         if ($range eq 'all') { # TODO: YYYY[-MM]
 157                 $query = '';
 158         } else {
 159                 return [404, [qw(Content-Type text/plain)], []];
 160         }
 161         mbox_all($ctx, $query);
 162 }
 163
 164 sub mbox_all_ids {
 165         my ($ctx) = @_;
 166         my $prev = 0;
 167         my $ids = $ctx->{-inbox}->mm->ids_after(\$prev) or return
 168                 [404, [qw(Content-Type text/plain)], ["No results found\n"]];
 169         my $i = 0;
 170         my $over = $ctx->{srch}->{over_ro};
 171         my $cb = sub {
 172                 do {
 173                         while ((my $num = $ids->[$i++])) {
 174                                 my $smsg = $over->get_art($num) or next;
 175                                 return $smsg;
 176                         }
 177                         $ids = $ctx->{-inbox}->mm->ids_after(\$prev);
 178                         $i = 0;
 179                 } while (@$ids);
 180                 undef;
 181         };
 182         return PublicInbox::MboxGz->response($ctx, $cb, 'all');
 183 }
 184
 185 sub mbox_all {
 186         my ($ctx, $query) = @_;
 187
 188         eval { require IO::Compress::Gzip };
 189         return sub { need_gzip(@_) } if $@;
 190         return mbox_all_ids($ctx) if $query eq '';
 191         my $opts = { mset => 2 };
 192         my $srch = $ctx->{srch};
 193         my $mset = $srch->query($query, $opts);
 194         $opts->{offset} = $mset->size or
 195                         return [404, [qw(Content-Type text/plain)],
 196                                 ["No results found\n"]];
 197         my $i = 0;
 198         my $cb = sub { # called by MboxGz->getline
 199                 while (1) {
 200                         while (my $mi = (($mset->items)[$i++])) {
 201                                 my $doc = $mi->get_document;
 202                                 my $smsg = $srch->retry_reopen(sub {
 203                                         PublicInbox::SearchMsg->load_doc($doc);
 204                                 }) or next;
 205                                 return $smsg;
 206                         }
 207                         # refill result set
 208                         $mset = $srch->query($query, $opts);
 209                         my $size = $mset->size or return;
 210                         $opts->{offset} += $size;
 211                         $i = 0;
 212                 }
 213         };
 214         PublicInbox::MboxGz->response($ctx, $cb, 'results-'.$query);
 215 }
 216
 217 sub need_gzip {
 218         my $fh = $_[0]->([501, ['Content-Type' => 'text/html']]);
 219         my $title = 'gzipped mbox not available';
 220         $fh->write(<<EOF);
 221 <html><head><title>$title</title><body><pre>$title
 222 The administrator needs to install the IO::Compress::Gzip Perl module
 223 to support gzipped mboxes.
 224 <a href="../">Return to index</a></pre></body></html>
 225 EOF
 226         $fh->close;
 227 }
 228
 229 1;
 230
 231 package PublicInbox::MboxGz;
 232 use strict;
 233 use warnings;
 234 use PublicInbox::Hval qw/to_filename/;
 235
 236 sub new {
 237         my ($class, $ctx, $cb) = @_;
 238         my $buf = '';
 239         bless {
 240                 buf => \$buf,
 241                 gz => IO::Compress::Gzip->new(\$buf, Time => 0),
 242                 cb => $cb,
 243                 ctx => $ctx,
 244         }, $class;
 245 }
 246
 247 sub response {
 248         my ($class, $ctx, $cb, $fn) = @_;
 249         my $body = $class->new($ctx, $cb);
 250         # http://www.iana.org/assignments/media-types/application/gzip
 251         my @h = qw(Content-Type application/gzip);
 252         if ($fn) {
 253                 $fn = to_filename($fn);
 254                 push @h, 'Content-Disposition', "inline; filename=$fn.mbox.gz";
 255         }
 256         [ 200, \@h, $body ];
 257 }
 258
 259 # called by Plack::Util::foreach or similar
 260 sub getline {
 261         my ($self) = @_;
 262         my $ctx = $self->{ctx} or return;
 263         while (my $smsg = $self->{cb}->()) {
 264                 my $msg = $ctx->{-inbox}->msg_by_smsg($smsg) or next;
 265                 $msg = Email::Simple->new($msg);
 266                 $self->{gz}->write(PublicInbox::Mbox::msg_str($ctx, $msg,
 267                                 $smsg->{mid}));
 268                 my $bref = $self->{buf};
 269                 if (length($$bref) >= 8192) {
 270                         my $ret = $$bref; # copy :<
 271                         ${$self->{buf}} = '';
 272                         return $ret;
 273                 }
 274
 275                 # be fair to other clients on public-inbox-httpd:
 276                 return '';
 277         }
 278         delete($self->{gz})->close;
 279         # signal that we're done and can return undef next call:
 280         delete $self->{ctx};
 281         ${delete $self->{buf}};
 282 }
 283
 284 sub close {} # noop
 285
 286 1;