File Coverage

lib/Sisimai/Lhost/X4.pm
Criterion Covered Total %
statement 83 96 86.4
branch 41 62 66.1
condition 7 15 46.6
subroutine 6 6 100.0
pod 2 2 100.0
total 139 181 76.8


line stmt bran cond sub pod time code
1             package Sisimai::Lhost::X4;
2 14     14   5464 use parent 'Sisimai::Lhost';
  14         23  
  14         66  
3 14     14   728 use feature ':5.10';
  14         22  
  14         856  
4 14     14   63 use strict;
  14         19  
  14         240  
5 14     14   51 use warnings;
  14         110  
  14         20878  
6              
7 2     2 1 1022 sub description { 'Unknown MTA #4 qmail clones' }
8             sub make {
9             # Detect an error from Unknown MTA #4, qmail clones
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.1.23
15 193     193 1 578 my $class = shift;
16 193   100     505 my $mhead = shift // return undef;
17 192   50     495 my $mbody = shift // return undef;
18 192         293 my $match = 0;
19 192         639 my $tryto = qr/\A[(]qmail[ ]+\d+[ ]+invoked[ ]+for[ ]+bounce[)]/;
20              
21             # Pre process email headers and the body part of the message which generated
22             # by qmail, see https://cr.yp.to/qmail.html
23             # e.g.) Received: (qmail 12345 invoked for bounce); 29 Apr 2009 12:34:56 -0000
24             # Subject: failure notice
25 192 100 50     604 $match ||= 1 if index($mhead->{'subject'}, 'failure notice') == 0;
26 192 100 50     502 $match ||= 1 if index($mhead->{'subject'}, 'Permanent Delivery Failure') == 0;
27 192 50 0     200 $match ||= 1 if grep { $_ =~ $tryto } @{ $mhead->{'received'} };
  268         1078  
  192         435  
28 192 100       629 return undef unless $match;
29              
30 11         40 state $indicators = __PACKAGE__->INDICATORS;
31 11         20 state $rebackbone = qr/^---[ ](?:Below this line is a copy of the message|Original message follows)[.]/m;
32 11         23 state $startingof = { 'error' => ['Remote host said:'] };
33 11         22 state $markingsof = {
34             # qmail-remote.c:248| if (code >= 500) {
35             # qmail-remote.c:249| out("h"); outhost(); out(" does not like recipient.\n");
36             # qmail-remote.c:265| if (code >= 500) quit("D"," failed on DATA command");
37             # qmail-remote.c:271| if (code >= 500) quit("D"," failed after I sent the message");
38             #
39             # Characters: K,Z,D in qmail-qmqpc.c, qmail-send.c, qmail-rspawn.c
40             # K = success, Z = temporary error, D = permanent error
41             #
42             # MTA module for qmail clones
43             'message' => qr{\A(?>
44             He/Her[ ]is[ ]not[ ].+[ ]user
45             |Hi[.][ ].+[ ]unable[ ]to[ ]deliver[ ]your[ ]message[ ]to[ ]the[ ]following[ ]addresses
46             |Su[ ]mensaje[ ]no[ ]pudo[ ]ser[ ]entregado
47             |This[ ]is[ ]the[ ](?:
48             machine[ ]generated[ ]message[ ]from[ ]mail[ ]service
49             |mail[ ]delivery[ ]agent[ ]at
50             )
51             |Unable[ ]to[ ]deliver[ ]message[ ]to[ ]the[ ]following[ ]address
52             |Unfortunately,[ ]your[ ]mail[ ]was[ ]not[ ]delivered[ ]to[ ]the[ ]following[ ]address:
53             |Your[ ](?:
54             mail[ ]message[ ]to[ ]the[ ]following[ ]address
55             |message[ ]to[ ]the[ ]following[ ]addresses
56             )
57             |We're[ ]sorry[.]
58             )
59             }x,
60             };
61              
62 11         36 state $resmtp = {
63             # Error text regular expressions which defined in qmail-remote.c
64             # qmail-remote.c:225| if (smtpcode() != 220) quit("ZConnected to "," but greeting failed");
65             'conn' => qr/(?:Error:)?Connected to [^ ]+ but greeting failed[.]/,
66             # qmail-remote.c:231| if (smtpcode() != 250) quit("ZConnected to "," but my name was rejected");
67             'ehlo' => qr/(?:Error:)?Connected to [^ ]+ but my name was rejected[.]/,
68             # qmail-remote.c:238| if (code >= 500) quit("DConnected to "," but sender was rejected");
69             # reason = rejected
70             'mail' => qr/(?:Error:)?Connected to [^ ]+ but sender was rejected[.]/,
71             # qmail-remote.c:249| out("h"); outhost(); out(" does not like recipient.\n");
72             # qmail-remote.c:253| out("s"); outhost(); out(" does not like recipient.\n");
73             # reason = userunknown
74             'rcpt' => qr/(?:Error:)?[^ ]+ does not like recipient[.]/,
75             # qmail-remote.c:265| if (code >= 500) quit("D"," failed on DATA command");
76             # qmail-remote.c:266| if (code >= 400) quit("Z"," failed on DATA command");
77             # qmail-remote.c:271| if (code >= 500) quit("D"," failed after I sent the message");
78             # qmail-remote.c:272| if (code >= 400) quit("Z"," failed after I sent the message");
79             'data' => qr{(?:
80             (?:Error:)?[^ ]+[ ]failed[ ]on[ ]DATA[ ]command[.]
81             |(?:Error:)?[^ ]+[ ]failed[ ]after[ ]I[ ]sent[ ]the[ ]message[.]
82             )
83             }x,
84             };
85 11         18 state $rehost = qr{(?:
86             # qmail-remote.c:261| if (!flagbother) quit("DGiving up on ","");
87             Giving[ ]up[ ]on[ ]([^ ]+[0-9a-zA-Z])[.]?\z
88             |Connected[ ]to[ ]([-0-9a-zA-Z.]+[0-9a-zA-Z])[ ]
89             |remote[ ]host[ ]([-0-9a-zA-Z.]+[0-9a-zA-Z])[ ]said:
90             )
91             }x;
92              
93             # qmail-send.c:922| ... (&dline[c],"I'm not going to try again; this message has been in the queue too long.\n")) nomem();
94 11         18 state $hasexpired = 'this message has been in the queue too long.';
95             # qmail-remote-fallback.patch
96 11         19 state $recommands = qr/Sorry,[ ]no[ ]SMTP[ ]connection[ ]got[ ]far[ ]enough;[ ]most[ ]progress[ ]was[ ]([A-Z]{4})[ ]/x;
97 11         21 state $reisonhold = qr/\A[^ ]+ does not like recipient[.][ \t]+.+this message has been in the queue too long[.]\z/;
98 11         30 state $failonldap = {
99             # qmail-ldap-1.03-20040101.patch:19817 - 19866
100             'suspend' => ['Mailaddress is administrative?le?y disabled'], # 5.2.1
101             'userunknown' => ['Sorry, no mailbox here by that name'], # 5.1.1
102             'exceedlimit' => ['The message exeeded the maximum size the user accepts'], # 5.2.3
103             'systemerror' => [
104             'Automatic homedir creator crashed', # 4.3.0
105             'Illegal value in LDAP attribute', # 5.3.5
106             'LDAP attribute is not given but mandatory', # 5.3.5
107             'Timeout while performing search on LDAP server', # 4.4.3
108             'Too many results returned but needs to be unique', # 5.3.5
109             'Permanent error while executing qmail-forward', # 5.4.4
110             'Temporary error in automatic homedir creation', # 4.3.0 or 5.3.0
111             'Temporary error while executing qmail-forward', # 4.4.4
112             'Temporary failure in LDAP lookup', # 4.4.3
113             'Unable to contact LDAP server', # 4.4.3
114             'Unable to login into LDAP server, bad credentials',# 4.4.3
115             ],
116             };
117 11         32 state $messagesof = {
118             # qmail-local.c:589| strerr_die1x(100,"Sorry, no mailbox here by that name. (#5.1.1)");
119             # qmail-remote.c:253| out("s"); outhost(); out(" does not like recipient.\n");
120             'userunknown' => [
121             'no mailbox here by that name',
122             'does not like recipient.',
123             ],
124             # error_str.c:192| X(EDQUOT,"disk quota exceeded")
125             'mailboxfull' => ['disk quota exceeded'],
126             # qmail-qmtpd.c:233| ... result = "Dsorry, that message size exceeds my databytes limit (#5.3.4)";
127             # qmail-smtpd.c:391| ... out("552 sorry, that message size exceeds my databytes limit (#5.3.4)\r\n"); return;
128             'mesgtoobig' => ['Message size exceeds fixed maximum message size:'],
129             # qmail-remote.c:68| Sorry, I couldn't find any host by that name. (#4.1.2)\n"); zerodie();
130             # qmail-remote.c:78| Sorry, I couldn't find any host named ");
131             'hostunknown' => ["Sorry, I couldn't find any host "],
132             'systemfull' => ['Requested action not taken: mailbox unavailable (not enough free space)'],
133             'systemerror' => [
134             'bad interpreter: No such file or directory',
135             'system error',
136             'Unable to',
137             ],
138             'networkerror'=> [
139             "Sorry, I wasn't able to establish an SMTP connection",
140             "Sorry, I couldn't find a mail exchanger or IP address",
141             "Sorry. Although I'm listed as a best-preference MX or A for that host",
142             ],
143             };
144              
145 11         54 my $dscontents = [__PACKAGE__->DELIVERYSTATUS];
146 11         61 my $emailsteak = Sisimai::RFC5322->fillet($mbody, $rebackbone);
147 11         19 my $readcursor = 0; # (Integer) Points the current cursor position
148 11         18 my $recipients = 0; # (Integer) The number of 'Final-Recipient' header
149 11         19 my $v = undef;
150              
151 11         53 for my $e ( split("\n", $emailsteak->[0]) ) {
152             # Read error messages and delivery status lines from the head of the email
153             # to the previous line of the beginning of the original message.
154 72 100       113 unless( $readcursor ) {
155             # Beginning of the bounce message or message/delivery-status part
156 16 100       111 $readcursor |= $indicators->{'deliverystatus'} if $e =~ $markingsof->{'message'};
157 16         25 next;
158             }
159 56 50       90 next unless $readcursor & $indicators->{'deliverystatus'};
160 56 100       75 next unless length $e;
161              
162             # :
163             # 192.0.2.153 does not like recipient.
164             # Remote host said: 550 5.1.1 ... User Unknown
165             # Giving up on 192.0.2.153.
166 45         47 $v = $dscontents->[-1];
167              
168 45 100       141 if( $e =~ /\A(?:To[ ]*:)?[<](.+[@].+)[>]:[ \t]*\z/ ) {
    100          
169             # :
170 11 50       40 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 11         37 $v->{'recipient'} = $1;
176 11         15 $recipients++;
177              
178             } elsif( scalar @$dscontents == $recipients ) {
179             # Append error message
180 16 50       53 next unless length $e;
181 16         44 $v->{'diagnosis'} .= $e.' ';
182 16 50       55 $v->{'alterrors'} = $e if index($e, $startingof->{'error'}->[0]) == 0;
183              
184 16 50       33 next if $v->{'rhost'};
185 16 50       94 $v->{'rhost'} = $1 if $e =~ $rehost;
186             }
187             }
188 11 50       38 return undef unless $recipients;
189              
190 11         27 for my $e ( @$dscontents ) {
191 11         76 $e->{'diagnosis'} = Sisimai::String->sweep($e->{'diagnosis'});
192              
193 11 50       33 unless( $e->{'command'} ) {
194             # Get the SMTP command name for the session
195 11         41 SMTP: for my $r ( keys %$resmtp ) {
196             # Verify each regular expression of SMTP commands
197 55 50       629 next unless $e->{'diagnosis'} =~ $resmtp->{ $r };
198 0         0 $e->{'command'} = uc $r;
199 0         0 last;
200             }
201              
202 11 50       28 unless( $e->{'command'} ) {
203             # Verify each regular expression of patches
204 11 50       47 $e->{'command'} = uc $1 if $e->{'diagnosis'} =~ $recommands;
205             }
206             }
207              
208             # Detect the reason of bounce
209 11 50 33     69 if( $e->{'command'} eq 'MAIL' ) {
    50          
210             # MAIL | Connected to 192.0.2.135 but sender was rejected.
211 0         0 $e->{'reason'} = 'rejected';
212              
213             } elsif( $e->{'command'} eq 'HELO' || $e->{'command'} eq 'EHLO' ) {
214             # HELO | Connected to 192.0.2.135 but my name was rejected.
215 0         0 $e->{'reason'} = 'blocked';
216              
217             } else {
218             # Try to match with each error message in the table
219 11 50       55 if( $e->{'diagnosis'} =~ $reisonhold ) {
220             # To decide the reason require pattern match with
221             # Sisimai::Reason::* modules
222 0         0 $e->{'reason'} = 'onhold';
223              
224             } else {
225 11         41 SESSION: for my $r ( keys %$messagesof ) {
226             # Verify each regular expression of session errors
227 64 50       113 if( $e->{'alterrors'} ) {
228             # Check the value of "alterrors"
229 0 0       0 next unless grep { index($e->{'alterrors'}, $_) > -1 } @{ $messagesof->{ $r } };
  0         0  
  0         0  
230 0         0 $e->{'reason'} = $r;
231             }
232 64 50       82 last if $e->{'reason'};
233              
234 64 100       59 next unless grep { index($e->{'diagnosis'}, $_) > -1 } @{ $messagesof->{ $r } };
  119         290  
  64         86  
235 5         12 $e->{'reason'} = $r;
236 5         10 last;
237             }
238              
239 11 100       32 unless( $e->{'reason'} ) {
240 6         16 LDAP: for my $r ( keys %$failonldap ) {
241             # Verify each regular expression of LDAP errors
242 24 50       51 next unless grep { index($e->{'diagnosis'}, $_) > -1 } @{ $failonldap->{ $r } };
  84         165  
  24         31  
243 0         0 $e->{'reason'} = $r;
244 0         0 last;
245             }
246             }
247              
248 11 100       26 unless( $e->{'reason'} ) {
249 6 50       21 $e->{'reason'} = 'expired' if index($e->{'diagnosis'}, $hasexpired) > -1;
250             }
251             }
252             }
253 11   50     43 $e->{'command'} ||= '';
254             }
255 11         62 return { 'ds' => $dscontents, 'rfc822' => $emailsteak->[1] };
256             }
257              
258             1;
259             __END__