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.7 by root, Tue Nov 16 01:16:58 2010 UTC vs.
Revision 1.21 by root, Sat May 30 05:41:02 2020 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
9 my $api = new AnyEvent::Porttracker
10 host => "10.0.0.1",
11 user => "admin",
12 pass => "31331",
13 tls => 1,
14 on_error => sub {
15 die $_[1];
16 },
17 ;
18
19 # Example 1
20 # a simple request: ping the server synchronously
21
22 my ($timestamp, $pid) = $api->req_sync ("ping");
23
24 # Example 2
25 # find all realms, start a discovery on all of them
26 # and wait until all discovery processes have finished
27 # but execute individual discoveries in parallel,
28 # asynchronously
29
30 my $cv = AE::cv;
31
32 $cv->begin;
33 # find all realms
34 $api->req (realm_info => ["gid", "name"], sub {
35 my ($api, @realms) = @_;
36
37 # start discovery on all realms
38 for my $realm (@realms) {
39 my ($gid, $name) = @$realm;
40
41 $cv->begin;
42 $api->req (realm_discover => $gid, sub {
43 warn "discovery for realm '$name' finished\n";
44 $cv->end;
45 });
46 }
47
48 $cv->end;
49 });
50
51 $cv->recv;
52
53 # Example 3
54 # subscribe to realm_poll_stop events and report each occurance
55
56 $api->req (subscribe => "realm_poll_stop", sub {});
57 $api->on (realm_poll_stop_event => sub {
58 my ($api, $gid) = @_;
59 warn "this just in: poll for realm <$gid> finished.\n";
60 });
61
62 AE::cv->recv; # wait forever
8 63
9=head1 DESCRIPTION 64=head1 DESCRIPTION
10 65
11Porttracker (L<http://www.porttracker.com/>) is a product that (among 66Porttracker (L<http://www.porttracker.com/>) is a product that (among
12other 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
13view 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
14switches 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
15this module is an implementation. 70this module is an implementation.
16 71
17In addition to Porttracker, the PortIQ product is also supported, as it
18uses the same protocol.
19
20If 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
21module will be of little value to you. 73little value to you.
22 74
23This 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
24run a supported event loop. 76run a supported event loop.
25 77
26To quickly understand how this module works you should read how to 78To quickly understand how this module works you should read how to
… …
28system. 80system.
29 81
30The actual low-level protocol and, more importantly, the existing 82The actual low-level protocol and, more importantly, the existing
31requests and responses, are documented in the official Porttracker 83requests and responses, are documented in the official Porttracker
32API documentation (a copy of which is included in this module as 84API documentation (a copy of which is included in this module as
33L<AnyEvent::Porttracker::protocol>. 85L<AnyEvent::Porttracker::protocol>).
34 86
35=head1 THE AnyEvent::Porttracker CLASS 87=head1 THE AnyEvent::Porttracker CLASS
36 88
37The AnyEvent::Porttracker class represents a single connection. 89The AnyEvent::Porttracker class represents a single connection.
38 90
… …
42 94
43package AnyEvent::Porttracker; 95package AnyEvent::Porttracker;
44 96
45use common::sense; 97use common::sense;
46 98
99use Carp ();
47use Scalar::Util (); 100use Scalar::Util ();
48 101
49use AnyEvent (); 102use AnyEvent ();
50use AnyEvent::Handle (); 103use AnyEvent::Handle ();
51 104
52use MIME::Base64 (); 105use MIME::Base64 ();
53use Digest::HMAC_MD6 ();
54use JSON ();
55 106
56our $VERSION = '0.0'; 107our $VERSION = 1.02;
57 108
58sub call { 109sub call {
59 my ($self, $type, @args) = @_; 110 my ($self, $type, @args) = @_;
60 111
61 $self->{$type} 112 $self->{$type}
… …
65 : () 116 : ()
66} 117}
67 118
68=item $api = new AnyEvent::Porttracker [key => value...] 119=item $api = new AnyEvent::Porttracker [key => value...]
69 120
70Creates a new porttracker API connection object and tries to connect to 121Creates a new porttracker API connection object and tries to connect
71the specified host (see below). After the connection has been established, 122to the specified host (see below). After the connection has been
72the TLS handshake (if requested) will take place, followed by a login 123established, the TLS handshake (if requested) will take place, followed
73attempt 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>,
74in 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
75shields against some man-in-the-middle attacks and avoids transferring the 127man-in-the-middle attacks and avoids transferring the password).
76password).
77 128
78It is permissible to send requests immediately after creating the object - 129It is permissible to send requests immediately after creating the object -
79they will be queued until after successful login. 130they will be queued until after successful login.
80 131
81Possible key-value pairs are: 132Possible key-value pairs are:
… …
99 150
100Enables or disables TLS (default: disables). When enabled, then the 151Enables or disables TLS (default: disables). When enabled, then the
101connection will try to handshake a TLS connection before logging in. If 152connection will try to handshake a TLS connection before logging in. If
102unsuccessful a fatal error will be raised. 153unsuccessful a fatal error will be raised.
103 154
104Since most Porttracker/PortIQ boxes will not have a sensible/verifiable 155Since most Porttracker boxes will not have a sensible/verifiable
105certificate, no attempt at verifying it will be done (which means 156certificate, no attempt at verifying it will be done (which means
106man-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
107verification 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<<
108verify => 1, verify_peername => [1, 1, 1] >> or whatever verification mode 159verify => 1, verify_peername => [1, 1, 1] >> or whatever verification mode
109you wish to use. 160you wish to use.
110 161
111=item tls_ctx => $tls_ctx 162=item tls_ctx => $tls_ctx
112 163
113The L<AnyEvent::TLS> object to use. 164The L<AnyEvent::TLS> object to use. See C<tls>, above.
114
115#TODO#
116 165
117=item on_XYZ => $coderef 166=item on_XYZ => $coderef
118 167
119You can specify event callbacks either by subclassing and overriding the 168You can specify event callbacks either by sub-classing and overriding the
120respective methods or by specifying coderefs as key-value pairs when 169respective methods or by specifying code-refs as key-value pairs when
121constructing the object. 170constructing the object. You add or remove event handlers at any time with
171the C<event> method.
122 172
123=back 173=back
124 174
125=cut 175=cut
126 176
127sub new { 177sub new {
128 my $class = shift; 178 my $class = shift;
129 179
130 my $self = bless { 180 my $self = bless {
131 id => "a",
132 ids => [],
133 queue => [], # ininitially queue everything
134 @_, 181 @_,
182 id => "a",
183 ids => [],
184 rframe => "json",
185 wframe => "json",
186 queue => [], # initially queue everything
135 }, $class; 187 }, $class;
136 188
137 { 189 {
138 Scalar::Util::weaken (my $self = $self); 190 Scalar::Util::weaken (my $self = $self);
139 191
… …
150 202
151 $self->_login; 203 $self->_login;
152 }); 204 });
153 } 205 }
154 }, 206 },
155 on_read => sub {
156 while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {
157 my $msg = JSON::decode_json $1;
158 my $id = shift @$msg;
159
160 if (defined $id) {
161 my $cb = delete $self->{cb}{$id}
162 or return $self->error ("received unexpected reply msg with id $id");
163
164 push @{ $self->{ids} }, $id;
165
166 $cb->($self, @$msg);
167 } else {
168 $msg->[0] = "on_$msg->[0]_notify";
169 call $self, @$msg;
170 }
171 }
172 },
173 ; 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});
174 } 229 }
175 230
176 $self 231 $self
177} 232}
178 233
… …
198 my $id = (pop @{ $self->{ids} }) || $self->{id}++; 253 my $id = (pop @{ $self->{ids} }) || $self->{id}++;
199 254
200 unshift @_, $id; 255 unshift @_, $id;
201 $self->{cb}{$id} = $cb; 256 $self->{cb}{$id} = $cb;
202 257
203 my $msg = JSON::encode_json \@_;
204
205 $self->{hdl}->push_write ($msg); 258 $self->{hdl}->push_write ($self->{wframe} => \@_);
206} 259}
207 260
208=item $api->req ($type => @args, $callback->($api, @reply)) 261=item $api->req ($type => @args, $callback->($api, @reply))
209 262
210Sends 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
… …
260 $_[0]{queue} 313 $_[0]{queue}
261 ? push @{ $_[0]{queue} }, [@_] 314 ? push @{ $_[0]{queue} }, [@_]
262 : &_req 315 : &_req
263} 316}
264 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
265=item $api->req_failok ($type => @args, $callback->($api, $success, @reply)) 338=item $api->req_failok ($type => @args, $callback->($api, $success, @reply))
266 339
267Just like C<< ->req >>, with two differences: first, a failure will not 340Just like C<< ->req >>, with two differences: first, a failure will not
268raise an error, second, the initial status reply which indicates success 341raise an error, second, the initial status reply which indicates success
269or failure is not removed before calling the callback. 342or failure is not removed before calling the callback.
… …
274 $_[0]{queue} 347 $_[0]{queue}
275 ? push @{ $_[0]{queue} }, [@_] 348 ? push @{ $_[0]{queue} }, [@_]
276 : &_req 349 : &_req
277} 350}
278 351
352=item $api->on (XYZ => $callback)
353
354Overwrites any currently registered handler for C<on_XYZ> or
355installs a new one. Or, when C<$callback> is undef, unregisters any
356currently-registered handler.
357
358Example: replace/set the handler for C<on_discover_stop_event>.
359
360 $api->on (discover_stop_event => sub {
361 my ($api, $gid) = @_;
362 ...
363 });
364
365=cut
366
367sub on {
368 my $self = shift;
369
370 while (@_) {
371 my ($event, $cb) = splice @_, 0, 2;
372 $event =~ s/^on_//;
373
374 $self->{"on_$event"} = $cb;
375 }
376}
377
279sub on_start_tls_notify { 378sub on_start_tls_notify {
280 my ($self) = @_; 379 my ($self) = @_;
281 380
282 $self->{hdl}->starttls (connect => $self->{tls_ctx}); 381 $self->{hdl}->starttls (connect => $self->{tls_ctx});
283 $self->{tls} ||= 1; 382 $self->{tls} ||= 1;
284 383
285 $self->_login; 384 $self->_login;
286} 385}
287 386
387sub on_start_cbor_notify {
388 my ($self) = @_;
389
390 $self->{rframe} = "cbor";
391}
392
288sub on_hello_notify { 393sub on_hello_notify {
289 my ($self, $version, $auths, $nonce) = @_; 394 my ($self, $version, $features, $nonce) = @_;
290 395
291 $version == 1 396 $version == 1
292 or return $self->error ("protocol mismatch, got $version, expected/supported 1"); 397 or return $self->error ("protocol mismatch, got $version, expected/supported 1");
293 398
294 $nonce = MIME::Base64::decode_base64 $nonce; 399 $nonce = MIME::Base64::decode_base64 $nonce;
295 400
296 $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 }
297 418
298 $self->_login 419 $self->_login
299 unless $self->{tls}; # delay login when trying to handshake tls 420 unless $self->{tls}; # delay login when trying to handshake tls
300} 421}
301 422
… …
309} 430}
310 431
311sub _login { 432sub _login {
312 my ($self) = @_; 433 my ($self) = @_;
313 434
314 my ($auths, $nonce) = @{ delete $self->{hello} or return }; 435 my ($features, $nonce) = @{ $self->{hello} or return };
315 436
316 if (grep $_ eq "none", @$auths) { 437 if (grep $_ eq "none", @$features) {
317 $self->_login_success ("none"); 438 $self->_login_success ("none");
318 439 } elsif (grep $_ eq "login_cram_sha3", @$features and eval 'require Digest::SHA3; require Digest::HMAC') {
319 } elsif (grep $_ eq "login_cram_md6", @$auths) {
320 my $cc = join "", map chr 256 * rand, 0..63; 440 my $cc = join "", map chr 256 * rand, 0..63;
321 441
322 my $key = Digest::HMAC_MD6::hmac_md6 $self->{pass}, $self->{user}, 64, 256; 442 my $hmac_sha3 = sub ($$){ # $key, $text
323 my $cr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256; 443 Digest::HMAC::hmac ($_[1], $_[0], \&Digest::SHA3::sha3_512, 72)
324 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");
325 449
326 $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;
327 473
328 $self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub { 474 $self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub {
329 my ($self, $ok, $msg) = @_; 475 my ($self, $ok, $msg) = @_;
330 476
331 $ok 477 $ok
332 or return call $self, on_login_failure => $msg; 478 or return call $self, on_login_failure => $msg;
333 479
334 $msg eq $sr 480 (MIME::Base64::decode_base64 $msg) eq $sr
335 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";
336 482
337 $self->_login_success ("login_cram_md6"); 483 $self->_login_success ("login_cram_md6");
338 }); 484 });
339 } elsif (grep $_ eq "login", @$auths) { 485 } elsif (grep $_ eq "login", @$features) {
340 $self->_req (login => $self->{user}, $self->{pass}, sub { 486 $self->_req (login => $self->{user}, $self->{pass}, sub {
341 my ($self, $ok, $msg) = @_; 487 my ($self, $ok, $msg) = @_;
342 488
343 $ok 489 $ok
344 or return call $self, on_login_failure => $msg; 490 or return call $self, on_login_failure => $msg;
345 491
346 $self->_login_success ("login"); 492 $self->_login_success ("login");
347 }); 493 });
348 } else { 494 } else {
349 call $self, on_login_failure => "no supported auth method (@$auths)"; 495 call $self, on_login_failure => "no supported auth method (@$features)";
350 } 496 }
351 497
352 # 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
353 delete $self->{user}; 499 delete $self->{user};
354 delete $self->{pass}; 500 delete $self->{pass};
… …
379 525
380 $msg =~ s/\n$//; 526 $msg =~ s/\n$//;
381 $self->error ("login failed: $msg"); 527 $self->error ("login failed: $msg");
382} 528}
383 529
530sub on_event_notify {
531 my ($self, $event, @args) = @_;
532
533 call $self, "on_${event}_event", @args;
534}
535
384=back 536=back
385 537
386=head2 EVENTS 538=head1 EVENTS/CALLBACKS
387 539
388AnyEvent::Porttracker conenctions are fully event-driven, and naturally 540AnyEvent::Porttracker connections are fully event-driven, and naturally
389there 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
390starting with C<on_> (example: C<on_login_failure>). 542starting with C<on_> (example: C<on_login_failure>).
391 543
392Programs can catch these events in two ways: either by providing 544Programs can catch these events in two ways: either by providing
393constructor 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:
394 546
395 my $api = new AnyEvent::Porttracker 547 my $api = new AnyEvent::Porttracker
396 host => ..., 548 host => ...,
397 user => ..., pass => ..., 549 user => ..., pass => ...,
398 on_error => sub { 550 on_error => sub {
… …
400 warn $msg; 552 warn $msg;
401 exit 1; 553 exit 1;
402 }, 554 },
403 ; 555 ;
404 556
405Or by subclassing C<AnyEvent::Porttracker> and overriding methods of the 557Or by sub-classing C<AnyEvent::Porttracker> and overriding methods of the
406same name: 558same name:
407 559
408 package MyClass; 560 package MyClass;
409 561
410 use base AnyEvent::Porttracker; 562 use base AnyEvent::Porttracker;
… …
439=item on_login_failure $api, $msg 591=item on_login_failure $api, $msg
440 592
441Called when all login attempts have failed - the default raises a fatal 593Called when all login attempts have failed - the default raises a fatal
442error with the error message from the server. 594error with the error message from the server.
443 595
444=item on_hello_notify $api, $version, $authtypes, $nonce 596=item on_hello_notify $api, $version, $features, $nonce
445 597
446This protocol notification is used internally by AnyEvent::Porttracker - 598This protocol notification is used internally by AnyEvent::Porttracker -
447you can override it, but the module will most likely not work. 599you can override it, but the module will most likely not work.
448 600
449=item on_info_notify $api, $msg 601=item on_info_notify $api, $msg
… …
458 610
459=item on_start_tls_notify $api 611=item on_start_tls_notify $api
460 612
461Called when the server wants to start TLS negotiation. This is used 613Called when the server wants to start TLS negotiation. This is used
462internally and - while it is possible to override it - should not be 614internally and - while it is possible to override it - should not be
463overriden. 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.
621
622=item on_event_notify $api, $eventname, @args
623
624Called when the server broadcasts an event the API object is subscribed
625to. The default implementation (which should not be overridden) simply
626re-issues an "on_eventname_event" event with the @args.
464 627
465=item on_XYZ_notify $api, ... 628=item on_XYZ_notify $api, ...
466 629
467In general, any protocol notification will result in an event of the form 630In general, any protocol notification will result in an event of the form
468C<on_NOTIFICATION_notify>. 631C<on_NOTIFICATION_notify>.
469 632
633=item on_XYZ_event $api, ...
634
635Called when the server broadcasts the named (XYZ) event.
636
470=back 637=back
471 638
472=head1 SEE ALSO 639=head1 SEE ALSO
473 640
474L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>. 641L<AnyEvent>, L<http://www.porttracker.com/>.
475 642
476=head1 AUTHOR 643=head1 AUTHOR
477 644
478 Marc Lehmann <marc@porttracker.net> 645 Marc Lehmann <marc@nethype.de>
479 646
480=cut 647=cut
481 648
4821 6491

Diff Legend

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