lib/PublicInbox/ContentId.pm

   1 # Copyright (C) 2018 all contributors <meta@public-inbox.org>
   2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   3
   4 package PublicInbox::ContentId;
   5 use strict;
   6 use warnings;
   7 use base qw/Exporter/;
   8 our @EXPORT_OK = qw/content_id content_digest/;
   9 use PublicInbox::MID qw(mids references);
  10 use PublicInbox::MsgIter;
  11
  12 # not sure if less-widely supported hash families are worth bothering with
  13 use Digest::SHA;
  14
  15 sub digest_addr ($$$) {
  16         my ($dig, $h, $v) = @_;
  17         $v =~ tr/"//d;
  18         $v =~ s/@([a-z0-9\_\.\-\(\)]*([A-Z])\S*)/'@'.lc($1)/ge;
  19         utf8::encode($v);
  20         $dig->add("$h\0$v\0");
  21 }
  22
  23 sub content_digest ($) {
  24         my ($mime) = @_;
  25         my $dig = Digest::SHA->new(256);
  26         my $hdr = $mime->header_obj;
  27
  28         # References: and In-Reply-To: get used interchangeably
  29         # in some "duplicates" in LKML.  We treat them the same
  30         # in SearchIdx, so treat them the same for this:
  31         my %seen;
  32         foreach my $mid (@{mids($hdr)}) {
  33                 # do NOT consider the Message-ID as part of the content_id
  34                 # if we got here, we've already got Message-ID reuse
  35                 $seen{$mid} = 1;
  36         }
  37         foreach my $mid (@{references($hdr)}) {
  38                 next if $seen{$mid};
  39                 $dig->add("ref\0$mid\0");
  40         }
  41
  42         # Only use Sender: if From is not present
  43         foreach my $h (qw(From Sender)) {
  44                 my @v = $hdr->header($h);
  45                 if (@v) {
  46                         digest_addr($dig, $h, $_) foreach @v;
  47                 }
  48         }
  49         foreach my $h (qw(Subject Date)) {
  50                 my @v = $hdr->header($h);
  51                 foreach my $v (@v) {
  52                         utf8::encode($v);
  53                         $dig->add("$h\0$v\0");
  54                 }
  55         }
  56         # Some mail processors will add " to unquoted names that were
  57         # not in the original message.  For the purposes of deduplication,
  58         # do not take it into account:
  59         foreach my $h (qw(To Cc)) {
  60                 my @v = $hdr->header($h);
  61                 digest_addr($dig, $h, $_) foreach @v;
  62         }
  63         msg_iter($mime, sub {
  64                 my ($part, $depth, @idx) = @{$_[0]};
  65                 $dig->add("\0$depth:".join('.', @idx)."\0");
  66                 my $fn = $part->filename;
  67                 if (defined $fn) {
  68                         utf8::encode($fn);
  69                         $dig->add("fn\0$fn\0");
  70                 }
  71                 my @d = $part->header('Content-Description');
  72                 foreach my $d (@d) {
  73                         utf8::encode($d);
  74                         $dig->add("d\0$d\0");
  75                 }
  76                 $dig->add("b\0");
  77                 my $ct = $part->content_type || 'text/plain';
  78                 my $s = eval { $part->body_str };
  79                 if ($@ && $ct =~ m!\btext/plain\b!i) {
  80                         # Try to assume UTF-8 because Alpine
  81                         # seems to do wacky things and set
  82                         # charset=X-UNKNOWN
  83                         $part->charset_set('UTF-8');
  84                         $s = eval { $part->body_str };
  85                 }
  86                 if (defined $s) {
  87                         $s =~ s/\r\n/\n/gs;
  88                         $s =~ s/\s*\z//s;
  89                         utf8::encode($s);
  90                 } else {
  91                         $s = $part->body;
  92                 }
  93                 $dig->add($s);
  94         });
  95         $dig;
  96 }
  97
  98 sub content_id ($) {
  99         content_digest($_[0])->digest;
 100 }
 101
 102 1;