File Coverage

blib/lib/Net/AS2.pm
Criterion Covered Total %
statement 7 9 77.7
branch n/a
condition n/a
subroutine 3 3 100.0
pod n/a
total 10 12 83.3


line stmt bran cond sub pod time code
1             package Net::AS2;
2 2     2   145224 use strict;
  2         5  
  2         76  
3 2     2   9 use warnings qw(all);
  2         3  
  2         110  
4            
5             =head1 NAME
6            
7             Net::AS2 - AS2 Protocol implementation (RFC 4130) used in Electronic Data Exchange (EDI)
8            
9             =head1 SYNOPSIS
10            
11             ### Create an AS2 handler
12             my $as2 = Net::AS2->new(
13             MyId => 'alice',
14             MyKey => '...RSA KEY in PEM...',
15             MyCert => '...X509 Cert in PEM...'
16             PartnerId => 'bob', PartnerCert => '...X509 Cert in PEM...'
17             );
18            
19             ### Sending Message (Sync MDN)
20             my $mdn = $as2->send($body, Type => 'application/xml', MessageId => 'my-message-id-12345@localhost')
21            
22             ### Receiving MDN (Async MDN)
23             my $mdn = $as2->decode_mdn($headers, $body);
24            
25             ### Receiving Message and sending MDN
26             my $message = $as2->decode_message($headers, $post_body);
27            
28             if ($message->is_success) {
29             print $message->content;
30             }
31            
32             if ($message->is_mdn_async) {
33             # ASYNC MDN is expected
34            
35             # stored the state for later use
36             my $state = $message->serialized_state;
37            
38             # ...in another perl instance...
39             my $message = Net::AS2::Message->create_from_serialized_state($state);
40             $as2->send_async_mdn(
41             $message->is_success ?
42             Net::AS2::MDN->create_success($message) :
43             Net::AS2::MDN->create_from_unsuccessful_message($message),
44             'id-23456@localhost'
45             );
46             } else
47             {
48             # SYNC MDN is expected
49             my ($new_headers, $mdn_body) = $as2->prepare_sync_mdn(
50             $message->is_success ?
51             Net::AS2::MDN->create_success($message) :
52             Net::AS2::MDN->create_from_unsuccessful_message($message),
53             'id-23456@localhost'
54             );
55            
56             # ... Send headers and body ...
57             }
58            
59             =head1 DESCRIPTION
60            
61             This is a class for handling AS2 (RFC-4130) communication - sending
62             message (optionally sign and encrypt), decoding MDN. Receving message
63             and produce corresponding MDN.
64            
65             =head2 Protocol Introduction
66            
67             AS2 is a protocol that defines communication over HTTP(s), and
68             optionally using SMIME as payload container, plus a mandated
69             multipart/report machine readable Message Disposition Notification
70             response (MDN).
71            
72             When encryption and signature are used in SMIME payload (agree between
73             parties), as well as a signed MDN, the protocol offers data
74             confidentiality, data integrity/authenticity, non-repudiation of
75             origin, and non-repudiation of receipt over HTTP.
76            
77             In AS2, MDN can only be signed but not encrypted, some MIME headers
78             are also exposed in the HTTP headers when sending. Use HTTPS if this
79             is a concerns.
80            
81             Encryption and Signature are done in PKCS7/SMIME favor. The certifacate
82             are usually exchanged out of band before establishing communication.
83             The certificates could be self-signed.
84            
85             =head1 PUBLIC INTERFACE
86            
87             =cut
88            
89 2     2   1333 use Net::AS2::MDN;
  0            
  0            
