| OLD | NEW |
| 1 package DJabberd::Stanza::StartTLS; | 1 package DJabberd::Stanza::StartTLS; |
| 2 use strict; | 2 use strict; |
| 3 use base qw(DJabberd::Stanza); | 3 use base qw(DJabberd::Stanza); |
| 4 use Net::SSLeay; | 4 use Net::SSLeay; |
| 5 | 5 |
| 6 Net::SSLeay::load_error_strings(); | 6 Net::SSLeay::load_error_strings(); |
| 7 Net::SSLeay::SSLeay_add_ssl_algorithms(); | 7 Net::SSLeay::SSLeay_add_ssl_algorithms(); |
| 8 Net::SSLeay::randomize(); | 8 Net::SSLeay::randomize(); |
| 9 | 9 |
| 10 use constant SSL_ERROR_WANT_READ => 2; | 10 use constant SSL_ERROR_WANT_READ => 2; |
| 11 use constant SSL_ERROR_WANT_WRITE => 3; | 11 use constant SSL_ERROR_WANT_WRITE => 3; |
| 12 use constant SSL_ERROR_WANT_CONNECT => 4; |
| 13 use constant SSL_ERROR_WANT_ACCEPT => 5; |
| 12 | 14 |
| 13 sub on_recv_from_server { &process } | 15 sub on_recv_from_server { &process } |
| 14 sub on_recv_from_client { &process } | 16 sub on_recv_from_client { &process } |
| 15 | 17 |
| 16 sub process { | 18 sub process { |
| 17 my ($self, $conn) = @_; | 19 my ($self, $conn) = @_; |
| 18 | 20 |
| 19 # {=tls-no-spaces} -- we can't send spaces after the closing bracket | 21 # {=tls-no-spaces} -- we can't send spaces after the closing bracket |
| 20 $conn->write("<proceed xmlns='urn:ietf:params:xml:ns:xmpp-tls' />"); | 22 $conn->write("<proceed xmlns='urn:ietf:params:xml:ns:xmpp-tls' />"); |
| 21 | 23 |
| (...skipping 37 matching lines...) Expand 10 before | Expand all | Expand 10 after Loading... |
| 59 if (!$rv) { | 61 if (!$rv) { |
| 60 warn "SSL accept error on $conn\n"; | 62 warn "SSL accept error on $conn\n"; |
| 61 $conn->close; | 63 $conn->close; |
| 62 return; | 64 return; |
| 63 } | 65 } |
| 64 | 66 |
| 65 warn "$conn: Cipher `" . Net::SSLeay::get_cipher($ssl) . "'\n"; | 67 warn "$conn: Cipher `" . Net::SSLeay::get_cipher($ssl) . "'\n"; |
| 66 | 68 |
| 67 $conn->set_writer_func(DJabberd::Stanza::StartTLS->danga_socket_writerfunc($
conn)); | 69 $conn->set_writer_func(DJabberd::Stanza::StartTLS->danga_socket_writerfunc($
conn)); |
| 68 } | 70 } |
| 71 |
| 72 sub actual_error_on_empty_read { |
| 73 my ($class, $ssl) = @_; |
| 74 my $err = Net::SSLeay::get_error($ssl, -1); |
| 75 if ($err == SSL_ERROR_WANT_READ || |
| 76 $err == SSL_ERROR_WANT_WRITE || |
| 77 $err == SSL_ERROR_WANT_CONNECT || |
| 78 $err == SSL_ERROR_WANT_ACCEPT) { |
| 79 # Not an actual error, SSL is busy doing something like renegotiating en
cryption |
| 80 # just try again next time |
| 81 return 0; |
| 82 } |
| 83 # This is actually an error (return the SSL err code) |
| 84 # unlike the 'no-op' WANT_READ and WANT_WRITE |
| 85 return $err; |
| 86 } |
| 87 |
| 69 | 88 |
| 70 sub danga_socket_writerfunc { | 89 sub danga_socket_writerfunc { |
| 71 my ($class, $conn) = @_; | 90 my ($class, $conn) = @_; |
| 72 my $ssl = $conn->{ssl}; | 91 my $ssl = $conn->{ssl}; |
| 73 return sub { | 92 return sub { |
| 74 my ($bref, $to_write, $offset) = @_; | 93 my ($bref, $to_write, $offset) = @_; |
| 75 | 94 |
| 76 # unless our event_read has been called, we don't want to try | 95 # unless our event_read has been called, we don't want to try |
| 77 # to do any work now. and probably we should complain. | 96 # to do any work now. and probably we should complain. |
| 78 if ($conn->{write_when_readable}) { | 97 if ($conn->{write_when_readable}) { |
| (...skipping 28 matching lines...) Expand all Loading... |
| 107 return 0; | 126 return 0; |
| 108 } | 127 } |
| 109 | 128 |
| 110 return $written; | 129 return $written; |
| 111 }; | 130 }; |
| 112 } | 131 } |
| 113 | 132 |
| 114 1; | 133 1; |
| 115 | 134 |
| 116 # LocalWords: conn | 135 # LocalWords: conn |
| OLD | NEW |