File Coverage

blib/lib/Mail/TLSRPT/Failure.pm
Criterion Covered Total %
statement 50 50 100.0
branch 32 34 94.1
condition 7 10 70.0
subroutine 12 12 100.0
pod 4 4 100.0
total 105 110 95.4


line stmt bran cond sub pod time code
1             package Mail::TLSRPT::Failure;
2             # ABSTRACT: TLSRPT failure object
3             our $VERSION = '2.20210112'; # VERSION
4 9     9   654 use 5.20.0;
  9         31  
5 9     9   45 use Moo;
  9         20  
  9         50  
6 9     9   2744 use Mail::TLSRPT::Pragmas;
  9         28  
  9         50  
7 9     9   8107 use Net::IP;
  9         498907  
  9         9490  
8             has result_type => (is => 'rw', isa => Enum[ qw( starttls-not-supported certificate-host-mismatch certificate-expired certificate-not-trusted validation-failure tlsa-invalid dnssec-invalid dane-required sts-policy-fetch-error sts-policy-invalid sts-webpki-invalid ) ], required => 1);
9             has sending_mta_ip => (is => 'rw', isa => class_type('Net::IP'), required => 1,coerce => sub{&_coerce_ip});
10             has receiving_mx_hostname => (is => 'rw', isa => Str, required => 1);
11             has receiving_mx_helo => (is => 'rw', isa => Str, required => 0);
12             has receiving_ip => (is => 'rw', isa => class_type('Net::IP'), required => 0, coerce => sub{&_coerce_ip});
13             has failed_session_count => (is => 'rw', isa => Int, required => 1);
14             has additional_information => (is => 'rw', isa => Str, required => 0);
15             has failure_reason_code => (is => 'rw', isa => Str, required => 0);
16              
17             sub _coerce_ip {
18 54     54   97 my $ip = shift;
19 54 100       250 $ip = Net::IP->new($ip) unless ref $ip eq 'Net::IP';
20 54         49750 return $ip;
21             }
22              
23              
24 13     13 1 4749 sub new_from_data($class,$data) {
  13         24  
  13         141  
  13         22  
25             my $self = $class->new(
26             result_type => $data->{'result-type'},
27             sending_mta_ip => $data->{'sending-mta-ip'},
28             receiving_mx_hostname => $data->{'receiving-mx-hostname'},
29             $data->{'receiving-mx-helo'} ? ( receiving_mx_helo => $data->{'receiving-mx-helo'} ) : (),
30             $data->{'receiving-ip'} ? ( receiving_ip => $data->{'receiving-ip'} ) : (),
31             failed_session_count => $data->{'failed-session-count'} // 0,
32             $data->{'additional-information'} ? ( additional_information => $data->{'additional-information'} ) : (),
33 13 100 50     292 $data->{'failure-reason-code'} ? ( failure_reason_code => $data->{'failure-reason-code'} ) : (),
    100          
    100          
    100          
34             );
35 13         398 return $self;
36             }
37              
38              
39 4     4 1 844 sub as_struct($self) {
  4         8  
  4         5  
40             return {
41 4 50       65 'result-type' => $self->result_type,
    100          
    100          
    100          
    100          
42             $self->sending_mta_ip ? ( 'sending-mta-ip' => $self->sending_mta_ip->ip ) : (),
43             'receiving-mx-hostname' => $self->receiving_mx_hostname,
44             $self->receiving_mx_helo ? ( 'receiving-mx-helo' => $self->receiving_mx_helo ) : (),
45             $self->receiving_ip ? ( 'receiving-ip' => $self->receiving_ip->ip ) : (),
46             'failed-session-count' => $self->failed_session_count,
47             $self->additional_information ? ( 'additional-information' => $self->additional_information ) : (),
48             $self->failure_reason_code ? ( 'failure-reason-code' => $self->failure_reason_code ) : (),
49             };
50             }
51              
52              
53 5     5 1 15391 sub as_string($self) {
  5         9  
  5         8  
54 5 100       81 my $receiving_ip = $self->receiving_ip ? ' ('.$self->receiving_ip->ip.')' : '';
55 5 50       211 return join( "\n",
    100          
    100          
    100          
56             ' Failure:',
57             ' Result-Type: '.$self->result_type,
58             $self->sending_mta_ip ? (' Sending-MTA-IP: '.$self->sending_mta_ip->ip) : (),
59             ' Receiving-MX-Hostname: '.$self->receiving_mx_hostname . $receiving_ip,
60             $self->receiving_mx_helo ? (' Receiving-MX-HELO: '.$self->receiving_mx_helo) : (),
61             ' Failed-Session-Count: '.$self->failed_session_count,
62             $self->additional_information ? (' Additional-Information: '.$self->additional_information ) : (),
63             $self->failure_reason_code ? (' Failure-Reason-Code: '.$self->failure_reason_code ) : (),
64             );
65             }
66              
67 3     3   5 sub _register_prometheus($self,$prometheus) {
  3         4  
  3         3  
  3         4  
68 3         4 $prometheus->declare('tlsrpt_failures_total', help=>'TLSRPT failures', type=>'counter' );
69             }
70              
71              
72 3     3 1 4 sub process_prometheus($self,$policy,$report,$prometheus) {
  3         4  
  3         3  
  3         4  
  3         4  
  3         3  
73 3         7 $self->_register_prometheus($prometheus);
74 3 100 50     73 $prometheus->add('tlsrpt_failures_total',$self->failed_session_count,{
75             organization_name=>$report->organization_name,
76             policy_type=>$policy->policy_type,
77             policy_domain=>$policy->policy_domain,
78             policy_mx_host=>$policy->policy_mx_host,
79             result_type=>$self->result_type,
80             sending_mta_ip=>$self->sending_mta_ip,
81             receiving_mx_hostname=>$self->receiving_mx_hostname,
82             receiving_mx_helo=>$self->receiving_mx_helo // '',
83             receiving_ip=>($self->receiving_ip?$self->receiving_ip->ip:''),
84             });
85             }
86              
87 1     1   2 sub _csv_headers($self) {
  1         2  
  1         2  
88             return (
89 1         12 'result type',
90             'sending mta ip',
91             'receiving mx hostname',
92             'receiving mx helo',
93             'receiving ip',
94             'failed session count',
95             'additional information',
96             'failure reason code',
97             );
98             }
99              
100 3     3   282 sub _csv_fragment($self) {
  3         6  
  3         3  
101             return (
102 3 100 50     48 $self->result_type,
      100        
      100        
103             $self->sending_mta_ip->ip,
104             $self->receiving_mx_hostname,
105             $self->receiving_mx_helo // '',
106             $self->receiving_ip ? $self->receiving_ip->ip : '',
107             $self->failed_session_count,
108             $self->additional_information // '',
109             $self->failure_reason_code // '',
110             );
111             }
112              
113             1;
114              
115             __END__
116              
117             =pod
118              
119             =encoding UTF-8
120              
121             =head1 NAME
122              
123             Mail::TLSRPT::Failure - TLSRPT failure object
124              
125             =head1 VERSION
126              
127             version 2.20210112
128              
129             =head1 SYNOPSIS
130              
131             my $failure = Mail::TLSRPT::Failure->new(
132             result_type => 'certificate-expired',
133             sending_mta_ip => Net::IP->new($ip),
134             receiving_mx_hostname => 'mx.example.com',
135             receiving_mx_helo => 'mx1.example.com',
136             receiving_ip => Net::IP->new($ip),
137             failed_session_count => 10,
138             additional_information => 'Foo',
139             failure_reason_code => 'Bar',
140             );
141              
142             =head1 DESCRIPTION
143              
144             Classes to process tlsrpt failure in a report
145              
146             =head1 CONSTRUCTOR
147              
148             =head2 I<new($class)>
149              
150             Create a new object
151              
152             =head2 I<new_from_data($data)>
153              
154             Create a new object using a data structure, this will create sub-objects as required.
155              
156             =head1 METHODS
157              
158             =head2 I<as_struct>
159              
160             Return the current object as a data structure
161              
162             =head2 I<as_string>
163              
164             Return a textual human readable representation of the current object and its sub-objects
165              
166             =head2 I<process_prometheus($prometheus,$report)>
167              
168             Generate metrics using the given Prometheus::Tiny object
169              
170             =head1 AUTHOR
171              
172             Marc Bradshaw <marc@marcbradshaw.net>
173              
174             =head1 COPYRIGHT AND LICENSE
175              
176             This software is copyright (c) 2020 by Marc Bradshaw.
177              
178             This is free software; you can redistribute it and/or modify it under
179             the same terms as the Perl 5 programming language system itself.
180              
181             =cut