lib/PublicInbox/LeiToMail.pm

   1 # Copyright (C) 2020 all contributors <meta@public-inbox.org>
   2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   3
   4 # Writes PublicInbox::Eml objects atomically to a mbox variant or Maildir
   5 package PublicInbox::LeiToMail;
   6 use strict;
   7 use v5.10.1;
   8 use PublicInbox::Eml;
   9 use PublicInbox::Lock;
  10 use PublicInbox::ProcessPipe;
  11 use PublicInbox::Spawn qw(which spawn);
  12 use Symbol qw(gensym);
  13 use File::Temp ();
  14 use IO::Handle; # ->autoflush
  15
  16 my %kw2char = ( # Maildir characters
  17         draft => 'D',
  18         flagged => 'F',
  19         answered => 'R',
  20         seen => 'S'
  21 );
  22
  23 my %kw2status = (
  24         flagged => [ 'X-Status' => 'F' ],
  25         answered => [ 'X-Status' => 'A' ],
  26         seen => [ 'Status' => 'R' ],
  27         draft => [ 'X-Status' => 'T' ],
  28 );
  29
  30 sub _mbox_hdr_buf ($$$) {
  31         my ($eml, $type, $kw) = @_;
  32         $eml->header_set($_) for (qw(Lines Bytes Content-Length));
  33         my %hdr; # set Status, X-Status
  34         for my $k (@$kw) {
  35                 if (my $ent = $kw2status{$k}) {
  36                         push @{$hdr{$ent->[0]}}, $ent->[1];
  37                 } else { # X-Label?
  38                         warn "TODO: keyword `$k' not supported for mbox\n";
  39                 }
  40         }
  41         while (my ($name, $chars) = each %hdr) {
  42                 $eml->header_set($name, join('', sort @$chars));
  43         }
  44         my $buf = delete $eml->{hdr};
  45
  46         # fixup old bug from import (pre-a0c07cba0e5d8b6a)
  47         $$buf =~ s/\A[\r\n]*From [^\r\n]*\r?\n//s;
  48
  49         substr($$buf, 0, 0, # prepend From line
  50                 "From lei\@$type Thu Jan  1 00:00:00 1970$eml->{crlf}");
  51         $buf;
  52 }
  53
  54 sub write_in_full ($$$) {
  55         my ($fh, $buf, $atomic) = @_;
  56         if ($atomic) {
  57                 defined(my $w = syswrite($fh, $$buf)) or die "write: $!";
  58                 $w == length($$buf) or die "short write: $w != ".length($$buf);
  59         } else {
  60                 print $fh $$buf or die "print: $!";
  61         }
  62 }
  63
  64 sub eml2mboxrd ($;$) {
  65         my ($eml, $kw) = @_;
  66         my $buf = _mbox_hdr_buf($eml, 'mboxrd', $kw);
  67         if (my $bdy = delete $eml->{bdy}) {
  68                 $$bdy =~ s/^(>*From )/>$1/gm;
  69                 $$buf .= $eml->{crlf};
  70                 substr($$bdy, 0, 0, $$buf); # prepend header
  71                 $buf = $bdy;
  72         }
  73         $$buf .= $eml->{crlf};
  74         $buf;
  75 }
  76
  77 sub eml2mboxo {
  78         my ($eml, $kw) = @_;
  79         my $buf = _mbox_hdr_buf($eml, 'mboxo', $kw);
  80         if (my $bdy = delete $eml->{bdy}) {
  81                 $$bdy =~ s/^From />From /gm;
  82                 $$buf .= $eml->{crlf};
  83                 substr($$bdy, 0, 0, $$buf); # prepend header
  84                 $buf = $bdy;
  85         }
  86         $$buf .= $eml->{crlf};
  87         $buf;
  88 }
  89
  90 # mboxcl still escapes "From " lines
  91 sub eml2mboxcl {
  92         my ($eml, $kw) = @_;
  93         my $buf = _mbox_hdr_buf($eml, 'mboxcl', $kw);
  94         my $crlf = $eml->{crlf};
  95         if (my $bdy = delete $eml->{bdy}) {
  96                 $$bdy =~ s/^From />From /gm;
  97                 $$buf .= 'Content-Length: '.length($$bdy).$crlf.$crlf;
  98                 substr($$bdy, 0, 0, $$buf); # prepend header
  99                 $buf = $bdy;
 100         }
 101         $$buf .= $crlf;
 102         $buf;
 103 }
 104
 105 # mboxcl2 has no "From " escaping
 106 sub eml2mboxcl2 {
 107         my ($eml, $kw) = @_;
 108         my $buf = _mbox_hdr_buf($eml, 'mboxcl2', $kw);
 109         my $crlf = $eml->{crlf};
 110         if (my $bdy = delete $eml->{bdy}) {
 111                 $$buf .= 'Content-Length: '.length($$bdy).$crlf.$crlf;
 112                 substr($$bdy, 0, 0, $$buf); # prepend header
 113                 $buf = $bdy;
 114         }
 115         $$buf .= $crlf;
 116         $buf;
 117 }
 118
 119 sub mkmaildir ($) {
 120         my ($maildir) = @_;
 121         for (qw(new tmp cur)) {
 122                 my $d = "$maildir/$_";
 123                 next if -d $d;
 124                 require File::Path;
 125                 if (!File::Path::mkpath($d) && !-d $d) {
 126                         die "failed to mkpath($d): $!\n";
 127                 }
 128         }
 129 }
 130
 131 sub git_to_mail { # git->cat_async callback
 132         my ($bref, $oid, $type, $size, $arg) = @_;
 133         if ($type ne 'blob') {
 134                 if ($type eq 'missing') {
 135                         warn "missing $oid\n";
 136                 } else {
 137                         warn "unexpected type=$type for $oid\n";
 138                 }
 139         }
 140         if ($size > 0) {
 141                 my ($write_cb, $kw) = @$arg;
 142                 $write_cb->($bref, $oid, $kw);
 143         }
 144 }
 145
 146 sub reap_compress { # dwaitpid callback
 147         my ($lei, $pid) = @_;
 148         my $cmd = delete $lei->{"pid.$pid"};
 149         return if $? == 0;
 150         $lei->fail("@$cmd failed", $? >> 8);
 151 }
 152
 153 sub compress_dst {
 154         my ($out, $sfx, $lei) = @_;
 155         my $cmd = [];
 156         if ($sfx eq 'gz') {
 157                 $cmd->[0] = which($lei->{env}->{GZIP} // 'pigz') //
 158                                 which('gzip') //
 159                         die "pigz or gzip missing for $sfx\n";
 160                         # TODO: use IO::Compress::Gzip
 161                 push @$cmd, '-c'; # stdout
 162                 push @$cmd, '--rsyncable' if $lei->{opt}->{rsyncable};
 163         } else {
 164                 die "TODO $sfx"
 165         }
 166         pipe(my ($r, $w)) or die "pipe: $!";
 167         my $rdr = { 0 => $r, 1 => $out, 2 => $lei->{2} };
 168         my $pid = spawn($cmd, $lei->{env}, $rdr);
 169         $lei->{"pid.$pid"} = $cmd;
 170         my $pp = gensym;
 171         tie *$pp, 'PublicInbox::ProcessPipe', $pid, $w, \&reap_compress, $lei;
 172         my $tmp = File::Temp->new("$sfx.lock-XXXXXX", TMPDIR => 1);
 173         my $pipe_lk = ($lei->{opt}->{jobs} // 0) > 1 ? bless({
 174                 lock_path => $tmp->filename,
 175                 tmp => $tmp
 176         }, 'PublicInbox::Lock') : undef;
 177         ($pp, $pipe_lk);
 178 }
 179
 180 sub write_cb {
 181         my ($cls, $dst, $lei) = @_;
 182         if ($dst =~ s!\A(mbox(?:rd|cl|cl2|o))?:!!) {
 183                 my $m = "eml2$1";
 184                 my $eml2mbox = $cls->can($m) or die "$cls->$m missing";
 185                 my ($out, $pipe_lk);
 186                 open $out, '>>', $dst or die "open $dst: $!";
 187                 my $atomic = !!(($lei->{opt}->{jobs} // 0) > 1);
 188                 if ($dst =~ /\.(gz|bz2|xz)\z/) {
 189                         ($out, $pipe_lk) = compress_dst($out, $1, $lei);
 190                 }
 191                 sub {
 192                         my ($buf, $oid, $kw) = @_;
 193                         $buf = $eml2mbox->(PublicInbox::Eml->new($buf), $kw);
 194                         my $lock = $pipe_lk->lock_for_scope if $pipe_lk;
 195                         write_in_full($out, $buf, $atomic);
 196                 }
 197         }
 198 }
 199
 200 1;