File Coverage

blib/lib/Mail/Milter/Authentication/Handler/TLS.pm
Criterion Covered Total %
statement 58 84 69.0
branch 14 30 46.6
condition n/a
subroutine 12 14 85.7
pod 1 9 11.1
total 85 137 62.0


line stmt bran cond sub pod time code
1             package Mail::Milter::Authentication::Handler::TLS;
2 16     16   8971 use 5.20.0;
  16         80  
3 16     16   133 use strict;
  16         40  
  16         401  
4 16     16   91 use warnings;
  16         35  
  16         426  
5 16     16   134 use Mail::Milter::Authentication::Pragmas;
  16         35  
  16         145  
6             # ABSTRACT: Handler class for TLS
7             our $VERSION = '3.20230629'; # VERSION
8 16     16   4150 use base 'Mail::Milter::Authentication::Handler';
  16         121  
  16         20368  
9              
10             sub default_config {
11 0     0 0 0 return {};
12             }
13              
14             sub grafana_rows {
15 0     0 0 0 my ( $self ) = @_;
16 0         0 my @rows;
17 0         0 push @rows, $self->get_json( 'TLS_metrics' );
18 0         0 return \@rows;
19             }
20              
21             sub register_metrics {
22             return {
23 15     15 1 107 'tls_connect_total' => 'The number of connections which were enctypted',
24             };
25             }
26              
27             sub pre_loop_setup {
28 15     15 0 46 my ( $self ) = @_;
29 15         83 my $protocol = Mail::Milter::Authentication::Config::get_config()->{'protocol'};
30 15 50       99 if ( $protocol eq 'smtp' ) {
31 15         318 warn 'When in smtp mode, the TLS handler requires the MTA to write TLS data into the first Received header.';
32             }
33             }
34              
35             sub connect_callback {
36 39     39 0 185 my ( $self ) = @_;
37             # Reset state on a connection
38 39         212 delete $self->{'is_encrypted'};
39             }
40              
41             sub envfrom_callback {
42 39     39 0 196 my ( $self, $env_from ) = @_;
43              
44 39         128 delete $self->{'first_header_read'};
45              
46 39         209 my $protocol = Mail::Milter::Authentication::Config::get_config()->{'protocol'};
47 39 50       240 return if $protocol ne 'milter';
48              
49 0         0 my $version = $self->get_symbol('{tls_version}');
50 0         0 my $cipher = $self->get_symbol('{cipher}');
51 0         0 my $bits = $self->get_symbol('{cipher_bits}');
52             # on postfix the macro is empty on untrusted connections
53 0 0       0 my $trusted = $self->get_symbol('{cert_issuer}') ? ', trusted' : '';
54              
55 0 0       0 if ($version) {
56 0         0 $self->dbgout( 'EncryptedAs', "$version, $cipher, $bits bits$trusted", LOG_DEBUG );
57 0         0 $self->{'is_encrypted'} = 1;
58              
59 0         0 my $metric_data = {};
60 0         0 my $header = Mail::AuthenticationResults::Header::Entry->new()->set_key( 'x-tls' )->safe_set_value( 'pass' );
61 0         0 $header->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'smtp.version' )->safe_set_value( $version ) );
62 0         0 $metric_data->{ 'version' } = $version;
63              
64 0 0       0 if ( $cipher ) {
65 0         0 $header->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'smtp.cipher' )->safe_set_value( $cipher ) );
66 0         0 $metric_data->{ 'cipher' } = $cipher;
67             }
68 0 0       0 if ( $bits ) {
69 0         0 $header->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'smtp.bits' )->safe_set_value( $bits ) );
70 0         0 $metric_data->{ 'bits' } = $bits;
71             }
72 0 0       0 $metric_data->{ 'trusted' } = $trusted ? 1 : 0;
73              
74 0         0 $self->metric_count( 'tls_connect_total', $metric_data );
75              
76 0         0 $self->add_auth_header( $header );
77             }
78             else {
79 0         0 $self->{'is_encrypted'} = 0;
80             }
81             }
82              
83             sub header_callback {
84 403     403 0 1233 my ( $self, $header, $value ) = @_;
85              
86 403 100       1683 return if lc $header ne 'received';
87 64 100       369 return if ( exists( $self->{'first_header_read'} ) );
88 28         135 $self->{'first_header_read'} = 1;
89              
90              
91 28         120 my $protocol = Mail::Milter::Authentication::Config::get_config()->{'protocol'};
92 28 50       122 return if $protocol ne 'smtp';
93              
94             # Try and parse the first received header, this should be something like...
95             # Received: from mail-ua0-f173.google.com (mail-ua0-f173.google.com [209.85.217.173])
96             # (using TLSv1.2 with cipher ECDHE-RSA-AES128-GCM-SHA256 (128/128 bits))
97             # (No client certificate requested)
98             # by mx5.messagingengine.com (Postfix) with ESMTPS
99             # for <marcmctest@fastmail.com>; Thu, 1 Dec 2016 22:35:06 -0500 (EST)
100              
101             # Future, extend to check for client certificates
102              
103 28         237 $value =~ m/using ([^ ]*) with cipher ([^ ]+) \(([^ ]+) bits\)/;
104 28         137 my $version = $1;
105 28         91 my $cipher = $2;
106 28         82 my $bits = $3;
107              
108 28 100       129 if ($version) {
109 14         172 $self->dbgout( 'EncryptedAs', "$version, $cipher, $bits bits", LOG_DEBUG );
110 14         121 $self->{'is_encrypted'} = 1;
111              
112 14         108 my $metric_data = {};
113 14         151 my $header = Mail::AuthenticationResults::Header::Entry->new()->set_key( 'x-tls' )->safe_set_value( 'pass' );
114 14         1698 $header->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'smtp.version' )->safe_set_value( $version ) );
115 14         1672 $metric_data->{ 'version' } = $version;
116              
117 14 50       74 if ( $cipher ) {
118 14         108 $header->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'smtp.cipher' )->safe_set_value( $cipher ) );
119 14         1496 $metric_data->{ 'cipher' } = $cipher;
120             }
121 14 50       71 if ( $bits ) {
122 14         66 $header->add_child( Mail::AuthenticationResults::Header::SubEntry->new()->set_key( 'smtp.bits' )->safe_set_value( $bits ) );
123 14         1460 $metric_data->{ 'bits' } = $bits;
124             }
125              
126 14         95 $self->metric_count( 'tls_connect_total', $metric_data );
127              
128 14         209 $self->add_auth_header( $header );
129             }
130             }
131              
132             sub eoh_callback {
133 39     39 0 182 my ( $self ) = @_;
134 39         185 my $protocol = Mail::Milter::Authentication::Config::get_config()->{'protocol'};
135 39 50       264 return if $protocol ne 'smtp';
136 39 100       193 return if defined $self->{'is_encrypted'};
137 25         189 $self->{'is_encrypted'} = 0;
138             }
139              
140             sub close_callback {
141 71     71 0 275 my ( $self ) = @_;
142 71         243 delete $self->{'first_header_read'};
143 71         267 delete $self->{'is_encrypted'};
144             }
145              
146             1;
147              
148             __END__
149              
150             =pod
151              
152             =encoding UTF-8
153              
154             =head1 NAME
155              
156             Mail::Milter::Authentication::Handler::TLS - Handler class for TLS
157              
158             =head1 VERSION
159              
160             version 3.20230629
161              
162             =head1 DESCRIPTION
163              
164             Identify TLS protected connections.
165              
166             =head1 CONFIGURATION
167              
168             No configuration options exist for this handler.
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