File Coverage

blib/lib/Net/AS2/MDN.pm
Criterion Covered Total %
statement 40 145 27.5
branch 4 68 5.8
condition 5 49 10.2
subroutine 18 29 62.0
pod 17 21 80.9
total 84 312 26.9


line stmt bran cond sub pod time code
1             package Net::AS2::MDN;
2 4     4   18 use strict;
  4         5  
  4         143  
3 4     4   15 use warnings qw(all);
  4         7  
  4         121  
4            
5             =head1 NAME
6            
7             Net::AS2::MDN - AS2 Message Deposition Notification
8            
9             =head1 SYNOPSIS
10            
11             ### Sending Message and got a Sync MDN
12             my $mdn = $as2->send($body, Type => 'application/xml', MessageId => 'my-message-id-12345@localhost')
13            
14             if (!$mdn->is_success) {
15             print STDERR $mdn->description;
16             }
17            
18             =head1 PUBLIC INTERFACE
19            
20             =cut
21            
22 4     4   15 use Carp;
  4         4  
  4         335  
23 4     4   4382 use MIME::Parser;
  4         460907  
  4         198  
24 4     4   43 use MIME::Entity;
  4         7  
  4         95  
25 4     4   20 use Scalar::Util qw(blessed);
  4         8  
  4         7332  
