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.18 by root, Wed Jan 7 01:41:33 2015 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 Digest::HMAC_MD6 ();
107use JSON ();
108 106
109our $VERSION = '1.01'; 107our $VERSION = 1.02;
110 108
111sub call { 109sub call {
112 my ($self, $type, @args) = @_; 110 my ($self, $type, @args) = @_;
113 111
114 $self->{$type} 112 $self->{$type}
… …
118 : () 116 : ()
119} 117}
120 118
121=item $api = new AnyEvent::Porttracker [key => value...] 119=item $api = new AnyEvent::Porttracker [key => value...]
122 120
123Creates a new porttracker API connection object and tries to connect to 121Creates a new porttracker API connection object and tries to connect
124the specified host (see below). After the connection has been established, 122to the specified host (see below). After the connection has been
125the TLS handshake (if requested) will take place, followed by a login 123established, the TLS handshake (if requested) will take place, followed
126attempt using either the C<none>, C<login_cram_md6> or C<login> methods, 124by a login attempt using either the C<none>, C<login_cram_sha3>,
127in this order of preference (typically, C<login_cram_md6> is used, which 125C<login_cram_md6> or C<login> methods, in this order of preference
126(typically, C<login_cram_sha3> is used, which shields against some
128shields against some man-in-the-middle attacks and avoids transferring the 127man-in-the-middle attacks and avoids transferring the password).
129password).
130 128
131It is permissible to send requests immediately after creating the object - 129It is permissible to send requests immediately after creating the object -
132they will be queued until after successful login. 130they will be queued until after successful login.
133 131
134Possible key-value pairs are: 132Possible key-value pairs are:
… …
178 176
179sub new { 177sub new {
180 my $class = shift; 178 my $class = shift;
181 179
182 my $self = bless { 180 my $self = bless {
183 id => "a",
184 ids => [],
185 queue => [], # initially queue everything
186 @_, 181 @_,
182 id => "a",
183 ids => [],
184 rframe => "json",
185 wframe => "json",
186 queue => [], # initially queue everything
187 }, $class; 187 }, $class;
188 188
189 { 189 {
190 Scalar::Util::weaken (my $self = $self); 190 Scalar::Util::weaken (my $self = $self);
191 191
… …
202 202
203 $self->_login; 203 $self->_login;
204 }); 204 });
205 } 205 }
206 }, 206 },
207 on_read => sub {
208 while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {
209 my $msg = JSON::decode_json $1;
210 my $id = shift @$msg;
211
212 if (defined $id) {
213 my $cb = delete $self->{cb}{$id}
214 or return $self->error ("received unexpected reply msg with id $id");
215
216 push @{ $self->{ids} }, $id;
217
218 $cb->($self, @$msg);
219 } else {
220 $msg->[0] = "on_$msg->[0]_notify";
221 call $self, @$msg;
222 }
223 }
224 },
225 ; 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});
226 } 229 }
227 230
228 $self 231 $self
229} 232}
230 233
… …
250 my $id = (pop @{ $self->{ids} }) || $self->{id}++; 253 my $id = (pop @{ $self->{ids} }) || $self->{id}++;
251 254
252 unshift @_, $id; 255 unshift @_, $id;
253 $self->{cb}{$id} = $cb; 256 $self->{cb}{$id} = $cb;
254 257
255 my $msg = JSON::encode_json \@_;
256
257 $self->{hdl}->push_write ($msg); 258 $self->{hdl}->push_write ($self->{wframe} => \@_);
258} 259}
259 260
260=item $api->req ($type => @args, $callback->($api, @reply)) 261=item $api->req ($type => @args, $callback->($api, @reply))
261 262
262Sends 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
… …
381 $self->{tls} ||= 1; 382 $self->{tls} ||= 1;
382 383
383 $self->_login; 384 $self->_login;
384} 385}
385 386
387sub on_start_cbor_notify {
388 my ($self) = @_;
389
390 $self->{rframe} = "cbor";
391}
392
386sub on_hello_notify { 393sub on_hello_notify {
387 my ($self, $version, $auths, $nonce) = @_; 394 my ($self, $version, $features, $nonce) = @_;
388 395
389 $version == 1 396 $version == 1
390 or return $self->error ("protocol mismatch, got $version, expected/supported 1"); 397 or return $self->error ("protocol mismatch, got $version, expected/supported 1");
391 398
392 $nonce = MIME::Base64::decode_base64 $nonce; 399 $nonce = MIME::Base64::decode_base64 $nonce;
393 400
394 $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 }
395 418
396 $self->_login 419 $self->_login
397 unless $self->{tls}; # delay login when trying to handshake tls 420 unless $self->{tls}; # delay login when trying to handshake tls
398} 421}
399 422
… …
407} 430}
408 431
409sub _login { 432sub _login {
410 my ($self) = @_; 433 my ($self) = @_;
411 434
412 my ($auths, $nonce) = @{ delete $self->{hello} or return }; 435 my ($features, $nonce) = @{ $self->{hello} or return };
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 439 } elsif (grep $_ eq "login_cram_sha3", @$features and eval 'require Digest::SHA3; require Digest::HMAC') {
417 } elsif (grep $_ eq "login_cram_md6", @$auths) {
418 my $cc = join "", map chr 256 * rand, 0..63; 440 my $cc = join "", map chr 256 * rand, 0..63;
419 441
420 my $key = Digest::HMAC_MD6::hmac_md6 $self->{pass}, $self->{user}, 64, 256; 442 my $hmac_sha3 = sub ($$){ # $key, $text
421 my $cr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256; 443 Digest::HMAC::hmac ($_[1], $_[0], \&Digest::SHA3::sha3_512, 72)
422 my $sr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$nonce$cc", 64, 256; 444 };
445
446 my $key = $hmac_sha3->($self->{pass}, $self->{user});
447 my $cr = $hmac_sha3->($key, "$cc$nonce");
448 my $sr = $hmac_sha3->($key, "$nonce$cc");
423 449
424 $cc = MIME::Base64::encode_base64 $cc; 450 $cc = MIME::Base64::encode_base64 $cc;
451 $cr = MIME::Base64::encode_base64 $cr;
452
453 $self->_req (login_cram_sha3 => $self->{user}, $cr, $cc, sub {
454 my ($self, $ok, $msg) = @_;
455
456 $ok
457 or return call $self, on_login_failure => $msg;
458
459 (MIME::Base64::decode_base64 $msg) eq $sr
460 or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";
461
462 $self->_login_success ("login_cram_sha3");
463 });
464 } elsif (grep $_ eq "login_cram_md6", @$features and eval 'require Digest::HMAC_MD6') {
465 my $cc = join "", map chr 256 * rand, 0..63;
466
467 my $key = Digest::HMAC_MD6::hmac_md6 ($self->{pass}, $self->{user}, 64, 256);
468 my $cr = Digest::HMAC_MD6::hmac_md6 ($key, "$cc$nonce", 64, 256);
469 my $sr = Digest::HMAC_MD6::hmac_md6 ($key, "$nonce$cc", 64, 256);
470
471 $cc = MIME::Base64::encode_base64 $cc;
472 $cr = MIME::Base64::encode_base64 $cr;
425 473
426 $self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub { 474 $self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub {
427 my ($self, $ok, $msg) = @_; 475 my ($self, $ok, $msg) = @_;
428 476
429 $ok 477 $ok
430 or return call $self, on_login_failure => $msg; 478 or return call $self, on_login_failure => $msg;
431 479
432 $msg eq $sr 480 (MIME::Base64::decode_base64 $msg) eq $sr
433 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";
434 482
435 $self->_login_success ("login_cram_md6"); 483 $self->_login_success ("login_cram_md6");
436 }); 484 });
437 } elsif (grep $_ eq "login", @$auths) { 485 } elsif (grep $_ eq "login", @$features) {
438 $self->_req (login => $self->{user}, $self->{pass}, sub { 486 $self->_req (login => $self->{user}, $self->{pass}, sub {
439 my ($self, $ok, $msg) = @_; 487 my ($self, $ok, $msg) = @_;
440 488
441 $ok 489 $ok
442 or return call $self, on_login_failure => $msg; 490 or return call $self, on_login_failure => $msg;
443 491
444 $self->_login_success ("login"); 492 $self->_login_success ("login");
445 }); 493 });
446 } else { 494 } else {
447 call $self, on_login_failure => "no supported auth method (@$auths)"; 495 call $self, on_login_failure => "no supported auth method (@$features)";
448 } 496 }
449 497
450 # 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
451 delete $self->{user}; 499 delete $self->{user};
452 delete $self->{pass}; 500 delete $self->{pass};
… …
543=item on_login_failure $api, $msg 591=item on_login_failure $api, $msg
544 592
545Called when all login attempts have failed - the default raises a fatal 593Called when all login attempts have failed - the default raises a fatal
546error with the error message from the server. 594error with the error message from the server.
547 595
548=item on_hello_notify $api, $version, $authtypes, $nonce 596=item on_hello_notify $api, $version, $features, $nonce
549 597
550This protocol notification is used internally by AnyEvent::Porttracker - 598This protocol notification is used internally by AnyEvent::Porttracker -
551you can override it, but the module will most likely not work. 599you can override it, but the module will most likely not work.
552 600
553=item on_info_notify $api, $msg 601=item on_info_notify $api, $msg
… …
564 612
565Called when the server wants to start TLS negotiation. This is used 613Called when the server wants to start TLS negotiation. This is used
566internally and - while it is possible to override it - should not be 614internally and - while it is possible to override it - should not be
567overridden. 615overridden.
568 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
569=item on_event_notify $api, $eventname, @args 622=item on_event_notify $api, $eventname, @args
570 623
571Called when the server broadcasts an event the API object is subscribed 624Called when the server broadcasts an event the API object is subscribed
572to. The default implementation (which should not be overridden) simply 625to. The default implementation (which should not be overridden) simply
573re-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