Bivio::Mail::Incoming
# Copyright (c) 1999-2012 bivio Software, Inc. All rights reserved.
# $Id$
package Bivio::Mail::Incoming;
use strict;
use Bivio::Base 'Mail.Common';
use IO::Scalar ();
require 'ctime.pl';
our($_TRACE);
b_use('IO.Trace');
my($_A) = b_use('Mail.Address');
my($_DT) = b_use('Type.DateTime');
my($_RFC) = b_use('Mail.RFC822');
my($_MS) = b_use('Type.MailSubject');
my($_E) = b_use('Type.Email');
my($_EA) = b_use('Type.EmailArray');
my($_M) = b_use('Biz.Model');
my($_SA) = b_use('Type.StringArray');
my($_MI) = b_use('Type.MessageId');
sub NO_MESSAGE_ID {
return 'no-message-id';
}
sub get_body {
my($self, $body) = @_;
# Returns the body of the message or puts a copy in I<body>.
return substr(${$self->get('rfc822')}, $self->get('body_offset'))
unless defined($body);
$$body = substr(${$self->get('rfc822')}, $self->get('body_offset'));
return;
}
sub get_date_time {
my($self) = @_;
# Returns the date specified by the message
return $self->get_if_exists_else_put(date_time => sub {
return ($_DT->from_literal(_get_field($self, 'date:') || $_DT->now))[0]
|| $_DT->now;
});
}
sub get_from {
my($self) = @_;
# Return <I>From:</I> email address and name or just email if not array context.
# 822: The "Sender" field mailbox should NEVER be used
# automatically, in a recipient's reply message.
return _two_parter(
$self,
qw(from_email from_name),
['from:', 'apparently-from:'],
);
}
sub get_from_user_id {
my($self, $req) = @_;
return b_use('Model.Email')->new($req)
->unsafe_user_id_from_email(($self->get_from)[0]);
}
sub get_headers {
my($self, $headers) = @_;
# Returns a hash of headers. The key is a the field name in lower case sans the
# colon. The value is the field name in original case followed by the field
# value, i.e. the original text. If a header appears multiple times, its
# value will be a scalar contain all instances of the field.
#
# Note: the field values include the terminating newline.
#
# If I<headers> is undefined, a new hash will be created. If I<headers> is
# defined, fills in and returns I<headers>.
$headers ||= {};
my($fn) = $_RFC->FIELD_NAME;
# Important to include the newline in $f
foreach my $f (split(/^(?=$fn)/om, $self->get('header'))) {
my($n) = $f =~ /^($fn)/o;
unless (defined($n)) {
Bivio::IO::Alert->warn($f, ': invalid RFC822 field');
next;
}
$n =~ s/:$//;
$headers->{lc($n)} .= $f;
}
return $headers;
}
sub get_message_id {
my($self) = @_;
# Returns the Message-Id for this message.
return $self->get_if_exists_else_put(message_id => sub {
my($id) = _get_field($self, 'message-id:') =~ /<([^<>]+)>/;
return _check_message_id($self, $id, 'Message-Id')
|| $self->NO_MESSAGE_ID;
});
}
sub get_references {
my($self) = @_;
# Return sorted array of message ids this message refers to.
#
# The first id in the array returned is either the "In-Reply-To" value
# or (if In-Reply-To does not exist) the last (most recent) id in the
# "References" list.
return $self->get_if_exists_else_put(references => sub {
my($seen) = {};
return [map({
my($which) = $_;
map(
$seen->{$_}++ ? () : _check_message_id($self, $_, $which),
reverse(_get_field($self, "$which:") =~ /<([^<>]+)>/g),
);
} qw(In-Reply-To References))];
});
}
sub get_reply_email_arrays {
my($self, $who, $canonical_email, $realm_emails, $req) = @_;
return ($_EA->new($canonical_email), $_EA->new([]))
unless ref($self) and !$who->eq_realm;
my($reply_to) = lc($self->get_reply_to || '');
$reply_to = undef
if grep($_E->is_equal($reply_to, $_), @$realm_emails);
my($from) = lc($reply_to || $self->get_from);
return ($_EA->new([$from]), $_EA->new([]))
if $who->eq_author;
my($dups) = {
@{$_M->new($req, 'RealmEmailList')->get_recipients(
sub {shift->get('Email.email') => 1},
)},
map($_ ? ($_ => 1) : (), @$realm_emails),
};
my($to, $cc) = map(
$_EA->new([
grep(!$dups->{$_},
map(lc($_), @{$_A->parse_list(_get_field($self, "$_:"))})),
]),
qw(to cc),
);
$to = $to->append($from)
unless $dups->{$from};
if ($to->as_length) {
$cc = $cc->append($canonical_email);
}
else {
$to = $to->append($canonical_email);
}
return ($to, $cc);
}
sub get_reply_subject {
my($self) = @_;
my($s) = ($_MS->clean_and_trim(_get_field($self, 'subject:')))[0]
|| $_MS->EMPTY_VALUE;
return 'Re: ' . $s;
}
sub get_reply_to {
my($self) = @_;
# Return I<Reply-To:> email address and name or just email
# if not array context.
return _two_parter(
$self,
qw(reply_to_email reply_to_name),
['reply-to:'],
);
}
sub get_rfc822 {
my($self) = @_;
# I was not sure what to call this method. Basically, you want it to return
# the entire RFC822, offset by the header_offset.
return substr(${$self->get('rfc822')}, $self->get('header_offset'));
}
sub get_rfc822_io {
my($self) = @_;
# Return IO::File opend
#TODO: Read only?
my($file) = IO::Scalar->new($self->get('rfc822'));
#TODO: setpos uses opaque ; SEEK whence?
$file->setpos($self->get('header_offset'));
return $file;
}
sub get_rfc822_length {
# Returns length of C<rfc822>.
return shift->get('rfc822_length');
}
sub get_subject {
my($self) = @_;
# Returns I<Subject> of message or C<undef>.
return $self->get_if_exists_else_put(
subject => sub {
my($subject) = _get_field($self, 'subject:');
return undef
unless length($subject);
$subject =~ s/^\s+|\s+$//sg;
return $subject;
});
}
sub get_unix_mailbox {
my($self, $buffer, $offset) = @_;
# Returns the message in unix mailbox format. Always ends in a newline.
# ctime already has newline
return 'From unknown ' . ctime($self->get('time'))
. substr(${$self->get('rfc822')}, $self->get('header_offset'))
. (substr(${$self->get('rfc822')}, -1) eq "\n" ? '' : "\n");
}
sub grep_headers {
my($self, $key_re, $value_re) = @_;
my($headers) = $self->get_headers;
return [grep($_ =~ $key_re && $headers->{$_} =~ $value_re, keys(%$headers))];
}
sub initialize {
my($self, $rfc822, $offset) = @_;
$rfc822 = $rfc822->get_rfc822
if Bivio::UNIVERSAL->is_blesser_of($rfc822);
my($r) = ref($rfc822) ? $rfc822 : \$rfc822;
# Initializes the object with the reference supplied.
#
# Note: the reference to I<rfc822> will be retained, so do not modify this value
# until L<uninitialize|"uninitialize"> has been called or the object is
# destroyed.
$offset ||= 0;
my($i) = index($$r, "\n\n", $offset);
my($h);
if (substr($$r, $offset, 5) eq 'From ') {
# Skip Unix From line
$offset = index($$r, "\n", $offset) + 1;
}
if ($i >= 0) {
$i -= $offset;
$h = substr($$r, $offset, $i + 1);
# Account for \n\n
$i += 2 + $offset;
}
else {
$i = length($$r) - $offset;
$h = substr($$r, $offset, $i + 1);
}
#TODO: Handle "From " start lines.
#TODO: Don't unfold headers in advance. Unfold headers as they
# are parsed. This makes resent mail messages cleaner.
# unfold all headers in advance. Makes other code simpler.
#
# [rfc882] Unfolding is accomplished by regarding CRLF immediately
# followed by a LWSP-char as equivalent to the LWSP-char.
# Can't use \s, because isn't locale specific.
# TODO: Not handling quoted CRLF sequences which appear to be legitimate.
# The effect will be to lose quoted LF and replace it with a
# quoted space.
$h =~ s/\r?\n[ \t]/ /gs;
return $self->put(
rfc822 => $r,
header => $h,
header_offset => $offset,
rfc822_length => length($$r) - $offset,
# If there is no body, get_body will return empty string.
body_offset => $i,
time => time,
);
}
sub is_duplicate {
my($self, $req) = @_;
my($res) = 0;
my($count) = 0;
my($headers, $body, $date_time) = (
$self->get_headers,
$self->get_body,
$self->get_date_time,
);
my($cfg) = $self->internal_get_config;
b_use('Model.RealmMail')->new($req)->set_ephemeral->do_iterate(
sub {
my($rm) = @_;
return 0 if ++$count > 10;
my($rf) = $rm->get_model('RealmFile');
return 1
if abs($_DT->diff_seconds(
$date_time,
$rf->get('modified_date_time')
)) > 3600;
my($mi) = $self->new($rf->get_content);
my($mih) = $mi->get_headers;
if (
$mi->get_body eq $body
&& ($cfg->{dedup_ignores_recipients} || (
$mih->{to} eq $headers->{to}
&& ($mih->{cc} // '') eq ($headers->{cc} // '')
)),
) {
$res = 1;
return 0;
}
return 1;
},
'realm_file_id DESC',
);
return $res;
}
sub is_forwarding_loop {
my($self) = @_;
return $self->get('header') =~ $self->FORWARDING_HDR_RE && $1 > 3 ? 1 : 0;
}
sub new {
# Create an instance and L<initialize|"initialize"> with I<rfc822>.
# Default I<offset> is 0.
#
# Note: the reference to I<rfc822> will be retained, so do not modify this value
# until L<uninitialize|"uninitialize"> has been called or the object is
# destroyed.
return shift->SUPER::new->initialize(@_);
}
sub send {
my($self, $req) = shift->internal_req(@_);
# Send the mail message to the specified recipients (see
# L<set_recipients|"set_recipients">). The headers
# and body remain unchanged, even C<Sender:>. This should be used
# for "alias-like" forwarding only.
Bivio::IO::Alert->warn_deprecated('convert to Outgoing to send');
return $self->SUPER::send(
undef,
$self->get(qw(rfc822 header_offset)),
($self->get_from)[0],
$req,
);
}
sub uninitialize {
# Clear any state associated with this object.
shift->delete_all;
return;
}
sub _check_message_id {
my($self, $id, $which) = @_;
my($v, $e) = $_MI->from_literal($id);
return $v
if $v;
b_warn($id, ": invalid $which; from=", ($self->get_from)[0],
' date=', $_DT->to_string($self->get_date_time));
return;
}
sub _get_field {
my($self, $name) = @_;
return $self->get_if_exists_else_put(
lc($name),
sub {
my($v) = $self->get('header') =~ m{^$name(?: |\t)*(.*)}im;
return defined($v) ? $v : '';
},
);
}
sub _two_parter {
my($self, $field1, $field2, $headers) = @_;
my($f1) = $self->get_if_exists_else_put($field1 => sub {
my($v);
foreach my $f (@$headers) {
last if $v = _get_field($self, $f);
}
my($f1, $f2) = $v ? $_A->parse($v) : ();
$self->put($field2 => $f2);
return $f1;
});
return wantarray ? ($f1, $self->get($field2)) : $f1;
}
1;