File Coverage

lib/Sisimai/Lhost/qmail.pm

Criterion	Covered	Total	%
statement	78	78	100.0
branch	39	40	97.5
condition	15	21	71.4
subroutine	6	6	100.0
pod	2	2	100.0
total	140	147	95.2

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

sub description { 'qmail: https://cr.yp.to/qmail.html' }
sub inquire {
    # Detect an error from qmail
    # @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.0.0
    my $class = shift;
    my $mhead = shift // return undef;
    my $mbody = shift // return undef;

    # Pre process email headers and the body part of the message which generated by qmail.
    # see https://cr.yp.to/qmail.html
    #   e.g.) Received: (qmail 12345 invoked for bounce); 29 Apr 2009 12:34:56 -0000
    #         Subject: failure notice
    my $emailtitle = [
        "failure notice", # qmail-send.c:Subject: failure notice\n\
        "Failure Notice", # Yahoo
    ];
    my $proceedsto = 0; $proceedsto++ if grep { $mhead->{"subject"} eq $_ } @$emailtitle;

    for my $e ( $mhead->{"received"}->@* ) {
        # Received: (qmail 2222 invoked for bounce);29 Apr 2017 23:34:45 +0900
        # Received: (qmail 2202 invoked from network); 29 Apr 2018 00:00:00 +0900
        $proceedsto ||= 1 if Sisimai::String->aligned(\$e, ["(qmail", " invoked "]);
    }
    return undef if $proceedsto == 0;

    require Sisimai::SMTP::Command;
    state $indicators = __PACKAGE__->INDICATORS;
    state $boundaries = [
        # qmail-send.c:qmail_puts(&qqt,*sender.s ? "--- Below this line is a copy of the message.\n\n" :...
        "--- Below this line is a copy of the message.",     # qmail-1.03
        "--- Below this line is a copy of the mail header.",
        "--- Below the next line is a copy of the message.", # The followings are the qmail clone
        "--- Mensaje original adjunto.",
        "Content-Type: message/rfc822",
        "Original message follows.",
    ];
    state $startingof = {
        #  qmail-remote.c:248|    if (code >= 500) {
        #  qmail-remote.c:249|      out("h"); outhost(); out(" does not like recipient.\n");
        #  qmail-remote.c:265|  if (code >= 500) quit("D"," failed on DATA command");
        #  qmail-remote.c:271|  if (code >= 500) quit("D"," failed after I sent the message");
        #
        # Characters: K,Z,D in qmail-qmqpc.c, qmail-send.c, qmail-rspawn.c
        #  K = success, Z = temporary error, D = permanent error
        "error"   => ["Remote host said:"],
        "message" => [
            "Hi. This is the qmail", # qmail-send.c:Hi. This is the qmail-send program at ");
            "He/Her is not ",        # The followings are the qmail clone
            "unable to deliver your message to the following addresses",
            "Su mensaje no pudo ser entregado",
            "Sorry, we were unable to deliver your message to the following address",
            "This is the machine generated message from mail service",
            "This is the mail delivery agent at",
            "Unable to deliver message to the following address",
            "unable to deliver your message to the following addresses",
            "Unfortunately, your mail was not delivered to the following address:",
            "Your mail message to the following address",
            "Your message to the following addresses",
            "We're sorry.",
        ],
        "rhost"   => ['Giving up on ', 'Connected to ', 'remote host '],
    };
    state $commandset = {
        # Error text regular expressions which defined in qmail-remote.c
        # qmail-remote.c:225|  if (smtpcode() != 220) quit("ZConnected to "," but greeting failed");
        "CONN" => [" but greeting failed."],
        # qmail-remote.c:231|  if (smtpcode() != 250) quit("ZConnected to "," but my name was rejected");
        "EHLO" => [" but my name was rejected."],
        # qmail-remote.c:238|  if (code >= 500) quit("DConnected to "," but sender was rejected");
        # reason = rejected
        "MAIL" => [" but sender was rejected."],
        # qmail-remote.c:249|  out("h"); outhost(); out(" does not like recipient.\n");
        # qmail-remote.c:253|  out("s"); outhost(); out(" does not like recipient.\n");
        # reason = userunknown
        "RCPT" => [" does not like recipient."],
        # qmail-remote.c:265|  if (code >= 500) quit("D"," failed on DATA command");
        # qmail-remote.c:266|  if (code >= 400) quit("Z"," failed on DATA command");
        # qmail-remote.c:271|  if (code >= 500) quit("D"," failed after I sent the message");
        # qmail-remote.c:272|  if (code >= 400) quit("Z"," failed after I sent the message");
        "DATA" => [" failed on DATA command", " failed after I sent the message"],
    };

    state $messagesof = {
        # notqmail 1.08 returns the following error message when the destination MX is NullMX
        "notaccept"   => ["Sorry, I couldn't find a mail exchanger or IP address"],
        "userunknown" => ["no mailbox here by that name"],
    };

    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, $_) > -1 } $startingof->{'message'}->@*;
            next;
        }
        next if ($readcursor & $indicators->{'deliverystatus'}) == 0 || $e eq "";

        # :
        # 192.0.2.153 does not like recipient.
        # Remote host said: 550 5.1.1 ... User Unknown
        # Giving up on 192.0.2.153.
        $v = $dscontents->[-1];

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

        } elsif( scalar @$dscontents == $recipients ) {
            # Append error message
            $v->{'diagnosis'} .= $e.' ';
            $v->{'alterrors'}  = $e if index($e, $startingof->{'error'}->[0]) == 0;

            next if $v->{'rhost'};
            for my $r ( $startingof->{'rhost'}->@* ) {
                # Find a remote host name
                my $p1 = index($e, $r); next if $p1 == -1;
                my $cm = length $r;
                my $p2 = index($e, ' ', $p1 + $cm + 1); $p2 = rindex($e, '.') if $p2 == -1;

                $v->{'rhost'} = substr($e, $p1 + $cm, $p2 - $p1 - $cm);
                last;
            }
        }
    }
    return undef unless $recipients;

    for my $e ( @$dscontents ) {
        # Get the SMTP command name for the session
        SMTP: for my $r ( keys %$commandset ) {
            # Get the last SMTP Command
            next unless grep { index($e->{"diagnosis"}, $_) > 0 } $commandset->{ $r }->@*;
            $e->{"command"} = $r;
            last;
        }
        if( index($e->{"diagnosis"}, "no SMTP connection got far enough") > -1 ) {
            # Sorry, no SMTP connection got far enough; most progress was RCPT TO response; ...
            $e->{"command"} ||= Sisimai::SMTP::Command->find($e->{"diagnosis"});
        }

        # Detect the reason of bounce
        if( $e->{"command"} eq "HELO" || $e->{"command"} eq "EHLO" ) {
            # HELO | Connected to 192.0.2.135 but my name was rejected.
            $e->{"reason"} = "blocked";

        } else {
            # The error message includes any of patterns defined in the variable avobe
            FINDREASON: for my $f ( $e->{"alterrors"}, $e->{"diagnosis"} ) {
                # Check that the error message includes any of message patterns or not
                last if $e->{"reason"};
                next unless $f;
                MESG: for my $r ( keys %$messagesof ) {
                    # The key is a bounce reason name
                    next unless grep { index($f, $_) > -1 } $messagesof->{ $r }->@*;
                    $e->{"reason"} = $r;
                    last FINDREASON;
                }
            }
        }
        $e->{"command"} ||= Sisimai::SMTP::Command->find($e->{"diagnosis"});
    }
    return {"ds" => $dscontents, "rfc822" => $emailparts->[1]};
}

1;
__END__