File Coverage

blib/lib/Net/AS2/MDN.pm

Criterion	Covered	Total	%
statement	10	12	83.3
branch			n/a
condition			n/a
subroutine	4	4	100.0
pod			n/a
total	14	16	87.5

package Net::AS2::MDN;
use strict;
use warnings qw(all);

=head1 NAME

Net::AS2::MDN - AS2 Message Deposition Notification

=head1 SYNOPSIS

    ### Sending Message and got a Sync MDN
    my $mdn = $as2->send($body, Type => 'application/xml', MessageId => 'my-message-id-12345@localhost')

    if (!$mdn->is_success) {
        print STDERR $mdn->description;
    }

=head1 PUBLIC INTERFACE

=cut

use Carp;
use MIME::Parser;
use MIME::Entity;
use Scalar::Util qw(blessed);

my $crlf = "\x0d\x0a";

=head2 Constructor

=over 4

=item $mdn = Net::AS2::MDN->create_success($message)

=item $mdn = Net::AS2::MDN->create_success($message, $plain_text)

Create an C indicating processed with transaction information
provided by C. Optionally with a human readable text.

=cut

sub create_success
{
    my ($class, $message, $plain_text) = @_;

    my $self = $class->_create_from_message($message, 'Message is received successfully.', $plain_text);
    $self->{success} = 1;
    return bless ($self, ref($class) || $class);
}

=item $mdn = Net::AS2::MDN->create_warning($message, $status_text)

=item $mdn = Net::AS2::MDN->create_warning($message, $status_text, $plain_text)

Create an C indicating processed with warnings with transaction
information provided by C. Optionally with a human readable text.

Status text is required and will goes to the C line.
It is limited to printable ASCII.

=cut

sub create_warning
{
    my ($class, $message, $status_text, $plain_text) = @_;

    my $self = $class->_create_from_message($message, $status_text, $plain_text);
    $self->{success} = 1;
    $self->{warning} = 1;
    return $self
}

=item $mdn = Net::AS2::MDN->create_failure($message, $status_text)

=item $mdn = Net::AS2::MDN->create_failure($message, $status_text, $plain_text)

Create an C indicating failed/failure status with transaction
information provided by C. Optionally with a human readable text.

Status text is required and will goes to the C line.
It is limited to printable ASCII.

=cut

sub create_failure
{
    my ($class, $message, $status_text, $plain_text) = @_;

    my $self = $class->_create_from_message($message, $status_text, $plain_text);
    $self->{failure} = 1;
    return $self
}

=item $mdn = Net::AS2::MDN->create_error($message, $status_text)

=item $mdn = Net::AS2::MDN->create_error($message, $status_text, $plain_text)

Create an C indicating processed/error status with transaction
information provided by C. Optionally with a human readable text.

Status text is required and will goes to the C line.
It is limited to printable ASCII.

=cut

sub create_error
{
    my ($class, $message, $status_text, $plain_text) = @_;

    my $self = $class->_create_from_message($message, $status_text, $plain_text);
    $self->{error} = 1;
    return $self
}

=item $mdn = Net::AS2::MDN->create_from_unsuccessful_message($message)

Create a corresponding C for unsuccessful C
notice generated while receiving and decoding. Message's error text
will be used.

=cut

sub create_from_unsuccessful_message
{
    my ($class, $error_message) = @_;

    croak "error_message is not an Net::AS2::Message"
        unless blessed($error_message) && $error_message->isa('Net::AS2::Message');
    croak "message is not error"
        unless !$error_message->is_success;

    my $self = $class->_create_from_message(
        $error_message,
        $error_message->error_status_text,
        $error_message->error_plain_text);

    if ($error_message->is_error) {
        $self->{error} = 1;
    } else {
        $self->{failure} = 1;
    }
    return $self
}

sub _create_from_message
{
    my ($class, $message, $status_text, $plain_text) = @_;

    croak "message is not an Net::AS2::Message"
        unless blessed($message) && $message->isa('Net::AS2::Message');

    croak "status_text should be in English" unless
        defined $status_text && $status_text =~ /^[\x20-\x7E^]+$/;

    my $self = {
        status_text => $status_text,
        plain_text => $plain_text // $status_text,
        original_message_id => $message->message_id,
        mic_hash => $message->mic,
        mic_alg => defined $message->mic ? 'sha1' : undef,
        async_url => $message->async_url,
        should_sign => $message->should_mdn_sign,
    };
    return bless ($self, ref($class) || $class);
}

