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.3 by root, Mon Nov 15 19:49: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
26To quickly understand how this module works you should read how to 78To quickly understand how this module works you should read how to
27construct a new connection object and then read about the event/callback 79construct a new connection object and then read about the event/callback
28system. 80system.
29 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
30=head1 THE AnyEvent::Porttracker CLASS 87=head1 THE AnyEvent::Porttracker CLASS
31 88
32The AnyEvent::Porttracker class represents a single connection. 89The AnyEvent::Porttracker class represents a single connection.
33 90
34=over 4 91=over 4
… …
37 94
38package AnyEvent::Porttracker; 95package AnyEvent::Porttracker;
39 96
40use common::sense; 97use common::sense;
41 98
99use Carp ();
42use Scalar::Util (); 100use Scalar::Util ();
43 101
44use AnyEvent (); 102use AnyEvent ();
45use AnyEvent::Handle (); 103use AnyEvent::Handle ();
46 104
47use MIME::Base64 (); 105use MIME::Base64 ();
48use Digest::HMAC_MD6 ();
49use JSON ();
50 106
51our $VERSION = '0.0'; 107our $VERSION = 1.02;
52 108
53sub call { 109sub call {
54 my ($self, $type, @args) = @_; 110 my ($self, $type, @args) = @_;
55 111
56 $self->{$type} 112 $self->{$type}
… …
58 : ($type = (UNIVERSAL::can $self, $type)) 114 : ($type = (UNIVERSAL::can $self, $type))
59 ? $type->($self, @args) 115 ? $type->($self, @args)
60 : () 116 : ()
61} 117}
62 118
63=item new AnyEvent::Porttracker [key => value...] 119=item $api = new AnyEvent::Porttracker [key => value...]
64 120
65Creates a new porttracker API connection object and tries to connect to 121Creates a new porttracker API connection object and tries to connect
66the specified host (see below). After the connection has been established, 122to the specified host (see below). After the connection has been
67the TLS handshake (if requested) will take place, followed by a login 123established, the TLS handshake (if requested) will take place, followed
68attempt 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>,
69in 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
70shields against some man-in-the-middle attacks and avoids transferring the 127man-in-the-middle attacks and avoids transferring the password).
71password).
72 128
73It is permissible to send requests immediately after creating the object - 129It is permissible to send requests immediately after creating the object -
74they will be queued until after successful login. 130they will be queued until after successful login.
75 131
76Possible key-value pairs are: 132Possible key-value pairs are:
… …
88=item user => $string, pass => $string 144=item user => $string, pass => $string
89 145
90These are the username and password to use when authentication is required 146These are the username and password to use when authentication is required
91(which it is in almost all cases, so these keys are normally mandatory). 147(which it is in almost all cases, so these keys are normally mandatory).
92 148
93=item tls => ... 149=item tls => $bool
94 150
95#TODO# 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.
96 165
97=item on_XYZ => $coderef 166=item on_XYZ => $coderef
98 167
99You can specify event callbacks either by subclassing and overriding the 168You can specify event callbacks either by sub-classing and overriding the
100respective methods or by specifying coderefs as key-value pairs when 169respective methods or by specifying code-refs as key-value pairs when
101constructing the object. 170constructing the object. You add or remove event handlers at any time with
171the C<event> method.
102 172
103=back 173=back
104 174
105=cut 175=cut
106 176
107sub new { 177sub new {
108 my $class = shift; 178 my $class = shift;
109 179
110 my $self = bless { 180 my $self = bless {
111 id => "a",
112 queue => [], # ininitially queue everything
113 @_, 181 @_,
182 id => "a",
183 ids => [],
184 rframe => "json",
185 wframe => "json",
186 queue => [], # initially queue everything
114 }, $class; 187 }, $class;
115 188
116 { 189 {
117 Scalar::Util::weaken (my $self = $self); 190 Scalar::Util::weaken (my $self = $self);
118 191
119 $self->{hdl} = new AnyEvent::Handle 192 $self->{hdl} = new AnyEvent::Handle
120 connect => [$self->{host}, $self->{port} || "porttracker=55"], 193 connect => [$self->{host}, $self->{port} || "porttracker=55"],
121 on_error => sub { 194 on_error => sub {
122 $self->error (); 195 $self->error ($_[2]);
123 }, 196 },
124 on_connect => sub { 197 on_connect => sub {
125 if ($self->{tls}) { 198 if ($self->{tls}) {
126 $self->_req (start_tls => sub { 199 $self->_req (start_tls => sub {
127 $_[1] 200 $_[1]
… …
129 202
130 $self->_login; 203 $self->_login;
131 }); 204 });
132 } 205 }
133 }, 206 },
134 on_read => sub {
135 while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {
136 my $msg = JSON::decode_json $1;
137 my $id = shift @$msg;
138
139 if (defined $id) {
140 my $cb = delete $self->{cb}{$id}
141 or return $self->error ("received unexpected reply msg with id $id");
142
143 $cb->($self, @$msg);
144 } else {
145 $msg->[0] = "on_$msg->[0]_notify";
146 call $self, @$msg;
147 }
148 }
149 },
150 ; 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});
151 } 229 }
152 230
153 $self 231 $self
154} 232}
155 233
… …
161} 239}
162 240
163sub error { 241sub error {
164 my ($self, $msg) = @_; 242 my ($self, $msg) = @_;
165 243
166 call on_error => $msg; 244 call $self, on_error => $msg;
167 245
168 () 246 ()
169} 247}
170 248
171sub _req { 249sub _req {
172 my $self = shift; 250 my $self = shift;
173 my $cb = pop; 251 my $cb = pop;
174 252
175 my $id = ++$self->{id}; 253 my $id = (pop @{ $self->{ids} }) || $self->{id}++;
176 254
177 unshift @_, $id; 255 unshift @_, $id;
178 $self->{cb}{$id} = $cb; 256 $self->{cb}{$id} = $cb;
179 257
180 my $msg = JSON::encode_json \@_;
181
182 $self->{hdl}->push_write ($msg); 258 $self->{hdl}->push_write ($self->{wframe} => \@_);
183} 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
184 303
185sub req { 304sub req {
305 my $cb = pop;
306 push @_, sub {
307 splice @_, 1, 1
308 or $_[0]->error ($_[1]);
309
310 &$cb
311 };
312
186 $_[0]{queue} 313 $_[0]{queue}
187 ? push @{ $_[0]{queue} }, [@_] 314 ? push @{ $_[0]{queue} }, [@_]
188 : &_req 315 : &_req
189} 316}
190 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
191sub on_start_tls_notify { 378sub on_start_tls_notify {
192 my ($self) = @_; 379 my ($self) = @_;
193 380
194 $self->{hdl}->starttls ("connect"); 381 $self->{hdl}->starttls (connect => $self->{tls_ctx});
195 $self->{tls} ||= 1; 382 $self->{tls} ||= 1;
196 383
197 $self->_login; 384 $self->_login;
198} 385}
199 386
387sub on_start_cbor_notify {
388 my ($self) = @_;
389
390 $self->{rframe} = "cbor";
391}
392
200sub on_hello_notify { 393sub on_hello_notify {
201 my ($self, $version, $auths, $nonce) = @_; 394 my ($self, $version, $features, $nonce) = @_;
202 395
203 $version == 1 396 $version == 1
204 or return $self->error ("protocol mismatch, got $version, expected/supported 1"); 397 or return $self->error ("protocol mismatch, got $version, expected/supported 1");
205 398
206 $nonce = MIME::Base64::decode_base64 $nonce; 399 $nonce = MIME::Base64::decode_base64 $nonce;
207 400
208 $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 }
209 418
210 $self->_login 419 $self->_login
211 unless $self->{tls}; # delay login when trying to handshake tls 420 unless $self->{tls}; # delay login when trying to handshake tls
212} 421}
213 422
… …
221} 430}
222 431
223sub _login { 432sub _login {
224 my ($self) = @_; 433 my ($self) = @_;
225 434
226 my ($auths, $nonce) = @{ delete $self->{hello} or return }; 435 my ($features, $nonce) = @{ $self->{hello} or return };
227 436
228 if (grep $_ eq "none", @$auths) { 437 if (grep $_ eq "none", @$features) {
229 $self->_login_success ("none"); 438 $self->_login_success ("none");
230 439 } elsif (grep $_ eq "login_cram_sha3", @$features and eval 'require Digest::SHA3; require Digest::HMAC') {
231 } elsif (grep $_ eq "login_cram_md6", @$auths) {
232 my $cc = join "", map chr 256 * rand, 0..63; 440 my $cc = join "", map chr 256 * rand, 0..63;
233 441
234 my $key = Digest::HMAC_MD6::hmac_md6 $self->{pass}, $self->{user}, 64, 256; 442 my $hmac_sha3 = sub ($$){ # $key, $text
235 my $cr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256; 443 Digest::HMAC::hmac ($_[1], $_[0], \&Digest::SHA3::sha3_512, 72)
236 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");
237 449
238 $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;
239 473
240 $self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub { 474 $self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub {
241 my ($self, $ok, $msg) = @_; 475 my ($self, $ok, $msg) = @_;
242 476
243 $ok 477 $ok
244 or return call $self, on_login_failure => $msg; 478 or return call $self, on_login_failure => $msg;
245 479
246 $msg eq $sr 480 (MIME::Base64::decode_base64 $msg) eq $sr
247 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";
248 482
249 $self->_login_success ("login_cram_md6"); 483 $self->_login_success ("login_cram_md6");
250 }); 484 });
251 } elsif (grep $_ eq "login", @$auths) { 485 } elsif (grep $_ eq "login", @$features) {
252 $self->_req (login => $self->{user}, $self->{pass}, sub { 486 $self->_req (login => $self->{user}, $self->{pass}, sub {
253 my ($self, $ok, $msg) = @_; 487 my ($self, $ok, $msg) = @_;
254 488
255 $ok 489 $ok
256 or return call $self, on_login_failure => $msg; 490 or return call $self, on_login_failure => $msg;
257 491
258 $self->_login_success ("login"); 492 $self->_login_success ("login");
259 }); 493 });
260 } else { 494 } else {
261 call $self, on_login_failure => "no supported auth method (@$auths)"; 495 call $self, on_login_failure => "no supported auth method (@$features)";
262 } 496 }
263 497
264 # 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
265 delete $self->{user}; 499 delete $self->{user};
266 delete $self->{pass}; 500 delete $self->{pass};
… …
291 525
292 $msg =~ s/\n$//; 526 $msg =~ s/\n$//;
293 $self->error ("login failed: $msg"); 527 $self->error ("login failed: $msg");
294} 528}
295 529
530sub on_event_notify {
531 my ($self, $event, @args) = @_;
532
533 call $self, "on_${event}_event", @args;
534}
535
296=back 536=back
297 537
298=head2 EVENTS 538=head1 EVENTS/CALLBACKS
299 539
300AnyEvent::Porttracker conenctions are fully event-driven, and naturally 540AnyEvent::Porttracker connections are fully event-driven, and naturally
301there 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
302starting with C<on_> (example: C<on_login_failure>). 542starting with C<on_> (example: C<on_login_failure>).
303 543
304Programs can catch these events in two ways: either by providing 544Programs can catch these events in two ways: either by providing
305constructor 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:
306 546
307 my $api = new AnyEvent::Porttracker 547 my $api = new AnyEvent::Porttracker
308 host => ..., 548 host => ...,
309 user => ..., pass => ..., 549 user => ..., pass => ...,
310 on_error => sub { 550 on_error => sub {
… …
312 warn $msg; 552 warn $msg;
313 exit 1; 553 exit 1;
314 }, 554 },
315 ; 555 ;
316 556
317Or by subclassing C<AnyEvent::Porttracker> and overriding methods of the 557Or by sub-classing C<AnyEvent::Porttracker> and overriding methods of the
318same name: 558same name:
319 559
320 package MyClass; 560 package MyClass;
321 561
322 use base AnyEvent::Porttracker; 562 use base AnyEvent::Porttracker;
… …
351=item on_login_failure $api, $msg 591=item on_login_failure $api, $msg
352 592
353Called when all login attempts have failed - the default raises a fatal 593Called when all login attempts have failed - the default raises a fatal
354error with the error message from the server. 594error with the error message from the server.
355 595
356=item on_hello_notify $api, $version, $authtypes, $nonce 596=item on_hello_notify $api, $version, $features, $nonce
357 597
358This protocol notification is used internally by AnyEvent::Porttracker - 598This protocol notification is used internally by AnyEvent::Porttracker -
359you can override it, but the module will most likely not work. 599you can override it, but the module will most likely not work.
360 600
361=item on_info_notify $api, $msg 601=item on_info_notify $api, $msg
… …
370 610
371=item on_start_tls_notify $api 611=item on_start_tls_notify $api
372 612
373Called when the server wants to start TLS negotiation. This is used 613Called when the server wants to start TLS negotiation. This is used
374internally and - while it is possible to override it - should not be 614internally and - while it is possible to override it - should not be
375overriden. 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.
376 627
377=item on_XYZ_notify $api, ... 628=item on_XYZ_notify $api, ...
378 629
379In 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
380C<on_NOTIFICATION_notify>. 631C<on_NOTIFICATION_notify>.
381 632
633=item on_XYZ_event $api, ...
634
635Called when the server broadcasts the named (XYZ) event.
636
382=back 637=back
383 638
384=head1 SEE ALSO 639=head1 SEE ALSO
385 640
386L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>. 641L<AnyEvent>, L<http://www.porttracker.com/>.
387 642
388=head1 AUTHOR 643=head1 AUTHOR
389 644
390 Marc Lehmann <marc@porttracker.net> 645 Marc Lehmann <marc@nethype.de>
391 646
392=cut 647=cut
393 648
3941 6491

Diff Legend

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