lib/PublicInbox/Mbox.pm

   1 # Copyright (C) 2015 all contributors <meta@public-inbox.org>
   2 # License: AGPLv3 or later (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/;
  10 use URI::Escape qw/uri_escape_utf8/;
  11 use Plack::Util;
  12 require Email::Simple;
  13
  14 sub emit1 {
  15         my $simple = Email::Simple->new(pop);
  16         my $ctx = pop;
  17         sub {
  18                 my ($response) = @_;
  19                 # single message should be easily renderable in browsers
  20                 my $fh = $response->([200, ['Content-Type'=>'text/plain']]);
  21                 emit_msg($ctx, $fh, $simple);
  22                 $fh->close;
  23         }
  24 }
  25
  26 sub emit_msg {
  27         my ($ctx, $fh, $simple) = @_; # Email::Simple object
  28         my $header_obj = $simple->header_obj;
  29
  30         # drop potentially confusing headers, ssoma already should've dropped
  31         # Lines and Content-Length
  32         foreach my $d (qw(Lines Bytes Content-Length Status)) {
  33                 $header_obj->header_set($d);
  34         }
  35         my $ibx = $ctx->{-inbox};
  36         my $base = $ibx->base_url($ctx->{cgi});
  37         my $mid = mid_clean($header_obj->header('Message-ID'));
  38         $mid = uri_escape_utf8($mid);
  39         my @append = (
  40                 'Archived-At', "<$base$mid/>",
  41                 'List-Archive', "<$base>",
  42                 'List-Post', "<mailto:$ibx->{-primary_address}>",
  43         );
  44         my $append = '';
  45         my $crlf = $simple->crlf;
  46         for (my $i = 0; $i < @append; $i += 2) {
  47                 my $k = $append[$i];
  48                 my $v = $append[$i + 1];
  49                 my @v = $header_obj->header($k);
  50                 foreach (@v) {
  51                         if ($v eq $_) {
  52                                 $v = undef;
  53                                 last;
  54                         }
  55                 }
  56                 $append .= "$k: $v$crlf" if defined $v;
  57         }
  58         my $buf = $header_obj->as_string;
  59         unless ($buf =~ /\AFrom /) {
  60                 $fh->write("From mboxrd\@z Thu Jan  1 00:00:00 1970\n");
  61         }
  62         $append .= $crlf;
  63         $fh->write($buf .= $append);
  64
  65         $buf = $simple->body;
  66         $simple->body_set('');
  67
  68         # mboxrd quoting style
  69         # ref: http://www.qmail.org/man/man5/mbox.html
  70         $buf =~ s/^(>*From )/>$1/gm;
  71
  72         $fh->write($buf .= "\n");
  73 }
  74
  75 sub noop {}
  76
  77 sub thread_mbox {
  78         my ($ctx, $srch, $sfx) = @_;
  79         eval { require IO::Compress::Gzip };
  80         return sub { need_gzip(@_) } if $@;
  81
  82         my $cb = sub { $srch->get_thread($ctx->{mid}, @_) };
  83         # http://www.iana.org/assignments/media-types/application/gzip
  84         [200, ['Content-Type' => 'application/gzip'],
  85                 PublicInbox::MboxGz->new($ctx, $cb) ];
  86 }
  87
  88 sub emit_range {
  89         my ($ctx, $range) = @_;
  90
  91         eval { require IO::Compress::Gzip };
  92         return sub { need_gzip(@_) } if $@;
  93         my $query;
  94         if ($range eq 'all') { # TODO: YYYY[-MM]
  95                 $query = '';
  96         } else {
  97                 return [404, [qw(Content-Type text/plain)], []];
  98         }
  99         my $cb = sub { $ctx->{srch}->query($query, @_) };
 100
 101         # http://www.iana.org/assignments/media-types/application/gzip
 102         [200, [qw(Content-Type application/gzip)],
 103                 PublicInbox::MboxGz->new($ctx, $cb) ];
 104 }
 105
 106 sub need_gzip {
 107         my $fh = $_[0]->([501, ['Content-Type' => 'text/html']]);
 108         my $title = 'gzipped mbox not available';
 109         $fh->write(<<EOF);
 110 <html><head><title>$title</title><body><pre>$title
 111 The administrator needs to install the IO::Compress::Gzip Perl module
 112 to support gzipped mboxes.
 113 <a href="../">Return to index</a></pre></body></html>
 114 EOF
 115         $fh->close;
 116 }
 117
 118 1;
 119
 120 package PublicInbox::MboxGz;
 121 use strict;
 122 use warnings;
 123 use PublicInbox::MID qw(mid2path);
 124
 125 sub new {
 126         my ($class, $ctx, $cb) = @_;
 127         my $buf;
 128         bless {
 129                 buf => \$buf,
 130                 gz => IO::Compress::Gzip->new(\$buf, Time => 0),
 131                 cb => $cb,
 132                 ctx => $ctx,
 133                 msgs => [],
 134                 opts => { asc => 1, offset => 0 },
 135         }, $class;
 136 }
 137
 138 sub _flush_buf {
 139         my ($self) = @_;
 140         my $ret = $self->{buf};
 141         $ret = $$ret;
 142         ${$self->{buf}} = undef;
 143         $ret;
 144 }
 145
 146 # called by Plack::Util::foreach or similar
 147 sub getline {
 148         my ($self) = @_;
 149         my $res;
 150         my $ctx = $self->{ctx};
 151         my $git = $ctx->{git};
 152         do {
 153                 while (defined(my $smsg = shift @{$self->{msgs}})) {
 154                         my $msg = eval {
 155                                 my $p = 'HEAD:'.mid2path($smsg->mid);
 156                                 Email::Simple->new($git->cat_file($p));
 157                         };
 158                         $msg or next;
 159
 160                         PublicInbox::Mbox::emit_msg($ctx, $self->{gz}, $msg);
 161                         my $ret = _flush_buf($self);
 162                         return $ret if $ret;
 163                 }
 164                 $res = $self->{cb}->($self->{opts});
 165                 $self->{msgs} = $res->{msgs};
 166                 $res = scalar @{$self->{msgs}};
 167                 $self->{opts}->{offset} += $res;
 168         } while ($res);
 169         $self->{gz}->close;
 170         _flush_buf($self);
 171 }
 172
 173 sub close {} # noop
 174
 175 1;