Skip to content

Commit

Permalink
Browse files Browse the repository at this point in the history
r31029@knight: rjbs | 2007-03-21 09:22:39 -0400
 release
  • Loading branch information
rjbs committed Mar 21, 2007
0 parents commit 2ae851c
Show file tree
Hide file tree
Showing 14 changed files with 921 additions and 0 deletions.
7 changes: 7 additions & 0 deletions Changes
@@ -0,0 +1,7 @@
Revision history for Email::ARF::Report

0.001 2007-03-21
add a lousy first-pass at create method

0.000 2007-03-20
initial, totally experimental release
377 changes: 377 additions & 0 deletions LICENSE

Large diffs are not rendered by default.

23 changes: 23 additions & 0 deletions MANIFEST
@@ -0,0 +1,23 @@
Changes
inc/Module/Install.pm
inc/Module/Install/Base.pm
inc/Module/Install/Can.pm
inc/Module/Install/Fetch.pm
inc/Module/Install/Makefile.pm
inc/Module/Install/Metadata.pm
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
lib/Email/ARF.pm
lib/Email/ARF/Report.pm
LICENSE
Makefile.PL
MANIFEST This list of files
META.yml
README
t/basic.t
t/create.t
t/messages/example-0.msg
t/messages/example-1.msg
t/messages/example-2.msg
t/pod-coverage.t
t/pod.t
17 changes: 17 additions & 0 deletions Makefile.PL
@@ -0,0 +1,17 @@
use strict;
use warnings;

use inc::Module::Install;

name ('Email-ARF');
author ('Ricardo SIGNES <rjbs@cpan.org>');
license ('perl');
version_from ('lib/Email/ARF/Report.pm');

requires('Email::MIME' => 1.859); # subparts method
requires('Params::Util' => 0.00); # no minimum; used for _INSTANCE
requires('Scalar::Util' => 0.00); # unknown minimum; used for blessed

requires('Email::MIME::ContentType' => 0.00); # no minimum

WriteAll();
3 changes: 3 additions & 0 deletions README
@@ -0,0 +1,3 @@

Email::ARF::Report represents the contents of a email feedback report in Abuse
Report Format.
20 changes: 20 additions & 0 deletions lib/Email/ARF.pm
@@ -0,0 +1,20 @@

package Email::ARF;

=head1 NAME
Email::ARF - abuse report format (placeholder module)
=head1 VERSION
version 0.000
$Id$
=cut

our $VERSION = '0.000';

warn "This module does nothing." unless $ENV{HARNESS_ACTIVE};

1;
262 changes: 262 additions & 0 deletions lib/Email/ARF/Report.pm
@@ -0,0 +1,262 @@
use strict;
use warnings;

package Email::ARF::Report;

use Carp ();
use Email::MIME 1.859 ();
use Email::MIME::ContentType ();
use Scalar::Util ();
use Params::Util qw(_INSTANCE);

=head1 NAME
Email::ARF::Report - interpret Abuse Reporting Format (ARF) messages
=head1 VERSION
version 0.001
$Id$
B<Achtung!> Yes, version 0.001. This is a prototype. This module will
definitely continue to exist, but maybe the interface will change radically
once more people have seen it and tried to use it. Don't rely on its interface
to keep you employed, just yet.
=cut

our $VERSION = '0.001';

=head1 SYNOPSIS
my $report = Email::ARF::Report->new($text);
=head1 DESCRIPTION
=head1 METHODS
=head2 new
my $report = Email::ARF::Report->new($message);
Given either an Email::MIME object or a string containing the text of an email
message, this method returns a new Email::ARF::Report object. If the given
message source is not a valid report in ARF format, an exception is raised.
=cut

sub new {
my ($class, $source) = @_;

Carp::croak "no report source provided" unless $source;

my $mime = Scalar::Util::blessed $source
? $source
: Email::MIME->new($source);

Carp::croak "ARF report source could not be interpreted as MIME message"
unless eval { $mime->isa('Email::MIME') };

my $ct_header = $mime->content_type;
my $ct = Email::MIME::ContentType::parse_content_type($ct_header);

Carp::croak "non-ARF content type '$ct_header' on ARF report source"
unless $ct->{discrete} eq 'multipart'
and $ct->{composite} eq 'report'
and $ct->{attributes}{'report-type'} eq 'feedback-report';

Carp::croak "too few subparts for ARF report" unless $mime->subparts >= 3;

my ($description_part, $report_part, $original_part) = $mime->subparts;

my $report_header = $report_part->content_type;
my $report_ct = Email::MIME::ContentType::parse_content_type($report_header);
Carp::croak "bad content type '$report_header' for machine-readable section"
unless $report_ct->{discrete} eq 'message'
and $report_ct->{composite} eq 'feedback-report';

my $self = bless {
description_part => $description_part,
report_part => $report_part,
original_part => $original_part,
} => $class;

$self->{fields} = $self->_email_from_body($report_part)->header_obj;
$self->{original_email} = $self->_email_from_body($original_part);

return $self;
}

