File Coverage

lib/Sisimai/Lhost/Exchange2007.pm

Criterion	Covered	Total	%
statement	80	82	97.5
branch	33	40	82.5
condition	18	20	90.0
subroutine	6	6	100.0
pod	2	2	100.0
total	139	150	92.6

package Sisimai::Lhost::Exchange2007;
use parent 'Sisimai::Lhost';
use v5.26;
use strict;
use warnings;

sub description { 'Microsoft Exchange Server 2007: https://www.microsoft.com/microsoft-365/exchange/email' }
sub inquire {
    # Detect an error from Microsoft Exchange Server 2007
    # @param    [Hash] mhead    Message headers of a bounce email
    # @param    [String] mbody  Message body of a bounce email
    # @return   [Hash]          Bounce data list and message/rfc822 part
    # @return   [undef]         failed to decode or the arguments are missing
    # @since v4.1.1
    my $class = shift;
    my $mhead = shift // return undef;
    my $mbody = shift // return undef;

    my $mailsender = ['[e-mail]', ".onmicrosoft.com"];
    my $emailtitle = [
        # "Subject:"        "Content-Language:"
        "Undeliverable",    # en-US
        "Non_remis_",       # fr-FR
        "Non remis ",       # fr-FR
        "Non recapitabile", # it-CH
        "Olevererbart",     # sv-SE
    ];
    my $proceedsto = 0; $proceedsto++ if grep { index($mhead->{"subject"}, $_) > -1 } @$emailtitle;
                        $proceedsto++ if grep { index($mhead->{"from"},  $_)   >  1 } @$mailsender;
                        $proceedsto++ if defined $mhead->{"content-language"};
    return undef if $proceedsto < 2;

    require Sisimai::RFC1123;
    state $indicators = __PACKAGE__->INDICATORS;
    state $boundaries = [
        "Original Message Headers",
        "Original message headers:",                # en-US
        "tes de message d'origine :",               # fr-FR/En-têtes de message d'origine
        "Intestazioni originali del messaggio:",    # it-CH
        "Ursprungshuvuden:",                        # sv-SE
    ];
    state $startingof = {
        "error"   => [" RESOLVER.", " QUEUE."],
        "message" => [
            "Error Details",
            "Diagnostic information for administrators:",           # en-US
            "Informations de diagnostic pour les administrateurs",  # fr-FR
            "Informazioni di diagnostica per gli amministratori",   # it-CH
            "Diagnostisk information f",                            # sv-SE
        ],
        "rhost"   => [
            "DSN generated by:",
            "Generating server",        # en-US
            "Serveur de g",             # fr-FR/Serveur de gènèration
            "Server di generazione",    # it-CH
            "Genererande server",       # sv-SE
        ],
    };
    state $ndrsubject = {
        "SMTPSEND.DNS.NonExistentDomain" => "hostunknown",   # 554 5.4.4 SMTPSEND.DNS.NonExistentDomain
        "SMTPSEND.DNS.MxLoopback"        => "networkerror",  # 554 5.4.4 SMTPSEND.DNS.MxLoopback
        "RESOLVER.ADR.BadPrimary"        => "systemerror",   # 550 5.2.0 RESOLVER.ADR.BadPrimary
        "RESOLVER.ADR.RecipNotFound"     => "userunknown",   # 550 5.1.1 RESOLVER.ADR.RecipNotFound
        "RESOLVER.ADR.RecipientNotFound" => "userunknown",   # 550 5.1.1 RESOLVER.ADR.RecipientNotFound
        "RESOLVER.ADR.ExRecipNotFound"   => "userunknown",   # 550 5.1.1 RESOLVER.ADR.ExRecipNotFound
        "RESOLVER.ADR.RecipLimit"        => "ratelimited",   # 550 5.5.3 RESOLVER.ADR.RecipLimit
        "RESOLVER.ADR.InvalidInSmtp"     => "systemerror",   # 550 5.1.0 RESOLVER.ADR.InvalidInSmtp
        "RESOLVER.ADR.Ambiguous"         => "systemerror",   # 550 5.1.4 RESOLVER.ADR.Ambiguous, 420 4.2.0 RESOLVER.ADR.Ambiguous
        "RESOLVER.RST.AuthRequired"      => "securityerror", # 550 5.7.1 RESOLVER.RST.AuthRequired
        "RESOLVER.RST.NotAuthorized"     => "rejected",      # 550 5.7.1 RESOLVER.RST.NotAuthorized
        "RESOLVER.RST.RecipSizeLimit"    => "emailtoolarge", # 550 5.2.3 RESOLVER.RST.RecipSizeLimit
        "QUEUE.Expired"                  => "expired",       # 550 4.4.7 QUEUE.Expired
    };

    my $dscontents = [__PACKAGE__->DELIVERYSTATUS]; my $v = undef;
    my $emailparts = Sisimai::RFC5322->part($mbody, $boundaries);
    my $readcursor = 0;     # (Integer) Points the current cursor position
    my $recipients = 0;     # (Integer) The number of 'Final-Recipient' header

    for my $e ( split("\n", $emailparts->[0]) ) {
        # Read error messages and delivery status lines from the head of the email to the previous
        # line of the beginning of the original message.
        unless( $readcursor ) {
            # Beginning of the bounce message or message/delivery-status part
            $readcursor |= $indicators->{"deliverystatus"} if grep { index($e, $_) == 0 } $startingof->{"message"}->@*;
            next;
        }
        next if ($readcursor & $indicators->{'deliverystatus'}) == 0 || $e eq "";

        # Diagnostic information for administrators:
        #
        # Generating server: mta2.neko.example.jp
        #
        # [e-mail]
        # #550 5.1.1 RESOLVER.ADR.RecipNotFound; not found ##
        #
        # Original message headers:
        $v = $dscontents->[-1];

        if( index($e, " ") < 0 && index($e, '@') > 1 ) {
            # [e-mail]
            if( $v->{"recipient"} ) {
                # There are multiple recipient addresses in the message body.
                push @$dscontents, __PACKAGE__->DELIVERYSTATUS;
                $v = $dscontents->[-1];
            }
            $v->{"recipient"} = Sisimai::Address->s3s4($e);
            $recipients++;

        } else {
            # Try to pick the remote hostname and status code, reply code from the error message
            if( grep { index($e, $_) == 0 } $startingof->{"rhost"}->@* ) {
                # Generating server: SG2APC01HT234.mail.protection.outlook.com
                # DSN generated by:       NEKONYAAN0022.apcprd01.prod.exchangelabs.com
                my $cv = Sisimai::RFC1123->find($e);
                $v->{"rhost"} = $cv if Sisimai::RFC1123->is_internethost($cv);

            } else {
                # #550 5.1.1 RESOLVER.ADR.RecipNotFound; not found ##
                # #550 5.2.3 RESOLVER.RST.RecipSizeLimit; message too large for this recipient ##
                my $cr = Sisimai::SMTP::Reply->find($e)  || "";
                my $cs = Sisimai::SMTP::Status->find($e) || "";
                if( $cr ne "" || $cs ne "" || index($e, "Remote Server ") > -1 ) {
                    # Remote Server returned '550 5.1.1 RESOLVER.ADR.RecipNotFound; not found'
                    # 3/09/2016 8:05:56 PM - Remote Server at mydomain.com (10.1.1.3) returned '550 4.4.7 QUEUE.Expired; message expired'
                    $v->{"replycode"}  = $cr;
                    $v->{"status"}     = $cs;
                    $v->{"diagnosis"} .= $e." ";
                }
            }
        }
    }

    while( $recipients == 0 ) {
        # Try to pick the recipient address from the following formatted bounce message:
        #
        # Original Message Details
        # Created Date:   4/29/2017 11:23:34 PM
        # Sender Address: [e-mail]
        # Recipient Address:      [e-mail]
        # Subject:        Nyaan?
        my $p1 = index($emailparts->[0], "Original Message Details"); last if $p1 < 0;
        my $p2 = index($emailparts->[0], "\nRecipient Address: ");    last if $p2 < 0;
        my $p3 = index($emailparts->[0], "\n", $p2 + 20);             last if $p3 < 0;
        my $cv = Sisimai::Address->s3s4(substr($emailparts->[0], $p2 + 20, $p3 - $p2 - 20));

        last unless Sisimai::Address->is_emailaddress($cv);
        $dscontents->[0]->{"recipient"} = $cv;
        $recipients++;
    }
    return undef unless $recipients;

    for my $e ( @$dscontents ) {
        # Tidy up the error message in $e->{'diagnosis'}, Try to detect the bounce reason.
        $e->{"diagnosis"} = Sisimai::String->sweep($e->{"diagnosis"});

        my $p0 = -1; for my $r ( $startingof->{"error"}->@* ) {
            # Try to find the NDR subject string such as "RESOLVER.ADR.RecipientNotFound" from the
            # error message
            $p0 = index($e->{"diagnosis"}, $r); last if $p0 > -1;
        }
        next if $p0 < 0;

        my $cv = substr($e->{"diagnosis"}, $p0 + 1, index($e->{"diagnosis"}, ";") - $p0 - 1);
        for my $r ( keys %$ndrsubject ) {
            # Try to match with error subject strings such as "RESOLVER.ADR.RecipNotFound"
            next unless $cv eq $r;
            $e->{"reason"} = $ndrsubject->{ $r };
            last;
        }
    }
    return {"ds" => $dscontents, "rfc822" => $emailparts->[1]};
}

1;
__END__