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.1 by root, Mon Nov 15 04:39:36 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
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
78To quickly understand how this module works you should read how to
79construct a new connection object and then read about the event/callback
80system.
81
82The actual low-level protocol and, more importantly, the existing
83requests and responses, are documented in the official Porttracker
84API documentation (a copy of which is included in this module as
85L<AnyEvent::Porttracker::protocol>.
86
26=head1 THE AnyEvent::Porttracker CLASS 87=head1 THE AnyEvent::Porttracker CLASS
27 88
89The AnyEvent::Porttracker class represents a single connection.
90
28=over 4 91=over 4
29 92
30=cut 93=cut
31 94
32package AnyEvent::Porttracker; 95package AnyEvent::Porttracker;
33 96
34use common::sense; 97use common::sense;
35 98
99use Carp ();
36use Scalar::Util (); 100use Scalar::Util ();
37 101
38use AnyEvent (); 102use AnyEvent ();
39use AnyEvent::Handle (); 103use AnyEvent::Handle ();
40 104
41use MIME::Base64 (); 105use MIME::Base64 ();
42use Digest::HMAC_MD6 ();
43use JSON ();
44 106
45our $VERSION = '0.0'; 107our $VERSION = 1.02;
46 108
47sub call { 109sub call {
48 my ($self, $type, @args) = @_; 110 my ($self, $type, @args) = @_;
49 111
50 $self->{$type} 112 $self->{$type}
51 ? $self->{$type}($self, @args) 113 ? $self->{$type}($self, @args)
52 : $type = (UNIVERSAL::can $self, $type) 114 : ($type = (UNIVERSAL::can $self, $type))
53 ? $type->($self, @args) 115 ? $type->($self, @args)
54 : () 116 : ()
55} 117}
56 118
57=item new AnyEvent::Porttracker 119=item $api = new AnyEvent::Porttracker [key => value...]
120
121Creates a new porttracker API connection object and tries to connect
122to the specified host (see below). After the connection has been
123established, the TLS handshake (if requested) will take place, followed
124by a login attempt using either the C<none>, C<login_cram_sha3>,
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
127man-in-the-middle attacks and avoids transferring the password).
128
129It is permissible to send requests immediately after creating the object -
130they will be queued until after successful login.
131
132Possible key-value pairs are:
133
134=over 4
135
136=item host => $hostname [MANDATORY]
137
138The hostname or IP address of the Porttracker box.
139
140=item port => $service
141
142The service (port) to use (default: C<porttracker=55>).
143
144=item user => $string, pass => $string
145
146These are the username and password to use when authentication is required
147(which it is in almost all cases, so these keys are normally mandatory).
148
149=item tls => $bool
150
151Enables or disables TLS (default: disables). When enabled, then the
152connection will try to handshake a TLS connection before logging in. If
153unsuccessful a fatal error will be raised.
154
155Since most Porttracker boxes will not have a sensible/verifiable
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
158verification you need to provide your own C<tls_ctx> object with C<<
159verify => 1, verify_peername => [1, 1, 1] >> or whatever verification mode
160you wish to use.
161
162=item tls_ctx => $tls_ctx
163
164The L<AnyEvent::TLS> object to use. See C<tls>, above.
165
166=item on_XYZ => $coderef
167
168You can specify event callbacks either by sub-classing and overriding the
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
171the C<event> method.
172
173=back
58 174
59=cut 175=cut
60 176
61sub new { 177sub new {
62 my $class = shift; 178 my $class = shift;
63 179
64 my $self = bless { 180 my $self = bless {
65 id => "a",
66 @_, 181 @_,
182 id => "a",
183 ids => [],
184 rframe => "json",
185 wframe => "json",
186 queue => [], # initially queue everything
67 }, $class; 187 }, $class;
68 188
69 { 189 {
70 Scalar::Util::weaken (my $self = $self); 190 Scalar::Util::weaken (my $self = $self);
71 191
72 $self->{hdl} = new AnyEvent::Handle 192 $self->{hdl} = new AnyEvent::Handle
73 connect => [$self->{host}, $self->{port} || "porttracker=55"], 193 connect => [$self->{host}, $self->{port} || "porttracker=55"],
74 on_error => sub { 194 on_error => sub {
75 $self->error (); 195 $self->error ($_[2]);
76 }, 196 },
77 on_read => sub { 197 on_connect => sub {
78 while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) { 198 if ($self->{tls}) {
79 my $msg = JSON::decode_json $1; 199 $self->_req (start_tls => sub {
80 my $id = shift @$msg; 200 $_[1]
201 or return $self->error ("TLS rejected by server");
81 202
82 if (defined $id) { 203 $self->_login;
83 my $cb = delete $self->{cb}{$id}
84 or return $self->error ("received unexpected reply msg with id $id");
85
86 $cb->($self, @$msg);
87 } else {
88 $msg->[0] = "on_$msg->[0]_notify";
89 call $self, @$msg;
90 } 204 });
91 } 205 }
92 }, 206 },
93 ; 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});
94 } 229 }
95 230
96 $self 231 $self
97} 232}
98 233
… …
104} 239}
105 240
106sub error { 241sub error {
107 my ($self, $msg) = @_; 242 my ($self, $msg) = @_;
108 243
109 warn $msg; 244 call $self, on_error => $msg;
110 245
111 () 246 ()
112} 247}
113 248
114sub send { 249sub _req {
115 my $self = shift; 250 my $self = shift;
116 my $cb = pop; 251 my $cb = pop;
117 252
118 my $id = ++$self->{id}; 253 my $id = (pop @{ $self->{ids} }) || $self->{id}++;
119 254
120 unshift @_, $id; 255 unshift @_, $id;
121 $self->{cb}{$id} = $cb; 256 $self->{cb}{$id} = $cb;
122 257
123 my $msg = JSON::encode_json \@_;
124
125 $self->{hdl}->push_write ($msg); 258 $self->{hdl}->push_write ($self->{wframe} => \@_);
259}
260
261=item $api->req ($type => @args, $callback->($api, @reply))
262
263Sends a generic request of type C<$type> to the server. When the server
264responds, the API object and the response arguments (without the success
265status) are passed to the callback, which is the last argument to this
266method.
267
268If the request fails, then a fatal error will be raised. If you want to
269handle failures gracefully, you need to use C<< ->req_failok >> instead.
270
271The available requests are documented in the Porttracker API
272documentation (a copy of which is included in this module as
273L<AnyEvent::Porttracker::protocol>.
274
275It is permissible to call this (or any other request function) at any
276time, even before the connection has been established - the API object
277always waits until after login before it actually sends the requests, and
278queues them until then.
279
280Example: ping the porttracker server.
281
282 $api->req ("ping", sub {
283 my ($api, $ok, $timestamp, $pid) = @_;
284 ...
285 });
286
287Example: determine the product ID.
288
289 $api->req (product_id => sub {
290 my ($api, $ok, $branding, $product_id) = @_;
291 ...
292 });
293
294Example: set a new license.
295
296 $api->req (set_license => $LICENSE_STRING, sub {
297 my ($api, $ok) = @_;
298
299 $ok or die "failed to set license";
300 });
301
302=cut
303
304sub req {
305 my $cb = pop;
306 push @_, sub {
307 splice @_, 1, 1
308 or $_[0]->error ($_[1]);
309
310 &$cb
311 };
312
313 $_[0]{queue}
314 ? push @{ $_[0]{queue} }, [@_]
315 : &_req
316}
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
338=item $api->req_failok ($type => @args, $callback->($api, $success, @reply))
339
340Just like C<< ->req >>, with two differences: first, a failure will not
341raise an error, second, the initial status reply which indicates success
342or failure is not removed before calling the callback.
343
344=cut
345
346sub req_failok {
347 $_[0]{queue}
348 ? push @{ $_[0]{queue} }, [@_]
349 : &_req
350}
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
378sub on_start_tls_notify {
379 my ($self) = @_;
380
381 $self->{hdl}->starttls (connect => $self->{tls_ctx});
382 $self->{tls} ||= 1;
383
384 $self->_login;
385}
386
387sub on_start_cbor_notify {
388 my ($self) = @_;
389
390 $self->{rframe} = "cbor";
126} 391}
127 392
128sub on_hello_notify { 393sub on_hello_notify {
129 my ($self, $version, $auths, $nonce) = @_; 394 my ($self, $version, $features, $nonce) = @_;
130 395
131 $version == 1 396 $version == 1
132 or return $self->error ("protocol mismatch, got $version, expected/supported 1"); 397 or return $self->error ("protocol mismatch, got $version, expected/supported 1");
133 398
134 $nonce = MIME::Base64::decode_base64 $nonce; 399 $nonce = MIME::Base64::decode_base64 $nonce;
135 400
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 }
418
419 $self->_login
420 unless $self->{tls}; # delay login when trying to handshake tls
421}
422
423sub _login_success {
424 my ($self, $method) = @_;
425
426 _req @$_
427 for @{ delete $self->{queue} };
428
429 call $self, on_login => $method;
430}
431
432sub _login {
433 my ($self) = @_;
434
435 my ($features, $nonce) = @{ $self->{hello} or return };
436
136 if (grep $_ eq "none", @$auths) { 437 if (grep $_ eq "none", @$features) {
137 # successfully authenticated... 438 $self->_login_success ("none");
138 } elsif (grep $_ eq "login_cram_md6", @$auths) { 439 } elsif (grep $_ eq "login_cram_sha3", @$features and eval 'require Digest::SHA3; require Digest::HMAC') {
139 my $cc = join "", map chr 256 * rand, 0..63; 440 my $cc = join "", map chr 256 * rand, 0..63;
140 441
141 my $key = Digest::HMAC_MD6::hmac_md6 $self->{password}, $self->{username}, 64, 256; 442 my $hmac_sha3 = sub ($$){ # $key, $text
142 my $cr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256; 443 Digest::HMAC::hmac ($_[1], $_[0], \&Digest::SHA3::sha3_512, 72)
143 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");
144 449
145 $cc = MIME::Base64::encode_base64 $cc; 450 $cc = MIME::Base64::encode_base64 $cc;
451 $cr = MIME::Base64::encode_base64 $cr;
146 452
147 $self->send (login_cram_md6 => $self->{username}, $cr, $cc, sub { 453 $self->_req (login_cram_sha3 => $self->{user}, $cr, $cc, sub {
148 my ($self, $ok, $msg) = @_; 454 my ($self, $ok, $msg) = @_;
149 455
150 $ok 456 $ok
151 or return call $self, on_login_failure => $msg; 457 or return call $self, on_login_failure => $msg;
152 458
153 $msg eq $sr 459 (MIME::Base64::decode_base64 $msg) eq $sr
154 or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack"; 460 or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";
155 461
156 call $self, "on_login" 462 $self->_login_success ("login_cram_sha3");
157 }); 463 });
158 } elsif (grep $_ eq "login", @$auths) { 464 } elsif (grep $_ eq "login_cram_md6", @$features and eval 'require Digest::HMAC_MD6') {
159 $self->send (login => $self->{username}, $self->{password}, sub { 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;
473
474 $self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub {
160 my ($self, $ok, $msg) = @_; 475 my ($self, $ok, $msg) = @_;
161 476
162 $ok 477 $ok
163 or return call $self, on_login_failure => $msg; 478 or return call $self, on_login_failure => $msg;
164 479
165 call $self, "on_login" 480 (MIME::Base64::decode_base64 $msg) eq $sr
481 or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";
482
483 $self->_login_success ("login_cram_md6");
484 });
485 } elsif (grep $_ eq "login", @$features) {
486 $self->_req (login => $self->{user}, $self->{pass}, sub {
487 my ($self, $ok, $msg) = @_;
488
489 $ok
490 or return call $self, on_login_failure => $msg;
491
492 $self->_login_success ("login");
166 }); 493 });
167 } else { 494 } else {
168 return $self->error ("no supported auth method (@$auths)"); 495 call $self, on_login_failure => "no supported auth method (@$features)";
169 } 496 }
497
498 # we no longer need these, make it a bit harder to get them
499 delete $self->{user};
500 delete $self->{pass};
501}
502
503sub on_info_notify {
504 my ($self, $msg) = @_;
505
506 warn $msg;
507}
508
509sub on_error_notify {
510 my ($self, $msg) = @_;
511
512 $self->error ($msg);
513}
514
515sub on_error {
516 my ($self, $msg) = @_;
517
518 warn $msg;
519
520 %$self = ();
170} 521}
171 522
172sub on_login_failure { 523sub on_login_failure {
173 my ($self, $msg) = @_; 524 my ($self, $msg) = @_;
174 525
175 $msg =~ s/\n$//; 526 $msg =~ s/\n$//;
176 $self->error ("login failed: $msg"); 527 $self->error ("login failed: $msg");
177} 528}
178 529
530sub on_event_notify {
531 my ($self, $event, @args) = @_;
532
533 call $self, "on_${event}_event", @args;
534}
535
179=back 536=back
180 537
538=head1 EVENTS/CALLBACKS
539
540AnyEvent::Porttracker connections are fully event-driven, and naturally
541there are a number of events that can occur. All these events have a name
542starting with C<on_> (example: C<on_login_failure>).
543
544Programs can catch these events in two ways: either by providing
545constructor arguments with the event name as key and a code-ref as value:
546
547 my $api = new AnyEvent::Porttracker
548 host => ...,
549 user => ..., pass => ...,
550 on_error => sub {
551 my ($api, $msg) = @_;
552 warn $msg;
553 exit 1;
554 },
555 ;
556
557Or by sub-classing C<AnyEvent::Porttracker> and overriding methods of the
558same name:
559
560 package MyClass;
561
562 use base AnyEvent::Porttracker;
563
564 sub on_error {
565 my ($api, $msg) = @_;
566 warn $msg;
567 exit 1;
568 }
569
570Event callbacks are not expected to return anything and are always passed
571the API object as first argument. Some might have default implementations
572(for example, C<on_error>), others are ignored unless overriden.
573
574Description of individual events follow:
575
576=over 4
577
578=item on_error $api, $msg
579
580Is called for every (fatal) error, including C<error> notifies. The
581default prints the message and destroys the object, so it is highly
582advisable to override this event.
583
584=item on_login $api, $method
585
586Called after a successful login, after which commands can be send. It is
587permissible to send commands before a successful login: those will be
588queued and sent just before this event is invoked. C<$method> is the auth
589method that was used.
590
591=item on_login_failure $api, $msg
592
593Called when all login attempts have failed - the default raises a fatal
594error with the error message from the server.
595
596=item on_hello_notify $api, $version, $features, $nonce
597
598This protocol notification is used internally by AnyEvent::Porttracker -
599you can override it, but the module will most likely not work.
600
601=item on_info_notify $api, $msg
602
603Called for informational messages from the server - the default
604implementation calls C<warn> but otherwise ignores this notification.
605
606=item on_error_notify $api, $msg
607
608Called for fatal errors from the server - the default implementation calls
609C<warn> and destroys the API object.
610
611=item on_start_tls_notify $api
612
613Called when the server wants to start TLS negotiation. This is used
614internally and - while it is possible to override it - should not be
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.
627
628=item on_XYZ_notify $api, ...
629
630In general, any protocol notification will result in an event of the form
631C<on_NOTIFICATION_notify>.
632
633=item on_XYZ_event $api, ...
634
635Called when the server broadcasts the named (XYZ) event.
636
637=back
638
181=head1 SEE ALSO 639=head1 SEE ALSO
182 640
183L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>. 641L<AnyEvent>, L<http://www.porttracker.com/>.
184 642
185=head1 AUTHOR 643=head1 AUTHOR
186 644
187 Marc Lehmann <marc@porttracker.net> 645 Marc Lehmann <marc@nethype.de>
188 646
189=cut 647=cut
190 648
1911 6491

Diff Legend

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