sub _email_from_body {
my ($self, $src_email) = @_;

my $src_email_body = $src_email->body;

$src_email_body =~ s/\A(\x0d|\x0a)+//g;

my $email = Email::Simple->new($src_email_body);
}

=head2 create
my $mail = Email::ARF::Report->create(
original_email => $email,
description => $description,
fields => \%fields, # or \@fields
);
This method creates a new ARF report from scratch, returning it as an
Email::MIME message.
=cut

sub create {
my ($class, %arg) = @_;

require Email::MIME::Creator;

my $description_part = Email::MIME->create(
attributes => { content_type => 'text/plain' },
body => $arg{description},
);

$description_part->header_set('Date');

my $original_part = Email::MIME->create(
attributes => { content_type => 'message/rfc822' },
body => $arg{original_email}->as_string,
);

$original_part->header_set('Date');

my $field_pairs = ref $arg{fields} eq 'HASH'
? [ %{ $arg{fields} } ]
: $arg{fields};

my $fields = Email::Simple->create(header => $field_pairs);

$fields->header_set('Date');

unless (defined $fields->header('user-agent')) {
$fields->header_set('User-Agent', "$class/" . $class->VERSION);
}

unless (defined $fields->header('version')) {
$fields->header_set('Version', "0.1");
}

unless (defined $fields->header('Feedback-Type')) {
$fields->header_set('Feedback-Type', "other");
}

my $report_part = Email::MIME->create(
attributes => { content_type => 'message/feedback-report' },
body => $fields->header_obj->as_string,
);

$report_part->header_set('Date');

my $report = Email::MIME->create(
attributes => {
# It is so asinine that I need to do this! Only certain blessed
# attributes are heeded, here. The rest are dropped. -- rjbs, 2007-03-21
content_type => 'multipart/report; report-type="feedback-report"',
},
header => $arg{header} || [],
parts => [ $description_part, $report_part, $original_part ],
);

return $report;
}

=head2 original_email
This method returns an Email::Simple object containing the original message to
which the report refers. Bear in mind that this message may have been edited
by the reporter to remove identifying information.
=cut

sub original_email {
$_[0]->{original_email}
}

=head2 description
This method returns the human-readable description of the report, taken from
the body of the human-readable (first) subpart of the report.
=cut

sub _description_part { $_[0]->{description_part} }

sub description {
$_[0]->_description_part->body;
}

sub _report_part {
$_[0]->{report_part}
}

sub _fields { $_[0]->{fields} }

=head2 field
my $value = $report->field($field_name);
my @values = $report->field($field_name);
This method returns the value for the given field from the second,
machine-readable part of the report. In scalar context, it returns the first
value for the field.
=cut

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

return $self->_fields->header($field);
}

=head2 feedback_type
=head2 user_agent
=head2 arf_version
These methods are shorthand for retrieving the fields of the same name, except
for C<arf_version>, which returns the F<Version> header. It has been renamed
to avoid confusion with the universal C<VERSION> method.
=cut

sub feedback_type { $_[0]->field('Feedback-Type'); }
sub user_agent { $_[0]->field('User-Agent'); }
sub arf_version { $_[0]->field('Version'); }

=head1 SEE ALSO
L<http://www.mipassoc.org/arf/>
L<http://www.shaftek.org/publications/drafts/abuse-report/draft-shafranovich-feedback-report-01.txt>
=head1 PERL EMAIL PROJECT
This module is maintained by the Perl Email Project
L<http://emailproject.perl.org/wiki/Email::ARF::Report>
=head1 AUTHORS
Ricardo SIGNES E<lt>F<rjbs@cpan.org>E<gt>
=head1 COPYRIGHT AND LICENSE
Copyright 2007 by Ricardo SIGNES
This library is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.
=cut

1;
35 changes: 35 additions & 0 deletions t/basic.t
@@ -0,0 +1,35 @@
#!perl -T
use strict;
use warnings;

use Test::More tests => 8;

BEGIN { use_ok('Email::ARF::Report'); }

sub test_report {
my ($filename) = @_;
open my $fh, '<', "t/messages/$filename.msg" or die "couldn't read file: $!";
my $content = do { local $/; <$fh> };
my $report = Email::ARF::Report->new($content);
}

my $report = test_report('example-0');
isa_ok($report, 'Email::ARF::Report');

is($report->feedback_type, 'abuse', "correct feedback_type");
is($report->user_agent, 'SomeGenerator/1.0', "correct user_agent");
is($report->arf_version, '0.1', "correct arf_version");

is($report->field('version'), '0.1', "field accessor works");

is(
$report->original_email->header('subject'),
'Earn money',
'we can get headers from the original message via the report',
);

like(
$report->description,
qr/\QIP 10.67.41.167\E/,
"we seem to be able to get the report description",
);

0 comments on commit 2ae851c

Please sign in to comment.