sub parse_mdn
{
    my ($class, $content) = @_;

    $class = ref($class) || $class;
    my $self = {};
    bless ($self, $class);

    $self->_parse_mdn($content);
    return $self;
}

sub create_error_mdn
{
    my ($class, $reason) = @_;

    $class = ref($class) || $class;
    my $self = { unparsable => 1, status_text => $reason };
    bless ($self, $class);

    return $self;
}

sub create_unparsable_mdn
{
    my ($class, $reason) = @_;

    $class = ref($class) || $class;
    my $self = { unparsable => 1, status_text => $reason };
    bless ($self, $class);

    return $self;
}

sub _parse_mdn
{
    my ($self, $content) = @_;

    my $parser = new MIME::Parser;
    $parser->output_to_core(1);
    $parser->tmp_to_core(1);
    my $entity = $parser->parse_data($content);

    unless ($entity->mime_type =~ m{^multipart/report}) {
        $self->{status_text} = 'unexpected content type';
        $self->{unparsable} = 1;
        return;
    }

    my @parts = $entity->parts_DFS();

    $self->{plain_text} = '';
    my $disposition_text = '';
    foreach my $p (@parts) {
        my $bh = $p->bodyhandle;
        next unless $bh;
        if ($p->effective_type =~ m{^text/}i) {
            $self->{plain_text} = $bh->as_string;
        } elsif ($p->effective_type =~ m{^message/disposition-notification$}i) {
            $disposition_text = $bh->as_string;
        }
    }

    my %disposition;
    while ($disposition_text =~ /^ *(.*?) *: *(.*?) *(?:$crlf|$)/gm)
    {
        $disposition{lc($1)} = $2;
    }

    if (defined $disposition{'final-recipient'})
    {
        my $recipient = $disposition{'final-recipient'};
        if ($recipient =~ /^.*? *; *(.+)$/) {
            $self->{recipient} = Net::AS2::_parse_as2_id($1);
        }
    }

    $self->{original_message_id} = $disposition{'original-message-id'}
        if defined $disposition{'original-message-id'};

    if (defined $disposition{'received-content-mic'})
    {
        if ($disposition{'received-content-mic'} =~ m{^ *([A-Za-z0-9/=+]+) *, * (.+?) *$})
        {
            $self->{mic_hash} = $1;
            $self->{mic_alg} = $2;
        }
    }

    my $status_text = '';
    if (defined $disposition{'disposition'}) {
        if ($disposition{'disposition'} =~ m{; *(.*?) *$})
        {
            my $op = $1;
            if ($op =~ /: *(.*?) *$/) {
                $status_text = $1;
            }
            if ($op =~ /^processed$/i) {
                # All success
                $self->{success} = 1;
            } elsif ($op =~ m{^processed/warning}i) {
                # Warning
                $self->{success} = 1;
                $self->{warning} = 1;
            } elsif ($op =~ m{^failed/failure}i) {
                # Failed (Failure - EDI level)
                $self->{failure} = 1;
            } else {
                # including processed/error
                # Failed (Content - protocol level, e.g. parse/decode/auth)
                $self->{error} = 1;
            }
        } else {
            $status_text = "disposition not parsable";
            $self->{unparsable} = 1;
        }
    } else {
        $status_text = "disposition not found";
            $self->{unparsable} = 1;
    }
    $self->{status_text} = $status_text;
}

=back

=head2 Methods

=over 4

=item $mdn->match($mic, $alg)

Verify the MDN MIC value with a pre-calculated one to make sure the receiving party got what we sent.

The MDN will be marked C if the MICs do not match.

    $mdn->match($mic, 'sha1');
    if ($mdn->is_success) {
        # still success after comparing mic
    }

=cut

sub match_mic
{
    my ($self, $hash, $alg) = @_;
    return undef if !$self->is_success;
    unless (
        defined $self->{mic_hash} &&
        defined $hash && defined $alg &&
        $self->{mic_hash} eq $hash &&
        $self->{mic_alg} eq $alg)
    {
        $self->{success} = $self->{warning} = $self->{failure} = 0;
        $self->{error} = 1;
        $self->{status_text} .= "; MDN MIC validation failure";
        return 0;
    }
    return 1;
}

=item $mdn->is_success

Indicating a successfully processed status. (This returns true even with warning was presented)

=cut

sub is_success { return (shift)->{success}; }

=item $mdn->with_warning

Indicating the message was processed with warning.

=cut

sub with_warning { return (shift)->{warning}; }

=item $mdn->is_failure

Indicating a failed/failure status.

=cut

sub is_failure { return (shift)->{failure}; }

=item $mdn->is_error

Indicating a processed/error status

=cut

sub is_error { return (shift)->{error}; }

=item $mdn->is_unparsable

Indicating the MDN was unparsable

=cut

sub is_unparsable { return (shift)->{unparsable}; }

=item $mdn->status_text

The machine readable text follows the Disposition status

=cut

sub status_text { return (shift)->{status_text}; }

=item $mdn->async_url

The URL where the MDN was requested to sent to

=cut

sub async_url { return (shift)->{async_url}; }

=item $mdn->should_sign

Returns true if the MDN was requested to be signed

=cut

sub should_sign { return (shift)->{should_sign}; }

=item $mdn->recipient

Returns the AS2 name of the final recipient field of the MDN

=cut

sub recipient {
    my ($self, $value) = @_;
    $self->{recipient} = $value if @_ >= 2;
    return $self->{recipient};
}

=item $mdn->original_message_id

Returns the Original-Message-Id field of the MDN

=cut

sub original_message_id { return (shift)->{original_message_id}; }

=item $mdn->description

Returns a concatenated text message of the MDN status, machine readable text
and human readable text.

=cut

sub description {
    my $self = shift;
    return sprintf("%s; %s",
        $self->{warning} ? 'processed/warning: ' . $self->{status_text} :
        $self->{success} ? 'processed' :
        $self->{failure} ? 'failed/failure: ' . $self->{status_text} :
        $self->{error} ? 'processed/error: ' . $self->{status_text} :
        'unparsable: ' . $self->{status_text},
        $self->{plain_text} // '');
}

=item $mdn->as_mime

Returns a multipart/report C representation of the MDN

=cut

sub as_mime
{
    my $self = shift;

    my $quoted_recipient = Net::AS2::_encode_as2_id($self->{recipient});

    my $machine_report =
    join($crlf, (
        "Reporting-UA: Perl AS2",
        sprintf("Original-Recipient: rfc822; %s", $quoted_recipient),
        sprintf("Final-Recipient: rfc822; %s", $quoted_recipient),
        ( $self->{original_message_id} ?
            sprintf("Original-Message-ID: %s", $self->{original_message_id} ) :
            ()),
        sprintf("Disposition: automatic-action/MDN-sent-automatically; %s",
            $self->{warning} ? 'processed/warning: ' . $self->{status_text} :
            $self->{success} ? 'processed' :
            $self->{failure} ? 'failed/failure: ' . $self->{status_text} :
            'processed/error: ' . ($self->{status_text} // 'unknown-error')
        ),
        ( defined $self->{mic_hash} ?
            sprintf("Received-Content-MIC: %s, %s", $self->{mic_hash}, $self->{mic_alg}) :
            ())
    ));

    my $human_report_mime = new MIME::Entity->build(
        Type => 'text/plain',
        Data => $self->{plain_text} // $self->{status_text} // (
            $self->{success} ?
                'Message is received successfully.' :
                'Message could not be processed.'),
        Top => 0);
    $human_report_mime->head->delete('Content-disposition');
    my $machine_report_mime = new MIME::Entity->build(
        Type => 'message/disposition-notification',
        Data => $machine_report,
        Top => 0);
    $machine_report_mime->head->delete('Content-disposition');
    my $report_mime = new MIME::Entity->build(
        Type => 'multipart/report; report-type="disposition-notification"',
        'X-Mailer' => undef);
    $report_mime->add_part($human_report_mime);
    $report_mime->add_part($machine_report_mime);
    $report_mime->preamble([]);
    return $report_mime;
}

1;

=back

=head1 SEE ALSO

L, L