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