ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent/lib/AnyEvent/Handle.pm
(Generate patch)

Comparing AnyEvent/lib/AnyEvent/Handle.pm (file contents):
Revision 1.113 by root, Wed Jan 21 06:02:21 2009 UTC vs.
Revision 1.150 by root, Thu Jul 16 04:16:25 2009 UTC

14 14
15AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent 15AnyEvent::Handle - non-blocking I/O on file handles via AnyEvent
16 16
17=cut 17=cut
18 18
19our $VERSION = 4.331; 19our $VERSION = 4.82;
20 20
21=head1 SYNOPSIS 21=head1 SYNOPSIS
22 22
23 use AnyEvent; 23 use AnyEvent;
24 use AnyEvent::Handle; 24 use AnyEvent::Handle;
25 25
26 my $cv = AnyEvent->condvar; 26 my $cv = AnyEvent->condvar;
27 27
28 my $handle = 28 my $hdl; $hdl = new AnyEvent::Handle
29 AnyEvent::Handle->new (
30 fh => \*STDIN, 29 fh => \*STDIN,
31 on_eof => sub { 30 on_error => sub {
31 warn "got error $_[2]\n";
32 $cv->send; 32 $cv->send;
33 },
34 ); 33 );
35 34
36 # send some request line 35 # send some request line
37 $handle->push_write ("getinfo\015\012"); 36 $hdl->push_write ("getinfo\015\012");
38 37
39 # read the response line 38 # read the response line
40 $handle->push_read (line => sub { 39 $hdl->push_read (line => sub {
41 my ($handle, $line) = @_; 40 my ($hdl, $line) = @_;
42 warn "read line <$line>\n"; 41 warn "got line <$line>\n";
43 $cv->send; 42 $cv->send;
44 }); 43 });
45 44
46 $cv->recv; 45 $cv->recv;
47 46
63 62
64=head1 METHODS 63=head1 METHODS
65 64
66=over 4 65=over 4
67 66
68=item B<new (%args)> 67=item $handle = B<new> AnyEvent::TLS fh => $filehandle, key => value...
69 68
70The constructor supports these arguments (all as key => value pairs). 69The constructor supports these arguments (all as C<< key => value >> pairs).
71 70
72=over 4 71=over 4
73 72
74=item fh => $filehandle [MANDATORY] 73=item fh => $filehandle [MANDATORY]
75 74
81 80
82=item on_eof => $cb->($handle) 81=item on_eof => $cb->($handle)
83 82
84Set the callback to be called when an end-of-file condition is detected, 83Set the callback to be called when an end-of-file condition is detected,
85i.e. in the case of a socket, when the other side has closed the 84i.e. in the case of a socket, when the other side has closed the
86connection cleanly. 85connection cleanly, and there are no outstanding read requests in the
86queue (if there are read requests, then an EOF counts as an unexpected
87connection close and will be flagged as an error).
87 88
88For sockets, this just means that the other side has stopped sending data, 89For sockets, this just means that the other side has stopped sending data,
89you can still try to write data, and, in fact, one can return from the EOF 90you can still try to write data, and, in fact, one can return from the EOF
90callback and continue writing data, as only the read part has been shut 91callback and continue writing data, as only the read part has been shut
91down. 92down.
92 93
93While not mandatory, it is I<highly> recommended to set an EOF callback,
94otherwise you might end up with a closed socket while you are still
95waiting for data.
96
97If an EOF condition has been detected but no C<on_eof> callback has been 94If an EOF condition has been detected but no C<on_eof> callback has been
98set, then a fatal error will be raised with C<$!> set to <0>. 95set, then a fatal error will be raised with C<$!> set to <0>.
99 96
100=item on_error => $cb->($handle, $fatal) 97=item on_error => $cb->($handle, $fatal, $message)
101 98
102This is the error callback, which is called when, well, some error 99This is the error callback, which is called when, well, some error
103occured, such as not being able to resolve the hostname, failure to 100occured, such as not being able to resolve the hostname, failure to
104connect or a read error. 101connect or a read error.
105 102
106Some errors are fatal (which is indicated by C<$fatal> being true). On 103Some errors are fatal (which is indicated by C<$fatal> being true). On
107fatal errors the handle object will be shut down and will not be usable 104fatal errors the handle object will be destroyed (by a call to C<< ->
108(but you are free to look at the current C<< ->rbuf >>). Examples of fatal 105destroy >>) after invoking the error callback (which means you are free to
109errors are an EOF condition with active (but unsatisifable) read watchers 106examine the handle object). Examples of fatal errors are an EOF condition
110(C<EPIPE>) or I/O errors. 107with active (but unsatisifable) read watchers (C<EPIPE>) or I/O errors.
108
109AnyEvent::Handle tries to find an appropriate error code for you to check
110against, but in some cases (TLS errors), this does not work well. It is
111recommended to always output the C<$message> argument in human-readable
112error messages (it's usually the same as C<"$!">).
111 113
112Non-fatal errors can be retried by simply returning, but it is recommended 114Non-fatal errors can be retried by simply returning, but it is recommended
113to simply ignore this parameter and instead abondon the handle object 115to simply ignore this parameter and instead abondon the handle object
114when this callback is invoked. Examples of non-fatal errors are timeouts 116when this callback is invoked. Examples of non-fatal errors are timeouts
115C<ETIMEDOUT>) or badly-formatted data (C<EBADMSG>). 117C<ETIMEDOUT>) or badly-formatted data (C<EBADMSG>).
116 118
117On callback entrance, the value of C<$!> contains the operating system 119On callback entrance, the value of C<$!> contains the operating system
118error (or C<ENOSPC>, C<EPIPE>, C<ETIMEDOUT> or C<EBADMSG>). 120error code (or C<ENOSPC>, C<EPIPE>, C<ETIMEDOUT>, C<EBADMSG> or
121C<EPROTO>).
119 122
120While not mandatory, it is I<highly> recommended to set this callback, as 123While not mandatory, it is I<highly> recommended to set this callback, as
121you will not be notified of errors otherwise. The default simply calls 124you will not be notified of errors otherwise. The default simply calls
122C<croak>. 125C<croak>.
123 126
127and no read request is in the queue (unlike read queue callbacks, this 130and no read request is in the queue (unlike read queue callbacks, this
128callback will only be called when at least one octet of data is in the 131callback will only be called when at least one octet of data is in the
129read buffer). 132read buffer).
130 133
131To access (and remove data from) the read buffer, use the C<< ->rbuf >> 134To access (and remove data from) the read buffer, use the C<< ->rbuf >>
132method or access the C<$handle->{rbuf}> member directly. 135method or access the C<< $handle->{rbuf} >> member directly. Note that you
136must not enlarge or modify the read buffer, you can only remove data at
137the beginning from it.
133 138
134When an EOF condition is detected then AnyEvent::Handle will first try to 139When an EOF condition is detected then AnyEvent::Handle will first try to
135feed all the remaining data to the queued callbacks and C<on_read> before 140feed all the remaining data to the queued callbacks and C<on_read> before
136calling the C<on_eof> callback. If no progress can be made, then a fatal 141calling the C<on_eof> callback. If no progress can be made, then a fatal
137error will be raised (with C<$!> set to C<EPIPE>). 142error will be raised (with C<$!> set to C<EPIPE>).
143
144Note that, unlike requests in the read queue, an C<on_read> callback
145doesn't mean you I<require> some data: if there is an EOF and there
146are outstanding read requests then an error will be flagged. With an
147C<on_read> callback, the C<on_eof> callback will be invoked.
138 148
139=item on_drain => $cb->($handle) 149=item on_drain => $cb->($handle)
140 150
141This sets the callback that is called when the write buffer becomes empty 151This sets the callback that is called when the write buffer becomes empty
142(or when the callback is set and the buffer is empty already). 152(or when the callback is set and the buffer is empty already).
235 245
236This will not work for partial TLS data that could not be encoded 246This will not work for partial TLS data that could not be encoded
237yet. This data will be lost. Calling the C<stoptls> method in time might 247yet. This data will be lost. Calling the C<stoptls> method in time might
238help. 248help.
239 249
250=item peername => $string
251
252A string used to identify the remote site - usually the DNS hostname
253(I<not> IDN!) used to create the connection, rarely the IP address.
254
255Apart from being useful in error messages, this string is also used in TLS
256peername verification (see C<verify_peername> in L<AnyEvent::TLS>). This
257verification will be skipped when C<peername> is not specified or
258C<undef>.
259
240=item tls => "accept" | "connect" | Net::SSLeay::SSL object 260=item tls => "accept" | "connect" | Net::SSLeay::SSL object
241 261
242When this parameter is given, it enables TLS (SSL) mode, that means 262When this parameter is given, it enables TLS (SSL) mode, that means
243AnyEvent will start a TLS handshake as soon as the conenction has been 263AnyEvent will start a TLS handshake as soon as the conenction has been
244established and will transparently encrypt/decrypt data afterwards. 264established and will transparently encrypt/decrypt data afterwards.
265
266All TLS protocol errors will be signalled as C<EPROTO>, with an
267appropriate error message.
245 268
246TLS mode requires Net::SSLeay to be installed (it will be loaded 269TLS mode requires Net::SSLeay to be installed (it will be loaded
247automatically when you try to create a TLS handle): this module doesn't 270automatically when you try to create a TLS handle): this module doesn't
248have a dependency on that module, so if your module requires it, you have 271have a dependency on that module, so if your module requires it, you have
249to add the dependency yourself. 272to add the dependency yourself.
253mode. 276mode.
254 277
255You can also provide your own TLS connection object, but you have 278You can also provide your own TLS connection object, but you have
256to make sure that you call either C<Net::SSLeay::set_connect_state> 279to make sure that you call either C<Net::SSLeay::set_connect_state>
257or C<Net::SSLeay::set_accept_state> on it before you pass it to 280or C<Net::SSLeay::set_accept_state> on it before you pass it to
258AnyEvent::Handle. 281AnyEvent::Handle. Also, this module will take ownership of this connection
282object.
283
284At some future point, AnyEvent::Handle might switch to another TLS
285implementation, then the option to use your own session object will go
286away.
259 287
260B<IMPORTANT:> since Net::SSLeay "objects" are really only integers, 288B<IMPORTANT:> since Net::SSLeay "objects" are really only integers,
261passing in the wrong integer will lead to certain crash. This most often 289passing in the wrong integer will lead to certain crash. This most often
262happens when one uses a stylish C<< tls => 1 >> and is surprised about the 290happens when one uses a stylish C<< tls => 1 >> and is surprised about the
263segmentation fault. 291segmentation fault.
264 292
265See the C<< ->starttls >> method for when need to start TLS negotiation later. 293See the C<< ->starttls >> method for when need to start TLS negotiation later.
266 294
267=item tls_ctx => $ssl_ctx 295=item tls_ctx => $anyevent_tls
268 296
269Use the given C<Net::SSLeay::CTX> object to create the new TLS connection 297Use the given C<AnyEvent::TLS> object to create the new TLS connection
270(unless a connection object was specified directly). If this parameter is 298(unless a connection object was specified directly). If this parameter is
271missing, then AnyEvent::Handle will use C<AnyEvent::Handle::TLS_CTX>. 299missing, then AnyEvent::Handle will use C<AnyEvent::Handle::TLS_CTX>.
300
301Instead of an object, you can also specify a hash reference with C<< key
302=> value >> pairs. Those will be passed to L<AnyEvent::TLS> to create a
303new TLS context object.
304
305=item on_starttls => $cb->($handle, $success[, $error_message])
306
307This callback will be invoked when the TLS/SSL handshake has finished. If
308C<$success> is true, then the TLS handshake succeeded, otherwise it failed
309(C<on_stoptls> will not be called in this case).
310
311The session in C<< $handle->{tls} >> can still be examined in this
312callback, even when the handshake was not successful.
313
314TLS handshake failures will not cause C<on_error> to be invoked when this
315callback is in effect, instead, the error message will be passed to C<on_starttls>.
316
317Without this callback, handshake failures lead to C<on_error> being
318called, as normal.
319
320Note that you cannot call C<starttls> right again in this callback. If you
321need to do that, start an zero-second timer instead whose callback can
322then call C<< ->starttls >> again.
323
324=item on_stoptls => $cb->($handle)
325
326When a SSLv3/TLS shutdown/close notify/EOF is detected and this callback is
327set, then it will be invoked after freeing the TLS session. If it is not,
328then a TLS shutdown condition will be treated like a normal EOF condition
329on the handle.
330
331The session in C<< $handle->{tls} >> can still be examined in this
332callback.
333
334This callback will only be called on TLS shutdowns, not when the
335underlying handle signals EOF.
272 336
273=item json => JSON or JSON::XS object 337=item json => JSON or JSON::XS object
274 338
275This is the json coder object used by the C<json> read and write types. 339This is the json coder object used by the C<json> read and write types.
276 340
285 349
286=cut 350=cut
287 351
288sub new { 352sub new {
289 my $class = shift; 353 my $class = shift;
290
291 my $self = bless { @_ }, $class; 354 my $self = bless { @_ }, $class;
292 355
293 $self->{fh} or Carp::croak "mandatory argument fh is missing"; 356 $self->{fh} or Carp::croak "mandatory argument fh is missing";
294 357
295 AnyEvent::Util::fh_nonblocking $self->{fh}, 1; 358 AnyEvent::Util::fh_nonblocking $self->{fh}, 1;
359
360 $self->{_activity} = AnyEvent->now;
361 $self->_timeout;
362
363 $self->no_delay (delete $self->{no_delay}) if exists $self->{no_delay};
296 364
297 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx}) 365 $self->starttls (delete $self->{tls}, delete $self->{tls_ctx})
298 if $self->{tls}; 366 if $self->{tls};
299 367
300 $self->{_activity} = AnyEvent->now;
301 $self->_timeout;
302
303 $self->on_drain (delete $self->{on_drain}) if exists $self->{on_drain}; 368 $self->on_drain (delete $self->{on_drain}) if $self->{on_drain};
304 $self->no_delay (delete $self->{no_delay}) if exists $self->{no_delay};
305 369
306 $self->start_read 370 $self->start_read
307 if $self->{on_read}; 371 if $self->{on_read};
308 372
309 $self 373 $self->{fh} && $self
310} 374}
311 375
312sub _shutdown { 376#sub _shutdown {
313 my ($self) = @_; 377# my ($self) = @_;
314 378#
315 delete $self->{_tw}; 379# delete @$self{qw(_tw _rw _ww fh wbuf on_read _queue)};
316 delete $self->{_rw}; 380# $self->{_eof} = 1; # tell starttls et. al to stop trying
317 delete $self->{_ww}; 381#
318 delete $self->{fh};
319
320 &_freetls; 382# &_freetls;
321 383#}
322 delete $self->{on_read};
323 delete $self->{_queue};
324}
325 384
326sub _error { 385sub _error {
327 my ($self, $errno, $fatal) = @_; 386 my ($self, $errno, $fatal, $message) = @_;
328
329 $self->_shutdown
330 if $fatal;
331 387
332 $! = $errno; 388 $! = $errno;
389 $message ||= "$!";
333 390
334 if ($self->{on_error}) { 391 if ($self->{on_error}) {
335 $self->{on_error}($self, $fatal); 392 $self->{on_error}($self, $fatal, $message);
393 $self->destroy;
336 } elsif ($self->{fh}) { 394 } elsif ($self->{fh}) {
395 $self->destroy;
337 Carp::croak "AnyEvent::Handle uncaught error: $!"; 396 Carp::croak "AnyEvent::Handle uncaught error: $message";
338 } 397 }
339} 398}
340 399
341=item $fh = $handle->fh 400=item $fh = $handle->fh
342 401
403 local $SIG{__DIE__}; 462 local $SIG{__DIE__};
404 setsockopt $_[0]{fh}, &Socket::IPPROTO_TCP, &Socket::TCP_NODELAY, int $_[1]; 463 setsockopt $_[0]{fh}, &Socket::IPPROTO_TCP, &Socket::TCP_NODELAY, int $_[1];
405 }; 464 };
406} 465}
407 466
467=item $handle->on_starttls ($cb)
468
469Replace the current C<on_starttls> callback (see the C<on_starttls> constructor argument).
470
471=cut
472
473sub on_starttls {
474 $_[0]{on_starttls} = $_[1];
475}
476
477=item $handle->on_stoptls ($cb)
478
479Replace the current C<on_stoptls> callback (see the C<on_stoptls> constructor argument).
480
481=cut
482
483sub on_starttls {
484 $_[0]{on_stoptls} = $_[1];
485}
486
408############################################################################# 487#############################################################################
409 488
410=item $handle->timeout ($seconds) 489=item $handle->timeout ($seconds)
411 490
412Configures (or disables) the inactivity timeout. 491Configures (or disables) the inactivity timeout.
436 $self->{_activity} = $NOW; 515 $self->{_activity} = $NOW;
437 516
438 if ($self->{on_timeout}) { 517 if ($self->{on_timeout}) {
439 $self->{on_timeout}($self); 518 $self->{on_timeout}($self);
440 } else { 519 } else {
441 $self->_error (&Errno::ETIMEDOUT); 520 $self->_error (Errno::ETIMEDOUT);
442 } 521 }
443 522
444 # callback could have changed timeout value, optimise 523 # callback could have changed timeout value, optimise
445 return unless $self->{timeout}; 524 return unless $self->{timeout};
446 525
509 Scalar::Util::weaken $self; 588 Scalar::Util::weaken $self;
510 589
511 my $cb = sub { 590 my $cb = sub {
512 my $len = syswrite $self->{fh}, $self->{wbuf}; 591 my $len = syswrite $self->{fh}, $self->{wbuf};
513 592
514 if ($len >= 0) { 593 if (defined $len) {
515 substr $self->{wbuf}, 0, $len, ""; 594 substr $self->{wbuf}, 0, $len, "";
516 595
517 $self->{_activity} = AnyEvent->now; 596 $self->{_activity} = AnyEvent->now;
518 597
519 $self->{on_drain}($self) 598 $self->{on_drain}($self)
654 733
655 pack "w/a*", Storable::nfreeze ($ref) 734 pack "w/a*", Storable::nfreeze ($ref)
656}; 735};
657 736
658=back 737=back
738
739=item $handle->push_shutdown
740
741Sometimes you know you want to close the socket after writing your data
742before it was actually written. One way to do that is to replace your
743C<on_drain> handler by a callback that shuts down the socket (and set
744C<low_water_mark> to C<0>). This method is a shorthand for just that, and
745replaces the C<on_drain> callback with:
746
747 sub { shutdown $_[0]{fh}, 1 } # for push_shutdown
748
749This simply shuts down the write side and signals an EOF condition to the
750the peer.
751
752You can rely on the normal read queue and C<on_eof> handling
753afterwards. This is the cleanest way to close a connection.
754
755=cut
756
757sub push_shutdown {
758 my ($self) = @_;
759
760 delete $self->{low_water_mark};
761 $self->on_drain (sub { shutdown $_[0]{fh}, 1 });
762}
659 763
660=item AnyEvent::Handle::register_write_type type => $coderef->($handle, @args) 764=item AnyEvent::Handle::register_write_type type => $coderef->($handle, @args)
661 765
662This function (not method) lets you add your own types to C<push_write>. 766This function (not method) lets you add your own types to C<push_write>.
663Whenever the given C<type> is used, C<push_write> will invoke the code 767Whenever the given C<type> is used, C<push_write> will invoke the code
763 867
764 if ( 868 if (
765 defined $self->{rbuf_max} 869 defined $self->{rbuf_max}
766 && $self->{rbuf_max} < length $self->{rbuf} 870 && $self->{rbuf_max} < length $self->{rbuf}
767 ) { 871 ) {
768 $self->_error (&Errno::ENOSPC, 1), return; 872 $self->_error (Errno::ENOSPC, 1), return;
769 } 873 }
770 874
771 while () { 875 while () {
876 # we need to use a separate tls read buffer, as we must not receive data while
877 # we are draining the buffer, and this can only happen with TLS.
878 $self->{rbuf} .= delete $self->{_tls_rbuf} if exists $self->{_tls_rbuf};
879
772 my $len = length $self->{rbuf}; 880 my $len = length $self->{rbuf};
773 881
774 if (my $cb = shift @{ $self->{_queue} }) { 882 if (my $cb = shift @{ $self->{_queue} }) {
775 unless ($cb->($self)) { 883 unless ($cb->($self)) {
776 if ($self->{_eof}) { 884 if ($self->{_eof}) {
777 # no progress can be made (not enough data and no data forthcoming) 885 # no progress can be made (not enough data and no data forthcoming)
778 $self->_error (&Errno::EPIPE, 1), return; 886 $self->_error (Errno::EPIPE, 1), return;
779 } 887 }
780 888
781 unshift @{ $self->{_queue} }, $cb; 889 unshift @{ $self->{_queue} }, $cb;
782 last; 890 last;
783 } 891 }
791 && !@{ $self->{_queue} } # and the queue is still empty 899 && !@{ $self->{_queue} } # and the queue is still empty
792 && $self->{on_read} # but we still have on_read 900 && $self->{on_read} # but we still have on_read
793 ) { 901 ) {
794 # no further data will arrive 902 # no further data will arrive
795 # so no progress can be made 903 # so no progress can be made
796 $self->_error (&Errno::EPIPE, 1), return 904 $self->_error (Errno::EPIPE, 1), return
797 if $self->{_eof}; 905 if $self->{_eof};
798 906
799 last; # more data might arrive 907 last; # more data might arrive
800 } 908 }
801 } else { 909 } else {
807 915
808 if ($self->{_eof}) { 916 if ($self->{_eof}) {
809 if ($self->{on_eof}) { 917 if ($self->{on_eof}) {
810 $self->{on_eof}($self) 918 $self->{on_eof}($self)
811 } else { 919 } else {
812 $self->_error (0, 1); 920 $self->_error (0, 1, "Unexpected end-of-file");
813 } 921 }
814 } 922 }
815 923
816 # may need to restart read watcher 924 # may need to restart read watcher
817 unless ($self->{_rw}) { 925 unless ($self->{_rw}) {
837 945
838=item $handle->rbuf 946=item $handle->rbuf
839 947
840Returns the read buffer (as a modifiable lvalue). 948Returns the read buffer (as a modifiable lvalue).
841 949
842You can access the read buffer directly as the C<< ->{rbuf} >> member, if 950You can access the read buffer directly as the C<< ->{rbuf} >>
843you want. 951member, if you want. However, the only operation allowed on the
952read buffer (apart from looking at it) is removing data from its
953beginning. Otherwise modifying or appending to it is not allowed and will
954lead to hard-to-track-down bugs.
844 955
845NOTE: The read buffer should only be used or modified if the C<on_read>, 956NOTE: The read buffer should only be used or modified if the C<on_read>,
846C<push_read> or C<unshift_read> methods are used. The other read methods 957C<push_read> or C<unshift_read> methods are used. The other read methods
847automatically manage the read buffer. 958automatically manage the read buffer.
848 959
1048 return 1; 1159 return 1;
1049 } 1160 }
1050 1161
1051 # reject 1162 # reject
1052 if ($reject && $$rbuf =~ $reject) { 1163 if ($reject && $$rbuf =~ $reject) {
1053 $self->_error (&Errno::EBADMSG); 1164 $self->_error (Errno::EBADMSG);
1054 } 1165 }
1055 1166
1056 # skip 1167 # skip
1057 if ($skip && $$rbuf =~ $skip) { 1168 if ($skip && $$rbuf =~ $skip) {
1058 $data .= substr $$rbuf, 0, $+[0], ""; 1169 $data .= substr $$rbuf, 0, $+[0], "";
1074 my ($self, $cb) = @_; 1185 my ($self, $cb) = @_;
1075 1186
1076 sub { 1187 sub {
1077 unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) { 1188 unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) {
1078 if ($_[0]{rbuf} =~ /[^0-9]/) { 1189 if ($_[0]{rbuf} =~ /[^0-9]/) {
1079 $self->_error (&Errno::EBADMSG); 1190 $self->_error (Errno::EBADMSG);
1080 } 1191 }
1081 return; 1192 return;
1082 } 1193 }
1083 1194
1084 my $len = $1; 1195 my $len = $1;
1087 my $string = $_[1]; 1198 my $string = $_[1];
1088 $_[0]->unshift_read (chunk => 1, sub { 1199 $_[0]->unshift_read (chunk => 1, sub {
1089 if ($_[1] eq ",") { 1200 if ($_[1] eq ",") {
1090 $cb->($_[0], $string); 1201 $cb->($_[0], $string);
1091 } else { 1202 } else {
1092 $self->_error (&Errno::EBADMSG); 1203 $self->_error (Errno::EBADMSG);
1093 } 1204 }
1094 }); 1205 });
1095 }); 1206 });
1096 1207
1097 1 1208 1
1164=cut 1275=cut
1165 1276
1166register_read_type json => sub { 1277register_read_type json => sub {
1167 my ($self, $cb) = @_; 1278 my ($self, $cb) = @_;
1168 1279
1169 require JSON; 1280 my $json = $self->{json} ||=
1281 eval { require JSON::XS; JSON::XS->new->utf8 }
1282 || do { require JSON; JSON->new->utf8 };
1170 1283
1171 my $data; 1284 my $data;
1172 my $rbuf = \$self->{rbuf}; 1285 my $rbuf = \$self->{rbuf};
1173
1174 my $json = $self->{json} ||= JSON->new->utf8;
1175 1286
1176 sub { 1287 sub {
1177 my $ref = eval { $json->incr_parse ($self->{rbuf}) }; 1288 my $ref = eval { $json->incr_parse ($self->{rbuf}) };
1178 1289
1179 if ($ref) { 1290 if ($ref) {
1187 $json->incr_skip; 1298 $json->incr_skip;
1188 1299
1189 $self->{rbuf} = $json->incr_text; 1300 $self->{rbuf} = $json->incr_text;
1190 $json->incr_text = ""; 1301 $json->incr_text = "";
1191 1302
1192 $self->_error (&Errno::EBADMSG); 1303 $self->_error (Errno::EBADMSG);
1304
1193 () 1305 ()
1194
1195 } else { 1306 } else {
1196 $self->{rbuf} = ""; 1307 $self->{rbuf} = "";
1308
1197 () 1309 ()
1198 } 1310 }
1199 } 1311 }
1200}; 1312};
1201 1313
1233 # read remaining chunk 1345 # read remaining chunk
1234 $_[0]->unshift_read (chunk => $len, sub { 1346 $_[0]->unshift_read (chunk => $len, sub {
1235 if (my $ref = eval { Storable::thaw ($_[1]) }) { 1347 if (my $ref = eval { Storable::thaw ($_[1]) }) {
1236 $cb->($_[0], $ref); 1348 $cb->($_[0], $ref);
1237 } else { 1349 } else {
1238 $self->_error (&Errno::EBADMSG); 1350 $self->_error (Errno::EBADMSG);
1239 } 1351 }
1240 }); 1352 });
1241 } 1353 }
1242 1354
1243 1 1355 1
1322 } 1434 }
1323 }); 1435 });
1324 } 1436 }
1325} 1437}
1326 1438
1439our $ERROR_SYSCALL;
1440our $ERROR_WANT_READ;
1441
1442sub _tls_error {
1443 my ($self, $err) = @_;
1444
1445 return $self->_error ($!, 1)
1446 if $err == Net::SSLeay::ERROR_SYSCALL ();
1447
1448 my $err =Net::SSLeay::ERR_error_string (Net::SSLeay::ERR_get_error ());
1449
1450 # reduce error string to look less scary
1451 $err =~ s/^error:[0-9a-fA-F]{8}:[^:]+:([^:]+):/\L$1: /;
1452
1453 if ($self->{_on_starttls}) {
1454 (delete $self->{_on_starttls})->($self, undef, $err);
1455 &_freetls;
1456 } else {
1457 &_freetls;
1458 $self->_error (Errno::EPROTO, 1, $err);
1459 }
1460}
1461
1327# poll the write BIO and send the data if applicable 1462# poll the write BIO and send the data if applicable
1463# also decode read data if possible
1464# this is basiclaly our TLS state machine
1465# more efficient implementations are possible with openssl,
1466# but not with the buggy and incomplete Net::SSLeay.
1328sub _dotls { 1467sub _dotls {
1329 my ($self) = @_; 1468 my ($self) = @_;
1330 1469
1331 my $tmp; 1470 my $tmp;
1332 1471
1333 if (length $self->{_tls_wbuf}) { 1472 if (length $self->{_tls_wbuf}) {
1334 while (($tmp = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) { 1473 while (($tmp = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) {
1335 substr $self->{_tls_wbuf}, 0, $tmp, ""; 1474 substr $self->{_tls_wbuf}, 0, $tmp, "";
1336 } 1475 }
1476
1477 $tmp = Net::SSLeay::get_error ($self->{tls}, $tmp);
1478 return $self->_tls_error ($tmp)
1479 if $tmp != $ERROR_WANT_READ
1480 && ($tmp != $ERROR_SYSCALL || $!);
1337 } 1481 }
1338 1482
1339 while (defined ($tmp = Net::SSLeay::read ($self->{tls}))) { 1483 while (defined ($tmp = Net::SSLeay::read ($self->{tls}))) {
1340 unless (length $tmp) { 1484 unless (length $tmp) {
1341 # let's treat SSL-eof as we treat normal EOF 1485 $self->{_on_starttls}
1342 delete $self->{_rw}; 1486 and (delete $self->{_on_starttls})->($self, undef, "EOF during handshake"); # ???
1343 $self->{_eof} = 1;
1344 &_freetls; 1487 &_freetls;
1488
1489 if ($self->{on_stoptls}) {
1490 $self->{on_stoptls}($self);
1491 return;
1492 } else {
1493 # let's treat SSL-eof as we treat normal EOF
1494 delete $self->{_rw};
1495 $self->{_eof} = 1;
1496 }
1345 } 1497 }
1346 1498
1347 $self->{rbuf} .= $tmp; 1499 $self->{_tls_rbuf} .= $tmp;
1348 $self->_drain_rbuf unless $self->{_in_drain}; 1500 $self->_drain_rbuf unless $self->{_in_drain};
1349 $self->{tls} or return; # tls session might have gone away in callback 1501 $self->{tls} or return; # tls session might have gone away in callback
1350 } 1502 }
1351 1503
1352 $tmp = Net::SSLeay::get_error ($self->{tls}, -1); 1504 $tmp = Net::SSLeay::get_error ($self->{tls}, -1);
1353
1354 if ($tmp != Net::SSLeay::ERROR_WANT_READ ()) {
1355 if ($tmp == Net::SSLeay::ERROR_SYSCALL ()) {
1356 return $self->_error ($!, 1); 1505 return $self->_tls_error ($tmp)
1357 } elsif ($tmp == Net::SSLeay::ERROR_SSL ()) { 1506 if $tmp != $ERROR_WANT_READ
1358 return $self->_error (&Errno::EIO, 1); 1507 && ($tmp != $ERROR_SYSCALL || $!);
1359 }
1360
1361 # all other errors are fine for our purposes
1362 }
1363 1508
1364 while (length ($tmp = Net::SSLeay::BIO_read ($self->{_wbio}))) { 1509 while (length ($tmp = Net::SSLeay::BIO_read ($self->{_wbio}))) {
1365 $self->{wbuf} .= $tmp; 1510 $self->{wbuf} .= $tmp;
1366 $self->_drain_wbuf; 1511 $self->_drain_wbuf;
1367 } 1512 }
1513
1514 $self->{_on_starttls}
1515 and Net::SSLeay::state ($self->{tls}) == Net::SSLeay::ST_OK ()
1516 and (delete $self->{_on_starttls})->($self, 1, "TLS/SSL connection established");
1368} 1517}
1369 1518
1370=item $handle->starttls ($tls[, $tls_ctx]) 1519=item $handle->starttls ($tls[, $tls_ctx])
1371 1520
1372Instead of starting TLS negotiation immediately when the AnyEvent::Handle 1521Instead of starting TLS negotiation immediately when the AnyEvent::Handle
1374C<starttls>. 1523C<starttls>.
1375 1524
1376The first argument is the same as the C<tls> constructor argument (either 1525The first argument is the same as the C<tls> constructor argument (either
1377C<"connect">, C<"accept"> or an existing Net::SSLeay object). 1526C<"connect">, C<"accept"> or an existing Net::SSLeay object).
1378 1527
1379The second argument is the optional C<Net::SSLeay::CTX> object that is 1528The second argument is the optional C<AnyEvent::TLS> object that is used
1380used when AnyEvent::Handle has to create its own TLS connection object. 1529when AnyEvent::Handle has to create its own TLS connection object, or
1530a hash reference with C<< key => value >> pairs that will be used to
1531construct a new context.
1381 1532
1382The TLS connection object will end up in C<< $handle->{tls} >> after this 1533The TLS connection object will end up in C<< $handle->{tls} >>, the TLS
1383call and can be used or changed to your liking. Note that the handshake 1534context in C<< $handle->{tls_ctx} >> after this call and can be used or
1384might have already started when this function returns. 1535changed to your liking. Note that the handshake might have already started
1536when this function returns.
1385 1537
1386If it an error to start a TLS handshake more than once per 1538If it an error to start a TLS handshake more than once per
1387AnyEvent::Handle object (this is due to bugs in OpenSSL). 1539AnyEvent::Handle object (this is due to bugs in OpenSSL).
1388 1540
1389=cut 1541=cut
1390 1542
1543our %TLS_CACHE; #TODO not yet documented, should we?
1544
1391sub starttls { 1545sub starttls {
1392 my ($self, $ssl, $ctx) = @_; 1546 my ($self, $ssl, $ctx) = @_;
1393 1547
1394 require Net::SSLeay; 1548 require Net::SSLeay;
1395 1549
1396 Carp::croak "it is an error to call starttls more than once on an AnyEvent::Handle object" 1550 Carp::croak "it is an error to call starttls more than once on an AnyEvent::Handle object"
1397 if $self->{tls}; 1551 if $self->{tls};
1552
1553 $ERROR_SYSCALL = Net::SSLeay::ERROR_SYSCALL ();
1554 $ERROR_WANT_READ = Net::SSLeay::ERROR_WANT_READ ();
1555
1556 $ctx ||= $self->{tls_ctx};
1557
1558 if ("HASH" eq ref $ctx) {
1559 require AnyEvent::TLS;
1560
1561 local $Carp::CarpLevel = 1; # skip ourselves when creating a new context
1562
1563 if ($ctx->{cache}) {
1564 my $key = $ctx+0;
1565 $ctx = $TLS_CACHE{$key} ||= new AnyEvent::TLS %$ctx;
1566 } else {
1567 $ctx = new AnyEvent::TLS %$ctx;
1568 }
1569 }
1398 1570
1399 if ($ssl eq "accept") { 1571 $self->{tls_ctx} = $ctx || TLS_CTX ();
1400 $ssl = Net::SSLeay::new ($ctx || TLS_CTX ()); 1572 $self->{tls} = $ssl = $self->{tls_ctx}->_get_session ($ssl, $self, $self->{peername});
1401 Net::SSLeay::set_accept_state ($ssl);
1402 } elsif ($ssl eq "connect") {
1403 $ssl = Net::SSLeay::new ($ctx || TLS_CTX ());
1404 Net::SSLeay::set_connect_state ($ssl);
1405 }
1406
1407 $self->{tls} = $ssl;
1408 1573
1409 # basically, this is deep magic (because SSL_read should have the same issues) 1574 # basically, this is deep magic (because SSL_read should have the same issues)
1410 # but the openssl maintainers basically said: "trust us, it just works". 1575 # but the openssl maintainers basically said: "trust us, it just works".
1411 # (unfortunately, we have to hardcode constants because the abysmally misdesigned 1576 # (unfortunately, we have to hardcode constants because the abysmally misdesigned
1412 # and mismaintained ssleay-module doesn't even offer them). 1577 # and mismaintained ssleay-module doesn't even offer them).
1416 # 1581 #
1417 # note that we do not try to keep the length constant between writes as we are required to do. 1582 # note that we do not try to keep the length constant between writes as we are required to do.
1418 # we assume that most (but not all) of this insanity only applies to non-blocking cases, 1583 # we assume that most (but not all) of this insanity only applies to non-blocking cases,
1419 # and we drive openssl fully in blocking mode here. Or maybe we don't - openssl seems to 1584 # and we drive openssl fully in blocking mode here. Or maybe we don't - openssl seems to
1420 # have identity issues in that area. 1585 # have identity issues in that area.
1421 Net::SSLeay::CTX_set_mode ($self->{tls}, 1586# Net::SSLeay::CTX_set_mode ($ssl,
1422 (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1) 1587# (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1)
1423 | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2)); 1588# | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2));
1589 Net::SSLeay::CTX_set_mode ($ssl, 1|2);
1424 1590
1425 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1591 $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
1426 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); 1592 $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
1427 1593
1428 Net::SSLeay::set_bio ($ssl, $self->{_rbio}, $self->{_wbio}); 1594 Net::SSLeay::set_bio ($ssl, $self->{_rbio}, $self->{_wbio});
1595
1596 $self->{_on_starttls} = sub { $_[0]{on_starttls}(@_) }
1597 if $self->{on_starttls};
1429 1598
1430 &_dotls; # need to trigger the initial handshake 1599 &_dotls; # need to trigger the initial handshake
1431 $self->start_read; # make sure we actually do read 1600 $self->start_read; # make sure we actually do read
1432} 1601}
1433 1602
1446 if ($self->{tls}) { 1615 if ($self->{tls}) {
1447 Net::SSLeay::shutdown ($self->{tls}); 1616 Net::SSLeay::shutdown ($self->{tls});
1448 1617
1449 &_dotls; 1618 &_dotls;
1450 1619
1451 # we don't give a shit. no, we do, but we can't. no... 1620# # we don't give a shit. no, we do, but we can't. no...#d#
1452 # we, we... have to use openssl :/ 1621# # we, we... have to use openssl :/#d#
1453 &_freetls; 1622# &_freetls;#d#
1454 } 1623 }
1455} 1624}
1456 1625
1457sub _freetls { 1626sub _freetls {
1458 my ($self) = @_; 1627 my ($self) = @_;
1459 1628
1460 return unless $self->{tls}; 1629 return unless $self->{tls};
1461 1630
1462 Net::SSLeay::free (delete $self->{tls}); 1631 $self->{tls_ctx}->_put_session (delete $self->{tls});
1463 1632
1464 delete @$self{qw(_rbio _wbio _tls_wbuf)}; 1633 delete @$self{qw(_rbio _wbio _tls_wbuf _on_starttls)};
1465} 1634}
1466 1635
1467sub DESTROY { 1636sub DESTROY {
1468 my $self = shift; 1637 my ($self) = @_;
1469 1638
1470 &_freetls; 1639 &_freetls;
1471 1640
1472 my $linger = exists $self->{linger} ? $self->{linger} : 3600; 1641 my $linger = exists $self->{linger} ? $self->{linger} : 3600;
1473 1642
1493} 1662}
1494 1663
1495=item $handle->destroy 1664=item $handle->destroy
1496 1665
1497Shuts down the handle object as much as possible - this call ensures that 1666Shuts down the handle object as much as possible - this call ensures that
1498no further callbacks will be invoked and resources will be freed as much 1667no further callbacks will be invoked and as many resources as possible
1499as possible. You must not call any methods on the object afterwards. 1668will be freed. You must not call any methods on the object afterwards.
1500 1669
1501Normally, you can just "forget" any references to an AnyEvent::Handle 1670Normally, you can just "forget" any references to an AnyEvent::Handle
1502object and it will simply shut down. This works in fatal error and EOF 1671object and it will simply shut down. This works in fatal error and EOF
1503callbacks, as well as code outside. It does I<NOT> work in a read or write 1672callbacks, as well as code outside. It does I<NOT> work in a read or write
1504callback, so when you want to destroy the AnyEvent::Handle object from 1673callback, so when you want to destroy the AnyEvent::Handle object from
1505within such an callback. You I<MUST> call C<< ->destroy >> explicitly in 1674within such an callback. You I<MUST> call C<< ->destroy >> explicitly in
1506that case. 1675that case.
1507 1676
1677Destroying the handle object in this way has the advantage that callbacks
1678will be removed as well, so if those are the only reference holders (as
1679is common), then one doesn't need to do anything special to break any
1680reference cycles.
1681
1508The handle might still linger in the background and write out remaining 1682The handle might still linger in the background and write out remaining
1509data, as specified by the C<linger> option, however. 1683data, as specified by the C<linger> option, however.
1510 1684
1511=cut 1685=cut
1512 1686
1517 %$self = (); 1691 %$self = ();
1518} 1692}
1519 1693
1520=item AnyEvent::Handle::TLS_CTX 1694=item AnyEvent::Handle::TLS_CTX
1521 1695
1522This function creates and returns the Net::SSLeay::CTX object used by 1696This function creates and returns the AnyEvent::TLS object used by default
1523default for TLS mode. 1697for TLS mode.
1524 1698
1525The context is created like this: 1699The context is created by calling L<AnyEvent::TLS> without any arguments.
1526
1527 Net::SSLeay::load_error_strings;
1528 Net::SSLeay::SSLeay_add_ssl_algorithms;
1529 Net::SSLeay::randomize;
1530
1531 my $CTX = Net::SSLeay::CTX_new;
1532
1533 Net::SSLeay::CTX_set_options $CTX, Net::SSLeay::OP_ALL
1534 1700
1535=cut 1701=cut
1536 1702
1537our $TLS_CTX; 1703our $TLS_CTX;
1538 1704
1539sub TLS_CTX() { 1705sub TLS_CTX() {
1540 $TLS_CTX || do { 1706 $TLS_CTX ||= do {
1541 require Net::SSLeay; 1707 require AnyEvent::TLS;
1542 1708
1543 Net::SSLeay::load_error_strings (); 1709 new AnyEvent::TLS
1544 Net::SSLeay::SSLeay_add_ssl_algorithms ();
1545 Net::SSLeay::randomize ();
1546
1547 $TLS_CTX = Net::SSLeay::CTX_new ();
1548
1549 Net::SSLeay::CTX_set_options ($TLS_CTX, Net::SSLeay::OP_ALL ());
1550
1551 $TLS_CTX
1552 } 1710 }
1553} 1711}
1554 1712
1555=back 1713=back
1556 1714
1595 1753
1596 $handle->on_read (sub { }); 1754 $handle->on_read (sub { });
1597 $handle->on_eof (undef); 1755 $handle->on_eof (undef);
1598 $handle->on_error (sub { 1756 $handle->on_error (sub {
1599 my $data = delete $_[0]{rbuf}; 1757 my $data = delete $_[0]{rbuf};
1600 undef $handle;
1601 }); 1758 });
1602 1759
1603The reason to use C<on_error> is that TCP connections, due to latencies 1760The reason to use C<on_error> is that TCP connections, due to latencies
1604and packets loss, might get closed quite violently with an error, when in 1761and packets loss, might get closed quite violently with an error, when in
1605fact, all data has been received. 1762fact, all data has been received.
1621 $handle->on_drain (sub { 1778 $handle->on_drain (sub {
1622 warn "all data submitted to the kernel\n"; 1779 warn "all data submitted to the kernel\n";
1623 undef $handle; 1780 undef $handle;
1624 }); 1781 });
1625 1782
1783If you just want to queue some data and then signal EOF to the other side,
1784consider using C<< ->push_shutdown >> instead.
1785
1786=item I want to contact a TLS/SSL server, I don't care about security.
1787
1788If your TLS server is a pure TLS server (e.g. HTTPS) that only speaks TLS,
1789simply connect to it and then create the AnyEvent::Handle with the C<tls>
1790parameter:
1791
1792 tcp_connect $host, $port, sub {
1793 my ($fh) = @_;
1794
1795 my $handle = new AnyEvent::Handle
1796 fh => $fh,
1797 tls => "connect",
1798 on_error => sub { ... };
1799
1800 $handle->push_write (...);
1801 };
1802
1803=item I want to contact a TLS/SSL server, I do care about security.
1804
1805Then you should additionally enable certificate verification, including
1806peername verification, if the protocol you use supports it (see
1807L<AnyEvent::TLS>, C<verify_peername>).
1808
1809E.g. for HTTPS:
1810
1811 tcp_connect $host, $port, sub {
1812 my ($fh) = @_;
1813
1814 my $handle = new AnyEvent::Handle
1815 fh => $fh,
1816 peername => $host,
1817 tls => "connect",
1818 tls_ctx => { verify => 1, verify_peername => "https" },
1819 ...
1820
1821Note that you must specify the hostname you connected to (or whatever
1822"peername" the protocol needs) as the C<peername> argument, otherwise no
1823peername verification will be done.
1824
1825The above will use the system-dependent default set of trusted CA
1826certificates. If you want to check against a specific CA, add the
1827C<ca_file> (or C<ca_cert>) arguments to C<tls_ctx>:
1828
1829 tls_ctx => {
1830 verify => 1,
1831 verify_peername => "https",
1832 ca_file => "my-ca-cert.pem",
1833 },
1834
1835=item I want to create a TLS/SSL server, how do I do that?
1836
1837Well, you first need to get a server certificate and key. You have
1838three options: a) ask a CA (buy one, use cacert.org etc.) b) create a
1839self-signed certificate (cheap. check the search engine of your choice,
1840there are many tutorials on the net) or c) make your own CA (tinyca2 is a
1841nice program for that purpose).
1842
1843Then create a file with your private key (in PEM format, see
1844L<AnyEvent::TLS>), followed by the certificate (also in PEM format). The
1845file should then look like this:
1846
1847 -----BEGIN RSA PRIVATE KEY-----
1848 ...header data
1849 ... lots of base64'y-stuff
1850 -----END RSA PRIVATE KEY-----
1851
1852 -----BEGIN CERTIFICATE-----
1853 ... lots of base64'y-stuff
1854 -----END CERTIFICATE-----
1855
1856The important bits are the "PRIVATE KEY" and "CERTIFICATE" parts. Then
1857specify this file as C<cert_file>:
1858
1859 tcp_server undef, $port, sub {
1860 my ($fh) = @_;
1861
1862 my $handle = new AnyEvent::Handle
1863 fh => $fh,
1864 tls => "accept",
1865 tls_ctx => { cert_file => "my-server-keycert.pem" },
1866 ...
1867
1868When you have intermediate CA certificates that your clients might not
1869know about, just append them to the C<cert_file>.
1870
1626=back 1871=back
1627 1872
1628 1873
1629=head1 SUBCLASSING AnyEvent::Handle 1874=head1 SUBCLASSING AnyEvent::Handle
1630 1875

Diff Legend

Removed lines
+ Added lines
< Changed lines
> Changed lines