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