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.10 by root, Tue Nov 16 02:07:31 2010 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 20 # a simple request: ping the server synchronously
18 21
19 $api->req ("ping", sub { 22 my ($timestamp, $pid) = $api->req_sync ("ping");
20 my ($api, $ok, $timestamp, $pid) = @_;
21 ...
22 });
23 23
24 # Example 2 24 # Example 2
25 # find all realms, start a discovery on all of them 25 # find all realms, start a discovery on all of them
26 # and wait until all discovery processes have finished 26 # and wait until all discovery processes have finished
27 # but execute individual discoveries in parallel,
28 # asynchronously
27 29
28 my $cv = AE::cv; 30 my $cv = AE::cv;
29 31
30 $cv->begin; 32 $cv->begin;
31 # find all realms 33 # find all realms
… …
35 # start discovery on all realms 37 # start discovery on all realms
36 for my $realm (@realms) { 38 for my $realm (@realms) {
37 my ($gid, $name) = @$realm; 39 my ($gid, $name) = @$realm;
38 40
39 $cv->begin; 41 $cv->begin;
40 $api->req (realm_discover => $realm->[0], sub { 42 $api->req (realm_discover => $gid, sub {
41 warn "discovery for realm '$realm->[1]' finished\n"; 43 warn "discovery for realm '$name' finished\n";
42 $cv->end; 44 $cv->end;
43 }); 45 });
44 } 46 }
45 47
46 $cv->end; 48 $cv->end;
… …
55 $api->on (realm_poll_stop_event => sub { 57 $api->on (realm_poll_stop_event => sub {
56 my ($api, $gid) = @_; 58 my ($api, $gid) = @_;
57 warn "this just in: poll for realm <$gid> finished.\n"; 59 warn "this just in: poll for realm <$gid> finished.\n";
58 }); 60 });
59 61
62 AE::cv->recv; # wait forever
63
60=head1 DESCRIPTION 64=head1 DESCRIPTION
61 65
62Porttracker (L<http://www.porttracker.com/>) is a product that (among 66Porttracker (L<http://www.porttracker.com/>) is a product that (among
63other 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
64view 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
65switches 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
66this module is an implementation. 70this module is an implementation.
67 71
68In addition to Porttracker, the PortIQ product is also supported, as it
69uses the same protocol.
70
71If 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
72module will be of little value to you. 73little value to you.
73 74
74This 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
75run a supported event loop. 76run a supported event loop.
76 77
77To quickly understand how this module works you should read how to 78To quickly understand how this module works you should read how to
… …
93 94
94package AnyEvent::Porttracker; 95package AnyEvent::Porttracker;
95 96
96use common::sense; 97use common::sense;
97 98
99use Carp ();
98use Scalar::Util (); 100use Scalar::Util ();
99 101
100use AnyEvent (); 102use AnyEvent ();
101use AnyEvent::Handle (); 103use AnyEvent::Handle ();
102 104
103use MIME::Base64 (); 105use MIME::Base64 ();
104use Digest::HMAC_MD6 ();
105use JSON ();
106 106
107our $VERSION = '0.0'; 107our $VERSION = 1.02;
108 108
109sub call { 109sub call {
110 my ($self, $type, @args) = @_; 110 my ($self, $type, @args) = @_;
111 111
112 $self->{$type} 112 $self->{$type}
… …
116 : () 116 : ()
117} 117}
118 118
119=item $api = new AnyEvent::Porttracker [key => value...] 119=item $api = new AnyEvent::Porttracker [key => value...]
120 120
121Creates a new porttracker API connection object and tries to connect to 121Creates a new porttracker API connection object and tries to connect
122the specified host (see below). After the connection has been established, 122to the specified host (see below). After the connection has been
123the TLS handshake (if requested) will take place, followed by a login 123established, the TLS handshake (if requested) will take place, followed
124attempt 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>,
125in 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
126shields against some man-in-the-middle attacks and avoids transferring the 127man-in-the-middle attacks and avoids transferring the password).
127password).
128 128
129It is permissible to send requests immediately after creating the object - 129It is permissible to send requests immediately after creating the object -
130they will be queued until after successful login. 130they will be queued until after successful login.
131 131
132Possible key-value pairs are: 132Possible key-value pairs are:
… …
150 150
151Enables or disables TLS (default: disables). When enabled, then the 151Enables or disables TLS (default: disables). When enabled, then the
152connection will try to handshake a TLS connection before logging in. If 152connection will try to handshake a TLS connection before logging in. If
153unsuccessful a fatal error will be raised. 153unsuccessful a fatal error will be raised.
154 154
155Since most Porttracker/PortIQ boxes will not have a sensible/verifiable 155Since most Porttracker boxes will not have a sensible/verifiable
156certificate, no attempt at verifying it will be done (which means 156certificate, no attempt at verifying it will be done (which means
157man-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
158verification 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<<
159verify => 1, verify_peername => [1, 1, 1] >> or whatever verification mode 159verify => 1, verify_peername => [1, 1, 1] >> or whatever verification mode
160you wish to use. 160you wish to use.
… …
163 163
164The L<AnyEvent::TLS> object to use. See C<tls>, above. 164The L<AnyEvent::TLS> object to use. See C<tls>, above.
165 165
166=item on_XYZ => $coderef 166=item on_XYZ => $coderef
167 167
168You can specify event callbacks either by subclassing and overriding the 168You can specify event callbacks either by sub-classing and overriding the
169respective methods or by specifying coderefs as key-value pairs when 169respective methods or by specifying code-refs as key-value pairs when
170constructing the object. You add or remove event handlers at any time with 170constructing the object. You add or remove event handlers at any time with
171the C<event> method. 171the C<event> method.
172 172
173=back 173=back
174 174
… …
176 176
177sub new { 177sub new {
178 my $class = shift; 178 my $class = shift;
179 179
180 my $self = bless { 180 my $self = bless {
181 id => "a",
182 ids => [],
183 queue => [], # ininitially queue everything
184 @_, 181 @_,
182 id => "a",
183 ids => [],
184 rframe => "json",
185 wframe => "json",
186 queue => [], # initially queue everything
185 }, $class; 187 }, $class;
186 188
187 { 189 {
188 Scalar::Util::weaken (my $self = $self); 190 Scalar::Util::weaken (my $self = $self);
189 191
… …
200 202
201 $self->_login; 203 $self->_login;
202 }); 204 });
203 } 205 }
204 }, 206 },
205 on_read => sub {
206 while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {
207 my $msg = JSON::decode_json $1;
208 my $id = shift @$msg;
209
210 if (defined $id) {
211 my $cb = delete $self->{cb}{$id}
212 or return $self->error ("received unexpected reply msg with id $id");
213
214 push @{ $self->{ids} }, $id;
215
216 $cb->($self, @$msg);
217 } else {
218 $msg->[0] = "on_$msg->[0]_notify";
219 call $self, @$msg;
220 }
221 }
222 },
223 ; 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});
224 } 229 }
225 230
226 $self 231 $self
227} 232}
228 233
… …
248 my $id = (pop @{ $self->{ids} }) || $self->{id}++; 253 my $id = (pop @{ $self->{ids} }) || $self->{id}++;
249 254
250 unshift @_, $id; 255 unshift @_, $id;
251 $self->{cb}{$id} = $cb; 256 $self->{cb}{$id} = $cb;
252 257
253 my $msg = JSON::encode_json \@_;
254
255 $self->{hdl}->push_write ($msg); 258 $self->{hdl}->push_write ($self->{wframe} => \@_);
256} 259}
257 260
258=item $api->req ($type => @args, $callback->($api, @reply)) 261=item $api->req ($type => @args, $callback->($api, @reply))
259 262
260Sends 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
… …
310 $_[0]{queue} 313 $_[0]{queue}
311 ? push @{ $_[0]{queue} }, [@_] 314 ? push @{ $_[0]{queue} }, [@_]
312 : &_req 315 : &_req
313} 316}
314 317
318=item @res = $api->req_sync ($type => @args)
319
320Similar to C<< ->req >>, but waits for the results of the request and on
321success, returns the values instead (without the success flag, and only
322the first value in scalar context). On failure, the method will C<croak>
323with the error message.
324
325=cut
326
327sub req_sync {
328 push @_, my $cv = AE::cv;
329 &req;
330 my ($ok, @res) = $cv->recv;
331
332 $ok
333 or Carp::croak $res[0];
334
335 wantarray ? @res : $res[0]
336}
337
315=item $api->req_failok ($type => @args, $callback->($api, $success, @reply)) 338=item $api->req_failok ($type => @args, $callback->($api, $success, @reply))
316 339
317Just like C<< ->req >>, with two differences: first, a failure will not 340Just like C<< ->req >>, with two differences: first, a failure will not
318raise an error, second, the initial status reply which indicates success 341raise an error, second, the initial status reply which indicates success
319or failure is not removed before calling the callback. 342or failure is not removed before calling the callback.
… …
359 $self->{tls} ||= 1; 382 $self->{tls} ||= 1;
360 383
361 $self->_login; 384 $self->_login;
362} 385}
363 386
387sub on_start_cbor_notify {
388 my ($self) = @_;
389
390 $self->{rframe} = "cbor";
391}
392
364sub on_hello_notify { 393sub on_hello_notify {
365 my ($self, $version, $auths, $nonce) = @_; 394 my ($self, $version, $features, $nonce) = @_;
366 395
367 $version == 1 396 $version == 1
368 or return $self->error ("protocol mismatch, got $version, expected/supported 1"); 397 or return $self->error ("protocol mismatch, got $version, expected/supported 1");
369 398
370 $nonce = MIME::Base64::decode_base64 $nonce; 399 $nonce = MIME::Base64::decode_base64 $nonce;
371 400
372 $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 }
373 418
374 $self->_login 419 $self->_login
375 unless $self->{tls}; # delay login when trying to handshake tls 420 unless $self->{tls}; # delay login when trying to handshake tls
376} 421}
377 422
… …
385} 430}
386 431
387sub _login { 432sub _login {
388 my ($self) = @_; 433 my ($self) = @_;
389 434
390 my ($auths, $nonce) = @{ delete $self->{hello} or return }; 435 my ($features, $nonce) = @{ $self->{hello} or return };
391 436
392 if (grep $_ eq "none", @$auths) { 437 if (grep $_ eq "none", @$features) {
393 $self->_login_success ("none"); 438 $self->_login_success ("none");
394 439 } elsif (grep $_ eq "login_cram_sha3", @$features and eval 'require Digest::SHA3; require Digest::HMAC') {
395 } elsif (grep $_ eq "login_cram_md6", @$auths) {
396 my $cc = join "", map chr 256 * rand, 0..63; 440 my $cc = join "", map chr 256 * rand, 0..63;
397 441
398 my $key = Digest::HMAC_MD6::hmac_md6 $self->{pass}, $self->{user}, 64, 256; 442 my $hmac_sha3 = sub ($$){ # $key, $text
399 my $cr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256; 443 Digest::HMAC::hmac ($_[1], $_[0], \&Digest::SHA3::sha3_512, 72)
400 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");
401 449
402 $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;
403 473
404 $self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub { 474 $self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub {
405 my ($self, $ok, $msg) = @_; 475 my ($self, $ok, $msg) = @_;
406 476
407 $ok 477 $ok
408 or return call $self, on_login_failure => $msg; 478 or return call $self, on_login_failure => $msg;
409 479
410 $msg eq $sr 480 (MIME::Base64::decode_base64 $msg) eq $sr
411 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";
412 482
413 $self->_login_success ("login_cram_md6"); 483 $self->_login_success ("login_cram_md6");
414 }); 484 });
415 } elsif (grep $_ eq "login", @$auths) { 485 } elsif (grep $_ eq "login", @$features) {
416 $self->_req (login => $self->{user}, $self->{pass}, sub { 486 $self->_req (login => $self->{user}, $self->{pass}, sub {
417 my ($self, $ok, $msg) = @_; 487 my ($self, $ok, $msg) = @_;
418 488
419 $ok 489 $ok
420 or return call $self, on_login_failure => $msg; 490 or return call $self, on_login_failure => $msg;
421 491
422 $self->_login_success ("login"); 492 $self->_login_success ("login");
423 }); 493 });
424 } else { 494 } else {
425 call $self, on_login_failure => "no supported auth method (@$auths)"; 495 call $self, on_login_failure => "no supported auth method (@$features)";
426 } 496 }
427 497
428 # 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
429 delete $self->{user}; 499 delete $self->{user};
430 delete $self->{pass}; 500 delete $self->{pass};
… …
463 call $self, "on_${event}_event", @args; 533 call $self, "on_${event}_event", @args;
464} 534}
465 535
466=back 536=back
467 537
468=head1 EVENTS 538=head1 EVENTS/CALLBACKS
469 539
470AnyEvent::Porttracker conenctions are fully event-driven, and naturally 540AnyEvent::Porttracker connections are fully event-driven, and naturally
471there are a number of events that can occur. All these events have a name 541there are a number of events that can occur. All these events have a name
472starting with C<on_> (example: C<on_login_failure>). 542starting with C<on_> (example: C<on_login_failure>).
473 543
474Programs can catch these events in two ways: either by providing 544Programs can catch these events in two ways: either by providing
475constructor arguments with the event name as key and a coderef as value: 545constructor arguments with the event name as key and a code-ref as value:
476 546
477 my $api = new AnyEvent::Porttracker 547 my $api = new AnyEvent::Porttracker
478 host => ..., 548 host => ...,
479 user => ..., pass => ..., 549 user => ..., pass => ...,
480 on_error => sub { 550 on_error => sub {
… …
482 warn $msg; 552 warn $msg;
483 exit 1; 553 exit 1;
484 }, 554 },
485 ; 555 ;
486 556
487Or by subclassing C<AnyEvent::Porttracker> and overriding methods of the 557Or by sub-classing C<AnyEvent::Porttracker> and overriding methods of the
488same name: 558same name:
489 559
490 package MyClass; 560 package MyClass;
491 561
492 use base AnyEvent::Porttracker; 562 use base AnyEvent::Porttracker;
… …
521=item on_login_failure $api, $msg 591=item on_login_failure $api, $msg
522 592
523Called when all login attempts have failed - the default raises a fatal 593Called when all login attempts have failed - the default raises a fatal
524error with the error message from the server. 594error with the error message from the server.
525 595
526=item on_hello_notify $api, $version, $authtypes, $nonce 596=item on_hello_notify $api, $version, $features, $nonce
527 597
528This protocol notification is used internally by AnyEvent::Porttracker - 598This protocol notification is used internally by AnyEvent::Porttracker -
529you can override it, but the module will most likely not work. 599you can override it, but the module will most likely not work.
530 600
531=item on_info_notify $api, $msg 601=item on_info_notify $api, $msg
… …
540 610
541=item on_start_tls_notify $api 611=item on_start_tls_notify $api
542 612
543Called when the server wants to start TLS negotiation. This is used 613Called when the server wants to start TLS negotiation. This is used
544internally and - while it is possible to override it - should not be 614internally and - while it is possible to override it - should not be
545overriden. 615overridden.
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.
546 621
547=item on_event_notify $api, $eventname, @args 622=item on_event_notify $api, $eventname, @args
548 623
549Called when the server broadcasts an event the API object is subscribed 624Called when the server broadcasts an event the API object is subscribed
550to. The default implementation (which should not be overridden) simply 625to. The default implementation (which should not be overridden) simply
… …
561 636
562=back 637=back
563 638
564=head1 SEE ALSO 639=head1 SEE ALSO
565 640
566L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>. 641L<AnyEvent>, L<http://www.porttracker.com/>.
567 642
568=head1 AUTHOR 643=head1 AUTHOR
569 644
570 Marc Lehmann <marc@porttracker.net> 645 Marc Lehmann <marc@nethype.de>
571 646
572=cut 647=cut
573 648
5741 6491

Diff Legend

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