File Coverage

lib/Sisimai/Fact.pm

Criterion	Covered	Total	%
statement	288	290	99.3
branch	127	148	85.8
condition	107	140	76.4
subroutine	23	23	100.0
pod	2	4	50.0
total	547	605	90.4

package Sisimai::Fact;
use v5.26;
use strict;
use warnings;
use Digest::SHA;
use Sisimai::Message;
use Sisimai::RFC791;
use Sisimai::RFC1123;
use Sisimai::RFC1894;
use Sisimai::RFC5322;
use Sisimai::Reason;
use Sisimai::Address;
use Sisimai::DateTime;
use Sisimai::Time;
use Sisimai::SMTP::Command;
use Sisimai::SMTP::Failure;
use Sisimai::String;
use Sisimai::Rhost;
use Sisimai::LDA;
use Class::Accessor::Lite ('new' => 0, 'rw' => [
    'action',           # [String] The value of Action: header
    'addresser',        # [Sisimai::Address] From address
    'alias',            # [String] Alias of the recipient address
    'bogus',            # [Integer] EXPERIMENTAL
    'catch',            # [?] Results generated by hook method
    'command',          # [String] The last SMTP command
    'decodedby',        # [String] MTA Module name since v5.2.0
    'deliverystatus',   # [String] Delivery Status(DSN)
    'destination',      # [String] The domain part of the "recipient"
    'diagnosticcode',   # [String] Diagnostic-Code: Header
    'diagnostictype',   # [String] The 1st part of Diagnostic-Code: Header
    'feedbackid',       # [String] The value of Feedback-ID: header of the original message
    'feedbacktype',     # [String] Feedback Type
    'hardbounce',       # [Integer] 1 = Hard bounce, 0 = Is not a hard bounce
    'lhost',            # [String] local host name/Local MTA
    'listid',           # [String] List-Id header of each ML
    'messageid',        # [String] Message-Id: header
    'origin',           # [String] Email path as a data source
    'reason',           # [String] Bounce reason
    'recipient',        # [Sisimai::Address] Recipient address which bounced
    'replycode',        # [String] SMTP Reply Code
    'rhost',            # [String] Remote host name/Remote MTA
    'senderdomain',     # [String] The domain part of the "addresser"
    'subject',          # [String] UTF-8 Subject text
    'timestamp',        # [Sisimai::Time] Date: header in the original message
    'timezoneoffset',   # [Integer] Time zone offset(seconds)
    'token',            # [String] Message token/MD5 Hex digest value
    'toxic',            # [Integer] EXPERIMENTAL
]);