90             use Net::AS2::Message;
91             use Carp;
92             use Crypt::SMIME;
93             use LWP::UserAgent;
94             use HTTP::Request;
95             use Digest::SHA1;
96             use MIME::Base64;
97             use MIME::Parser;
98             use Encode;
99             use MIME::Entity;
100             use Sys::Hostname;
101            
102             my $crlf = "\x0d\x0a";
103            
104             our $VERSION = "0.02";
105            
106             =head2 Constructor
107            
108             =over 4
109            
110             =item $as2 = Net::AS2->new(%ARGS)
111            
112             Create an AS2 handler. For preparing keys and certificates, see L
113            
114             The arguments are:
115            
116             =over 4
117            
118             =item MyId
119            
120             I
121             Your AS2 name. This will be used in the AS2-From header.
122            
123             =item PartnerId
124            
125             I
126             The AS2 name of the partner. This will be used in the AS2-To header.
127            
128             =item PartnerUrl
129            
130             I
131             The Url of partner where message would be sent to.
132            
133             =item MyKey
134            
135             I
136             Our private key in PEM format.
137             Please includes the C<-----BEGIN RSA PRIVATE KEY-----> and C<-----END RSA PRIVATE KEY-----> line.
138            
139             =item MyEncryptionKey, MySignatureKey
140            
141             I
142             Different private keys could be used for encryption and signing. L will be used if not independently supplied.
143            
144             =item MyCertificate
145            
146             I
147             Our corresponding certificate in PEM format.
148             Please includes the C<-----BEGIN CERTIFICATE-----> and C<-----END CERTIFICATE-----> line.
149            
150             =item MyEncryptionKey, MySignatureKey
151            
152             I
153             Different certificate could be used for encryption and signing. L will be used if not independently supplied.
154            
155             =item PartnerCertificate
156            
157             I
158             Partner's certificate in PEM format.
159             Please includes the C<-----BEGIN CERTIFICATE-----> and C<-----END CERTIFICATE-----> line.
160            
161             =item PartnerEncryptionCertificate, PartnerSignatureCertificate
162            
163             I
164             Different certificate could be used for encryption and signing. If so, load them here.
165             L will be used if not independently supplied.
166            
167             =item Encryption
168            
169             I
170             Encryption alogrithm used in SMIME encryption operation. Only C<3des> is supported at this moment.
171            
172             If left undefined, encryption is enabled and C<3des> would be used.
173             A false value must be specified to disable encryption.
174            
175             If enabled, encryption would also be required for receiving.
176             Otherwise, encryption would be optional for receiving.
177            
178             =item Signature
179            
180             I
181             Signing alogrithm used in SMIME signing operation. Only C is supported at this moment.
182            
183             If left undefined, signing is enabled and C would be used.
184             A false value must be specified to disable signature.
185            
186             If enabled, signature would also be required for receiving.
187             Otherwise, signature would be optional for receiving.
188            
189             Also, if enabled, signed MDN would be requested.
190            
191             =item Mdn
192            
193             I
194             The preferred MDN method - C or C. The default is C.
195            
196             =item MdnAsyncUrl
197            
198             i.
199             The Url where the parten should send the async MDN to.
200            
201             =item Timeout
202            
203             i
204             The timeout in seconds for HTTP communication. The default is 30.
205            
206             This is passed to LWP::UserAgent.
207            
208             =item UserAgent
209            
210             I
211             User Agent name used in HTTP communication.
212            
213             This is passed to LWP::UserAgent.
214            
215             =back
216            
217             =cut
218            
219             sub new
220             {
221             my ($class, %opts) = @_;
222            
223             $class = ref($class) || $class;
224             my $self = { %opts };
225             bless ($self, $class);
226            
227             $self->_validations();
228            
229             my $s_e = $self->{_smime_enc} = Crypt::SMIME->new();
230            
231             eval { $s_e->setPrivateKey($self->{MyEncryptionKey}, $self->{MyEncryptionCertificate}); };
232             croak "Unable to load private key/certificate for encryption: $@" if $@;
233            
234             eval { $s_e->setPublicKey($self->{PartnerEncryptionCertificate}); };
235             croak "Unable to load public certificate for encryption: $@" if $@;
236            
237             if (
238             $self->{MyEncryptionKey} eq $self->{MySignatureKey} &&
239             $self->{MyEncryptionCertificate} eq $self->{MySignatureCertificate} &&
240             $self->{PartnerEncryptionCertificate} eq $self->{PartnerSignatureCertificate}
241             ) {
242             $self->{_smime_sign} = $self->{_smime_enc};
243             } else
244             {
245             my $s_s = $self->{_smime_sign} = Crypt::SMIME->new();
246            
247             eval { $s_s->setPrivateKey($self->{MySignatureKey}, $self->{MySignatureCertificate}); };
248             croak "Unable to load private key/certificate for signature: $@" if $@;
249            
250             eval { $s_s->setPublicKey($self->{PartnerSignatureCertificate}); };
251             croak "Unable to load public certificate for signature: $@" if $@;
252             }
253            
254             return $self;
255             }
256            
257             sub _validations
258             {
259             my ($self) = @_;
260            
261             $self->{Encryption} = lc($self->{Encryption} // '3des');
262             croak sprintf("encryption %s is not supported", $self->{Encryption})
263             unless !$self->{Encryption} || $self->{Encryption} ~~ ['3des'];
264            
265             $self->{Signature} = lc($self->{Signature} // 'sha1');
266             croak sprintf("signature %s is not supported", $self->{Signature})
267             unless !$self->{Signature} || $self->{Signature} ~~ ['sha1'];
268            
269             $self->{MyEncryptionKey} //= $self->{MyKey};
270             $self->{MyEncryptionCertificate} //= $self->{MyCertificate};
271             $self->{MySignatureKey} //= $self->{MyKey};
272             $self->{MySignatureCertificate} //= $self->{MyCertificate};
273             $self->{PartnerEncryptionCertificate} //= $self->{PartnerCertificate};
274             $self->{PartnerSignatureCertificate} //= $self->{PartnerCertificate};
275             delete $self->{MyKey};
276             delete $self->{MyCertificate};
277             delete $self->{PartnerCertificate};
278            
279             foreach my $t (qw(
280             MyId
281             MyEncryptionKey MyEncryptionCertificate
282             MySignatureKey MySignatureCertificate
283             PartnerId
284             PartnerEncryptionCertificate PartnerSignatureCertificate
285             ))
286             {
287             croak "$t is not valid"
288             unless defined $self->{$t} && $self->{$t} =~ /^[\r\n\x20-\x7E]+$/;
289             }
290             croak "PartnerUrl is invalid"
291             unless defined $self->{PartnerUrl} && $self->{PartnerUrl} =~ m{^https?://[\x20-\x7E]+$};
292            
293             $self->{Mdn} = lc($self->{Mdn} // 'sync');
294             croak sprintf("mdn %s is not supported", $self->{Mdn})
295             unless lc($self->{Mdn}) ~~ [qw(sync async)];
296            
297             croak "mdn_async_url is invalid"
298             unless
299             !defined $self->{MdnAsyncUrl} && $self->{Mdn} eq 'sync' ||
300             defined $self->{MdnAsyncUrl} && $self->{MdnAsyncUrl} =~ m{^https?://[\x20-\x7E]+$} &&
301             $self->{Mdn} eq 'async';
302            
303             $self->{Timeout} //= 30;
304             croak "timeout is invalid"
305             unless $self->{Timeout} =~ /^[0-9]+$/;
306            
307             $self->{UserAgent} //= "Perl AS2/$VERSION";
308             }
309            
310             =back
311            
312             =head2 Methods
313            
314             =over 4
315            
316             =item $message = $as2->decode_message($headers, $content)
317            
318             Decode the incoming HTTP request as AS2 Message.
319            
320             Headers is an hash ref and should be supplied in PSGI format, or C<\%ENV> in CGI mode.
321             Content is the raw POST body of the request.
322            
323             This method always returns a C object and never dies.
324             The message could be successfully parsed, or contains corresponding error message.
325            
326             Check the C<$message-Eis_async> property and send the MDN accordingly.
327            
328             If ASYNC MDN is requested, it should be sent after this HTTP request is returned
329             or in another thread - some AS2 server might block otherwise, YMMV. How to handle
330             this is out of topic.
331            
332             =cut
333            
334             sub decode_message
335             {
336             my ($self, $headers, $content) = @_;
337             croak "headers must be an hash reference"
338             unless ref $headers eq 'HASH';
339             croak "content is undefined"
340             unless defined $content;
341            
342             my $message_id = $headers->{HTTP_MESSAGE_ID};
343             my $async_url = $headers->{HTTP_RECEIPT_DELIVERY_OPTION};
344             my @new_prefix = ($message_id, $async_url, 0);
345            
346             unless (!defined $async_url || $async_url =~ m{^https?://}) {
347             $new_prefix[1] = undef;
348             return Net::AS2::Message->create_failure_message(@new_prefix, 'Async transport other than http/https is not supported');
349             }
350            
351             if ($headers->{HTTP_DISPOSITION_NOTIFICATION_OPTIONS}) {
352             my $status = Net::AS2::Message::notification_options_check($headers->{HTTP_DISPOSITION_NOTIFICATION_OPTIONS});
353             return Net::AS2::Message->create_failure_message(@new_prefix, $status)
354             if defined $status;
355             $new_prefix[2] = 1;
356             }
357            
358             unless (
359             defined $headers->{CONTENT_TYPE} &&
360             defined $headers->{HTTP_MESSAGE_ID} &&
361             defined $headers->{HTTP_AS2_VERSION} &&
362             defined $headers->{HTTP_AS2_FROM} &&
363             defined $headers->{HTTP_AS2_TO})
364             {
365             return Net::AS2::Message->create_error_message(@new_prefix, 'unexpected-processing-error', 'Malformed AS2 Message, crucial headers are missing.');
366             }
367            
368             if (
369             _parse_as2_id($headers->{HTTP_AS2_FROM}) ne $self->{PartnerId} ||
370             _parse_as2_id($headers->{HTTP_AS2_TO}) ne $self->{MyId}
371             ) {
372             return Net::AS2::Message->create_error_message(@new_prefix, 'authentication-failed', 'AS2-From or AS2-To is not expected');
373             }
374            
375             my $is_content_raw = 1;
376            
377             my $raw_content = $content;
378             my $merged_headers =
379             join($crlf, map {
380             if (/^HTTP_/ || /^CONTENT_TYPE$/) {
381             my $key = $_;
382             $key =~ s/^HTTP_//;
383             $key =~ s/_/-/g;
384             "$key: ". $headers->{$_};
385             } else { (); }
386             } keys %{$headers}) . "$crlf$crlf";
387            
388             if ($self->{_smime_enc}->isEncrypted($merged_headers . $content))
389             {
390             # OpenSSL (Crypt::SMIME) in Windows cannot handle binary content,
391             # convert the data to base64
392             $content =
393             "Content-Transfer-Encoding: base64$crlf" .
394             $merged_headers .
395             encode_base64($content);
396             $is_content_raw = 0;
397            
398             $content = eval { $self->{_smime_enc}->decrypt($content); };
399             return Net::AS2::Message->create_error_message(@new_prefix,
400             'decryption-failed', 'Unable to decrypt the message')
401             if $@;
402             } else {
403             return Net::AS2::Message->create_error_message(@new_prefix,
404             'insufficient-message-security', 'Encryption is expected but the message is not encrypted')
405             if $self->{Encryption};
406             }
407            
408             if ($self->{_smime_sign}->isSigned($is_content_raw ? $merged_headers . $content : $content))
409             {
410             if ($is_content_raw) {
411             $content =
412             $merged_headers .
413             $content;
414             $is_content_raw = 0;
415             }
416             $content = eval { $self->{_smime_sign}->check($content); };
417            
418             return Net::AS2::Message->create_error_message(@new_prefix,
419             'insufficient-message-security', 'Unable to verify the signature')
420             if $@;
421             } else {
422             return Net::AS2::Message->create_error_message(@new_prefix,
423             'insufficient-message-security', 'Signature is expected but the message is not signed')
424             if $self->{Signature};
425             }
426            
427             my $mic = Digest::SHA1::sha1_base64($content) . '=';
428            
429             my $parser = new MIME::Parser;
430             $parser->output_to_core(1);
431             $parser->tmp_to_core(1);
432             my $entity = $parser->parse_data($is_content_raw ? $merged_headers . $content : $content);
433             my $bh = $entity->bodyhandle;
434            
435             return Net::AS2::Message->create_failure_message(@new_prefix,
436             'unexpected-processing-error',
437             'MIME has no body (multipart message is not supported)')
438             unless defined $bh;
439            
440             $content = $bh->as_string;
441             return Net::AS2::Message->new(@new_prefix, $mic, $content);
442             }
443            
444             =item $mdn = $as2->decode_mdn($headers, $content)
445            
446             I
447             Decode the incoming HTTP request as AS2 MDN.
448            
449             Headers is an hash ref and should be supplied in PSGI format, or C<\%ENV> in CGI mode.
450             Content is the raw POST body of the request.
451            
452             This method always returns a C object and never dies.
453             The MDN could be successfully parsed, or contains unparsable error details
454             if it is malformed, or signature could not be verified.
455            
456             C<$mdn-Ematch_mic($content_mic)> should be called afterward with the
457             pre-calculated MIC from the outgoing message to verify the correctness
458             of the MIC.
459            
460             =cut
461            
462             sub decode_mdn
463             {
464             my ($self, $headers, $content) = @_;
465             croak "headers must be an hash reference"
466             unless ref $headers eq 'HASH';
467             croak "content is undefined"
468             unless defined $content;
469            
470             unless (
471             defined $headers->{CONTENT_TYPE} &&
472             defined $headers->{HTTP_MESSAGE_ID} &&
473             defined $headers->{HTTP_AS2_VERSION} &&
474             defined $headers->{HTTP_AS2_FROM} &&
475             defined $headers->{HTTP_AS2_TO})
476             {
477             return Net::AS2::MDN->create_unparsable_mdn('Malformed AS2 MDN, crucial headers are missing.')
478             }
479            
480             if (
481             _parse_as2_id($headers->{HTTP_AS2_FROM}) ne $self->{PartnerId} ||
482             _parse_as2_id($headers->{HTTP_AS2_TO}) ne $self->{MyId}
483             ) {
484             return Net::AS2::MDN->create_unparsable_mdn('AS2-From or AS2-To is not expected')
485             }
486            
487             my $merged_headers =
488             join($crlf, map {
489             if (/^HTTP_/ || /^CONTENT_TYPE$/) {
490             my $key = $_;
491             $key =~ s/^HTTP_//;
492             $key =~ s/_/-/g;
493             "$key: ". $headers->{$_};
494             } else { (); }
495             } keys %{$headers}) . "$crlf$crlf";
496            
497             $content =
498             $merged_headers .
499             $content;
500            
501             return $self->_parse_mdn($content);
502             }
503            
504             =item ($headers, $content) = $as2->prepare_sync_mdn($mdn, $message_id)
505            
506             Returns the headers and content to be sent in a HTTP response for a sync MDN.
507            
508             The MDN is usually created after an incoming message is received, with
509             Ccreate_success> or Ccreate_from_unsuccessful_message>.
510            
511             The headers are in arrayref format in PSGI response format.
512             The content is raw and ready to be sent.
513            
514             For CGI, it should be sent like this:
515            
516             my ($headers, $content) = $as2->prepare_sync_mdn($mdn, $message_id);
517            
518             my $mh = '';
519             for (my $i = 0; $i < scalar @{$headers}; $i += 2)
520             {
521             $mh .= $headers->[$i] . ': ' . $headers->[$i+1] . "\x0d\x0a";
522             }
523            
524             binmode(STDOUT);
525             print $mh . "\x0d\x0a" . $content;
526            
527             If message id not specified, a random one will be generated.
528            
529             =cut
530            
531             sub prepare_sync_mdn
532             {
533             my ($self, $mdn, $message_id) = @_;
534            
535             $mdn->recipient($self->{MyId});
536            
537             $message_id =
538             defined $message_id && $message_id =~ /@/ ? $message_id :
539             sprintf('<%s@%s>', ($message_id || time + rand()), hostname);
540             my ($headers, $payload) =
541             $self->_send_preprocess($mdn->as_mime->stringify, $message_id, undef, undef,
542             1, $mdn->should_sign);
543            
544             return ($headers, $payload);
545             }
546            
547             =item $resp = $as2->send_async_mdn($mdn, $message_id)
548            
549             Send an ASYNC MDN requested by partner. Returns a L.
550            
551             The MDN is usually created after an incoming message is received, with
552             Ccreate_success> or Ccreate_from_unsuccessful_message>.
553            
554             If message id is not specified, a random one will be generated.
555            
556             Note that the destination URL is passed by the partner in its request,
557             but not specified during construction.
558            
559             =cut
560            
561             sub send_async_mdn
562             {
563             my ($self, $mdn, $message_id) = @_;
564            
565             $mdn->recipient($self->{MyId});
566             my $target_url = $mdn->async_url;
567            
568             croak "MDN async url is not defined" unless $target_url;
569             croak "MDN async url is not valid" unless $target_url =~ m{^https?://};
570            
571             $message_id =
572             defined $message_id && $message_id =~ /@/ ? $message_id :
573             sprintf('<%s@%s>', ($message_id || time + rand()), hostname);
574             my ($headers, $payload) =
575             $self->_send_preprocess($mdn->as_mime->stringify, $message_id, $target_url, undef,
576             1, $mdn->should_sign);
577            
578             my $req = HTTP::Request->new(POST => $target_url, \@$headers);
579             $req->content($payload);
580            
581             my $ua = $self->create_useragent;
582             my $resp = $ua->request($req);
583            
584             return $resp;
585             }
586            
587            
588             =item ($mdn, $mic) = $as2->send($data, %MIMEHEADERS)
589            
590             Send a message to the partner. Returns a C object and calculated SHA-1 MIC.
591            
592             The data should be encoded (or assumed to be UTF-8 encoded).
593            
594             The mime headers should be listed in a hash.
595             It will be passed to C almost transparently with some defaults dedicated for AS2,
596             at least the following must also be supplied
597            
598             =over 4
599            
600             =item MessageId
601            
602             Message id of this request should be supplied, or a random one would be generated.
603            
604             =item Type
605            
606             Content type of the message should be supplied.
607            
608             =back
609            
610             In case of HTTP failure, the MDN object will be marked with C<$mdn-Eis_error>.
611            
612             In case ASYNC MDN is expected, the MDN object returned will most likely be marked with
613             C<$mdn-Eis_unparsable> and should be ignored. A misbehave AS2 server could returns
614             a valid MDN even if async was requested - in this case the C<$mdn-Eis_success> would
615             be true.
616            
617             =cut
618            
619             sub send
620             {
621             my ($self, $data, %opts) = @_;
622            
623             croak "data is not defined"
624             unless defined $data;
625            
626             $data = utf8::is_utf8($data) ? encode("utf8", $data) : $data;
627             my $mic;
628             $mic = Digest::SHA1::sha1_base64($data) . '='
629             unless $self->{Signature} || $self->{Encryption};
630            
631             my $message_id = $opts{MessageId} // '';
632             $message_id =
633             $message_id =~ /@/ ? $message_id :
634             sprintf('<%s@%s>', ($message_id || time + rand()), hostname);
635            
636             $opts{Encoding} = 'base64';
637             $opts{Disposition} //= 'attachment';
638             $opts{Subject} //= 'AS2 Message';
639             $opts{'X-Mailer'} = undef;
640            
641             my $mime = new MIME::Entity->build(Data => $data, %opts);
642             return $self->_send($mime->stringify, $message_id, $mic);
643             }
644            
645             sub _send_preprocess
646             {
647             my ($self, $data, $message_id, $target_url, $pre_mic, $is_mdn, $should_mdn_signed) = @_;
648            
649             $data =~ s/(?:$crlf|\n)/$crlf/g;
650             my $mic = $is_mdn ? undef : ($pre_mic // Digest::SHA1::sha1_base64($data) . '=');
651            
652             if ($is_mdn && $should_mdn_signed || !$is_mdn && $self->{Signature}) {
653             $data = $self->{_smime_sign}->sign($data);
654             }
655             if ($self->{Encryption} && !$is_mdn) {
656             $data = $self->{_smime_enc}->encrypt($data);
657             }
658            
659             my ($header, $payload) = $data =~ /^(.*?)$crlf$crlf(.*)$/s;
660            
661             $header =~ //;
662            
663             my @header;
664             my ($prev_head, $prev_value);
665             my $is_base64 = 0;
666             foreach my $line (split(/$crlf/, $header))
667             {
668             if ($line =~ m/^([^:]+):\s*(.*)/) {
669             my ($key, $value) = ($1, $2);
670             push @header, ($prev_head => $prev_value)
671             if defined $prev_head;
672             if (lc($key) eq 'content-type') {
673             $value =~ s{application/x-pkcs7}{application/pkcs7};
674             } elsif (lc($key) eq 'content-transfer-encoding') {
675             $is_base64 = 1 if lc($value) eq 'base64';
676             $key = undef;
677             }
678             $prev_head = $key;
679             $prev_value = $value;
680             } elsif (defined $prev_head) {
681             $prev_value .= " $line";
682             }
683             }
684             push @header, ($prev_head => $prev_value)
685             if defined $prev_head;
686            
687             push @header, (
688             defined $target_url ? ('Recipient-Address' => $target_url) : (),
689             'Message-Id' => $message_id,
690             'AS2-Version' => '1.0',
691             'AS2-From' => _encode_as2_id($self->{MyId}), 'AS2-To' => _encode_as2_id($self->{PartnerId}),
692             $is_mdn ? () : (
693             'Disposition-notification-To' => 'example@example.com',
694             ($self->{Signature} ? (
695             'Disposition-Notification-Options' => 'signed-receipt-protocol=required, pkcs7-signature; signed-receipt-micalg=required, sha1'
696             ) : ()),
697             ($self->{MdnAsyncUrl} ? (
698             'Receipt-Delivery-Option' => $self->{MdnAsyncUrl}
699             ) : ())
700             ),
701             );
702             $payload = decode_base64($payload)
703             if $is_base64;
704             return (\@header, $payload, $mic);
705             }
706            
707             =back
708            
709             =head2 Test Hooks
710            
711             =over 4
712            
713             =item $as2->create_useragent()
714            
715             This should return a C usable for handling HTTP request.
716            
717             This allows test code to monitor the HTTP request sending out.
718            
719             =cut
720            
721             sub create_useragent
722             {
723             my $self = shift;
724             my $ua = new LWP::UserAgent(timeout => $self->{Timeout}, agent => $self->{UserAgent});
725             return $ua;
726             }
727            
728             sub _send
729             {
730             my ($self, $data, $message_id, $pre_mic) = @_;
731            
732             my $target_url = $self->{PartnerUrl};
733             my ($headers, $payload, $mic) =
734             $self->_send_preprocess($data, $message_id, $target_url, $pre_mic);
735            
736             my $req = HTTP::Request->new(POST => $target_url, \@$headers);
737             $req->content($payload);
738            
739             my $test = $req->as_string;
740            
741             my $ua = $self->create_useragent;
742             my $resp = $ua->request($req);
743            
744             my $mdn;
745             if ($resp->is_success)
746             {
747             my $content = $resp->as_string;
748             # Remove the status line
749             $content =~ s{^.*?\r?\n}{};
750             $mdn = $self->_parse_mdn($content);
751             $mdn->match_mic($mic, 'sha1');
752            
753             } else {
754             $mdn =
755             Net::AS2::MDN->create_error_mdn(sprintf('HTTP failure: %s', $resp->status_line));
756             }
757             return wantarray ? ($mdn, $mic) : $mdn;
758             }
759            
760             sub _parse_mdn
761             {
762             my ($self, $content) = @_;
763            
764             if ($self->{_smime_sign}->isSigned($content))
765             {
766             # OpenSSL (Crypt::SMIME) in Windows cannot handle binary content,
767             # convert signature part to base64
768             $content = _pkcs7_base64($content);
769             $content = eval { $self->{_smime_sign}->check($content); };
770             return Net::AS2::MDN->create_unparsable_mdn('MDN signature failed verification: ' . $@)
771             if $@;
772             } else {
773             return Net::AS2::MDN->create_unparsable_mdn('MDN is not signed')
774             if $self->{Signature};
775             }
776             return Net::AS2::MDN->parse_mdn($content);
777             }
778            
779            
780             sub _parse_as2_id {
781             my $as2_id = shift;
782             $as2_id =~ /^ (?: ([!\x23-\x5B\x5D-\x7E]+) | "((?:\\\\|\\"|[!\x23-\x5B\x5D-\x7E ])+)" ) $/x;
783             if (defined $1) {
784             return $1;
785             } elsif (defined $2) {
786             $as2_id = $2;
787             $as2_id =~ s/\\(\\|")/$1/g;
788             return $as2_id;
789             }
790             return undef;
791             }
792            
793             sub _encode_as2_id {
794             my $as2_id = shift;
795             if ($as2_id =~ s/(\\|")/\\$1/g || $as2_id =~ / /) {
796             return qq{"$as2_id"};
797             } else {
798             return $as2_id;
799             }
800             }
801            
802             sub _pkcs7_base64
803             {
804             my ($content) = @_;
805             my $parser = new MIME::Parser;
806            
807             $parser->output_to_core(1);
808             $parser->tmp_to_core(1);
809             my $entity = $parser->parse_data($content);
810            
811             if ($entity->parts == 2)
812             {
813             my $p = $entity->parts(1);
814             if (defined $p && $p->head &&
815             $p->head->get('Content-type') =~ m{^application/(x-)?pkcs7-signature($|;)} &&
816             ($p->head->get('Content-transfer-encoding') // '') ne 'base64'
817             ) {
818             $p->head->replace('Content-transfer-encoding', 'base64');
819             return $entity->stringify;
820             }
821             }
822            
823             return $content;
824             }
825            
826             1;
827            
828             =back
829            
830             =head1 BUGS
831            
832             =over 4
833            
834             =item *
835            
836             A bug in L will caused test to fail - specifically failed to add public key after decryption failure.
837             I applied the fixes and fork it to L.
838            
839             =back
840            
841             =head1 SEE ALSO
842            
843             L, L, L, L
844            
845             Source code is maintained here at L. Patches are welcome.
846            
847             =head1 COPYRIGHT AND LICENSE
848            
849             This software is copyright (c) 2012 by Sam Wong.
850            
851             This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself.
852            
853             =head1 DISCLAIMER OF WARRANTY
854            
855             This module is not certificated by any AS2 body. This module generates MDN on behave of you.
856             When using this module, you must have reviewed and responsible for all the actions and in-actions caused by this module.
857            
858             More legal jargon follows:
859            
860             BECAUSE THIS SOFTWARE IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE SOFTWARE, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE SOFTWARE "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE SOFTWARE IS WITH YOU. SHOULD THE SOFTWARE PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR, OR CORRECTION.
861            
862             IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE SOFTWARE AS PERMITTED BY THE ABOVE LICENCE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE SOFTWARE (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE SOFTWARE TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES.
863            
864