--- AnyEvent/lib/AnyEvent/Handle.pm 2011/02/24 12:04:20 1.218 +++ AnyEvent/lib/AnyEvent/Handle.pm 2013/12/10 20:39:12 1.239 @@ -13,7 +13,7 @@ fh => \*STDIN, on_error => sub { my ($hdl, $fatal, $msg) = @_; - warn "got error $msg\n"; + AE::log error => $msg; $hdl->destroy; $cv->send; }; @@ -24,7 +24,7 @@ # read the response line $hdl->push_read (line => sub { my ($hdl, $line) = @_; - warn "got line <$line>\n"; + say "got line <$line>"; $cv->send; }); @@ -130,13 +130,19 @@ This callback is called when a connection has been successfully established. The peer's numeric host and port (the socket peername) are passed as -parameters, together with a retry callback. - -If, for some reason, the handle is not acceptable, calling C<$retry> -will continue with the next connection target (in case of multi-homed -hosts or SRV records there can be multiple connection endpoints). At the -time it is called the read and write queues, eof status, tls status and -similar properties of the handle will have been reset. +parameters, together with a retry callback. At the time it is called the +read and write queues, EOF status, TLS status and similar properties of +the handle will have been reset. + +It is not allowed to use the read or write queues while the handle object +is connecting. + +If, for some reason, the handle is not acceptable, calling C<$retry> will +continue with the next connection target (in case of multi-homed hosts or +SRV records there can be multiple connection endpoints). The C<$retry> +callback can be invoked after the connect callback returns, i.e. one can +start a handshake and then decide to retry with the next host if the +handshake fails. In most cases, you should ignore the C<$retry> parameter. @@ -166,9 +172,15 @@ often easiest to not report C errors in this callback. AnyEvent::Handle tries to find an appropriate error code for you to check -against, but in some cases (TLS errors), this does not work well. It is -recommended to always output the C<$message> argument in human-readable -error messages (it's usually the same as C<"$!">). +against, but in some cases (TLS errors), this does not work well. + +If you report the error to the user, it is recommended to always output +the C<$message> argument in human-readable error messages (you don't need +to report C<"$!"> if you report C<$message>). + +If you want to react programmatically to the error, then looking at C<$!> +and comparing it against some of the documented C values is usually +better than looking at the C<$message>. Non-fatal errors can be retried by returning, but it is recommended to simply ignore this parameter and instead abondon the handle object @@ -226,8 +238,8 @@ =item on_drain => $cb->($handle) -This sets the callback that is called when the write buffer becomes empty -(or immediately if the buffer is empty already). +This sets the callback that is called once when the write buffer becomes +empty (and immediately when the handle object is created). To append to the write buffer, use the C<< ->push_write >> method. @@ -361,10 +373,11 @@ =item read_size => -The initial read block size, the number of bytes this module will try to -read during each loop iteration. Each handle object will consume at least -this amount of memory for the read buffer as well, so when handling many -connections requirements). See also C. Default: C<2048>. +The initial read block size, the number of bytes this module will try +to read during each loop iteration. Each handle object will consume +at least this amount of memory for the read buffer as well, so when +handling many connections watch out for memory requirements). See also +C. Default: C<2048>. =item max_read_size => @@ -418,7 +431,8 @@ TLS mode requires Net::SSLeay to be installed (it will be loaded automatically when you try to create a TLS handle): this module doesn't have a dependency on that module, so if your module requires it, you have -to add the dependency yourself. +to add the dependency yourself. If Net::SSLeay cannot be loaded or is too +old, you get an C error. Unlike TCP, TLS has a server and client side: for the TLS server side, use C, and for the TLS client side of a connection, use C @@ -484,7 +498,7 @@ This callback will only be called on TLS shutdowns, not when the underlying handle signals EOF. -=item json => JSON or JSON::XS object +=item json => L or L object This is the json coder object used by the C read and write types. @@ -492,8 +506,21 @@ suitable one (on demand), which will write and expect UTF-8 encoded JSON texts. -Note that you are responsible to depend on the JSON module if you want to -use this functionality, as AnyEvent does not have a dependency itself. +Note that you are responsible to depend on the L module if you want +to use this functionality, as AnyEvent does not have a dependency on it +itself. + +=item cbor => L object + +This is the cbor coder object used by the C read and write types. + +If you don't supply it, then AnyEvent::Handle will create and use a +suitable one (on demand), which will write CBOR without using extensions, +if possible. texts. + +Note that you are responsible to depend on the L module if you +want to use this functionality, as AnyEvent does not have a dependency on +it itself. =back @@ -881,7 +908,7 @@ AnyEvent::Handle will automatically try to get rid of it for you. When data could be written and the write buffer is shorter then the low -water mark, the C callback will be invoked. +water mark, the C callback will be invoked once. =over 4 @@ -1041,10 +1068,10 @@ this module doesn't need delimiters after or between JSON texts to be able to read them, many other languages depend on that. -A simple RPC protocol that interoperates easily with others is to send -JSON arrays (or objects, although arrays are usually the better choice as -they mimic how function argument passing works) and a newline after each -JSON text: +A simple RPC protocol that interoperates easily with other languages is +to send JSON arrays (or objects, although arrays are usually the better +choice as they mimic how function argument passing works) and a newline +after each JSON text: $handle->push_write (json => ["method", "arg1", "arg2"]); # whatever $handle->push_write ("\012"); @@ -1057,6 +1084,26 @@ Other languages could read single lines terminated by a newline and pass this line into their JSON decoder of choice. +=item cbor => $perl_scalar + +Encodes the given scalar into a CBOR value. Unless you provide your own +L object, this means it will be encoded to a CBOR string not +using any extensions, if possible. + +CBOR values are self-delimiting, so you can write CBOR at one end of +a handle and read them at the other end without using any additional +framing. + +A simple nd very very fast RPC protocol that interoperates with +other languages is to send CBOR and receive CBOR values (arrays are +recommended): + + $handle->push_write (cbor => ["method", "arg1", "arg2"]); # whatever + +An AnyEvent::Handle receiver would simply use the C read type: + + $handle->push_read (cbor => sub { my $array = $_[1]; ... }); + =cut sub json_coder() { @@ -1067,9 +1114,20 @@ register_write_type json => sub { my ($self, $ref) = @_; - my $json = $self->{json} ||= json_coder; + ($self->{json} ||= json_coder) + ->encode ($ref) +}; + +sub cbor_coder() { + require CBOR::XS; + CBOR::XS->new +} + +register_write_type cbor => sub { + my ($self, $scalar) = @_; - $json->encode ($ref) + ($self->{cbor} ||= cbor_coder) + ->encode ($scalar) }; =item storable => $reference @@ -1082,7 +1140,7 @@ register_write_type storable => sub { my ($self, $ref) = @_; - require Storable; + require Storable unless $Storable::VERSION; pack "w/a*", Storable::nfreeze ($ref) }; @@ -1129,7 +1187,7 @@ the handle object and the remaining arguments. The function is supposed to return a single octet string that will be -appended to the write buffer, so you cna mentally treat this function as a +appended to the write buffer, so you can mentally treat this function as a "arguments to on-the-wire-format" converter. Example: implement a custom write type C that joins the remaining @@ -1433,7 +1491,7 @@ Example: read 2 bytes. $handle->push_read (chunk => 2, sub { - warn "yay ", unpack "H*", $_[1]; + say "yay " . unpack "H*", $_[1]; }); =cut @@ -1473,11 +1531,13 @@ my ($self, $cb, $eol) = @_; if (@_ < 3) { - # this is more than twice as fast as the generic code below + # this is faster then the generic code below sub { - $_[0]{rbuf} =~ s/^([^\015\012]*)(\015?\012)// or return; + (my $pos = index $_[0]{rbuf}, "\012") >= 0 + or return; - $cb->($_[0], $1, $2); + (my $str = substr $_[0]{rbuf}, 0, $pos + 1, "") =~ s/(\015?\012)\Z// or die; + $cb->($_[0], $str, "$1"); 1 } } else { @@ -1487,7 +1547,7 @@ sub { $_[0]{rbuf} =~ s/$eol// or return; - $cb->($_[0], $1, $2); + $cb->($_[0], "$1", "$2"); 1 } } @@ -1545,13 +1605,13 @@ # accept if ($$rbuf =~ $accept) { $data .= substr $$rbuf, 0, $+[0], ""; - $cb->($self, $data); + $cb->($_[0], $data); return 1; } # reject if ($reject && $$rbuf =~ $reject) { - $self->_error (Errno::EBADMSG); + $_[0]->_error (Errno::EBADMSG); } # skip @@ -1577,20 +1637,20 @@ sub { unless ($_[0]{rbuf} =~ s/^(0|[1-9][0-9]*)://) { if ($_[0]{rbuf} =~ /[^0-9]/) { - $self->_error (Errno::EBADMSG); + $_[0]->_error (Errno::EBADMSG); } return; } my $len = $1; - $self->unshift_read (chunk => $len, sub { + $_[0]->unshift_read (chunk => $len, sub { my $string = $_[1]; $_[0]->unshift_read (chunk => 1, sub { if ($_[1] eq ",") { $cb->($_[0], $string); } else { - $self->_error (Errno::EBADMSG); + $_[0]->_error (Errno::EBADMSG); } }); }); @@ -1670,35 +1730,80 @@ my $json = $self->{json} ||= json_coder; my $data; - my $rbuf = \$self->{rbuf}; sub { - my $ref = eval { $json->incr_parse ($self->{rbuf}) }; + my $ref = eval { $json->incr_parse ($_[0]{rbuf}) }; if ($ref) { - $self->{rbuf} = $json->incr_text; + $_[0]{rbuf} = $json->incr_text; $json->incr_text = ""; - $cb->($self, $ref); + $cb->($_[0], $ref); 1 } elsif ($@) { # error case $json->incr_skip; - $self->{rbuf} = $json->incr_text; + $_[0]{rbuf} = $json->incr_text; $json->incr_text = ""; - $self->_error (Errno::EBADMSG); + $_[0]->_error (Errno::EBADMSG); () } else { - $self->{rbuf} = ""; + $_[0]{rbuf} = ""; () } } }; +=item cbor => $cb->($handle, $scalar) + +Reads a CBOR value, decodes it and passes it to the callback. When a parse +error occurs, an C error will be raised. + +If a L object was passed to the constructor, then that will be +used for the final decode, otherwise it will create a CBOR coder without +enabling any options. + +You have to provide a dependency to L on your own: this module +will load the L module, but AnyEvent does not depend on it +itself. + +Since CBOR values are fully self-delimiting, the C read and write +types are an ideal simple RPC protocol: just exchange CBOR datagrams. See +the C write type description, above, for an actual example. + +=cut + +register_read_type cbor => sub { + my ($self, $cb) = @_; + + my $cbor = $self->{cbor} ||= cbor_coder; + + my $data; + + sub { + my (@value) = eval { $cbor->incr_parse ($_[0]{rbuf}) }; + + if (@value) { + $cb->($_[0], @value); + + 1 + } elsif ($@) { + # error case + $cbor->incr_reset; + + $_[0]->_error (Errno::EBADMSG); + + () + } else { + () + } + } +}; + =item storable => $cb->($handle, $ref) Deserialises a L frozen representation as written by the @@ -1712,7 +1817,7 @@ register_read_type storable => sub { my ($self, $cb) = @_; - require Storable; + require Storable unless $Storable::VERSION; sub { # when we can use 5.10 we can use ".", but for 5.8 we use the re-pack method @@ -1725,18 +1830,17 @@ if ($format + $len <= length $_[0]{rbuf}) { my $data = substr $_[0]{rbuf}, $format, $len; substr $_[0]{rbuf}, 0, $format + $len, ""; - $cb->($_[0], Storable::thaw ($data)); + + eval { $cb->($_[0], Storable::thaw ($data)); 1 } + or return $_[0]->_error (Errno::EBADMSG); } else { # remove prefix substr $_[0]{rbuf}, 0, $format, ""; # read remaining chunk $_[0]->unshift_read (chunk => $len, sub { - if (my $ref = eval { Storable::thaw ($_[1]) }) { - $cb->($_[0], $ref); - } else { - $self->_error (Errno::EBADMSG); - } + eval { $cb->($_[0], Storable::thaw ($_[1])); 1 } + or $_[0]->_error (Errno::EBADMSG); }); } @@ -1744,6 +1848,92 @@ } }; +=item tls_detect => $cb->($handle, $detect, $major, $minor) + +Checks the input stream for a valid SSL or TLS handshake TLSPaintext +record without consuming anything. Only SSL version 3 or higher +is handled, up to the fictituous protocol 4.x (but both SSL3+ and +SSL2-compatible framing is supported). + +If it detects that the input data is likely TLS, it calls the callback +with a true value for C<$detect> and the (on-wire) TLS version as second +and third argument (C<$major> is C<3>, and C<$minor> is 0..3 for SSL +3.0, TLS 1.0, 1.1 and 1.2, respectively). If it detects the input to +be definitely not TLS, it calls the callback with a false value for +C<$detect>. + +The callback could use this information to decide whether or not to start +TLS negotiation. + +In all cases the data read so far is passed to the following read +handlers. + +Usually you want to use the C read type instead. + +If you want to design a protocol that works in the presence of TLS +dtection, make sure that any non-TLS data doesn't start with the octet 22 +(ASCII SYN, 16 hex) or 128-255 (i.e. highest bit set). The checks this +read type does are a bit more strict, but might losen in the future to +accomodate protocol changes. + +This read type does not rely on L (and thus, not on +L). + +=item tls_autostart => $tls[, $tls_ctx] + +Tries to detect a valid SSL or TLS handshake. If one is detected, it tries +to start tls by calling C with the given arguments. + +In practise, C<$tls> must be C, or a Net::SSLeay context that has +been configured to accept, as servers do not normally send a handshake on +their own and ths cannot be detected in this way. + +See C above for more details. + +Example: give the client a chance to start TLS before accepting a text +line. + + $hdl->push_read (tls_detect => "accept"); + $hdl->push_read (line => sub { + print "received ", ($_[0]{tls} ? "encrypted" : "cleartext"), " <$_[1]>\n"; + }); + +=cut + +register_read_type tls_detect => sub { + my ($self, $cb) = @_; + + sub { + # this regex matches a full or partial tls record + if ( + # ssl3+: type(22=handshake) major(=3) minor(any) length_hi + $self->{rbuf} =~ /^(?:\z| \x16 (\z| [\x03\x04] (?:\z| . (?:\z| [\x00-\x40] ))))/xs + # ssl2 comapatible: len_hi len_lo type(1) major minor dummy(forlength) + or $self->{rbuf} =~ /^(?:\z| [\x80-\xff] (?:\z| . (?:\z| \x01 (\z| [\x03\x04] (?:\z| . (?:\z| . ))))))/xs + ) { + return if 3 != length $1; # partial match, can't decide yet + + # full match, valid TLS record + my ($major, $minor) = unpack "CC", $1; + $cb->($self, "accept", $major + $minor * 0.1); + } else { + # mismatch == guaranteed not TLS + $cb->($self, undef); + } + + 1 + } +}; + +register_read_type tls_autostart => sub { + my ($self, @tls) = @_; + + $RH{tls_detect}($self, sub { + return unless $_[1]; + $_[0]->starttls (@tls); + }) +}; + =back =item custom read types - Package::anyevent_read_type $handle, $cb, @args @@ -1793,7 +1983,7 @@ during a rehandshake. As a guideline, during the initial handshake, you should not stop reading, -and as a client, it might cause problems, depending on your applciation. +and as a client, it might cause problems, depending on your application. =cut @@ -1851,7 +2041,7 @@ return $self->_error ($!, 1) if $err == Net::SSLeay::ERROR_SYSCALL (); - my $err =Net::SSLeay::ERR_error_string (Net::SSLeay::ERR_get_error ()); + my $err = Net::SSLeay::ERR_error_string (Net::SSLeay::ERR_get_error ()); # reduce error string to look less scary $err =~ s/^error:[0-9a-fA-F]{8}:[^:]+:([^:]+):/\L$1: /; @@ -1875,15 +2065,18 @@ my $tmp; - if (length $self->{_tls_wbuf}) { - while (($tmp = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) { - substr $self->{_tls_wbuf}, 0, $tmp, ""; + while (length $self->{_tls_wbuf}) { + if (($tmp = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) <= 0) { + $tmp = Net::SSLeay::get_error ($self->{tls}, $tmp); + + return $self->_tls_error ($tmp) + if $tmp != $ERROR_WANT_READ + && ($tmp != $ERROR_SYSCALL || $!); + + last; } - $tmp = Net::SSLeay::get_error ($self->{tls}, $tmp); - return $self->_tls_error ($tmp) - if $tmp != $ERROR_WANT_READ - && ($tmp != $ERROR_SYSCALL || $!); + substr $self->{_tls_wbuf}, 0, $tmp, ""; } while (defined ($tmp = Net::SSLeay::read ($self->{tls}))) { @@ -1907,7 +2100,7 @@ $self->{tls} or return; # tls session might have gone away in callback } - $tmp = Net::SSLeay::get_error ($self->{tls}, -1); + $tmp = Net::SSLeay::get_error ($self->{tls}, -1); # -1 is not neccessarily correct, but Net::SSLeay doesn't tell us return $self->_tls_error ($tmp) if $tmp != $ERROR_WANT_READ && ($tmp != $ERROR_SYSCALL || $!); @@ -1927,11 +2120,13 @@ Instead of starting TLS negotiation immediately when the AnyEvent::Handle object is created, you can also do that at a later time by calling -C. +C. See the C constructor argument for general info. Starting TLS is currently an asynchronous operation - when you push some write data and then call C<< ->starttls >> then TLS negotiation will start -immediately, after which the queued write data is then sent. +immediately, after which the queued write data is then sent. This might +change in future versions, so best make sure you have no outstanding write +data when calling this method. The first argument is the same as the C constructor argument (either C<"connect">, C<"accept"> or an existing Net::SSLeay object). @@ -1963,13 +2158,19 @@ Carp::croak "It is an error to call starttls on an AnyEvent::Handle object while TLS is already active, caught" if $self->{tls}; + unless (defined $AnyEvent::TLS::VERSION) { + eval { + require Net::SSLeay; + require AnyEvent::TLS; + 1 + } or return $self->_error (Errno::EPROTO, 1, "TLS support not available on this system"); + } + $self->{tls} = $tls; $self->{tls_ctx} = $ctx if @_ > 2; return unless $self->{fh}; - require Net::SSLeay; - $ERROR_SYSCALL = Net::SSLeay::ERROR_SYSCALL (); $ERROR_WANT_READ = Net::SSLeay::ERROR_WANT_READ (); @@ -1979,8 +2180,6 @@ local $Carp::CarpLevel = 1; # skip ourselves when creating a new context or session if ("HASH" eq ref $ctx) { - require AnyEvent::TLS; - if ($ctx->{cache}) { my $key = $ctx+0; $ctx = $TLS_CACHE{$key} ||= new AnyEvent::TLS %$ctx; @@ -2012,7 +2211,8 @@ $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); - Net::SSLeay::BIO_write ($self->{_rbio}, delete $self->{rbuf}); + Net::SSLeay::BIO_write ($self->{_rbio}, $self->{rbuf}); + $self->{rbuf} = ""; Net::SSLeay::set_bio ($tls, $self->{_rbio}, $self->{_wbio}); @@ -2204,7 +2404,7 @@ considered an error as you clearly expected some data. To avoid this, make sure you have an empty read queue whenever your handle -is supposed to be "idle" (i.e. connection closes are O.K.). You cna set +is supposed to be "idle" (i.e. connection closes are O.K.). You can set an C handler that simply pushes the first read requests in the queue. @@ -2222,7 +2422,7 @@ client dropping the connection is an error, which means this variant can detect an unexpected detection close. -To handle this case, always make sure you have a on-empty read queue, by +To handle this case, always make sure you have a non-empty read queue, by pushing the "read request start" handler on it: # we assume a request starts with a single line @@ -2245,7 +2445,7 @@ The second variant is a protocol where the client can drop the connection at any time. For TCP, this means that the server machine may run out of -sockets easier, and in general, it means you cnanot distinguish a protocl +sockets easier, and in general, it means you cannot distinguish a protocl failure/client crash from a normal connection close. Nevertheless, these kinds of protocols are common (and sometimes even the best solution to the problem). @@ -2307,6 +2507,10 @@ my $data = delete $_[0]{rbuf}; }); +Note that this example removes the C member from the handle object, +which is not normally allowed by the API. It is expressly permitted in +this case only, as the handle object needs to be destroyed afterwards. + The reason to use C is that TCP connections, due to latencies and packets loss, might get closed quite violently with an error, when in fact all data has been received. @@ -2326,7 +2530,7 @@ $handle->push_write (...); $handle->on_drain (sub { - warn "all data submitted to the kernel\n"; + AE::log debug => "All data submitted to the kernel."; undef $handle; }); @@ -2420,7 +2624,6 @@ =back - =head1 SUBCLASSING AnyEvent::Handle In many cases, you might want to subclass AnyEvent::Handle. @@ -2456,4 +2659,5 @@ =cut -1; # End of AnyEvent::Handle +1 +