sub rise {
    # Constructor of Sisimai::Fact
    # @param         [Hash]   argvs
    # @options argvs [String]  data         Entire email message
    # @options argvs [Integer] delivered    1 if the result which has "delivered" reason is included
    # @options argvs [Integer] vacation     1 if the result which has "vacation" reason is included
    # @options argvs [Code]    hook         Code reference to callback method
    # @options argvs [String]  origin       Path to the original email file
    # @return        [Array]                Array of Sisimai::Fact objects
    my $class = shift;
    my $argvs = shift || return undef;
    die ' ***error: Sisimai::Fact->rise receives only a HASH reference as an argument' unless ref $argvs eq 'HASH';

    my $email = $argvs->{'data'} || return undef;
    my $args1 = {'data' => $email, 'hook' => $argvs->{'hook'}};
    my $mesg1 = Sisimai::Message->rise($args1) || return undef;

    return undef unless $mesg1->{'ds'};
    return undef unless $mesg1->{'rfc822'};

    state $retryindex = Sisimai::Reason->retry;
    state $rfc822head = Sisimai::RFC5322::HEADERTABLE;
    state $actionlist = {'delayed' => 1, 'delivered' => 1, 'expanded' => 1, 'failed' => 1, 'relayed' => 1};
    my    $rfc822data = $mesg1->{'rfc822'};
    my    $listoffact = [];

    RISEOF: for my $e ( $mesg1->{'ds'}->@* ) {
        # Create parameters
        next if length $e->{'recipient'} < 5;
        next if ! $argvs->{'delivered'} && index($e->{'status'}, '2.') == 0;
        next if ! $argvs->{'vacation'}  && $e->{'reason'} eq 'vacation';

        my $thing = {}; # To be blessed and pushed into the array above at the end of the loop
        my $piece = {
            'action'         => $e->{'action'}       // '',
            'alias'          => $e->{'alias'}        // '',
            'catch'          => $mesg1->{'catch'}    // undef,
            'decodedby'      => $e->{'agent'}        // '',
            'deliverystatus' => $e->{'status'}       // '',
            'diagnosticcode' => $e->{'diagnosis'}    // '',
            'diagnostictype' => $e->{'spec'}         // '',
            'feedbacktype'   => $e->{'feedbacktype'} // '',
            'hardbounce'     => 0,
            'lhost'          => $e->{'lhost'}        // '',
            'origin'         => $argvs->{'origin'}   // '',
            'reason'         => $e->{'reason'}       // '',
            'recipient'      => $e->{'recipient'}    // '',
            'replycode'      => $e->{'replycode'}    // '',
            'rhost'          => $e->{'rhost'}        // '',
            'command'        => $e->{'command'}      // '',
        };

        ADDRESSER: {
            # Detect an email address from message/rfc822 part
            my $j = [];
            for my $f ( $rfc822head->{'addresser'}->@* ) {
                # Check each header in message/rfc822 part
                next unless exists $rfc822data->{ $f };
                next unless $rfc822data->{ $f };

                $j = Sisimai::Address->find($rfc822data->{ $f }) || next;
                $piece->{'addresser'} = shift @$j;
                last ADDRESSER;
            }

            # Fallback: Get the sender address from the header of the bounced email if the address
            # is not set at the loop above.
            $j = Sisimai::Address->find($mesg1->{'header'}->{'to'}) || [];
            $piece->{'addresser'} = shift @$j;
        }
        next RISEOF unless $piece->{'addresser'};

        TIMESTAMP: {
            # Convert from a time stamp or a date string to a machine time.
            my $datestring = undef;
            my $zoneoffset = 0;
            my @datevalues; push @datevalues, $e->{'date'} if $e->{'date'};

            # Date information did not exist in message/delivery-status part,...
            for my $f ( $rfc822head->{'date'}->@* ) {
                # Get the value of Date header or other date related header.
                next unless $rfc822data->{ $f };
                push @datevalues, $rfc822data->{ $f };
            }

            # Set "date" getting from the value of "Date" in the bounce message
            push @datevalues, $mesg1->{'header'}->{'date'} if scalar(@datevalues) < 2;

            while( my $v = shift @datevalues ) {
                # Decode each date value in the array
                $datestring = Sisimai::DateTime->parse($v) || next;

                if( $datestring =~ /\A(.+)[ ]+([-+]\d{4})\z/ ) {
                    # Get the value of timezone offset from $datestring: Wed, 26 Feb 2014 06:05:48 -0500
                    $datestring = $1;
                    $zoneoffset = Sisimai::DateTime->tz2second($2);
                    $piece->{'timezoneoffset'} = $2;
                }
                last if $datestring;
            }

            eval {
                # Convert from the date string to an object then calculate time zone offset.
                my $t = Sisimai::Time->strptime($datestring, '%a, %d %b %Y %T');
                $piece->{'timestamp'} = ($t->epoch - $zoneoffset) // undef;
            };
        }
        next RISEOF unless defined $piece->{'timestamp'};

        RECEIVED: {
            # Scan "Received:" header of the original message
            my $recv = $mesg1->{'header'}->{'received'} || [];
            unless( $piece->{'rhost'} ) {
                # Try to pick a remote hostname from Received: headers of the bounce message
                my $ir = Sisimai::RFC1123->find($e->{'diagnosis'});
                $piece->{'rhost'} = $ir if Sisimai::RFC1123->is_internethost($ir);

                unless( $piece->{'rhost'} ) {
                    # The remote hostname in the error message did not exist or is not a valid
                    # internet hostname
                    for my $re ( reverse @$recv ) {
                        # Check the Received: headers backwards and get a remote hostname
                        last if $piece->{'rhost'};
                        my $cv = Sisimai::RFC5322->received($re)->[0];
                        next unless Sisimai::RFC1123->is_internethost($cv);
                        $piece->{'rhost'} = $cv;
                    }
                }
            }
            $piece->{'lhost'} = '' if $piece->{'lhost'} eq $piece->{'rhost'};

            unless( $piece->{'lhost'} ) {
                # Try to pick a local hostname from Received: headers of the bounce message
                for my $le ( @$recv ) {
                    # Check the Received: headers forwards and get a local hostname
                    my $cv = Sisimai::RFC5322->received($le)->[0];
                    next unless Sisimai::RFC1123->is_internethost($cv);
                    $piece->{'lhost'} = $cv; last;
                }
            }

            for my $v ('rhost', 'lhost') {
                # Check and rewrite each host name
                next unless length $piece->{ $v };
                if( index($piece->{ $v }, '@') > -1 ) {
                    # Use the domain part as a remote/local host when the value is an email address
                    $piece->{ $v } = (split('@', $piece->{ $v }))[-1];
                }
                y/[]()\r//d, s/\A.+=// for $piece->{ $v }; # Remove [], (), \r, and strings before "="

                if( index($piece->{ $v }, ' ') > -1 ) {
                    # Check a space character in each value and get the first hostname
                    my @ee = split(' ', $piece->{ $v });
                    for my $w ( @ee ) {
                        # get a hostname from the string like "127.0.0.1 x109-20.example.com 192.0.2.20"
                        # or "mx.sp.example.jp 192.0.2.135"
                        next if Sisimai::RFC791->is_ipv4address($w);
                        $piece->{ $v } = $w; last;
                    }
                    $piece->{ $v } = $ee[0] if index($piece->{ $v }, ' ') > 0;
                }
                chop $piece->{ $v } if substr($piece->{ $v }, -1, 1) eq '.'; # Remove "." at the end of the value
            }
        }

        ID_HEADERS: {
            # Message-ID:, List-ID: headers of the original message
            my $p0 = 0;
            my $p1 = 0;
            if( Sisimai::String->aligned(\$rfc822data->{'message-id'}, ['<', '@', '>']) ) {
                # https://www.rfc-editor.org/rfc/rfc5322#section-3.6.4
                # Leave only string inside of angle brackets(<>)
                $p0 = index($rfc822data->{'message-id'}, '<') + 1;
                $p1 = index($rfc822data->{'message-id'}, '>');
                $piece->{'messageid'} = substr($rfc822data->{'message-id'}, $p0, $p1 - $p0);

            } else {
                # Invalid value of the Message-Id: field
                $piece->{'messageid'} = '';
            }

            if( Sisimai::String->aligned(\$rfc822data->{'list-id'}, ['<', '.', '>']) ) {
                # https://www.rfc-editor.org/rfc/rfc2919
                # Get the value of List-Id header: "List name "
                $p0 = index($rfc822data->{'list-id'}, '<') + 1;
                $p1 = index($rfc822data->{'list-id'}, '>');
                $piece->{'listid'} = substr($rfc822data->{'list-id'}, $p0, $p1 - $p0);

            } else {
                # Invalid value of the List-Id: field
                $piece->{'listid'} = '';
            }
        }

        DIAGNOSTICCODE: {
            # Cleanup the value of "Diagnostic-Code:" header
            last unless length $piece->{'diagnosticcode'};

            # Get an SMTP Reply Code and an SMTP Enhanced Status Code
            chop $piece->{'diagnosticcode'} if substr($piece->{'diagnosticcode'}, -1, 1) eq "\r";

            my $cs = Sisimai::SMTP::Status->find($piece->{'diagnosticcode'})      || '';
            my $cr = Sisimai::SMTP::Reply->find( $piece->{'diagnosticcode'}, $cs) || '';
            $piece->{'deliverystatus'} = Sisimai::SMTP::Status->prefer($piece->{'deliverystatus'}, $cs, $cr);

            if( length $cr == 3 ) {
                # There is an SMTP reply code in the error message
                $piece->{'replycode'} ||= $cr;

                if( index($piece->{'diagnosticcode'}, $cr.'-') > -1 ) {
                    # 550-5.7.1 [192.0.2.222] Our system has detected that this message is
                    # 550-5.7.1 likely unsolicited mail. To reduce the amount of spam sent to Gmail,
                    # 550-5.7.1 this message has been blocked. Please visit
                    # 550 5.7.1 https://support.google.com/mail/answer/188131 for more information.
                    #
                    # [e-mail]
                    #   host c.eu.example.com [192.0.2.3]
                    #   SMTP error from remote mail server after end of data:
                    #   553-SPF (Sender Policy Framework) domain authentication
                    #   553-fail. Refer to the Troubleshooting page at
                    #   553-http://www.symanteccloud.com/troubleshooting for more
                    #   553 information. (#5.7.1)
                    for my $q ('-', ' ') {
                        # Remove strings: "550-5.7.1", and "550 5.7.1" from the error message
                        my $cx = sprintf("%s%s%s", $cr, $q, $cs);
                        my $p0 = index($piece->{'diagnosticcode'}, $cx);
                        while( $p0 > -1 ) {
                            # Remove strings like "550-5.7.1"
                            substr($piece->{'diagnosticcode'}, $p0, length $cx, '');
                            $p0 = index($piece->{'diagnosticcode'}, $cx);
                        }

                        # Remove "553-" and "553 " (SMTP reply code only) from the error message
                        $cx = sprintf("%s%s", $cr, $q);
                        $p0 = index($piece->{'diagnosticcode'}, $cx);
                        while( $p0 > -1 ) {
                            # Remove strings like "553-"
                            substr($piece->{'diagnosticcode'}, $p0, length $cx, '');
                            $p0 = index($piece->{'diagnosticcode'}, $cx);
                        }
                    }

                    if( index($piece->{'diagnosticcode'}, $cr) > 1 ) {
                        # Add "550 5.1.1" into the head of the error message when the error
                        # message does not begin with "550"
                        $piece->{'diagnosticcode'} = sprintf("%s %s %s", $cr, $cs, $piece->{'diagnosticcode'});
                    }
                }
            }

            my $dc = lc $piece->{'diagnosticcode'};
            my $p1 = index($dc, '');
            my $p2 = index($dc, '');
            substr($piece->{'diagnosticcode'}, $p1, $p2 + 7 - $p1, '') if $p1 > 0 && $p2 > 0;
            $piece->{'diagnosticcode'} = Sisimai::String->sweep($piece->{'diagnosticcode'});
        }

        DIAGNOSTICTYPE: {
            # Set the value of "diagnostictype" if it is empty
            $piece->{'diagnostictype'} ||= 'X-UNIX' if $piece->{'reason'} eq 'mailererror';
            $piece->{'diagnostictype'} ||= 'SMTP' unless grep { $piece->{'reason'} eq $_ } ('feedback', 'vacation');
        }

        # Check the Subject field of the original message
        $piece->{'subject'} = $rfc822data->{'subject'} // '';
        chop $piece->{'subject'} if substr($piece->{'subject'}, -1, 1) eq "\r";

        # When "RCPT first" in the error message, set "RCPT" as the last command.
        # - <<< 503 RCPT first (#5.5.1)
        # - <<< 503-5.5.1 RCPT first. A mail transaction protocol command was issued ...
        # -   RCPT first (in reply to DATA command)
        $piece->{'command'} = '' unless Sisimai::SMTP::Command->test($piece->{'command'});
        $piece->{'command'} = 'RCPT' if index($piece->{'diagnosticcode'}, 'RCPT first') > -1;

        CONSTRUCTOR: {
            # Create email address object
            my $as = Sisimai::Address->new($piece->{'addresser'})                || next RISEOF;
            my $ar = Sisimai::Address->new({'address' => $piece->{'recipient'}}) || next RISEOF;
            my @ea = (qw|
                action command decodedby deliverystatus diagnosticcode diagnostictype feedbacktype
                lhost listid messageid origin reason replycode rhost subject
            |);

            $thing = {
                'addresser'    => $as,
                'recipient'    => $ar,
                'senderdomain' => $as->host,
                'destination'  => $ar->host,
                'alias'        => $piece->{'alias'} || $ar->alias,
                'token'        => __PACKAGE__->maketoken($as->address, $ar->address, $piece->{'timestamp'}),
            };
            $thing->{ $_ }           ||= $piece->{ $_ }    // '' for @ea;
            $thing->{'bogus'}          = 0;
            $thing->{'catch'}          = $piece->{'catch'} // undef;
            $thing->{"feedbackid"}     = "";
            $thing->{'hardbounce'}     = int $piece->{'hardbounce'};
            $thing->{'replycode'}    ||= Sisimai::SMTP::Reply->find($piece->{'diagnosticcode'}) || '';
            $thing->{'timestamp'}      = Sisimai::Time->new($piece->{'timestamp'});
            $thing->{'timezoneoffset'} = $piece->{'timezoneoffset'} // '+0000';
            $thing->{'toxic'}          = 0;
        }

        ALIAS: {
            # Look up the Envelope-To address from the Received: header in the original message
            # when the recipient address is same with the value of $o->{'alias'}.
            last if length $thing->{'alias'} == 0 || $thing->{'recipient'}->address ne $thing->{'alias'};
            last unless exists $rfc822data->{'received'};
            last unless scalar $rfc822data->{'received'}->@*;

            for my $er ( reverse $rfc822data->{'received'}->@* ) {
                # Search for the string " for " from the Received: header
                next unless index($er, ' for ') > 1;
                my $or = Sisimai::RFC5322->received($er);

                next if scalar(@$or) == 0 || length($or->[5]) == 0;
                next if Sisimai::Address->is_emailaddress($or->[5]) == 0;
                next if $thing->{'recipient'}->address eq $or->[5];

                $thing->{'alias'} = $or->[5];
                last ALIAS;
            }
        }
        $thing->{'alias'} = '' if $thing->{'alias'} eq $thing->{'recipient'}->{'address'};

        REASON: {
            # Decide the reason of the email bounce
            if( $thing->{'reason'} eq '' || exists $retryindex->{ $thing->{'reason'} } ) {
                # The value of "reason" is empty or is needed to check with other values again
                my $re = $thing->{'reason'} || 'undefined';
                my $cr = "Sisimai::Reason";
                my $or = Sisimai::LDA->find($thing);    if( $cr->is_explicit($or) ){ $thing->{'reason'} = $or; last }
                   $or = Sisimai::Rhost->find($thing);  if( $cr->is_explicit($or) ){ $thing->{'reason'} = $or; last }
                   $or = Sisimai::Reason->find($thing); if( $cr->is_explicit($or) ){ $thing->{'reason'} = $or; last }
                $thing->{'reason'} = $thing->{'diagnosticcode'} ? "onhold" : $re;
            }
        }

        HARDBOUNCE: {
            # Set the value of "hardbounce", default value of "bouncebounce" is 0
            if( $thing->{'reason'} eq 'delivered' || $thing->{'reason'} eq 'feedback' || $thing->{'reason'} eq 'vacation' ) {
                # Delete the value of ReplyCode when the Reason is "feedback" or "vacation"
                $thing->{'replycode'} = '' unless $thing->{'reason'} eq 'delivered';

            } else {
                # The reason is not "delivered", or "feedback", or "vacation"
                my $smtperrors = $piece->{'deliverystatus'}.' '.$piece->{'diagnosticcode'};
                   $smtperrors = '' if length $smtperrors < 4;
                $thing->{'hardbounce'} = Sisimai::SMTP::Failure->is_hardbounce($thing->{'reason'}, $smtperrors);
            }
        }

        DELIVERYSTATUS: {
            # Set pseudo status code
            last DELIVERYSTATUS if $thing->{'deliverystatus'};

            my $smtperrors = $thing->{'replycode'}.' '.$piece->{'diagnosticcode'};
               $smtperrors = '' if length $smtperrors < 4;
            my $permanent0 = Sisimai::SMTP::Failure->is_permanent($smtperrors);
            my $temporary0 = Sisimai::SMTP::Failure->is_temporary($smtperrors);
            my $temporary1 = $permanent0.$temporary0 eq "00" ? 0 : $temporary0;
            $thing->{'deliverystatus'} = Sisimai::SMTP::Status->code($thing->{'reason'}, $temporary1);
        }

        REPLYCODE: {
            # Check both of the first digit of "deliverystatus" and "replycode"
            my $cx = [substr($thing->{'deliverystatus'}, 0, 1), substr($thing->{'replycode'}, 0, 1)];
            if( $cx->[0] ne $cx->[1] ) {
                # The class of the "Status:" is defer with the first digit of the reply code
                $cx->[1] = Sisimai::SMTP::Reply->find($piece->{'diagnosticcode'}, $cx->[0]) || '';
                $thing->{'replycode'} = index($cx->[1], $cx->[0]) == 0 ? $cx->[1] : '';
            }

            unless( exists $actionlist->{ $thing->{'action'} } ) {
                # There is an action value which is not described at RFC1894
                if( my $ox = Sisimai::RFC1894->field('Action: '.$thing->{'action'}) ) {
                    # Rewrite the value of "Action:" field to the valid value
                    #
                    #    The syntax for the action-field is:
                    #       action-field = "Action" ":" action-value
                    #       action-value = "failed" / "delayed" / "delivered" / "relayed" / "expanded"
                    $thing->{'action'} = $ox->[2];
                }
            }
            $thing->{'action'}   = 'delivered' if $thing->{'reason'} eq 'delivered';
            $thing->{'action'} ||= 'delayed'   if $thing->{'reason'} eq 'expired';
            $thing->{'action'} ||= 'failed'    if $cx->[0] eq '4' || $cx->[0] eq '5';
            $thing->{'action'} ||= "";
        }

        if( $thing->{'replycode'} ne "" ) {
            # Fill empty values: ["SMTP Command", "DSN", "Reason"]
            my $cv = Sisimai::SMTP::Reply->associatedwith($thing->{'replycode'});
            if( scalar @$cv > 0 ) {
                $thing->{'command'}        = $cv->[0] if $cv->[0] ne "" && $thing->{'command'} eq "";
                $thing->{'deliverystatus'} = $cv->[1] if $cv->[1] ne "" && Sisimai::SMTP::Status->is_explicit($thing->{'deliverystatus'}) == 0;
                $thing->{'reason'}         = $cv->[2] if $cv->[2] ne "" && Sisimai::Reason->is_explicit($thing->{'reason'}) == 0;
            }
        }
        # Feedback-ID: 1.us-west-2.QHuyeCQrGtIIMGKQfVdUhP9hCQR2LglVOrRamBc+Prk=:AmazonSES
        $thing->{'feedbackid'} = $rfc822data->{'feedback-id'} || "";

        push @$listoffact, bless($thing, __PACKAGE__);
    } # End of for(RISEOF)

    return $listoffact;
}

