File Coverage

lib/Sisimai/Lhost/AmazonSES.pm
Criterion Covered Total %
statement 149 162 91.9
branch 72 94 76.6
condition 26 50 52.0
subroutine 6 6 100.0
pod 2 2 100.0
total 255 314 81.2


line stmt bran cond sub pod time code
1             package Sisimai::Lhost::AmazonSES;
2 28     28   6291 use parent 'Sisimai::Lhost';
  28         60  
  28         154  
3 28     28   1691 use feature ':5.10';
  28         79  
  28         1960  
4 28     28   159 use strict;
  28         66  
  28         687  
5 28     28   164 use warnings;
  28         66  
  28         60262  
6              
7             # https://aws.amazon.com/ses/
8 2     2 1 1183 sub description { 'Amazon SES(Sending): https://aws.amazon.com/ses/' };
9             sub make {
10             # Detect an error from Amazon SES
11             # @param [Hash] mhead Message headers of a bounce email
12             # @param [String] mbody Message body of a bounce email
13             # @return [Hash] Bounce data list and message/rfc822 part
14             # @return [Undef] failed to parse or the arguments are missing
15             # @since v4.0.2
16 532     532 1 1316 my $class = shift;
17 532   100     1474 my $mhead = shift // return undef;
18 531   50     1445 my $mbody = shift // return undef;
19              
20 531         1158 state $indicators = __PACKAGE__->INDICATORS;
21 531         939 state $rebackbone = qr|^content-type:[ ]message/rfc822|m;
22 531         1351 state $startingof = {
23             'message' => ['The following message to <', 'An error occurred while trying to deliver the mail '],
24             };
25 531         890 state $messagesof = { 'expired' => ['Delivery expired'] };
26              
27 531         1649 my $dscontents = [__PACKAGE__->DELIVERYSTATUS];
28 531         1297 my $recipients = 0; # (Integer) The number of 'Final-Recipient' header
29              
30 531 100       2262 if( index($$mbody, '{') == 0 ) {
31             # The message body is JSON string
32 25 50       117 return undef unless exists $mhead->{'x-amz-sns-message-id'};
33 25 50       105 return undef unless $mhead->{'x-amz-sns-message-id'};
34              
35             # https://docs.aws.amazon.com/en_us/ses/latest/DeveloperGuide/notification-contents.html
36 25         266 my $bouncetype = {
37             'Permanent' => { 'General' => '', 'NoEmail' => '', 'Suppressed' => '' },
38             'Transient' => {
39             'General' => '',
40             'MailboxFull' => 'mailboxfull',
41             'MessageTooLarge' => 'mesgtoobig',
42             'ContentRejected' => '',
43             'AttachmentRejected' => '',
44             },
45             };
46 25         64 my $jsonstring = '';
47 25         57 my $foldedline = 0;
48 25         47 my $sespayload = undef;
49              
50 25         261 for my $e ( split(/\n/, $$mbody) ) {
51             # Find JSON string from the message body
52 130 100       237 next unless length $e;
53 110 100       203 last if $e eq '--';
54              
55 90 100       163 substr($e, 0, 1, '') if $foldedline; # The line starts with " ", continued from !\n.
56 90         107 $foldedline = 0;
57              
58 90 100       182 if( substr($e, -1, 1) eq '!' ) {
59             # ... long long line ...![\n]
60 15         55 substr($e, -1, 1, '');
61 15         39 $foldedline = 1;
62             }
63 90         163 $jsonstring .= $e;
64             }
65              
66 25         988 require JSON;
67 25         9021 eval {
68 25         322 my $jsonparser = JSON->new;
69 25         887 my $jsonobject = $jsonparser->decode($jsonstring);
70              
71 25 100       131 if( exists $jsonobject->{'Message'} ) {
72             # 'Message' => '{"notificationType":"Bounce",...
73 5         215 $sespayload = $jsonparser->decode($jsonobject->{'Message'});
74              
75             } else {
76             # 'mail' => { 'sourceArn' => '...',... }, 'bounce' => {...},
77 20         128 $sespayload = $jsonobject;
78             }
79             };
80 25 50       89 if( $@ ) {
81             # Something wrong in decoding JSON
82 0         0 warn sprintf(" ***warning: Failed to decode JSON: %s", $@);
83 0         0 return undef;
84             }
85 25 50       84 return undef unless exists $sespayload->{'notificationType'};
86              
87 25         60 my $rfc822head = {}; # (Hash) Check flags for headers in RFC822 part
88 25         104 my $labeltable = {
89             'Bounce' => 'bouncedRecipients',
90             'Complaint' => 'complainedRecipients',
91             };
92 25         50 my $p = $sespayload;
93 25         52 my $v = undef;
94              
95 25 100 100     154 if( $p->{'notificationType'} eq 'Bounce' || $p->{'notificationType'} eq 'Complaint' ) {
    50          
96             # { "notificationType":"Bounce", "bounce": { "bounceType":"Permanent",...
97 15         55 my $o = $p->{ lc $p->{'notificationType'} };
98 15   50     63 my $r = $o->{ $labeltable->{ $p->{'notificationType'} } } || [];
99              
100 15         43 for my $e ( @$r ) {
101             # 'bouncedRecipients' => [ { 'emailAddress' => 'bounce@si...' }, ... ]
102             # 'complainedRecipients' => [ { 'emailAddress' => 'complaint@si...' }, ... ]
103 15 50       112 next unless Sisimai::RFC5322->is_emailaddress($e->{'emailAddress'});
104              
105 15         55 $v = $dscontents->[-1];
106 15 50       44 if( $v->{'recipient'} ) {
107             # There are multiple recipient addresses in the message body.
108 0         0 push @$dscontents, __PACKAGE__->DELIVERYSTATUS;
109 0         0 $v = $dscontents->[-1];
110             }
111 15         27 $recipients++;
112 15         47 $v->{'recipient'} = $e->{'emailAddress'};
113              
114 15 100       59 if( $p->{'notificationType'} eq 'Bounce' ) {
115             # 'bouncedRecipients => [ {
116             # 'emailAddress' => 'bounce@simulator.amazonses.com',
117             # 'action' => 'failed',
118             # 'status' => '5.1.1',
119             # 'diagnosticCode' => 'smtp; 550 5.1.1 user unknown'
120             # }, ... ]
121 10         29 $v->{'action'} = $e->{'action'};
122 10         28 $v->{'status'} = $e->{'status'};
123              
124 10 50       60 if( $e->{'diagnosticCode'} =~ /\A(.+?);[ ]*(.+)\z/ ) {
125             # Diagnostic-Code: SMTP; 550 5.1.1 ... User Unknown
126 10         45 $v->{'spec'} = uc $1;
127 10         35 $v->{'diagnosis'} = $2;
128              
129             } else {
130 0         0 $v->{'diagnosis'} = $e->{'diagnosticCode'};
131             }
132              
133             # 'reportingMTA' => 'dsn; a27-23.smtp-out.us-west-2.amazonses.com',
134 10 50       71 $v->{'lhost'} = $1 if $o->{'reportingMTA'} =~ /\Adsn;[ ](.+)\z/;
135              
136 10 50 33     117 if( exists $bouncetype->{ $o->{'bounceType'} } &&
137             exists $bouncetype->{ $o->{'bounceType'} }->{ $o->{'bounceSubType'} } ) {
138             # 'bounce' => {
139             # 'bounceType' => 'Permanent',
140             # 'bounceSubType' => 'General'
141             # },
142 10         41 $v->{'reason'} = $bouncetype->{ $o->{'bounceType'} }->{ $o->{'bounceSubType'} };
143             }
144             } else {
145             # 'complainedRecipients' => [ {
146             # 'emailAddress' => 'complaint@simulator.amazonses.com' }, ... ],
147 5         13 $v->{'reason'} = 'feedback';
148 5   50     23 $v->{'feedbacktype'} = $o->{'complaintFeedbackType'} || '';
149             }
150 15   33     137 ($v->{'date'} = $o->{'timestamp'} || $p->{'mail'}->{'timestamp'}) =~ s/[.]\d+Z\z//;
151             }
152             } elsif( $p->{'notificationType'} eq 'Delivery' ) {
153             # { "notificationType":"Delivery", "delivery": { ...
154 10         24 my $o = $p->{'delivery'};
155 10   50     29 my $r = $o->{'recipients'} || [];
156              
157 10         34 for my $e ( @$r ) {
158             # 'delivery' => {
159             # 'timestamp' => '2016-11-23T12:01:03.512Z',
160             # 'processingTimeMillis' => 3982,
161             # 'reportingMTA' => 'a27-29.smtp-out.us-west-2.amazonses.com',
162             # 'recipients' => [
163             # 'success@simulator.amazonses.com'
164             # ],
165             # 'smtpResponse' => '250 2.6.0 Message received'
166             # },
167 10 50       64 next unless Sisimai::RFC5322->is_emailaddress($e);
168              
169 10         34 $v = $dscontents->[-1];
170 10 50       33 if( $v->{'recipient'} ) {
171             # There are multiple recipient addresses in the message body.
172 0         0 push @$dscontents, __PACKAGE__->DELIVERYSTATUS;
173 0         0 $v = $dscontents->[-1];
174             }
175 10         16 $recipients++;
176 10         19 $v->{'recipient'} = $e;
177 10   50     44 $v->{'lhost'} = $o->{'reportingMTA'} || '';
178 10   50     26 $v->{'diagnosis'} = $o->{'smtpResponse'} || '';
179 10   50     82 $v->{'status'} = Sisimai::SMTP::Status->find($v->{'diagnosis'}) || '';
180 10   50     60 $v->{'replycode'} = Sisimai::SMTP::Reply->find($v->{'diagnosis'}) || '';
181 10         26 $v->{'reason'} = 'delivered';
182 10         24 $v->{'action'} = 'delivered';
183 10   33     83 ($v->{'date'} = $o->{'timestamp'} || $p->{'mail'}->{'timestamp'}) =~ s/[.]\d+Z\z//;
184             }
185             } else {
186             # The value of "notificationType" is not any of "Bounce", "Complaint",
187             # or "Delivery".
188 0         0 return undef;
189             }
190 25 50       86 return undef unless $recipients;
191              
192 25 50       77 if( exists $p->{'mail'}->{'headers'} ) {
193             # "headersTruncated":false,
194             # "headers":[ { ...
195 25         42 for my $e ( @{ $p->{'mail'}->{'headers'} } ) {
  25         77  
196             # 'headers' => [ { 'name' => 'From', 'value' => 'neko@nyaan.jp' }, ... ],
197 150 100       479 next unless $e->{'name'} =~ /\A(?:From|To|Subject|Message-ID|Date)\z/;
198 75         205 $rfc822head->{ lc $e->{'name'} } = $e->{'value'};
199             }
200             }
201              
202 25 50       91 unless( $rfc822head->{'message-id'} ) {
203             # Try to get the value of "Message-Id".
204             # 'messageId' => '01010157e48f9b9b-891e9a0e-9c9d-4773-9bfe-608f2ef4756d-000000'
205 25 50       100 $rfc822head->{'message-id'} = $p->{'mail'}->{'messageId'} if $p->{'mail'}->{'messageId'};
206             }
207 25         348 return { 'ds' => $dscontents, 'rfc822' => $rfc822head };
208              
209             } else {
210             # The message body is an email
211             # 'from' => qr/\AMAILER-DAEMON[@]email[-]bounces[.]amazonses[.]com\z/,
212             # 'subject' => qr/\ADelivery Status Notification [(]Failure[)]\z/,
213 506   100     2610 my $xmail = $mhead->{'x-mailer'} || '';
214 506 100       1602 return undef if index($xmail, 'Amazon WorkMail') > -1;
215              
216             # X-SenderID: Sendmail Sender-ID Filter v1.0.0 nijo.example.jp p7V3i843003008
217             # X-Original-To: 000001321defbd2a-788e31c8-2be1-422f-a8d4-cf7765cc9ed7-000000@email-bounces.amazonses.com
218             # X-AWS-Outgoing: 199.255.192.156
219             # X-SES-Outgoing: 2016.10.12-54.240.27.6
220 470         680 my $match = 0;
221 470 100 50     1212 $match ||= 1 if $mhead->{'x-aws-outgoing'};
222 470 100 50     1726 $match ||= 1 if $mhead->{'x-ses-outgoing'};
223 470 100       2061 return undef unless $match;
224              
225 129         2262 require Sisimai::RFC1894;
226 129         749 my $fieldtable = Sisimai::RFC1894->FIELDTABLE;
227 129         355 my $permessage = {}; # (Hash) Store values of each Per-Message field
228 129         268 my $readcursor = 0; # (Integer) Points the current cursor position
229 129         649 my $emailsteak = Sisimai::RFC5322->fillet($mbody, $rebackbone);
230 129         320 my $v = undef;
231 129         254 my $p = '';
232              
233 129         1985 for my $e ( split("\n", $emailsteak->[0]) ) {
234             # Read each line between the start of the message and the start of rfc822 part.
235 5477 100       7398 unless( $readcursor ) {
236             # Beginning of the bounce message or message/delivery-status part
237 2298 100 100     6743 if( index($e, $startingof->{'message'}->[0]) == 0 ||
238             index($e, $startingof->{'message'}->[1]) == 0 ) {
239 82         187 $readcursor |= $indicators->{'deliverystatus'};
240 82         170 next;
241             }
242             }
243 5395 100       8202 next unless $readcursor & $indicators->{'deliverystatus'};
244 3179 100       4458 next unless length $e;
245              
246 2555 100       4303 if( my $f = Sisimai::RFC1894->match($e) ) {
247             # $e matched with any field defined in RFC3464
248 426 50       875 next unless my $o = Sisimai::RFC1894->field($e);
249 426         720 $v = $dscontents->[-1];
250              
251 426 100       931 if( $o->[-1] eq 'addr' ) {
    100          
252             # Final-Recipient: rfc822; kijitora@example.jp
253             # X-Actual-Recipient: rfc822; kijitora@example.co.jp
254 82 50       262 if( $o->[0] eq 'final-recipient' ) {
255             # Final-Recipient: rfc822; kijitora@example.jp
256 82 50       276 if( $v->{'recipient'} ) {
257             # There are multiple recipient addresses in the message body.
258 0         0 push @$dscontents, __PACKAGE__->DELIVERYSTATUS;
259 0         0 $v = $dscontents->[-1];
260             }
261 82         177 $v->{'recipient'} = $o->[2];
262 82         199 $recipients++;
263              
264             } else {
265             # X-Actual-Recipient: rfc822; kijitora@example.co.jp
266 0         0 $v->{'alias'} = $o->[2];
267             }
268             } elsif( $o->[-1] eq 'code' ) {
269             # Diagnostic-Code: SMTP; 550 5.1.1 ... User Unknown
270 82         232 $v->{'spec'} = $o->[1];
271 82         232 $v->{'diagnosis'} = $o->[2];
272              
273             } else {
274             # Other DSN fields defined in RFC3464
275 262 50       584 next unless exists $fieldtable->{ $o->[0] };
276 262         604 $v->{ $fieldtable->{ $o->[0] } } = $o->[2];
277              
278 262 100       651 next unless $f == 1;
279 82         340 $permessage->{ $fieldtable->{ $o->[0] } } = $o->[2];
280             }
281             } else {
282             # Continued line of the value of Diagnostic-Code field
283 2129 100       4167 next unless index($p, 'Diagnostic-Code:') == 0;
284 10 50       69 next unless $e =~ /\A[ \t]+(.+)\z/;
285 10         47 $v->{'diagnosis'} .= ' '.$1;
286             }
287             } continue {
288             # Save the current line for the next loop
289 5477         7399 $p = $e;
290             }
291 129 100       984 return undef unless $recipients;
292              
293 82         236 for my $e ( @$dscontents ) {
294             # Set default values if each value is empty.
295 82   33     490 $e->{'lhost'} ||= $permessage->{'rhost'};
296 82   0     467 $e->{ $_ } ||= $permessage->{ $_ } || '' for keys %$permessage;
      33        
297              
298 82         243 $e->{'diagnosis'} =~ y/\n/ /;
299 82         546 $e->{'diagnosis'} = Sisimai::String->sweep($e->{'diagnosis'});
300 82 100       431 if( $e->{'status'} =~ /\A[45][.][01][.]0\z/ ) {
301             # Get other D.S.N. value from the error message
302             # 5.1.0 - Unknown address error 550-'5.7.1 ...
303 22         94 my $errormessage = $e->{'diagnosis'};
304 22 100       169 $errormessage = $1 if $e->{'diagnosis'} =~ /["'](\d[.]\d[.]\d.+)['"]/;
305 22   33     156 $e->{'status'} = Sisimai::SMTP::Status->find($errormessage) || $e->{'status'};
306             }
307              
308 82         272 SESSION: for my $r ( keys %$messagesof ) {
309             # Verify each regular expression of session errors
310 82 50       134 next unless grep { index($e->{'diagnosis'}, $_) > -1 } @{ $messagesof->{ $r } };
  82         431  
  82         192  
311 0         0 $e->{'reason'} = $r;
312 0         0 last;
313             }
314             }
315 82         742 return { 'ds' => $dscontents, 'rfc822' => $emailsteak->[1] };
316             }
317             }
318              
319             1;
320             __END__