File Coverage

blib/lib/Email/ARF/Report.pm
Criterion Covered Total %
statement 75 75 100.0
branch 20 26 76.9
condition 8 15 53.3
subroutine 20 20 100.0
pod 10 10 100.0
total 133 146 91.1


line stmt bran cond sub pod time code
1 3     3   212998 use strict;
  3         27  
  3         90  
2 3     3   14 use warnings;
  3         6  
  3         195  
3             package Email::ARF::Report 0.011;
4             # ABSTRACT: interpret Abuse Reporting Format (ARF) messages
5              
6 3     3   19 use Carp ();
  3         6  
  3         98  
7 3     3   1923 use Email::MIME 1.929 (); # content-type attributes
  3         193548  
  3         100  
8 3     3   24 use Email::MIME::ContentType 1.016 (); # type/subtype
  3         38  
  3         54  
9 3     3   15 use Scalar::Util ();
  3         8  
  3         52  
10 3     3   1602 use Params::Util qw(_INSTANCE);
  3         10767  
  3         3256  
11              
12             #pod =begin :prelude
13             #pod
14             #pod =head1 WARNING
15             #pod
16             #pod B This is a prototype. This module will definitely continue to
17             #pod exist, but maybe the interface will change radically once more people have seen
18             #pod it and tried to use it. Don't rely on its interface to keep you employed, just
19             #pod yet.
20             #pod
21             #pod =end :prelude
22             #pod
23             #pod =head1 SYNOPSIS
24             #pod
25             #pod my $report = Email::ARF::Report->new($text);
26             #pod
27             #pod if ($report->field('source-ip') eq $our_ip) {
28             #pod my $sender = $report->original_email->header('from');
29             #pod
30             #pod UserManagement->disable_account($sender);
31             #pod }
32             #pod
33             #pod =head1 DESCRIPTION
34             #pod
35             #pod ARF, the Abuse Feedback Report Format, is used to report email abuse incidents
36             #pod to an email provider. It includes mechanisms for providing machine-readable
37             #pod details about the incident, a human-readable description, and a copy of the
38             #pod offending message.
39             #pod
40             #pod =method new
41             #pod
42             #pod my $report = Email::ARF::Report->new($message);
43             #pod
44             #pod Given either an Email::MIME object or a string containing the text of an email
45             #pod message, this method returns a new Email::ARF::Report object. If the given
46             #pod message source is not a valid report in ARF format, an exception is raised.
47             #pod
48             #pod =cut
49              
50             sub new {
51 16     16 1 34529 my ($class, $source) = @_;
52              
53 16 100       223 Carp::croak "no report source provided" unless $source;
54              
55 15 100       84 my $mime = Scalar::Util::blessed $source
56             ? $source
57             : Email::MIME->new($source);
58              
59             Carp::croak "ARF report source could not be interpreted as MIME message"
60 15 100       10508 unless eval { $mime->isa('Email::MIME') };
  15         187  
61              
62 14         50 my $ct_header = $mime->content_type;
63 14         734 my $ct = Email::MIME::ContentType::parse_content_type($ct_header);
64              
65             Carp::croak "non-ARF content type '$ct_header' on ARF report source"
66             unless $ct->{type} eq 'multipart'
67             and $ct->{subtype} eq 'report'
68 14 50 66     2784 and $ct->{attributes}{'report-type'} eq 'feedback-report';
      66        
69              
70 13 100       59 Carp::croak "too few subparts for ARF report" unless $mime->subparts >= 3;
71              
72 12         147 my ($description_part, $report_part, $original_part) = $mime->subparts;
73              
74 12         117 my $report_header = $report_part->content_type;
75 12         562 my $report_ct = Email::MIME::ContentType::parse_content_type($report_header);
76             Carp::croak "bad content type '$report_header' for machine-readable section"
77             unless $report_ct->{type} eq 'message'
78 12 50 33     862 and $report_ct->{subtype} eq 'feedback-report';
79              
80 12         52 my $self = bless {
81             mime => $mime,
82             description_part => $description_part,
83             original_part => $original_part,
84             } => $class;
85              
86 12         36 $self->{fields} = $self->_email_from_body($report_part, 1)->header_obj;
87 12         4872 $self->{original_email} = $self->_email_from_body($original_part);
88              
89 12         4582 return $self;
90             }
91              
92             sub _email_from_body {
93 24     24   64 my ($self, $src_email, $append_nl) = @_;
94              
95 24         55 my $src_email_body = $src_email->body;
96              
97 24         1400 $src_email_body =~ s/\A(\x0d|\x0a)+//g;
98              
99 24 100       91 my $email = Email::MIME->new(
100             $append_nl ? "$src_email_body\n" : $src_email_body
101             );
102             }
103              
104             #pod =method create
105             #pod
106             #pod my $mail = Email::ARF::Report->create(
107             #pod original_email => $email,
108             #pod description => $description,
109             #pod fields => \%fields, # or \@fields
110             #pod header_str => \@headers,
111             #pod );
112             #pod
113             #pod This method creates a new ARF report from scratch.
114             #pod
115             #pod The C parameter may be given as a string, a string reference,
116             #pod or as an object that provides an C method.
117             #pod
118             #pod The optional C parameter is an arrayref of name/value pairs to be
119             #pod added as extra headers in the ARF report. The values are expected to be
120             #pod character strings, and will be MIME-encoded as needed. To pass pre-encoded
121             #pod headers, use the C
parameter. These are handled by L's
122             #pod C constructor.
123             #pod
124             #pod Default values are provided for the following fields:
125             #pod
126             #pod version - 1
127             #pod user-agent - Email::ARF::Report/$VERSION
128             #pod feedback-type - other
129             #pod
130             #pod =cut
131              
132             sub create {
133 3     3 1 5507 my ($class, %arg) = @_;
134              
135 3         20 require Email::MIME::Creator;
136              
137             my $description_part = Email::MIME->create(
138             attributes => { content_type => 'text/plain' },
139             body => $arg{description},
140 3         19 );
141              
142             my $original_body = ref $arg{original_email}
143             ? Scalar::Util::blessed $arg{original_email}
144             ? $arg{original_email}->as_string
145 1         3 : ${ $arg{original_email} }
146 3 100       3222 : $arg{original_email};
    100          
147              
148 3         88 $description_part->header_set('Date');
149              
150 3         144 my $original_part = Email::MIME->create(
151             attributes => { content_type => 'message/rfc822' },
152             body => $original_body,
153             );
154              
155 3         2851 $original_part->header_set('Date');
156              
157             my $field_pairs = ref $arg{fields} eq 'HASH'
158 3         11 ? [ %{ $arg{fields} } ]
159 3 50       133 : $arg{fields};
160              
161 3         13 my $fields = Email::Simple->create(header => $field_pairs);
162              
163 3         1031 $fields->header_set('Date');
164              
165 3 50       110 unless (defined $fields->header('user-agent')) {
166 3   50     103 $fields->header_set(
167             'User-Agent',
168             "$class/" . ($class->VERSION || '(dev)')
169             );
170             }
171              
172 3 50       105 unless (defined $fields->header('version')) {
173 3         88 $fields->header_set('Version', "1");
174             }
175              
176 3 50       127 unless (defined $fields->header('Feedback-Type')) {
177 3         90 $fields->header_set('Feedback-Type', "other");
178             }
179              
180 3         120 my $report_part = Email::MIME->create(
181             attributes => { content_type => 'message/feedback-report' },
182             body => $fields->header_obj->as_string,
183             );
184              
185 3         3034 $report_part->header_set('Date');
186              
187             my $report = Email::MIME->create(
188             attributes => {
189             content_type => 'multipart/report',
190             'report-type' => 'feedback-report',
191             },
192             parts => [ $description_part, $report_part, $original_part ],
193              
194             header => $arg{header} || [],
195 3   50     148 header_str => $arg{header_str} || [],
      50        
196             );
197              
198 3         12862 $class->new($report);
199             }
200              
201             #pod =method as_email
202             #pod
203             #pod This method returns an Email::MIME object representing the report.
204             #pod
205             #pod Note! This method returns a B Email::MIME object each time it is called.
206             #pod If you just want to get a string representation of the report, call
207             #pod C>. If you call C and make changes to the Email::MIME
208             #pod object, the Email::ARF::Report will I be affected.
209             #pod
210             #pod =cut
211              
212             sub as_email {
213 9     9 1 4166 return Email::MIME->new($_[0]->as_string)
214             }
215              
216             #pod =method as_string
217             #pod
218             #pod This method returns a string representation of the report.
219             #pod
220             #pod =cut
221              
222 18     18 1 85 sub as_string { $_[0]->{mime}->as_string }
223              
224             #pod =method original_email
225             #pod
226             #pod This method returns an Email::Simple object containing the original message to
227             #pod which the report refers. Bear in mind that this message may have been edited
228             #pod by the reporter to remove identifying information.
229             #pod
230             #pod =cut
231              
232             sub original_email {
233             $_[0]->{original_email}
234 9     9 1 5700 }
235              
236             #pod =method description
237             #pod
238             #pod This method returns the human-readable description of the report, taken from
239             #pod the body of the human-readable (first) subpart of the report.
240             #pod
241             #pod =cut
242              
243 9     9   31 sub _description_part { $_[0]->{description_part} }
244              
245             sub description {
246 9     9 1 5869 $_[0]->_description_part->body;
247             }
248              
249 42     42   147 sub _fields { $_[0]->{fields} }
250              
251             #pod =method field
252             #pod
253             #pod my $value = $report->field($field_name);
254             #pod my @values = $report->field($field_name);
255             #pod
256             #pod This method returns the value for the given field from the second,
257             #pod machine-readable part of the report. In scalar context, it returns the first
258             #pod value for the field.
259             #pod
260             #pod =cut
261              
262             sub field {
263 42     42 1 9229 my ($self, $field) = @_;
264              
265 42         83 return $self->_fields->header($field);
266             }
267              
268             #pod =head2 feedback_type
269             #pod
270             #pod =method user_agent
271             #pod
272             #pod =method arf_version
273             #pod
274             #pod These methods are shorthand for retrieving the fields of the same name, except
275             #pod for C, which returns the F header. It has been renamed
276             #pod to avoid confusion with the universal C method.
277             #pod
278             #pod =cut
279              
280 9     9 1 22737 sub feedback_type { $_[0]->field('Feedback-Type'); }
281 9     9 1 5973 sub user_agent { $_[0]->field('User-Agent'); }
282 9     9 1 5839 sub arf_version { $_[0]->field('Version'); }
283              
284             #pod =head1 SEE ALSO
285             #pod
286             #pod L
287             #pod
288             #pod L
289             #pod
290             #pod =cut
291              
292             1;
293              
294             __END__