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         foreach my $i (0..$#mids) {
  69                 next if length($mids[$i]) <= MAX_MID_SIZE;
  70                 warn "Message-ID: <$mids[$i]> too long, truncating\n";
  71                 $mids[$i] = substr($mids[$i], 0, MAX_MID_SIZE);
  72         }
  73
  74         uniq_mids(\@mids);
  75 }
  76
  77 # last References should be IRT, but some mail clients do things
  78 # out of order, so trust IRT over References iff IRT exists
  79 sub references ($) {
  80         my ($hdr) = @_;
  81         my @mids;
  82         foreach my $f (qw(References In-Reply-To)) {
  83                 my @v = $hdr->header_raw($f);
  84                 foreach my $v (@v) {
  85                         push(@mids, ($v =~ /<([^>]+)>/sg));
  86                 }
  87         }
  88         uniq_mids(\@mids);
  89 }
  90
  91 sub uniq_mids ($) {
  92         my ($mids) = @_;
  93         my @ret;
  94         my %seen;
  95         foreach (@$mids) {
  96                 next if $seen{$_};
  97                 push @ret, $_;
  98                 $seen{$_} = 1;
  99         }
 100         \@ret;
 101 }
 102
 103 # RFC3986, section 3.3:
 104 sub MID_ESC () { '^A-Za-z0-9\-\._~!\$\&\';\(\)\*\+,;=:@' }
 105 sub mid_escape ($) { uri_escape_utf8($_[0], MID_ESC) }
 106
 107 1;