sub maketoken {
    # Create the message token from an addresser and a recipient
    # @param    [String] addr1  A sender's email address
    # @param    [String] addr2  A recipient's email address
    # @param    [Integer] epoch Machine time of the email bounce
    # @return   [String]        Message token(MD5 hex digest) or empty string
    #                           if the any argument is missing
    # @see       http://en.wikipedia.org/wiki/ASCII
    # @see       https://metacpan.org/pod/Digest::MD5
    my $class = shift || return '';
    my $addr1 = shift || return '';
    my $addr2 = shift || return '';
    my $epoch = shift // return '';

    # Format: STX(0x02) Sender-Address RS(0x1e) Recipient-Address ETX(0x03)
    return Digest::SHA::sha1_hex(sprintf("\x02%s\x1e%s\x1e%d\x03", lc $addr1, lc $addr2, $epoch));
}


sub damn {
    # Convert from object to hash reference
    # @return   [Hash] Data in Hash reference
    my $self = shift;
    my $data = undef;
    state $stringdata = [qw|
        action alias catch command decodedby deliverystatus destination diagnosticcode diagnostictype
        feedbackid feedbacktype lhost listid messageid origin reason replycode rhost senderdomain
        subject timezoneoffset token
    |];
    eval {
        my $v = {};
        $v->{ $_ }         = $self->$_ // '' for @$stringdata;
        $v->{'hardbounce'} = int $self->hardbounce;
        $v->{'bogus'}      = int $self->bogus;
        $v->{'toxic'}      = int $self->toxic;
        $v->{'addresser'}  = $self->addresser->address;
        $v->{'recipient'}  = $self->recipient->address;
        $v->{'timestamp'}  = $self->timestamp->epoch;
        $data = $v;
    };
    return $data;
}

sub dump {
    # Data dumper
    # @param    [String] type   Data format: json, yaml
    # @return   [String]        Dumped data or an empty string when the argument is neither "json" nor "yaml"
    my $self = shift;
    my $type = shift || 'json'; return "" unless $type =~ /\A(?:json|yaml)\z/;

    my $referclass = 'Sisimai::Fact::'.uc($type);
    my $modulepath = 'Sisimai/Fact/'.uc($type).'.pm';

    require $modulepath;
    return $referclass->dump($self);
}

1;
__END__