File Coverage

lib/Sisimai/Lhost/qmail.pm

Criterion	Covered	Total	%
statement	88	90	97.7
branch	44	46	95.6
condition	15	21	71.4
subroutine	6	6	100.0
pod	2	2	100.0
total	155	165	93.9

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"],
    };

    # qmail-send.c:922| ... (&dline[c],"I'm not going to try again; this message has been in the queue too long.\n")) nomem();
    # qmail-remote-fallback.patch
    state $hasexpired = "this message has been in the queue too long.";
    state $onholdpair = [" does not like recipient.", "this message has been in the queue too long."];
    state $failonldap = {
        # qmail-ldap-1.03-20040101.patch:19817 - 19866
        "emailtoolarge" => ["The message exeeded the maximum size the user accepts"], # 5.2.3
        "userunknown"   => ["Sorry, no mailbox here by that name"],           # 5.1.1
        "suspend"       => [ # 5.2.1
            "Mailaddress is administrativly disabled",
            "Mailaddress is administrativley disabled",
            "Mailaddress is administratively disabled",
            "Mailaddress is administrativeley disabled",
        ],
        "systemerror" => [
            "Automatic homedir creator crashed",                # 4.3.0
            "Illegal value in LDAP attribute",                  # 5.3.5
            "LDAP attribute is not given but mandatory",        # 5.3.5
            "Timeout while performing search on LDAP server",   # 4.4.3
            "Too many results returned but needs to be unique", # 5.3.5
            "Permanent error while executing qmail-forward",    # 5.4.4
            "Temporary error in automatic homedir creation",    # 4.3.0 or 5.3.0
            "Temporary error while executing qmail-forward",    # 4.4.4
            "Temporary failure in LDAP lookup",                 # 4.4.3
            "Unable to contact LDAP server",                    # 4.4.3
            "Unable to login into LDAP server, bad credentials",# 4.4.3
        ],
    };
    state $messagesof = {
        "emailtoolarge" => ["Message size exceeds fixed maximum message size:"],
        # qmail-remote.c:68|  Sorry, I couldn't find any host by that name. (#4.1.2)\n"); zerodie();
        # qmail-remote.c:78|  Sorry, I couldn't find any host named ");
        "hostunknown" => ["Sorry, I couldn't find any host "],
        # error_str.c:192|  X(EDQUOT,"disk quota exceeded")
        "mailboxfull" => ["disk quota exceeded"],
        # qmail-qmtpd.c:233| ... result = "Dsorry, that message size exceeds my databytes limit (#5.3.4)";
        # qmail-smtpd.c:391| ... out("552 sorry, that message size exceeds my databytes limit (#5.3.4)\r\n"); return;
        "networkerror" => [
            "Sorry, I wasn't able to establish an SMTP connection",
            "Sorry. Although I'm listed as a best-preference MX or A for that host",
        ],
        "notaccept" => [
            # notqmail 1.08 returns the following error message when the destination MX is NullMX
            "Sorry, I couldn't find a mail exchanger or IP address",
        ],
        "systemerror" => [
            "bad interpreter: No such file or directory",
            "system error",
            "Unable to",
        ],
        "systemfull"  => ["Requested action not taken: mailbox unavailable (not enough free space)"],
        # qmail-local.c:589|  strerr_die1x(100,"Sorry, no mailbox here by that name. (#5.1.1)");
        # qmail-remote.c:253|  out("s"); outhost(); out(" does not like recipient.\n");
        "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'} = Sisimai::String->sweep(substr($e, $p1 + $cm, $p2 - $p1 - $cm));
                last;
            }
        }
    }
    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"});

        # 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
            if( Sisimai::String->aligned(\$e->{"diagnosis"}, $onholdpair) ) {
                # Need to be matched with error message pattens defined in Sisimai/Reason/*
                $e->{"reason"} = "onhold";

            } else {
                # Check that the error message includes any of message patterns or not
                FINDREASON: for my $f ( $e->{"alterrors"}, $e->{"diagnosis"} ) {
                    # Try to detect an error reason
                    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;
                    }
                    LDAP: for my $r ( keys %$failonldap ) {
                        # The key is a bounce reason name
                        next unless grep { index($f, $_) > -1 } $failonldap->{ $r }->@*;
                        $e->{"reason"} = $r;
                        last FINDREASON;
                    }
                    $e->{"reason"} = "expired" if index($f, $hasexpired) > -1;
                }
            }
        }
        $e->{"command"} ||= Sisimai::SMTP::Command->find($e->{"diagnosis"});
    }
    return {"ds" => $dscontents, "rfc822" => $emailparts->[1]};
}

1;
__END__