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