26            
27             my $crlf = "\x0d\x0a";
28            
29             =head2 Constructor
30            
31             =over 4
32            
33             =item $mdn = Net::AS2::MDN->create_success($message)
34            
35             =item $mdn = Net::AS2::MDN->create_success($message, $plain_text)
36            
37             Create an C indicating processed with transaction information
38             provided by C. Optionally with a human readable text.
39            
40             =cut
41            
42             sub create_success
43             {
44 1     1 1 543 my ($class, $message, $plain_text) = @_;
45            
46 1         5 my $self = $class->_create_from_message($message, 'Message is received successfully.', $plain_text);
47 1         7 $self->{success} = 1;
48 1   33     8 return bless ($self, ref($class) || $class);
49             }
50            
51             =item $mdn = Net::AS2::MDN->create_warning($message, $status_text)
52            
53             =item $mdn = Net::AS2::MDN->create_warning($message, $status_text, $plain_text)
54            
55             Create an C indicating processed with warnings with transaction
56             information provided by C. Optionally with a human readable text.
57            
58             Status text is required and will goes to the C line.
59             It is limited to printable ASCII.
60            
61             =cut
62            
63             sub create_warning
64             {
65 0     0 1 0 my ($class, $message, $status_text, $plain_text) = @_;
66            
67 0         0 my $self = $class->_create_from_message($message, $status_text, $plain_text);
68 0         0 $self->{success} = 1;
69 0         0 $self->{warning} = 1;
70 0         0 return $self
71             }
72            
73             =item $mdn = Net::AS2::MDN->create_failure($message, $status_text)
74            
75             =item $mdn = Net::AS2::MDN->create_failure($message, $status_text, $plain_text)
76            
77             Create an C indicating failed/failure status with transaction
78             information provided by C. Optionally with a human readable text.
79            
80             Status text is required and will goes to the C line.
81             It is limited to printable ASCII.
82            
83             =cut
84            
85             sub create_failure
86             {
87 0     0 1 0 my ($class, $message, $status_text, $plain_text) = @_;
88            
89 0         0 my $self = $class->_create_from_message($message, $status_text, $plain_text);
90 0         0 $self->{failure} = 1;
91 0         0 return $self
92             }
93            
94             =item $mdn = Net::AS2::MDN->create_error($message, $status_text)
95            
96             =item $mdn = Net::AS2::MDN->create_error($message, $status_text, $plain_text)
97            
98             Create an C indicating processed/error status with transaction
99             information provided by C. Optionally with a human readable text.
100            
101             Status text is required and will goes to the C line.
102             It is limited to printable ASCII.
103            
104             =cut
105            
106             sub create_error
107             {
108 0     0 1 0 my ($class, $message, $status_text, $plain_text) = @_;
109            
110 0         0 my $self = $class->_create_from_message($message, $status_text, $plain_text);
111 0         0 $self->{error} = 1;
112 0         0 return $self
113             }
114            
115             =item $mdn = Net::AS2::MDN->create_from_unsuccessful_message($message)
116            
117             Create a corresponding C for unsuccessful C
118             notice generated while receiving and decoding. Message's error text
119             will be used.
120            
121             =cut
122            
123             sub create_from_unsuccessful_message
124             {
125 0     0 1 0 my ($class, $error_message) = @_;
126            
127 0 0 0     0 croak "error_message is not an Net::AS2::Message"
128             unless blessed($error_message) && $error_message->isa('Net::AS2::Message');
129 0 0       0 croak "message is not error"
130             unless !$error_message->is_success;
131            
132 0         0 my $self = $class->_create_from_message(
133             $error_message,
134             $error_message->error_status_text,
135             $error_message->error_plain_text);
136            
137 0 0       0 if ($error_message->is_error) {
138 0         0 $self->{error} = 1;
139             } else {
140 0         0 $self->{failure} = 1;
141             }
142 0         0 return $self
143             }
144            
145             sub _create_from_message
146             {
147 1     1   3 my ($class, $message, $status_text, $plain_text) = @_;
148            
149 1 50 33     24 croak "message is not an Net::AS2::Message"
150             unless blessed($message) && $message->isa('Net::AS2::Message');
151            
152 1 50 33     10 croak "status_text should be in English" unless
153             defined $status_text && $status_text =~ /^[\x20-\x7E^]+$/;
154            
155 1 50 33     5 my $self = {
156             status_text => $status_text,
157             plain_text => $plain_text // $status_text,
158             original_message_id => $message->message_id,
159             mic_hash => $message->mic,
160             mic_alg => defined $message->mic ? 'sha1' : undef,
161             async_url => $message->async_url,
162             should_sign => $message->should_mdn_sign,
163             };
164 1   33     8 return bless ($self, ref($class) || $class);
165             }
166            
167             sub parse_mdn
168             {
169 0     0 0 0 my ($class, $content) = @_;
170            
171 0   0     0 $class = ref($class) || $class;
172 0         0 my $self = {};
173 0         0 bless ($self, $class);
174            
175 0         0 $self->_parse_mdn($content);
176 0         0 return $self;
177             }
178            
179             sub create_error_mdn
180             {
181 0     0 0 0 my ($class, $reason) = @_;
182            
183 0   0     0 $class = ref($class) || $class;
184 0         0 my $self = { unparsable => 1, status_text => $reason };
185 0         0 bless ($self, $class);
186            
187 0         0 return $self;
188             }
189            
190             sub create_unparsable_mdn
191             {
192 0     0 0 0 my ($class, $reason) = @_;
193            
194 0   0     0 $class = ref($class) || $class;
195 0         0 my $self = { unparsable => 1, status_text => $reason };
196 0         0 bless ($self, $class);
197            
198 0         0 return $self;
199             }
200            
201             sub _parse_mdn
202             {
203 0     0   0 my ($self, $content) = @_;
204            
205 0         0 my $parser = new MIME::Parser;
206 0         0 $parser->output_to_core(1);
207 0         0 $parser->tmp_to_core(1);
208 0         0 my $entity = $parser->parse_data($content);
209            
210 0 0       0 unless ($entity->mime_type =~ m{^multipart/report}) {
211 0         0 $self->{status_text} = 'unexpected content type';
212 0         0 $self->{unparsable} = 1;
213 0         0 return;
214             }
215            
216 0         0 my @parts = $entity->parts_DFS();
217            
218 0         0 $self->{plain_text} = '';
219 0         0 my $disposition_text = '';
220 0         0 foreach my $p (@parts) {
221 0         0 my $bh = $p->bodyhandle;
222 0 0       0 next unless $bh;
223 0 0       0 if ($p->effective_type =~ m{^text/}i) {
    0          
224 0         0 $self->{plain_text} = $bh->as_string;
225             } elsif ($p->effective_type =~ m{^message/disposition-notification$}i) {
226 0         0 $disposition_text = $bh->as_string;
227             }
228             }
229            
230 0         0 my %disposition;
231 0         0 while ($disposition_text =~ /^ *(.*?) *: *(.*?) *(?:$crlf|$)/gm)
232             {
233 0         0 $disposition{lc($1)} = $2;
234             }
235            
236 0 0       0 if (defined $disposition{'final-recipient'})
237             {
238 0         0 my $recipient = $disposition{'final-recipient'};
239 0 0       0 if ($recipient =~ /^.*? *; *(.+)$/) {
240 0         0 $self->{recipient} = Net::AS2::_parse_as2_id($1);
241             }
242             }
243            
244 0 0       0 $self->{original_message_id} = $disposition{'original-message-id'}
245             if defined $disposition{'original-message-id'};
246            
247 0 0       0 if (defined $disposition{'received-content-mic'})
248             {
249 0 0       0 if ($disposition{'received-content-mic'} =~ m{^ *([A-Za-z0-9/=+]+) *, * (.+?) *$})
250             {
251 0         0 $self->{mic_hash} = $1;
252 0         0 $self->{mic_alg} = $2;
253             }
254             }
255            
256 0         0 my $status_text = '';
257 0 0       0 if (defined $disposition{'disposition'}) {
258 0 0       0 if ($disposition{'disposition'} =~ m{; *(.*?) *$})
259             {
260 0         0 my $op = $1;
261 0 0       0 if ($op =~ /: *(.*?) *$/) {
262 0         0 $status_text = $1;
263             }
264 0 0       0 if ($op =~ /^processed$/i) {
    0          
    0          
265             # All success
266 0         0 $self->{success} = 1;
267             } elsif ($op =~ m{^processed/warning}i) {
268             # Warning
269 0         0 $self->{success} = 1;
270 0         0 $self->{warning} = 1;
271             } elsif ($op =~ m{^failed/failure}i) {
272             # Failed (Failure - EDI level)
273 0         0 $self->{failure} = 1;
274             } else {
275             # including processed/error
276             # Failed (Content - protocol level, e.g. parse/decode/auth)
277 0         0 $self->{error} = 1;
278             }
279             } else {
280 0         0 $status_text = "disposition not parsable";
281 0         0 $self->{unparsable} = 1;
282             }
283             } else {
284 0         0 $status_text = "disposition not found";
285 0         0 $self->{unparsable} = 1;
286             }
287 0         0 $self->{status_text} = $status_text;
288             }
289            
290             =back
291            
292             =head2 Methods
293            
294             =over 4
295            
296             =item $mdn->match($mic, $alg)
297            
298             Verify the MDN MIC value with a pre-calculated one to make sure the receiving party got what we sent.
299            
300             The MDN will be marked C if the MICs do not match.
301            
302             $mdn->match($mic, 'sha1');
303             if ($mdn->is_success) {
304             # still success after comparing mic
305             }
306            
307             =cut
308            
309             sub match_mic
310             {
311 0     0 0 0 my ($self, $hash, $alg) = @_;
312 0 0       0 return undef if !$self->is_success;
313 0 0 0     0 unless (
      0        
      0        
      0        
314             defined $self->{mic_hash} &&
315             defined $hash && defined $alg &&
316             $self->{mic_hash} eq $hash &&
317             $self->{mic_alg} eq $alg)
318             {
319 0         0 $self->{success} = $self->{warning} = $self->{failure} = 0;
320 0         0 $self->{error} = 1;
321 0         0 $self->{status_text} .= "; MDN MIC validation failure";
322 0         0 return 0;
323             }
324 0         0 return 1;
325             }
326            
327             =item $mdn->is_success
328            
329             Indicating a successfully processed status. (This returns true even with warning was presented)
330            
331             =cut
332            
333 1     1 1 11 sub is_success { return (shift)->{success}; }
334            
335             =item $mdn->with_warning
336            
337             Indicating the message was processed with warning.
338            
339             =cut
340            
341 1     1 1 4 sub with_warning { return (shift)->{warning}; }
342            
343             =item $mdn->is_failure
344            
345             Indicating a failed/failure status.
346            
347             =cut
348            
349 1     1 1 4 sub is_failure { return (shift)->{failure}; }
350            
351             =item $mdn->is_error
352            
353             Indicating a processed/error status
354            
355             =cut
356            
357 1     1 1 4 sub is_error { return (shift)->{error}; }
358            
359             =item $mdn->is_unparsable
360            
361             Indicating the MDN was unparsable
362            
363             =cut
364            
365 1     1 1 4 sub is_unparsable { return (shift)->{unparsable}; }
366            
367             =item $mdn->status_text
368            
369             The machine readable text follows the Disposition status
370            
371             =cut
372            
373 0     0 1 0 sub status_text { return (shift)->{status_text}; }
374            
375             =item $mdn->async_url
376            
377             The URL where the MDN was requested to sent to
378            
379             =cut
380            
381 2     2 1 434 sub async_url { return (shift)->{async_url}; }
382            
383             =item $mdn->should_sign
384            
385             Returns true if the MDN was requested to be signed
386            
387             =cut
388            
389 1     1 1 5 sub should_sign { return (shift)->{should_sign}; }
390            
391             =item $mdn->recipient
392            
393             Returns the AS2 name of the final recipient field of the MDN
394            
395             =cut
396            
397             sub recipient {
398 1     1 1 9 my ($self, $value) = @_;
399 1 50       7 $self->{recipient} = $value if @_ >= 2;
400 1         3 return $self->{recipient};
401             }
402            
403             =item $mdn->original_message_id
404            
405             Returns the Original-Message-Id field of the MDN
406            
407             =cut
408            
409 1     1 1 4 sub original_message_id { return (shift)->{original_message_id}; }
410            
411             =item $mdn->description
412            
413             Returns a concatenated text message of the MDN status, machine readable text
414             and human readable text.
415            
416             =cut
417            
418             sub description {
419 0     0 1 0 my $self = shift;
420 0 0 0     0 return sprintf("%s; %s",
    0          
    0          
    0          
421             $self->{warning} ? 'processed/warning: ' . $self->{status_text} :
422             $self->{success} ? 'processed' :
423             $self->{failure} ? 'failed/failure: ' . $self->{status_text} :
424             $self->{error} ? 'processed/error: ' . $self->{status_text} :
425             'unparsable: ' . $self->{status_text},
426             $self->{plain_text} // '');
427             }
428            
429             =item $mdn->as_mime
430            
431             Returns a multipart/report C representation of the MDN
432            
433             =cut
434            
435             sub as_mime
436             {
437 1     1 1 6 my $self = shift;
438            
439 1         43 my $quoted_recipient = Net::AS2::_encode_as2_id($self->{recipient});
440            
441 0 0 0       my $machine_report =
    0          
    0          
    0          
    0          
442             join($crlf, (
443             "Reporting-UA: Perl AS2",
444             sprintf("Original-Recipient: rfc822; %s", $quoted_recipient),
445             sprintf("Final-Recipient: rfc822; %s", $quoted_recipient),
446             ( $self->{original_message_id} ?
447             sprintf("Original-Message-ID: %s", $self->{original_message_id} ) :
448             ()),
449             sprintf("Disposition: automatic-action/MDN-sent-automatically; %s",
450             $self->{warning} ? 'processed/warning: ' . $self->{status_text} :
451             $self->{success} ? 'processed' :
452             $self->{failure} ? 'failed/failure: ' . $self->{status_text} :
453             'processed/error: ' . ($self->{status_text} // 'unknown-error')
454             ),
455             ( defined $self->{mic_hash} ?
456             sprintf("Received-Content-MIC: %s, %s", $self->{mic_hash}, $self->{mic_alg}) :
457             ())
458             ));
459            
460 0 0 0       my $human_report_mime = new MIME::Entity->build(
      0        
461             Type => 'text/plain',
462             Data => $self->{plain_text} // $self->{status_text} // (
463             $self->{success} ?
464             'Message is received successfully.' :
465             'Message could not be processed.'),
466             Top => 0);
467 0           $human_report_mime->head->delete('Content-disposition');
468 0           my $machine_report_mime = new MIME::Entity->build(
469             Type => 'message/disposition-notification',
470             Data => $machine_report,
471             Top => 0);
472 0           $machine_report_mime->head->delete('Content-disposition');
473 0           my $report_mime = new MIME::Entity->build(
474             Type => 'multipart/report; report-type="disposition-notification"',
475             'X-Mailer' => undef);
476 0           $report_mime->add_part($human_report_mime);
477 0           $report_mime->add_part($machine_report_mime);
478 0           $report_mime->preamble([]);
479 0           return $report_mime;
480             }
481            
482             1;
483            
484             =back
485            
486             =head1 SEE ALSO
487            
488             L, L
489