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.16 by root, Thu Jun 2 01:27:46 2011 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
9 my $api = new AnyEvent::Porttracker 9 my $api = new AnyEvent::Porttracker
10 host => "10.0.0.1", 10 host => "10.0.0.1",
11 user => "admin", 11 user => "admin",
12 pass => "31331", 12 pass => "31331",
13 tls => 1, 13 tls => 1,
14 on_error => sub {
15 die $_[1];
16 },
14 ; 17 ;
15 18
16 # Example 1 19 # Example 1
17 # a simple request: ping the server synchronously 20 # a simple request: ping the server synchronously
18 21
… …
64other 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
65view 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
66switches 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
67this module is an implementation. 70this module is an implementation.
68 71
69In addition to Porttracker, the PortIQ product is also supported, as it
70uses the same protocol.
71
72If 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
73module will be of little value to you. 73little value to you.
74 74
75This 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
76run a supported event loop. 76run a supported event loop.
77 77
78To quickly understand how this module works you should read how to 78To quickly understand how this module works you should read how to
… …
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:
… …
152 150
153Enables or disables TLS (default: disables). When enabled, then the 151Enables or disables TLS (default: disables). When enabled, then the
154connection will try to handshake a TLS connection before logging in. If 152connection will try to handshake a TLS connection before logging in. If
155unsuccessful a fatal error will be raised. 153unsuccessful a fatal error will be raised.
156 154
157Since most Porttracker/PortIQ boxes will not have a sensible/verifiable 155Since most Porttracker boxes will not have a sensible/verifiable
158certificate, no attempt at verifying it will be done (which means 156certificate, no attempt at verifying it will be done (which means
159man-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
160verification 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<<
161verify => 1, verify_peername => [1, 1, 1] >> or whatever verification mode 159verify => 1, verify_peername => [1, 1, 1] >> or whatever verification mode
162you wish to use. 160you wish to use.
… …
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.
… …
583 636
584=back 637=back
585 638
586=head1 SEE ALSO 639=head1 SEE ALSO
587 640
588L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>. 641L<AnyEvent>, L<http://www.porttracker.com/>.
589 642
590=head1 AUTHOR 643=head1 AUTHOR
591 644
592 Marc Lehmann <marc@nethype.de> 645 Marc Lehmann <marc@nethype.de>
593 646

Diff Legend

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