lib/PublicInbox/MID.pm

   1 # Copyright (C) 2015-2018 all contributors <meta@public-inbox.org>
   2 # License: AGPL-3.0+ <https://www.gnu.org/licenses/agpl-3.0.txt>
   3 #
   4 # Various Message-ID-related functions.
   5 package PublicInbox::MID;
   6 use strict;
   7 use warnings;
   8 use base qw/Exporter/;
   9 our @EXPORT_OK = qw/mid_clean id_compress mid2path mid_mime mid_escape MID_ESC
  10         mids references/;
  11 use URI::Escape qw(uri_escape_utf8);
  12 use Digest::SHA qw/sha1_hex/;
  13 use constant {
  14         MID_MAX => 40, # SHA-1 hex length # TODO: get rid of this
  15         MAX_MID_SIZE => 244, # max term size (Xapian limitation) - length('Q')
  16 };
  17
  18 sub mid_clean {
  19         my ($mid) = @_;
  20         defined($mid) or die "no Message-ID";
  21         # MDA->precheck did more checking for us
  22         if ($mid =~ /<([^>]+)>/) {
  23                 $mid = $1;
  24         }
  25         $mid;
  26 }
  27
  28 # this is idempotent
  29 sub id_compress {
  30         my ($id, $force) = @_;
  31
  32         if ($force || $id =~ /[^\w\-]/ || length($id) > MID_MAX) {
  33                 utf8::encode($id);
  34                 return sha1_hex($id);
  35         }
  36         $id;
  37 }
  38
  39 sub mid2path {
  40         my ($mid) = @_;
  41         my ($x2, $x38) = ($mid =~ /\A([a-f0-9]{2})([a-f0-9]{38})\z/);
  42
  43         unless (defined $x38) {
  44                 # compatibility with old links (or short Message-IDs :)
  45                 $mid = mid_clean($mid);
  46                 utf8::encode($mid);
  47                 $mid = sha1_hex($mid);
  48                 ($x2, $x38) = ($mid =~ /\A([a-f0-9]{2})([a-f0-9]{38})\z/);
  49         }
  50         "$x2/$x38";
  51 }
  52
  53 # Only for v1 code paths:
  54 sub mid_mime ($) { mids($_[0]->header_obj)->[0] }
  55
  56 sub mids ($) {
  57         my ($hdr) = @_;
  58         my @mids;
  59         my @v = $hdr->header_raw('Message-Id');
  60         foreach my $v (@v) {
  61                 my @cur = ($v =~ /<([^>]+)>/sg);
  62                 if (@cur) {
  63                         push(@mids, @cur);
  64                 } else {
  65                         push(@mids, $v);
  66                 }
  67         }
  68         uniq_mids(\@mids);
  69 }
  70
  71 # last References should be IRT, but some mail clients do things
  72 # out of order, so trust IRT over References iff IRT exists
  73 sub references ($) {
  74         my ($hdr) = @_;
  75         my @mids;
  76         foreach my $f (qw(References In-Reply-To)) {
  77                 my @v = $hdr->header_raw($f);
  78                 foreach my $v (@v) {
  79                         push(@mids, ($v =~ /<([^>]+)>/sg));
  80                 }
  81         }
  82         uniq_mids(\@mids);
  83 }
  84
  85 sub uniq_mids ($) {
  86         my ($mids) = @_;
  87         my @ret;
  88         my %seen;
  89         foreach my $mid (@$mids) {
  90                 if (length($mid) > MAX_MID_SIZE) {
  91                         warn "Message-ID: <$mid> too long, truncating\n";
  92                         $mid = substr($mid, 0, MAX_MID_SIZE);
  93                 }
  94                 next if $seen{$mid};
  95                 push @ret, $mid;
  96                 $seen{$mid} = 1;
  97         }
  98         \@ret;
  99 }
 100
 101 # RFC3986, section 3.3:
 102 sub MID_ESC () { '^A-Za-z0-9\-\._~!\$\&\';\(\)\*\+,;=:@' }
 103 sub mid_escape ($) { uri_escape_utf8($_[0], MID_ESC) }
 104
 105 1;