1package DJabberd::Stanza::StartTLS;
2use strict;
3use base qw(DJabberd::Stanza);
4use Net::SSLeay qw(ERROR_WANT_READ ERROR_WANT_WRITE ERROR_SYSCALL);
5
6Net::SSLeay::load_error_strings();
7Net::SSLeay::SSLeay_add_ssl_algorithms();
8Net::SSLeay::randomize();
9
10sub on_recv_from_server { &process }
11sub on_recv_from_client { &process }
12
13sub process {
14    my ($self, $conn) = @_;
15
16    # {=tls-no-spaces} -- we can't send spaces after the closing bracket
17    $conn->write("<proceed xmlns='urn:ietf:params:xml:ns:xmpp-tls' />");
18
19    my $ctx = Net::SSLeay::CTX_new()
20        or die("Failed to create SSL_CTX $!");
21
22    $Net::SSLeay::ssl_version = 10; # Insist on TLSv1
23    #$Net::SSLeay::ssl_version = 3; # Insist on SSLv3
24
25    Net::SSLeay::CTX_set_options($ctx, &Net::SSLeay::OP_ALL)
26        and Net::SSLeay::die_if_ssl_error("ssl ctx set options");
27
28    Net::SSLeay::CTX_set_mode($ctx, 1)  # enable partial writes
29        and Net::SSLeay::die_if_ssl_error("ssl ctx set options");
30
31    # Following will ask password unless private key is not encrypted
32    Net::SSLeay::CTX_use_RSAPrivateKey_file ($ctx,  $conn->vhost->server->ssl_private_key_file,
33                                             &Net::SSLeay::FILETYPE_PEM);
34    Net::SSLeay::die_if_ssl_error("private key");
35
36    Net::SSLeay::CTX_use_certificate_file ($ctx, $conn->vhost->server->ssl_cert_file,
37                                           &Net::SSLeay::FILETYPE_PEM);
38    Net::SSLeay::die_if_ssl_error("certificate");
39
40    if ($conn->vhost->server->ssl_cert_chain_file) {
41        Net::SSLeay::CTX_use_certificate_chain_file ($ctx, $conn->vhost->server->ssl_cert_chain_file);
42        Net::SSLeay::die_if_ssl_error("certificate chain file");
43    }
44
45
46    my $ssl = Net::SSLeay::new($ctx) or die_now("Failed to create SSL $!");
47    $conn->{ssl} = $ssl;
48    $conn->restart_stream;
49
50    DJabberd::Stanza::StartTLS->finalize_ssl_negotiation($conn, $ssl, $ctx);
51}
52
53# Complete the transformation of stream from tcp socket into ssl socket:
54# 1. setup disconnect handler to free memory for $ssl and $ctx on connection close
55# 2. SSL object is connected to underlying connection socket
56# 3. 'accept' tells SSL to start negotiating encryption
57# 4. set a socket write function that encrypts data before writting to the underlying socket
58sub finalize_ssl_negotiation {
59    my ($class, $conn, $ssl, $ctx) = @_;
60
61    # Add a disconnect handler to this connection that will free memory
62    # and remove references to junk no longer needed on close
63    $conn->add_disconnect_handler(sub {
64         $conn->set_writer_func(sub { return 0 });
65         Net::SSLeay::free($ssl);
66         # Currently, a CTX_new is being called for every SSL connection.
67         # It would be more efficient to create one $ctx per-vhost instead of per-connection
68         # and to re-use that $ctx object for each new connection to that vhost.
69         # This would eliminate the need to free $ctx here.
70         Net::SSLeay::CTX_free($ctx);
71         $conn->{ssl} = undef;
72    });
73
74    my $fileno = $conn->{sock}->fileno;
75    warn "setting ssl ($ssl) fileno to $fileno\n";
76    Net::SSLeay::set_fd($ssl, $fileno);
77
78    $Net::SSLeay::trace = 2;
79
80    my $rv = Net::SSLeay::accept($ssl);
81    if (!$rv) {
82        warn "SSL accept error on $conn\n";
83        $conn->close;
84        return;
85    }
86
87    warn "$conn:  Cipher `" . Net::SSLeay::get_cipher($ssl) . "'\n";
88
89    $conn->set_writer_func(DJabberd::Stanza::StartTLS->danga_socket_writerfunc($conn));
90}
91
92sub actual_error_on_empty_read {
93    my ($class, $ssl) = @_;
94    my $err = Net::SSLeay::get_error($ssl, -1);
95    if ($err == ERROR_WANT_READ || $err == ERROR_WANT_WRITE) {
96        # Not an actual error, SSL is busy doing something like renegotiating encryption
97        # just try again next time
98        return undef;
99    }
100    if ($err == ERROR_SYSCALL) {
101        # return the specific syscall error
102        return "syscall error: $!";
103    }
104    # This is actually an error (return the SSL err code)
105    # unlike the 'no-op' WANT_READ and WANT_WRITE
106    return "ssl error $err: " . Net::SSLeay::ERR_error_string($err);
107}
108
109
110sub danga_socket_writerfunc {
111    my ($class, $conn) = @_;
112    my $ssl = $conn->{ssl};
113    return sub {
114        my ($bref, $to_write, $offset) = @_;
115
116        # unless our event_read has been called, we don't want to try
117        # to do any work now.  and probably we should complain.
118        if ($conn->{write_when_readable}) {
119            warn "writer func called when we're waiting for readability first.\n";
120            return 0;
121        }
122
123        # we can't write a lot or we get some SSL non-blocking error.
124        # NO LONGER RELEVANT?
125        # $to_write = 4096 if $to_write > 4096;
126
127        my $str = substr($$bref, $offset, $to_write);
128        my $written = Net::SSLeay::write($ssl, $str);
129
130        if ($written == -1) {
131            my $err = Net::SSLeay::get_error($ssl, $written);
132
133            if ($err == ERROR_WANT_READ) {
134                $conn->write_when_readable;
135                return 0;
136            }
137            if ($err == ERROR_WANT_WRITE) {
138                # unclear here.  it just wants to write some more?  okay.
139                # easy enough.  do nothing?
140                return 0;
141            }
142
143            my $errstr = Net::SSLeay::ERR_error_string($err);
144            warn " SSL write err = $err, $errstr\n";
145            Net::SSLeay::print_errs("SSL_write");
146            $conn->close;
147            return 0;
148        }
149
150        return $written;
151    };
152}
153
1541;
155
156#  LocalWords:  conn
157