$title

X-Git-Url: http://www.git.stargrave.org/?a=blobdiff_plain;f=lib%2FPublicInbox%2FMbox.pm;h=c92d444774cef389fb6f35d0b38b4b3639377aba;hb=f76f265a851944b5dedcc3be5f3b5224b6ebda89;hp=2ec50656e36e7f02cd093db88168270a65d4bdff;hpb=f71e9e9b67a6ff23642ccd119390bd6b3cb0d91e;p=public-inbox.git diff --git a/lib/PublicInbox/Mbox.pm b/lib/PublicInbox/Mbox.pm index 2ec50656..c92d4447 100644 --- a/lib/PublicInbox/Mbox.pm +++ b/lib/PublicInbox/Mbox.pm @@ -1,55 +1,145 @@ -# Copyright (C) 2015, all contributors +# Copyright (C) 2015 all contributors # License: AGPLv3 or later (https://www.gnu.org/licenses/agpl-3.0.txt) -# Streaming interface for formatting messages as an mbox +# Streaming interface for formatting messages as an mboxrd package PublicInbox::Mbox; use strict; use warnings; -use PublicInbox::MID qw/mid_clean mid_compressed mid2path/; -use Fcntl qw(SEEK_SET); +use PublicInbox::MID qw/mid2path/; +require Email::Simple; sub thread_mbox { - my ($ctx, $srch) = @_; - my $mid = mid_compressed($ctx->{mid}); - my $res = $srch->get_thread($mid); - my $msgs = delete $res->{msgs}; - require PublicInbox::GitCatFile; - require Email::Simple; - my $git = PublicInbox::GitCatFile->new($ctx->{git_dir}); + my ($ctx, $srch, $sfx) = @_; + sub { + my ($response) = @_; # Plack callback + emit_mbox($response, $ctx, $srch, $sfx); + } +} +sub emit1 { + my $simple = Email::Simple->new(pop); sub { - my ($res) = @_; # Plack callback - my $w = $res->([200, [ 'Content-Type' => 'text/plain' ] ]); - while (defined(my $smsg = shift @$msgs)) { - my $msg = eval { - my $path = 'HEAD:' . mid2path($smsg->mid); - Email::Simple->new($git->cat_file($path)); - }; - emit($w, $msg) if $msg; - } + my ($response) = @_; + # single message should be easily renderable in browsers + my $fh = $response->([200, ['Content-Type'=>'text/plain']]); + emit_msg($fh, $simple); + $fh->close; } } -sub emit { +sub emit_msg { my ($fh, $simple) = @_; # Email::Simple object + my $header_obj = $simple->header_obj; # drop potentially confusing headers, ssoma already should've dropped # Lines and Content-Length foreach my $d (qw(Lines Content-Length Status)) { - $simple->header_set($d); + $header_obj->header_set($d); } - my $buf = $simple->header_obj->as_string; + my $buf = $header_obj->as_string; unless ($buf =~ /\AFrom /) { - $fh->write("From a\@a Thu Jan 1 00:00:00 1970\n"); + $fh->write("From mboxrd\@z Thu Jan 1 00:00:00 1970\n"); } $fh->write($buf .= $simple->crlf); $buf = $simple->body; $simple->body_set(''); - $buf =~ s/^(From )/>$1/gm; + + # mboxrd quoting style + # ref: http://www.qmail.org/man/man5/mbox.html + $buf =~ s/^(>*From )/>$1/gm; + $buf .= "\n" unless $buf =~ /\n\z/s; $fh->write($buf); } +sub emit_mbox { + my ($response, $ctx, $srch, $sfx) = @_; + my $type = 'mbox'; + if ($sfx) { + eval { require IO::Compress::Gzip }; + return need_gzip($response) if $@; + $type = 'gzip'; + } + + # http://www.iana.org/assignments/media-types/application/gzip + # http://www.iana.org/assignments/media-types/application/mbox + my $fh = $response->([200, ['Content-Type' => "application/$type"]]); + $fh = PublicInbox::MboxGz->new($fh) if $sfx; + + require PublicInbox::GitCatFile; + my $mid = $ctx->{mid}; + my $git = PublicInbox::GitCatFile->new($ctx->{git_dir}); + my %opts = (offset => 0); + my $nr; + do { + my $res = $srch->get_thread($mid, \%opts); + my $msgs = $res->{msgs}; + $nr = scalar @$msgs; + while (defined(my $smsg = shift @$msgs)) { + my $msg = eval { + my $p = 'HEAD:'.mid2path($smsg->mid); + Email::Simple->new($git->cat_file($p)); + }; + emit_msg($fh, $msg) if $msg; + } + + $opts{offset} += $nr; + } while ($nr > 0); + + $fh->close; +} + +sub need_gzip { + my $fh = $_[0]->([501, ['Content-Type' => 'text/html']]); + my $title = 'gzipped mbox not available'; + $fh->write(<$title

$title
+The administrator needs to install the IO::Compress::Gzip Perl module
+to support gzipped mboxes.
+Return to index

+EOF + $fh->close; +} + +1; + +# fh may not be a proper IO, so we wrap the write and close methods +# to prevent IO::Compress::Gzip from complaining +package PublicInbox::MboxGz; +use strict; +use warnings; +use fields qw(gz fh buf); + +sub new { + my ($class, $fh) = @_; + my $self = fields::new($class); + my $buf; + $self->{buf} = \$buf; + $self->{gz} = IO::Compress::Gzip->new(\$buf); + $self->{fh} = $fh; + $self; +} + +sub _flush_buf { + my ($self) = @_; + if (defined ${$self->{buf}}) { + $self->{fh}->write(${$self->{buf}}); + ${$self->{buf}} = undef; + } +} + +sub write { + $_[0]->{gz}->write($_[1]); + _flush_buf($_[0]); +} + +sub close { + my ($self) = @_; + $self->{gz}->close; + _flush_buf($self); + $self->{fh}->close; +} + 1;