1package Net::SSL::Handshake::StartTLS::SMTP; 2 3use Moose; 4 5extends 'Net::SSL::Handshake'; 6 7use IO::Socket::Timeout; 8use Net::Cmd; # need constants 9use Net::SMTP; 10 11use English qw( -no_match_vars ); 12 13use 5.010; 14 15=encoding utf8 16 17=head1 NAME 18 19Net::SSL::Handshake::StartTLS::SMTP - SSL Handshake via SMTP+StartTLS 20 21=head1 VERSION 22 23Version 0.1.x, $Revision: 640 $ 24 25 26=cut 27 28 29=head1 SYNOPSIS 30 31 use Net::SSL::Handshake::StartTLS::SMTP; 32 33 # the same API as Net::SSL::Handshake 34 my $handshake = $self->Net::SSL::Handshake::StartTLS::SMTP->new 35 ( 36 host => $self->host, 37 ssl_version => $ssl_version, 38 ciphers => $self->ciphers_to_check 39 ); 40 $handshake->hello; 41 42 43=head1 DESCRIPTION 44 45This module simulates an SSL/TLS-Handshake like Net::SSL::Handshake, but encapsulated in a 46SMTP dialog with STARTSSL. 47 48This module derives everything from Net::SSL::Handshake, but adds SMTP and STARTTLS. For this, 49it overrides _build_socket to start an SMTP session and STARTTLS. After SSL/TLS connections ends, 50an SMTP quit command is sent. 51 52When no host (but a socket) is given, this code does not work and is nearly obsolete and 53the socket is used unaltered by Net::SSL::Handshake. 54 55 56New Parameters: 57 58=over 4 59 60=item * 61 62max_retries: when a temporary error (421/450) occured, the connection may be retried. 63Set max_retries to 0 to disable retry; or any other value to enable. Default: 2 retries. 64 65=item * 66 67throttle_time: time (in seconds) to wait when retrying. This time is multiplicated with the 68retry number. Default: 65 seconds (which means, that the 2nd retry waits 130 seconds, ...) 69 70=back 71 72 73 74=cut 75 76 77has '+port' => ( default => 25, ); 78has max_retries => ( is => "ro", isa => "Int", default => 0, ); 79has throttle_time => ( is => "ro", isa => "Int", default => 65, ); 80has my_hostname => ( is => "ro", isa => "Str", default => "tls-check.localhost", ); 81 82 83# when SSL/TLS closed: send SMTP QUIT! 84after close_notify => sub { 85 my $self = shift; 86 $self->socket->quit; 87 return; 88}; 89 90 91sub _build_socket 92 { 93 my $self = shift; 94 95 die __PACKAGE__ . ": need parameter socket or host!\n" unless $self->host; 96 97 my $mx = $self->host; 98 99 my $smtp; 100 for my $retry ( 0 .. $self->max_retries ) 101 { 102 my $state = ""; 103 $self->_wait( $retry, $state ) if $retry; 104 105 # Step 1: connect, die on error; but if 421 or 450: wait and retry 106 $smtp = Net::SMTP->new( Hello => $self->my_hostname, Host => $mx, Timeout => $self->timeout, ); 107 unless ($smtp) 108 { 109 110 if ( $@ =~ m{: \s* 4(?:21|50) }x ) 111 { 112 # no, can't quit on not defined obj ... $smtp->quit; 113 $state = "SMTP Connection"; 114 next; 115 } 116 else 117 { 118 die "Can't connect to SMTP Server $mx: $@"; 119 } 120 } 121 122 IO::Socket::Timeout->enable_timeouts_on($smtp); 123 $smtp->read_timeout( $self->timeout ); 124 $smtp->write_timeout( $self->timeout ); 125 126 127 # Step 2: die, when no STARTTLS supported 128 die "SMTP-Server $mx does not support STARTTLS\n" unless defined $smtp->supports("STARTTLS"); 129 130 # Step 3: do STARTTLS; when error code 421/450: wait and retry 131 unless ( $smtp->command("STARTTLS")->response() == CMD_OK ) 132 { 133 if ( $smtp->code == 421 or $smtp->code == 450 ) 134 { 135 $smtp->quit; 136 $state = "SMTP STARTTLS"; 137 next; 138 } 139 else 140 { 141 die "SMTP STARTTLS failed: " . $smtp->code . " " . $smtp->message . "\n"; 142 } 143 } 144 145 # All fine? exit retry loop 146 last; 147 148 } ## end for my $retry ( 0 .. $self...) 149 150 151 # die "NIX DA im smtp" unless defined $smtp; 152 153 binmode($smtp); 154 155 return $smtp; 156 } ## end sub _build_socket 157 158sub _wait 159 { 160 my $self = shift; 161 my $retry = shift // 1; 162 my $message = shift // __PACKAGE__; 163 164 warn "$message: Wait for retry, $retry: " . $self->throttle_time . " Seconds"; 165 166 sleep $retry * $self->throttle_time; 167 return $self; 168 } 169 170=head2 send, recv 171 172We have to override send and recv, because we use Net::SMTP instead ob IO::Socket object. 173 174=cut 175 176sub send 177 { 178 my $self = shift; 179 my $data = shift; 180 181 return $self->socket->rawdatasend($data); 182 } 183 184sub recv 185 { 186 my $self = shift; 187 188 my $ret = $self->socket->recv($ARG[0], $ARG[1], $ARG[2]); 189 190 return $ret; 191 } 192 193 1941; 195