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.2 by root, Mon Nov 15 04:57:39 2010 UTC vs.
Revision 1.18 by root, Wed Jan 7 01:41:33 2015 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 (); 106use Digest::HMAC_MD6 ();
43use JSON (); 107use JSON ();
44 108
45our $VERSION = '0.0'; 109our $VERSION = '1.01';
46 110
47sub call { 111sub call {
48 my ($self, $type, @args) = @_; 112 my ($self, $type, @args) = @_;
49 113
50 $self->{$type} 114 $self->{$type}
… …
52 : ($type = (UNIVERSAL::can $self, $type)) 116 : ($type = (UNIVERSAL::can $self, $type))
53 ? $type->($self, @args) 117 ? $type->($self, @args)
54 : () 118 : ()
55} 119}
56 120
57=item new AnyEvent::Porttracker 121=item $api = new AnyEvent::Porttracker [key => value...]
122
123Creates a new porttracker API connection object and tries to connect to
124the specified host (see below). After the connection has been established,
125the TLS handshake (if requested) will take place, followed by a login
126attempt using either the C<none>, C<login_cram_md6> or C<login> methods,
127in this order of preference (typically, C<login_cram_md6> is used, which
128shields against some man-in-the-middle attacks and avoids transferring the
129password).
130
131It is permissible to send requests immediately after creating the object -
132they will be queued until after successful login.
133
134Possible key-value pairs are:
135
136=over 4
137
138=item host => $hostname [MANDATORY]
139
140The hostname or IP address of the Porttracker box.
141
142=item port => $service
143
144The service (port) to use (default: C<porttracker=55>).
145
146=item user => $string, pass => $string
147
148These are the username and password to use when authentication is required
149(which it is in almost all cases, so these keys are normally mandatory).
150
151=item tls => $bool
152
153Enables or disables TLS (default: disables). When enabled, then the
154connection will try to handshake a TLS connection before logging in. If
155unsuccessful a fatal error will be raised.
156
157Since most Porttracker boxes will not have a sensible/verifiable
158certificate, no attempt at verifying it will be done (which means
159man-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<<
161verify => 1, verify_peername => [1, 1, 1] >> or whatever verification mode
162you wish to use.
163
164=item tls_ctx => $tls_ctx
165
166The L<AnyEvent::TLS> object to use. See C<tls>, above.
167
168=item on_XYZ => $coderef
169
170You can specify event callbacks either by sub-classing and overriding the
171respective methods or by specifying code-refs as key-value pairs when
172constructing the object. You add or remove event handlers at any time with
173the C<event> method.
174
175=back
58 176
59=cut 177=cut
60 178
61sub new { 179sub new {
62 my $class = shift; 180 my $class = shift;
63 181
64 my $self = bless { 182 my $self = bless {
65 id => "a", 183 id => "a",
184 ids => [],
185 queue => [], # initially queue everything
66 @_, 186 @_,
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_connect => sub { 197 on_connect => sub {
78 if ($self->{tls}) { 198 if ($self->{tls}) {
79 $self->{queue} ||= [];
80 $self->_req (start_tls => sub { 199 $self->_req (start_tls => sub {
81 $_[1] 200 $_[1]
82 or return $self->error ("TLS rejected by server"); 201 or return $self->error ("TLS rejected by server");
83 202
84 $self->unqueue; 203 $self->_login;
85 }); 204 });
86 } 205 }
87 }, 206 },
88 on_read => sub { 207 on_read => sub {
89 while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) { 208 while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {
… …
91 my $id = shift @$msg; 210 my $id = shift @$msg;
92 211
93 if (defined $id) { 212 if (defined $id) {
94 my $cb = delete $self->{cb}{$id} 213 my $cb = delete $self->{cb}{$id}
95 or return $self->error ("received unexpected reply msg with id $id"); 214 or return $self->error ("received unexpected reply msg with id $id");
215
216 push @{ $self->{ids} }, $id;
96 217
97 $cb->($self, @$msg); 218 $cb->($self, @$msg);
98 } else { 219 } else {
99 $msg->[0] = "on_$msg->[0]_notify"; 220 $msg->[0] = "on_$msg->[0]_notify";
100 call $self, @$msg; 221 call $self, @$msg;
… …
115} 236}
116 237
117sub error { 238sub error {
118 my ($self, $msg) = @_; 239 my ($self, $msg) = @_;
119 240
120 warn $msg; 241 call $self, on_error => $msg;
121 242
122 () 243 ()
123} 244}
124 245
125sub _req { 246sub _req {
126 my $self = shift; 247 my $self = shift;
127 my $cb = pop; 248 my $cb = pop;
128 249
129 my $id = ++$self->{id}; 250 my $id = (pop @{ $self->{ids} }) || $self->{id}++;
130 251
131 unshift @_, $id; 252 unshift @_, $id;
132 $self->{cb}{$id} = $cb; 253 $self->{cb}{$id} = $cb;
133 254
134 my $msg = JSON::encode_json \@_; 255 my $msg = JSON::encode_json \@_;
135 256
136 $self->{hdl}->push_write ($msg); 257 $self->{hdl}->push_write ($msg);
137} 258}
138 259
260=item $api->req ($type => @args, $callback->($api, @reply))
261
262Sends a generic request of type C<$type> to the server. When the server
263responds, the API object and the response arguments (without the success
264status) are passed to the callback, which is the last argument to this
265method.
266
267If the request fails, then a fatal error will be raised. If you want to
268handle failures gracefully, you need to use C<< ->req_failok >> instead.
269
270The available requests are documented in the Porttracker API
271documentation (a copy of which is included in this module as
272L<AnyEvent::Porttracker::protocol>.
273
274It is permissible to call this (or any other request function) at any
275time, even before the connection has been established - the API object
276always waits until after login before it actually sends the requests, and
277queues them until then.
278
279Example: ping the porttracker server.
280
281 $api->req ("ping", sub {
282 my ($api, $ok, $timestamp, $pid) = @_;
283 ...
284 });
285
286Example: determine the product ID.
287
288 $api->req (product_id => sub {
289 my ($api, $ok, $branding, $product_id) = @_;
290 ...
291 });
292
293Example: set a new license.
294
295 $api->req (set_license => $LICENSE_STRING, sub {
296 my ($api, $ok) = @_;
297
298 $ok or die "failed to set license";
299 });
300
301=cut
302
139sub req { 303sub req {
304 my $cb = pop;
305 push @_, sub {
306 splice @_, 1, 1
307 or $_[0]->error ($_[1]);
308
309 &$cb
310 };
311
140 $_[0]{queue} 312 $_[0]{queue}
141 ? push @{ $_[0]{queue} }, [@_] 313 ? push @{ $_[0]{queue} }, [@_]
142 : &_req 314 : &_req
143} 315}
144 316
145sub unqueue { 317=item @res = $api->req_sync ($type => @args)
318
319Similar to C<< ->req >>, but waits for the results of the request and on
320success, returns the values instead (without the success flag, and only
321the first value in scalar context). On failure, the method will C<croak>
322with the error message.
323
324=cut
325
326sub req_sync {
327 push @_, my $cv = AE::cv;
328 &req;
329 my ($ok, @res) = $cv->recv;
330
331 $ok
332 or Carp::croak $res[0];
333
334 wantarray ? @res : $res[0]
335}
336
337=item $api->req_failok ($type => @args, $callback->($api, $success, @reply))
338
339Just like C<< ->req >>, with two differences: first, a failure will not
340raise an error, second, the initial status reply which indicates success
341or failure is not removed before calling the callback.
342
343=cut
344
345sub req_failok {
346 $_[0]{queue}
347 ? push @{ $_[0]{queue} }, [@_]
348 : &_req
349}
350
351=item $api->on (XYZ => $callback)
352
353Overwrites any currently registered handler for C<on_XYZ> or
354installs a new one. Or, when C<$callback> is undef, unregisters any
355currently-registered handler.
356
357Example: replace/set the handler for C<on_discover_stop_event>.
358
359 $api->on (discover_stop_event => sub {
360 my ($api, $gid) = @_;
361 ...
362 });
363
364=cut
365
366sub on {
146 my ($self) = @_; 367 my $self = shift;
147 368
148 my $queue = delete $self->{queue} 369 while (@_) {
149 or return; 370 my ($event, $cb) = splice @_, 0, 2;
371 $event =~ s/^on_//;
150 372
151 _req @$_ 373 $self->{"on_$event"} = $cb;
152 for @$queue; 374 }
153} 375}
154 376
155sub on_start_tls_notify { 377sub on_start_tls_notify {
156 my ($self) = @_; 378 my ($self) = @_;
157 379
158 $self->{hdl}->starttls ("connect"); 380 $self->{hdl}->starttls (connect => $self->{tls_ctx});
381 $self->{tls} ||= 1;
159 382
160 $self->unqueue; 383 $self->_login;
161} 384}
162 385
163sub on_hello_notify { 386sub on_hello_notify {
164 my ($self, $version, $auths, $nonce) = @_; 387 my ($self, $version, $auths, $nonce) = @_;
165 388
166 $version == 1 389 $version == 1
167 or return $self->error ("protocol mismatch, got $version, expected/supported 1"); 390 or return $self->error ("protocol mismatch, got $version, expected/supported 1");
168 391
169 $nonce = MIME::Base64::decode_base64 $nonce; 392 $nonce = MIME::Base64::decode_base64 $nonce;
170 393
394 $self->{hello} = [$auths, $nonce];
395
396 $self->_login
397 unless $self->{tls}; # delay login when trying to handshake tls
398}
399
400sub _login_success {
401 my ($self, $method) = @_;
402
403 _req @$_
404 for @{ delete $self->{queue} };
405
406 call $self, on_login => $method;
407}
408
409sub _login {
410 my ($self) = @_;
411
412 my ($auths, $nonce) = @{ delete $self->{hello} or return };
413
171 if (grep $_ eq "none", @$auths) { 414 if (grep $_ eq "none", @$auths) {
172 call $self, "on_login"; 415 $self->_login_success ("none");
173 416
174 } elsif (grep $_ eq "login_cram_md6", @$auths) { 417 } elsif (grep $_ eq "login_cram_md6", @$auths) {
175 my $cc = join "", map chr 256 * rand, 0..63; 418 my $cc = join "", map chr 256 * rand, 0..63;
176 419
177 my $key = Digest::HMAC_MD6::hmac_md6 $self->{password}, $self->{username}, 64, 256; 420 my $key = Digest::HMAC_MD6::hmac_md6 $self->{pass}, $self->{user}, 64, 256;
178 my $cr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256; 421 my $cr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256;
179 my $sr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$nonce$cc", 64, 256; 422 my $sr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$nonce$cc", 64, 256;
180 423
181 $cc = MIME::Base64::encode_base64 $cc; 424 $cc = MIME::Base64::encode_base64 $cc;
182 425
183 $self->req (login_cram_md6 => $self->{username}, $cr, $cc, sub { 426 $self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub {
184 my ($self, $ok, $msg) = @_; 427 my ($self, $ok, $msg) = @_;
185 428
186 $ok 429 $ok
187 or return call $self, on_login_failure => $msg; 430 or return call $self, on_login_failure => $msg;
188 431
189 $msg eq $sr 432 $msg eq $sr
190 or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack"; 433 or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";
191 434
192 call $self, "on_login"; 435 $self->_login_success ("login_cram_md6");
193 }); 436 });
194 } elsif (grep $_ eq "login", @$auths) { 437 } elsif (grep $_ eq "login", @$auths) {
195 $self->req (login => $self->{username}, $self->{password}, sub { 438 $self->_req (login => $self->{user}, $self->{pass}, sub {
196 my ($self, $ok, $msg) = @_; 439 my ($self, $ok, $msg) = @_;
197 440
198 $ok 441 $ok
199 or return call $self, on_login_failure => $msg; 442 or return call $self, on_login_failure => $msg;
200 443
201 call $self, "on_login"; 444 $self->_login_success ("login");
202 }); 445 });
203 } else { 446 } else {
204 call $self, on_login_failure => "no supported auth method (@$auths)"; 447 call $self, on_login_failure => "no supported auth method (@$auths)";
205 } 448 }
449
450 # we no longer need these, make it a bit harder to get them
451 delete $self->{user};
452 delete $self->{pass};
453}
454
455sub on_info_notify {
456 my ($self, $msg) = @_;
457
458 warn $msg;
459}
460
461sub on_error_notify {
462 my ($self, $msg) = @_;
463
464 $self->error ($msg);
465}
466
467sub on_error {
468 my ($self, $msg) = @_;
469
470 warn $msg;
471
472 %$self = ();
206} 473}
207 474
208sub on_login_failure { 475sub on_login_failure {
209 my ($self, $msg) = @_; 476 my ($self, $msg) = @_;
210 477
211 $msg =~ s/\n$//; 478 $msg =~ s/\n$//;
212 $self->error ("login failed: $msg"); 479 $self->error ("login failed: $msg");
213} 480}
214 481
215sub on_error_notify { 482sub on_event_notify {
216 my ($self, $msg) = @_; 483 my ($self, $event, @args) = @_;
217 484
218 $self->error ($msg); 485 call $self, "on_${event}_event", @args;
219} 486}
220 487
221=back 488=back
222 489
490=head1 EVENTS/CALLBACKS
491
492AnyEvent::Porttracker connections are fully event-driven, and naturally
493there are a number of events that can occur. All these events have a name
494starting with C<on_> (example: C<on_login_failure>).
495
496Programs can catch these events in two ways: either by providing
497constructor arguments with the event name as key and a code-ref as value:
498
499 my $api = new AnyEvent::Porttracker
500 host => ...,
501 user => ..., pass => ...,
502 on_error => sub {
503 my ($api, $msg) = @_;
504 warn $msg;
505 exit 1;
506 },
507 ;
508
509Or by sub-classing C<AnyEvent::Porttracker> and overriding methods of the
510same name:
511
512 package MyClass;
513
514 use base AnyEvent::Porttracker;
515
516 sub on_error {
517 my ($api, $msg) = @_;
518 warn $msg;
519 exit 1;
520 }
521
522Event callbacks are not expected to return anything and are always passed
523the API object as first argument. Some might have default implementations
524(for example, C<on_error>), others are ignored unless overriden.
525
526Description of individual events follow:
527
528=over 4
529
530=item on_error $api, $msg
531
532Is called for every (fatal) error, including C<error> notifies. The
533default prints the message and destroys the object, so it is highly
534advisable to override this event.
535
536=item on_login $api, $method
537
538Called after a successful login, after which commands can be send. It is
539permissible to send commands before a successful login: those will be
540queued and sent just before this event is invoked. C<$method> is the auth
541method that was used.
542
543=item on_login_failure $api, $msg
544
545Called when all login attempts have failed - the default raises a fatal
546error with the error message from the server.
547
548=item on_hello_notify $api, $version, $authtypes, $nonce
549
550This protocol notification is used internally by AnyEvent::Porttracker -
551you can override it, but the module will most likely not work.
552
553=item on_info_notify $api, $msg
554
555Called for informational messages from the server - the default
556implementation calls C<warn> but otherwise ignores this notification.
557
558=item on_error_notify $api, $msg
559
560Called for fatal errors from the server - the default implementation calls
561C<warn> and destroys the API object.
562
563=item on_start_tls_notify $api
564
565Called when the server wants to start TLS negotiation. This is used
566internally and - while it is possible to override it - should not be
567overridden.
568
569=item on_event_notify $api, $eventname, @args
570
571Called when the server broadcasts an event the API object is subscribed
572to. The default implementation (which should not be overridden) simply
573re-issues an "on_eventname_event" event with the @args.
574
575=item on_XYZ_notify $api, ...
576
577In general, any protocol notification will result in an event of the form
578C<on_NOTIFICATION_notify>.
579
580=item on_XYZ_event $api, ...
581
582Called when the server broadcasts the named (XYZ) event.
583
584=back
585
223=head1 SEE ALSO 586=head1 SEE ALSO
224 587
225L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>. 588L<AnyEvent>, L<http://www.porttracker.com/>.
226 589
227=head1 AUTHOR 590=head1 AUTHOR
228 591
229 Marc Lehmann <marc@porttracker.net> 592 Marc Lehmann <marc@nethype.de>
230 593
231=cut 594=cut
232 595
2331 5961

Diff Legend

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