ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cvsroot/AnyEvent-Porttracker/Porttracker.pm
(Generate patch)

Comparing cvsroot/AnyEvent-Porttracker/Porttracker.pm (file contents):
Revision 1.19 by root, Tue Jul 26 16:12:46 2016 UTC vs.
Revision 1.20 by root, Tue Jul 26 18:20:09 2016 UTC

… …
101 101
102use AnyEvent (); 102use AnyEvent ();
103use AnyEvent::Handle (); 103use AnyEvent::Handle ();
104 104
105use MIME::Base64 (); 105use MIME::Base64 ();
106use JSON ();
107 106
108our $VERSION = 1.02; 107our $VERSION = 1.02;
109 108
110sub call { 109sub call {
111 my ($self, $type, @args) = @_; 110 my ($self, $type, @args) = @_;
… …
177 176
178sub new { 177sub new {
179 my $class = shift; 178 my $class = shift;
180 179
181 my $self = bless { 180 my $self = bless {
182 id => "a",
183 ids => [],
184 queue => [], # initially queue everything
185 @_, 181 @_,
182 id => "a",
183 ids => [],
184 rframe => "json",
185 wframe => "json",
186 queue => [], # initially queue everything
186 }, $class; 187 }, $class;
187 188
188 { 189 {
189 Scalar::Util::weaken (my $self = $self); 190 Scalar::Util::weaken (my $self = $self);
190 191
… …
201 202
202 $self->_login; 203 $self->_login;
203 }); 204 });
204 } 205 }
205 }, 206 },
206 on_read => sub {
207 while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {
208 my $msg = JSON::decode_json $1;
209 my $id = shift @$msg;
210
211 if (defined $id) {
212 my $cb = delete $self->{cb}{$id}
213 or return $self->error ("received unexpected reply msg with id $id");
214
215 push @{ $self->{ids} }, $id;
216
217 $cb->($self, @$msg);
218 } else {
219 $msg->[0] = "on_$msg->[0]_notify";
220 call $self, @$msg;
221 }
222 }
223 },
224 ; 207 ;
208
209 $self->{cb_read} = sub {
210 my ($hdl, $msg) = @_;
211 my $id = shift @$msg;
212
213 if (defined $id) {
214 my $cb = delete $self->{cb}{$id}
215 or return $self->error ("received unexpected reply msg with id $id");
216
217 push @{ $self->{ids} }, $id;
218
219 $cb->($self, @$msg);
220 } else {
221 $msg->[0] = "on_$msg->[0]_notify";
222 call $self, @$msg;
223 }
224
225 $hdl->push_read ($self->{rframe} => $self->{cb_read});
226 };
227
228 $self->{hdl}->push_read ($self->{rframe} => $self->{cb_read});
225 } 229 }
226 230
227 $self 231 $self
228} 232}
229 233
… …
249 my $id = (pop @{ $self->{ids} }) || $self->{id}++; 253 my $id = (pop @{ $self->{ids} }) || $self->{id}++;
250 254
251 unshift @_, $id; 255 unshift @_, $id;
252 $self->{cb}{$id} = $cb; 256 $self->{cb}{$id} = $cb;
253 257
254 my $msg = JSON::encode_json \@_;
255
256 $self->{hdl}->push_write ($msg); 258 $self->{hdl}->push_write ($self->{wframe} => \@_);
257} 259}
258 260
259=item $api->req ($type => @args, $callback->($api, @reply)) 261=item $api->req ($type => @args, $callback->($api, @reply))
260 262
261Sends a generic request of type C<$type> to the server. When the server 263Sends a generic request of type C<$type> to the server. When the server
… …
380 $self->{tls} ||= 1; 382 $self->{tls} ||= 1;
381 383
382 $self->_login; 384 $self->_login;
383} 385}
384 386
387sub on_start_cbor_notify {
388 my ($self) = @_;
389
390 $self->{rframe} = "cbor";
391}
392
385sub on_hello_notify { 393sub on_hello_notify {
386 my ($self, $version, $auths, $nonce) = @_; 394 my ($self, $version, $features, $nonce) = @_;
387 395
388 $version == 1 396 $version == 1
389 or return $self->error ("protocol mismatch, got $version, expected/supported 1"); 397 or return $self->error ("protocol mismatch, got $version, expected/supported 1");
390 398
391 $nonce = MIME::Base64::decode_base64 $nonce; 399 $nonce = MIME::Base64::decode_base64 $nonce;
392 400
393 $self->{hello} = [$auths, $nonce]; 401 $self->{hello} = [$features, $nonce];
402
403 if (grep $_ eq "start_cbor", @$features and eval 'require CBOR::XS') {
404 $self->_req (start_cbor => sub {
405 $_[1]
406 or $self->error ("start_cbor failed despite announced");
407 });
408
409 $self->{hdl}{cbor} =
410 CBOR::XS
411 ->new
412 ->max_depth (16)
413 ->max_size (1 << 30)
414 ->filter (sub { });
415
416 $self->{wframe} = "cbor";
417 }
394 418
395 $self->_login 419 $self->_login
396 unless $self->{tls}; # delay login when trying to handshake tls 420 unless $self->{tls}; # delay login when trying to handshake tls
397} 421}
398 422
… …
406} 430}
407 431
408sub _login { 432sub _login {
409 my ($self) = @_; 433 my ($self) = @_;
410 434
411 my ($auths, $nonce) = @{ delete $self->{hello} or return }; 435 my ($features, $nonce) = @{ $self->{hello} or return };
412 use Data::Dump; ddx $auths;#d#
413 436
414 if (grep $_ eq "none", @$auths) { 437 if (grep $_ eq "none", @$features) {
415 $self->_login_success ("none"); 438 $self->_login_success ("none");
416 } elsif (grep $_ eq "login_cram_sha3", @$auths) { 439 } elsif (grep $_ eq "login_cram_sha3", @$features and eval 'require Digest::SHA3; require Digest::HMAC') {
417 my $cc = join "", map chr 256 * rand, 0..63; 440 my $cc = join "", map chr 256 * rand, 0..63;
418
419 require Digest::SHA3;
420 require Digest::HMAC;
421 441
422 my $hmac_sha3 = sub ($$){ # $key, $text 442 my $hmac_sha3 = sub ($$){ # $key, $text
423 Digest::HMAC::hmac ($_[1], $_[0], \&Digest::SHA3::sha3_512, 72) 443 Digest::HMAC::hmac ($_[1], $_[0], \&Digest::SHA3::sha3_512, 72)
424 }; 444 };
425 445
… …
439 (MIME::Base64::decode_base64 $msg) eq $sr 459 (MIME::Base64::decode_base64 $msg) eq $sr
440 or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack"; 460 or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";
441 461
442 $self->_login_success ("login_cram_sha3"); 462 $self->_login_success ("login_cram_sha3");
443 }); 463 });
444 } elsif (grep $_ eq "login_cram_md6", @$auths) { 464 } elsif (grep $_ eq "login_cram_md6", @$features and eval 'require Digest::HMAC_MD6') {
445 my $cc = join "", map chr 256 * rand, 0..63; 465 my $cc = join "", map chr 256 * rand, 0..63;
446
447 require Digest::HMAC_MD6;
448 466
449 my $key = Digest::HMAC_MD6::hmac_md6 ($self->{pass}, $self->{user}, 64, 256); 467 my $key = Digest::HMAC_MD6::hmac_md6 ($self->{pass}, $self->{user}, 64, 256);
450 my $cr = Digest::HMAC_MD6::hmac_md6 ($key, "$cc$nonce", 64, 256); 468 my $cr = Digest::HMAC_MD6::hmac_md6 ($key, "$cc$nonce", 64, 256);
451 my $sr = Digest::HMAC_MD6::hmac_md6 ($key, "$nonce$cc", 64, 256); 469 my $sr = Digest::HMAC_MD6::hmac_md6 ($key, "$nonce$cc", 64, 256);
452 470
… …
462 (MIME::Base64::decode_base64 $msg) eq $sr 480 (MIME::Base64::decode_base64 $msg) eq $sr
463 or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack"; 481 or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";
464 482
465 $self->_login_success ("login_cram_md6"); 483 $self->_login_success ("login_cram_md6");
466 }); 484 });
467 } elsif (grep $_ eq "login", @$auths) { 485 } elsif (grep $_ eq "login", @$features) {
468 $self->_req (login => $self->{user}, $self->{pass}, sub { 486 $self->_req (login => $self->{user}, $self->{pass}, sub {
469 my ($self, $ok, $msg) = @_; 487 my ($self, $ok, $msg) = @_;
470 488
471 $ok 489 $ok
472 or return call $self, on_login_failure => $msg; 490 or return call $self, on_login_failure => $msg;
473 491
474 $self->_login_success ("login"); 492 $self->_login_success ("login");
475 }); 493 });
476 } else { 494 } else {
477 call $self, on_login_failure => "no supported auth method (@$auths)"; 495 call $self, on_login_failure => "no supported auth method (@$features)";
478 } 496 }
479 497
480 # we no longer need these, make it a bit harder to get them 498 # we no longer need these, make it a bit harder to get them
481 delete $self->{user}; 499 delete $self->{user};
482 delete $self->{pass}; 500 delete $self->{pass};
… …
573=item on_login_failure $api, $msg 591=item on_login_failure $api, $msg
574 592
575Called when all login attempts have failed - the default raises a fatal 593Called when all login attempts have failed - the default raises a fatal
576error with the error message from the server. 594error with the error message from the server.
577 595
578=item on_hello_notify $api, $version, $authtypes, $nonce 596=item on_hello_notify $api, $version, $features, $nonce
579 597
580This protocol notification is used internally by AnyEvent::Porttracker - 598This protocol notification is used internally by AnyEvent::Porttracker -
581you can override it, but the module will most likely not work. 599you can override it, but the module will most likely not work.
582 600
583=item on_info_notify $api, $msg 601=item on_info_notify $api, $msg
… …
594 612
595Called when the server wants to start TLS negotiation. This is used 613Called when the server wants to start TLS negotiation. This is used
596internally and - while it is possible to override it - should not be 614internally and - while it is possible to override it - should not be
597overridden. 615overridden.
598 616
617=item on_start_cbor_notify $api
618
619Called when the server switched to CBOR framing. This is used internally
620and - while it is possible to override it - should not be overridden.
621
599=item on_event_notify $api, $eventname, @args 622=item on_event_notify $api, $eventname, @args
600 623
601Called when the server broadcasts an event the API object is subscribed 624Called when the server broadcasts an event the API object is subscribed
602to. The default implementation (which should not be overridden) simply 625to. The default implementation (which should not be overridden) simply
603re-issues an "on_eventname_event" event with the @args. 626re-issues an "on_eventname_event" event with the @args.

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines