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.17 by root, Mon Mar 11 08:43:53 2013 UTC vs.
Revision 1.20 by root, Tue Jul 26 18:20:09 2016 UTC

1=head1 NAME 1=head1 NAME
2 2
3AnyEvent::Porttracker - Porttracker/PortIQ API client interface. 3AnyEvent::Porttracker - Porttracker API client interface.
4 4
5=head1 SYNOPSIS 5=head1 SYNOPSIS
6 6
7 use AnyEvent::Porttracker; 7 use AnyEvent::Porttracker;
8 8
… …
67other things) scans switches and routers in a network and gives a coherent 67other things) scans switches and routers in a network and gives a coherent
68view of which end devices are connected to which switch ports on which 68view of which end devices are connected to which switch ports on which
69switches and routers. It also offers a JSON-based client API, for which 69switches and routers. It also offers a JSON-based client API, for which
70this module is an implementation. 70this module is an implementation.
71 71
72In addition to Porttracker, the PortIQ product is also supported, as it
73uses the same protocol.
74
75If you do not have access to either a Porttracker or PortIQ box then this 72If you do not have access to a Porttracker box then this module will be of
76module will be of little value to you. 73little value to you.
77 74
78This module is an L<AnyEvent> user, you need to make sure that you use and 75This module is an L<AnyEvent> user, you need to make sure that you use and
79run a supported event loop. 76run a supported event loop.
80 77
81To quickly understand how this module works you should read how to 78To quickly understand how this module works you should read how to
… …
104 101
105use AnyEvent (); 102use AnyEvent ();
106use AnyEvent::Handle (); 103use AnyEvent::Handle ();
107 104
108use MIME::Base64 (); 105use MIME::Base64 ();
109use Digest::HMAC_MD6 ();
110use JSON ();
111 106
112our $VERSION = '1.01'; 107our $VERSION = 1.02;
113 108
114sub call { 109sub call {
115 my ($self, $type, @args) = @_; 110 my ($self, $type, @args) = @_;
116 111
117 $self->{$type} 112 $self->{$type}
… …
121 : () 116 : ()
122} 117}
123 118
124=item $api = new AnyEvent::Porttracker [key => value...] 119=item $api = new AnyEvent::Porttracker [key => value...]
125 120
126Creates a new porttracker API connection object and tries to connect to 121Creates a new porttracker API connection object and tries to connect
127the specified host (see below). After the connection has been established, 122to the specified host (see below). After the connection has been
128the TLS handshake (if requested) will take place, followed by a login 123established, the TLS handshake (if requested) will take place, followed
129attempt 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>,
130in 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
131shields against some man-in-the-middle attacks and avoids transferring the 127man-in-the-middle attacks and avoids transferring the password).
132password).
133 128
134It is permissible to send requests immediately after creating the object - 129It is permissible to send requests immediately after creating the object -
135they will be queued until after successful login. 130they will be queued until after successful login.
136 131
137Possible key-value pairs are: 132Possible key-value pairs are:
… …
155 150
156Enables or disables TLS (default: disables). When enabled, then the 151Enables or disables TLS (default: disables). When enabled, then the
157connection will try to handshake a TLS connection before logging in. If 152connection will try to handshake a TLS connection before logging in. If
158unsuccessful a fatal error will be raised. 153unsuccessful a fatal error will be raised.
159 154
160Since most Porttracker/PortIQ boxes will not have a sensible/verifiable 155Since most Porttracker boxes will not have a sensible/verifiable
161certificate, no attempt at verifying it will be done (which means 156certificate, no attempt at verifying it will be done (which means
162man-in-the-middle-attacks will be trivial). If you want some form of 157man-in-the-middle-attacks will be trivial). If you want some form of
163verification you need to provide your own C<tls_ctx> object with C<< 158verification you need to provide your own C<tls_ctx> object with C<<
164verify => 1, verify_peername => [1, 1, 1] >> or whatever verification mode 159verify => 1, verify_peername => [1, 1, 1] >> or whatever verification mode
165you wish to use. 160you wish to use.
… …
181 176
182sub new { 177sub new {
183 my $class = shift; 178 my $class = shift;
184 179
185 my $self = bless { 180 my $self = bless {
186 id => "a",
187 ids => [],
188 queue => [], # initially queue everything
189 @_, 181 @_,
182 id => "a",
183 ids => [],
184 rframe => "json",
185 wframe => "json",
186 queue => [], # initially queue everything
190 }, $class; 187 }, $class;
191 188
192 { 189 {
193 Scalar::Util::weaken (my $self = $self); 190 Scalar::Util::weaken (my $self = $self);
194 191
… …
205 202
206 $self->_login; 203 $self->_login;
207 }); 204 });
208 } 205 }
209 }, 206 },
210 on_read => sub {
211 while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {
212 my $msg = JSON::decode_json $1;
213 my $id = shift @$msg;
214
215 if (defined $id) {
216 my $cb = delete $self->{cb}{$id}
217 or return $self->error ("received unexpected reply msg with id $id");
218
219 push @{ $self->{ids} }, $id;
220
221 $cb->($self, @$msg);
222 } else {
223 $msg->[0] = "on_$msg->[0]_notify";
224 call $self, @$msg;
225 }
226 }
227 },
228 ; 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});
229 } 229 }
230 230
231 $self 231 $self
232} 232}
233 233
… …
253 my $id = (pop @{ $self->{ids} }) || $self->{id}++; 253 my $id = (pop @{ $self->{ids} }) || $self->{id}++;
254 254
255 unshift @_, $id; 255 unshift @_, $id;
256 $self->{cb}{$id} = $cb; 256 $self->{cb}{$id} = $cb;
257 257
258 my $msg = JSON::encode_json \@_;
259
260 $self->{hdl}->push_write ($msg); 258 $self->{hdl}->push_write ($self->{wframe} => \@_);
261} 259}
262 260
263=item $api->req ($type => @args, $callback->($api, @reply)) 261=item $api->req ($type => @args, $callback->($api, @reply))
264 262
265Sends 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
… …
384 $self->{tls} ||= 1; 382 $self->{tls} ||= 1;
385 383
386 $self->_login; 384 $self->_login;
387} 385}
388 386
387sub on_start_cbor_notify {
388 my ($self) = @_;
389
390 $self->{rframe} = "cbor";
391}
392
389sub on_hello_notify { 393sub on_hello_notify {
390 my ($self, $version, $auths, $nonce) = @_; 394 my ($self, $version, $features, $nonce) = @_;
391 395
392 $version == 1 396 $version == 1
393 or return $self->error ("protocol mismatch, got $version, expected/supported 1"); 397 or return $self->error ("protocol mismatch, got $version, expected/supported 1");
394 398
395 $nonce = MIME::Base64::decode_base64 $nonce; 399 $nonce = MIME::Base64::decode_base64 $nonce;
396 400
397 $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 }
398 418
399 $self->_login 419 $self->_login
400 unless $self->{tls}; # delay login when trying to handshake tls 420 unless $self->{tls}; # delay login when trying to handshake tls
401} 421}
402 422
… …
410} 430}
411 431
412sub _login { 432sub _login {
413 my ($self) = @_; 433 my ($self) = @_;
414 434
415 my ($auths, $nonce) = @{ delete $self->{hello} or return }; 435 my ($features, $nonce) = @{ $self->{hello} or return };
416 436
417 if (grep $_ eq "none", @$auths) { 437 if (grep $_ eq "none", @$features) {
418 $self->_login_success ("none"); 438 $self->_login_success ("none");
419 439 } elsif (grep $_ eq "login_cram_sha3", @$features and eval 'require Digest::SHA3; require Digest::HMAC') {
420 } elsif (grep $_ eq "login_cram_md6", @$auths) {
421 my $cc = join "", map chr 256 * rand, 0..63; 440 my $cc = join "", map chr 256 * rand, 0..63;
422 441
423 my $key = Digest::HMAC_MD6::hmac_md6 $self->{pass}, $self->{user}, 64, 256; 442 my $hmac_sha3 = sub ($$){ # $key, $text
424 my $cr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256; 443 Digest::HMAC::hmac ($_[1], $_[0], \&Digest::SHA3::sha3_512, 72)
425 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");
426 449
427 $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;
428 473
429 $self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub { 474 $self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub {
430 my ($self, $ok, $msg) = @_; 475 my ($self, $ok, $msg) = @_;
431 476
432 $ok 477 $ok
433 or return call $self, on_login_failure => $msg; 478 or return call $self, on_login_failure => $msg;
434 479
435 $msg eq $sr 480 (MIME::Base64::decode_base64 $msg) eq $sr
436 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";
437 482
438 $self->_login_success ("login_cram_md6"); 483 $self->_login_success ("login_cram_md6");
439 }); 484 });
440 } elsif (grep $_ eq "login", @$auths) { 485 } elsif (grep $_ eq "login", @$features) {
441 $self->_req (login => $self->{user}, $self->{pass}, sub { 486 $self->_req (login => $self->{user}, $self->{pass}, sub {
442 my ($self, $ok, $msg) = @_; 487 my ($self, $ok, $msg) = @_;
443 488
444 $ok 489 $ok
445 or return call $self, on_login_failure => $msg; 490 or return call $self, on_login_failure => $msg;
446 491
447 $self->_login_success ("login"); 492 $self->_login_success ("login");
448 }); 493 });
449 } else { 494 } else {
450 call $self, on_login_failure => "no supported auth method (@$auths)"; 495 call $self, on_login_failure => "no supported auth method (@$features)";
451 } 496 }
452 497
453 # 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
454 delete $self->{user}; 499 delete $self->{user};
455 delete $self->{pass}; 500 delete $self->{pass};
… …
546=item on_login_failure $api, $msg 591=item on_login_failure $api, $msg
547 592
548Called when all login attempts have failed - the default raises a fatal 593Called when all login attempts have failed - the default raises a fatal
549error with the error message from the server. 594error with the error message from the server.
550 595
551=item on_hello_notify $api, $version, $authtypes, $nonce 596=item on_hello_notify $api, $version, $features, $nonce
552 597
553This protocol notification is used internally by AnyEvent::Porttracker - 598This protocol notification is used internally by AnyEvent::Porttracker -
554you can override it, but the module will most likely not work. 599you can override it, but the module will most likely not work.
555 600
556=item on_info_notify $api, $msg 601=item on_info_notify $api, $msg
… …
567 612
568Called when the server wants to start TLS negotiation. This is used 613Called when the server wants to start TLS negotiation. This is used
569internally and - while it is possible to override it - should not be 614internally and - while it is possible to override it - should not be
570overridden. 615overridden.
571 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
572=item on_event_notify $api, $eventname, @args 622=item on_event_notify $api, $eventname, @args
573 623
574Called when the server broadcasts an event the API object is subscribed 624Called when the server broadcasts an event the API object is subscribed
575to. The default implementation (which should not be overridden) simply 625to. The default implementation (which should not be overridden) simply
576re-issues an "on_eventname_event" event with the @args. 626re-issues an "on_eventname_event" event with the @args.
… …
586 636
587=back 637=back
588 638
589=head1 SEE ALSO 639=head1 SEE ALSO
590 640
591L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>. 641L<AnyEvent>, L<http://www.porttracker.com/>.
592 642
593=head1 AUTHOR 643=head1 AUTHOR
594 644
595 Marc Lehmann <marc@nethype.de> 645 Marc Lehmann <marc@nethype.de>
596 646

Diff Legend

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