1package Sisimai::Lhost::Sendmail;
2use parent 'Sisimai::Lhost';
3use feature ':5.10';
4use strict;
5use warnings;
6
7sub description { 'V8Sendmail: /usr/sbin/sendmail' }
8sub make {
9    # Parse bounce messages from Sendmail
10    # @param    [Hash] mhead    Message headers of a bounce email
11    # @param    [String] mbody  Message body of a bounce email
12    # @return   [Hash]          Bounce data list and message/rfc822 part
13    # @return   [Undef]         failed to parse or the arguments are missing
14    # @since v4.0.0
15    my $class = shift;
16    my $mhead = shift // return undef;
17    my $mbody = shift // return undef;
18
19    return undef unless $mhead->{'subject'} =~ /(?:see transcript for details\z|\AWarning: )/;
20    return undef if $mhead->{'x-aol-ip'};   # X-AOL-IP is a header defined in AOL
21
22    state $indicators = __PACKAGE__->INDICATORS;
23    state $rebackbone = qr<^Content-Type:[ ](?:message/rfc822|text/rfc822-headers)>m;
24    state $startingof = {
25        #   savemail.c:1040|if (printheader && !putline("   ----- Transcript of session follows -----\n",
26        #   savemail.c:1041|          mci))
27        #   savemail.c:1042|  goto writeerr;
28        #   savemail.c:1360|if (!putline(
29        #   savemail.c:1361|    sendbody
30        #   savemail.c:1362|    ? "   ----- Original message follows -----\n"
31        #   savemail.c:1363|    : "   ----- Message header follows -----\n",
32        'message' => ['   ----- Transcript of session follows -----'],
33        'error'   => ['... while talking to '],
34    };
35
36    require Sisimai::RFC1894;
37    my $fieldtable = Sisimai::RFC1894->FIELDTABLE;
38    my $permessage = {};    # (Hash) Store values of each Per-Message field
39
40    my $dscontents = [__PACKAGE__->DELIVERYSTATUS];
41    my $emailsteak = Sisimai::RFC5322->fillet($mbody, $rebackbone);
42    my $readcursor = 0;     # (Integer) Points the current cursor position
43    my $recipients = 0;     # (Integer) The number of 'Final-Recipient' header
44    my $commandtxt = '';    # (String) SMTP Command name begin with the string '>>>'
45    my $esmtpreply = [];    # (Array) Reply from remote server on SMTP session
46    my $sessionerr = 0;     # (Integer) Flag, 1 if it is SMTP session error
47    my $anotherset = {};    # (Hash) Another error information
48    my $v = undef;
49    my $p = '';
50
51    for my $e ( split("\n", $emailsteak->[0]) ) {
52        # Read error messages and delivery status lines from the head of the email
53        # to the previous line of the beginning of the original message.
54        unless( $readcursor ) {
55            # Beginning of the bounce message or message/delivery-status part
56            $readcursor |= $indicators->{'deliverystatus'} if index($e, $startingof->{'message'}->[0]) == 0;
57            next;
58        }
59        next unless $readcursor & $indicators->{'deliverystatus'};
60        next unless length $e;
61
62        if( my $f = Sisimai::RFC1894->match($e) ) {
63            # $e matched with any field defined in RFC3464
64            next unless my $o = Sisimai::RFC1894->field($e);
65            $v = $dscontents->[-1];
66
67            if( $o->[-1] eq 'addr' ) {
68                # Final-Recipient: rfc822; kijitora@example.jp
69                # X-Actual-Recipient: rfc822; kijitora@example.co.jp
70                if( $o->[0] eq 'final-recipient' ) {
71                    # Final-Recipient: rfc822; kijitora@example.jp
72                    if( $v->{'recipient'} ) {
73                        # There are multiple recipient addresses in the message body.
74                        push @$dscontents, __PACKAGE__->DELIVERYSTATUS;
75                        $v = $dscontents->[-1];
76                    }
77                    $v->{'recipient'} = $o->[2];
78                    $recipients++;
79
80                } else {
81                    # X-Actual-Recipient: rfc822; kijitora@example.co.jp
82                    $v->{'alias'} = $o->[2];
83                }
84            } elsif( $o->[-1] eq 'code' ) {
85                # Diagnostic-Code: SMTP; 550 5.1.1 <userunknown@example.jp>... User Unknown
86                $v->{'spec'} = $o->[1];
87                $v->{'diagnosis'} = $o->[2];
88
89            } else {
90                # Other DSN fields defined in RFC3464
91                next unless exists $fieldtable->{ $o->[0] };
92                $v->{ $fieldtable->{ $o->[0] } } = $o->[2];
93
94                next unless $f == 1;
95                $permessage->{ $fieldtable->{ $o->[0] } } = $o->[2];
96            }
97        } else {
98            # The line does not begin with a DSN field defined in RFC3464
99            #
100            # ----- Transcript of session follows -----
101            # ... while talking to mta.example.org.:
102            # >>> DATA
103            # <<< 550 Unknown user recipient@example.jp
104            # 554 5.0.0 Service unavailable
105            if( substr($e, 0, 1) ne ' ') {
106                # Other error messages
107                if( $e =~ /\A[>]{3}[ ]+([A-Z]{4})[ ]?/ ) {
108                    # >>> DATA
109                    $commandtxt = $1;
110
111                } elsif( $e =~ /\A[<]{3}[ ]+(.+)\z/ ) {
112                    # <<< Response
113                    push @$esmtpreply, $1 unless grep { $1 eq $_ } @$esmtpreply;
114
115                } else {
116                    # Detect SMTP session error or connection error
117                    next if $sessionerr;
118                    if( index($e, $startingof->{'error'}->[0]) == 0 ) {
119                        # ----- Transcript of session follows -----
120                        # ... while talking to mta.example.org.:
121                        $sessionerr = 1;
122                        next;
123                    }
124
125                    if( $e =~ /\A[<](.+)[>][.]+ (.+)\z/ ) {
126                        # <kijitora@example.co.jp>... Deferred: Name server: example.co.jp.: host name lookup failure
127                        $anotherset->{'recipient'} = $1;
128                        $anotherset->{'diagnosis'} = $2;
129
130                    } else {
131                        # ----- Transcript of session follows -----
132                        # Message could not be delivered for too long
133                        # Message will be deleted from queue
134                        if( $e =~ /\A[45]\d\d[ \t]([45][.]\d[.]\d)[ \t].+/ ) {
135                            # 550 5.1.2 <kijitora@example.org>... Message
136                            #
137                            # DBI connect('dbname=...')
138                            # 554 5.3.0 unknown mailer error 255
139                            $anotherset->{'status'} = $1;
140                            $anotherset->{'diagnosis'} .= ' '.$e;
141
142                        } elsif( index($e, 'Message: ') == 0 || index($e, 'Warning: ') == 0 ) {
143                            # Message could not be delivered for too long
144                            # Warning: message still undelivered after 4 hours
145                            $anotherset->{'diagnosis'} .= ' '.$e;
146                        }
147                    }
148                }
149            } else {
150                # Continued line of the value of Diagnostic-Code field
151                next unless index($p, 'Diagnostic-Code:') == 0;
152                next unless $e =~ /\A[ \t]+(.+)\z/;
153                $v->{'diagnosis'} .= ' '.$1;
154            }
155        }
156    } continue {
157        # Save the current line for the next loop
158        $p = $e;
159    }
160    return undef unless $recipients;
161
162    for my $e ( @$dscontents ) {
163        # Set default values if each value is empty.
164        $e->{'lhost'}   ||= $permessage->{'rhost'};
165        $e->{ $_ }      ||= $permessage->{ $_ } || '' for keys %$permessage;
166        $e->{'command'} ||= $commandtxt         || '';
167        $e->{'command'} ||= 'EHLO' if scalar @$esmtpreply;
168
169        if( exists $anotherset->{'diagnosis'} && $anotherset->{'diagnosis'} ) {
170            # Copy alternative error message
171            $e->{'diagnosis'}   = $anotherset->{'diagnosis'} if $e->{'diagnosis'} =~ /\A[ \t]+\z/;
172            $e->{'diagnosis'} ||= $anotherset->{'diagnosis'};
173            $e->{'diagnosis'}   = $anotherset->{'diagnosis'} if $e->{'diagnosis'} =~ /\A\d+\z/;
174        }
175        if( scalar @$esmtpreply ) {
176            # Replace the error message in "diagnosis" with the ESMTP Reply
177            my $r = join(' ', @$esmtpreply);
178            $e->{'diagnosis'} = $r if length($r) > length($e->{'diagnosis'});
179        }
180        $e->{'diagnosis'} = Sisimai::String->sweep($e->{'diagnosis'});
181
182        if( exists $anotherset->{'status'} && $anotherset->{'status'} ) {
183            # Check alternative status code
184            if( ! $e->{'status'} || $e->{'status'} !~ /\A[45][.]\d[.]\d{1,3}\z/ ) {
185                # Override alternative status code
186                $e->{'status'} = $anotherset->{'status'};
187            }
188        }
189
190        # @example.jp, no local part
191        # Get email address from the value of Diagnostic-Code header
192        next if $e->{'recipient'} =~ /\A[^ ]+[@][^ ]+\z/;
193        $e->{'recipient'} = $1 if $e->{'diagnosis'} =~ /[<]([^ ]+[@][^ ]+)[>]/;
194    }
195    return { 'ds' => $dscontents, 'rfc822' => $emailsteak->[1] };
196}
197
1981;
199__END__
200
201=encoding utf-8
202
203=head1 NAME
204
205Sisimai::Lhost::Sendmail - bounce mail parser class for v8 Sendmail.
206
207=head1 SYNOPSIS
208
209    use Sisimai::Lhost::Sendmail;
210
211=head1 DESCRIPTION
212
213Sisimai::Lhost::Sendmail parses a bounce email which created by v8 Sendmail.
214Methods in the module are called from only Sisimai::Message.
215
216=head1 CLASS METHODS
217
218=head2 C<B<description()>>
219
220C<description()> returns description string of this module.
221
222    print Sisimai::Lhost::Sendmail->description;
223
224=head2 C<B<make(I<header data>, I<reference to body string>)>>
225
226C<make()> method parses a bounced email and return results as a array reference.
227See Sisimai::Message for more details.
228
229=head1 AUTHOR
230
231azumakuniyuki
232
233=head1 COPYRIGHT
234
235Copyright (C) 2014-2021 azumakuniyuki, All rights reserved.
236
237=head1 LICENSE
238
239This software is distributed under The BSD 2-Clause License.
240
241=cut
242