ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cvsroot/AnyEvent-Porttracker/Porttracker.pm
Revision: 1.6
Committed: Tue Nov 16 01:10:50 2010 UTC (13 years, 7 months ago) by root
Branch: MAIN
Changes since 1.5: +48 -7 lines
Log Message:
*** empty log message ***

File Contents

# Content
1 =head1 NAME
2
3 AnyEvent::Porttracker - Porttracker/PortIQ API client interface.
4
5 =head1 SYNOPSIS
6
7 use AnyEvent::Porttracker;
8
9 =head1 DESCRIPTION
10
11 Porttracker (L<http://www.porttracker.com/>) is a product that (among
12 other things) scans switches and routers in a network and gives a coherent
13 view of which end devices are connected to which switch ports on which
14 switches and routers. It also offers a JSON-based client API, for which
15 this module is an implementation.
16
17 In addition to Porttracker, the PortIQ product is also supported, as it
18 uses the same protocol.
19
20 If you do not have access to either a Porttracker or PortIQ box then this
21 module will be of little value to you.
22
23 This module is an L<AnyEvent> user, you need to make sure that you use and
24 run a supported event loop.
25
26 To quickly understand how this module works you should read how to
27 construct a new connection object and then read about the event/callback
28 system.
29
30 The actual low-level protocol and, more importantly, the existing
31 requests and responses, are documented in the official Porttracker
32 API documentation (a copy of which is included in this module as
33 L<AnyEvent::Porttracker::protocol>.
34
35 =head1 THE AnyEvent::Porttracker CLASS
36
37 The AnyEvent::Porttracker class represents a single connection.
38
39 =over 4
40
41 =cut
42
43 package AnyEvent::Porttracker;
44
45 use common::sense;
46
47 use Scalar::Util ();
48
49 use AnyEvent ();
50 use AnyEvent::Handle ();
51
52 use MIME::Base64 ();
53 use Digest::HMAC_MD6 ();
54 use JSON ();
55
56 our $VERSION = '0.0';
57
58 sub call {
59 my ($self, $type, @args) = @_;
60
61 $self->{$type}
62 ? $self->{$type}($self, @args)
63 : ($type = (UNIVERSAL::can $self, $type))
64 ? $type->($self, @args)
65 : ()
66 }
67
68 =item $api = new AnyEvent::Porttracker [key => value...]
69
70 Creates a new porttracker API connection object and tries to connect to
71 the specified host (see below). After the connection has been established,
72 the TLS handshake (if requested) will take place, followed by a login
73 attempt using either the C<none>, C<login_cram_md6> or C<login> methods,
74 in this order of preference (typically, C<login_cram_md6> is used, which
75 shields against some man-in-the-middle attacks and avoids transferring the
76 password).
77
78 It is permissible to send requests immediately after creating the object -
79 they will be queued until after successful login.
80
81 Possible key-value pairs are:
82
83 =over 4
84
85 =item host => $hostname [MANDATORY]
86
87 The hostname or IP address of the Porttracker box.
88
89 =item port => $service
90
91 The service (port) to use (default: C<porttracker=55>).
92
93 =item user => $string, pass => $string
94
95 These are the username and password to use when authentication is required
96 (which it is in almost all cases, so these keys are normally mandatory).
97
98 =item tls => $bool
99
100 Enables or disables TLS (default: disables). When enabled, then the
101 connection will try to handshake a TLS connection before logging in. If
102 unsuccessful a fatal error will be raised.
103
104 Since most Porttracker/PortIQ boxes will not have a sensible/verifiable
105 certificate, no attempt at verifying it will be done (which means
106 man-in-the-middle-attacks will be trivial). If you want some form of
107 verification you need to provide your own C<tls_ctx> object with C<<
108 verify => 1, verify_peername => [1, 1, 1] >> or whatever verification mode
109 you wish to use.
110
111 =item tls_ctx => $tls_ctx
112
113 The L<AnyEvent::TLS> object to use.
114
115 #TODO#
116
117 =item on_XYZ => $coderef
118
119 You can specify event callbacks either by subclassing and overriding the
120 respective methods or by specifying coderefs as key-value pairs when
121 constructing the object.
122
123 =back
124
125 =cut
126
127 sub new {
128 my $class = shift;
129
130 my $self = bless {
131 id => "a",
132 ids => [],
133 queue => [], # ininitially queue everything
134 @_,
135 }, $class;
136
137 {
138 Scalar::Util::weaken (my $self = $self);
139
140 $self->{hdl} = new AnyEvent::Handle
141 connect => [$self->{host}, $self->{port} || "porttracker=55"],
142 on_error => sub {
143 $self->error ($_[2]);
144 },
145 on_connect => sub {
146 if ($self->{tls}) {
147 $self->_req (start_tls => sub {
148 $_[1]
149 or return $self->error ("TLS rejected by server");
150
151 $self->_login;
152 });
153 }
154 },
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 ;
174 }
175
176 $self
177 }
178
179 sub DESTROY {
180 my ($self) = @_;
181
182 $self->{hdl}->destroy
183 if $self->{hdl};
184 }
185
186 sub error {
187 my ($self, $msg) = @_;
188
189 call $self, on_error => $msg;
190
191 ()
192 }
193
194 sub _req {
195 my $self = shift;
196 my $cb = pop;
197
198 my $id = (pop @{ $self->{ids} }) || $self->{id}++;
199
200 unshift @_, $id;
201 $self->{cb}{$id} = $cb;
202
203 my $msg = JSON::encode_json \@_;
204
205 $self->{hdl}->push_write ($msg);
206 }
207
208 =item $api->req ($type => @args, $callback->($api, @reply))
209
210 Sends a generic request of type C<$type> to the server. When the server
211 responds, the API object and the response arguments (without the success
212 status) are passed to the callback, which is the last argument to this
213 method.
214
215 If the request fails, then a fatal error will be raised. If you want to
216 handle failures gracefully, you need to use C<< ->req_failok >> instead.
217
218 The available requests are documented in the Porttracker API
219 documentation (a copy of which is included in this module as
220 L<AnyEvent::Porttracker::protocol>.
221
222 It is permissible to call this (or any other request function) at any
223 time, even before the connection has been established - the API object
224 always waits until after login before it actually sends the requests, and
225 queues them until then.
226
227 Example: ping the porttracker server.
228
229 $api->req ("ping", sub {
230 my ($api, $ok, $timestamp, $pid) = @_;
231 ...
232 });
233
234 Example: determine the product ID.
235
236 $api->req (product_id => sub {
237 my ($api, $ok, $branding, $product_id) = @_;
238 ...
239 });
240
241 Example: set a new license.
242
243 $api->req (set_license => $LICENSE_STRING, sub {
244 my ($api, $ok) = @_;
245
246 $ok or die "failed to set license";
247 });
248
249 =cut
250
251 sub req {
252 my $cb = pop;
253 push @_, sub {
254 shift
255 or $_[0]->error ($_[1]);
256
257 &$cb
258 };
259
260 $_[0]{queue}
261 ? push @{ $_[0]{queue} }, [@_]
262 : &_req
263 }
264
265 =item $api->req_failok ($type => @args, $callback->($api, $success, @reply))
266
267 Just like C<< ->req >>, with two differences: first, a failure will not
268 raise an error, second, the initial status reply which indicates success
269 or failure is not removed before calling the callback.
270
271 =cut
272
273 sub req_failok {
274 $_[0]{queue}
275 ? push @{ $_[0]{queue} }, [@_]
276 : &_req
277 }
278
279 sub on_start_tls_notify {
280 my ($self) = @_;
281
282 $self->{hdl}->starttls (connect => $self->{tls_ctx});
283 $self->{tls} ||= 1;
284
285 $self->_login;
286 }
287
288 sub on_hello_notify {
289 my ($self, $version, $auths, $nonce) = @_;
290
291 $version == 1
292 or return $self->error ("protocol mismatch, got $version, expected/supported 1");
293
294 $nonce = MIME::Base64::decode_base64 $nonce;
295
296 $self->{hello} = [$auths, $nonce];
297
298 $self->_login
299 unless $self->{tls}; # delay login when trying to handshake tls
300 }
301
302 sub _login_success {
303 my ($self, $method) = @_;
304
305 _req @$_
306 for @{ delete $self->{queue} };
307
308 call $self, on_login => $method;
309 }
310
311 sub _login {
312 my ($self) = @_;
313
314 my ($auths, $nonce) = @{ delete $self->{hello} or return };
315
316 if (grep $_ eq "none", @$auths) {
317 $self->_login_success ("none");
318
319 } elsif (grep $_ eq "login_cram_md6", @$auths) {
320 my $cc = join "", map chr 256 * rand, 0..63;
321
322 my $key = Digest::HMAC_MD6::hmac_md6 $self->{pass}, $self->{user}, 64, 256;
323 my $cr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256;
324 my $sr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$nonce$cc", 64, 256;
325
326 $cc = MIME::Base64::encode_base64 $cc;
327
328 $self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub {
329 my ($self, $ok, $msg) = @_;
330
331 $ok
332 or return call $self, on_login_failure => $msg;
333
334 $msg eq $sr
335 or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";
336
337 $self->_login_success ("login_cram_md6");
338 });
339 } elsif (grep $_ eq "login", @$auths) {
340 $self->_req (login => $self->{user}, $self->{pass}, sub {
341 my ($self, $ok, $msg) = @_;
342
343 $ok
344 or return call $self, on_login_failure => $msg;
345
346 $self->_login_success ("login");
347 });
348 } else {
349 call $self, on_login_failure => "no supported auth method (@$auths)";
350 }
351
352 # we no longer need these, make it a bit harder to get them
353 delete $self->{user};
354 delete $self->{pass};
355 }
356
357 sub on_info_notify {
358 my ($self, $msg) = @_;
359
360 warn $msg;
361 }
362
363 sub on_error_notify {
364 my ($self, $msg) = @_;
365
366 $self->error ($msg);
367 }
368
369 sub on_error {
370 my ($self, $msg) = @_;
371
372 warn $msg;
373
374 %$self = ();
375 }
376
377 sub on_login_failure {
378 my ($self, $msg) = @_;
379
380 $msg =~ s/\n$//;
381 $self->error ("login failed: $msg");
382 }
383
384 =back
385
386 =head2 EVENTS
387
388 AnyEvent::Porttracker conenctions are fully event-driven, and naturally
389 there are a number of events that can occur. All these events have a name
390 starting with C<on_> (example: C<on_login_failure>).
391
392 Programs can catch these events in two ways: either by providing
393 constructor arguments with the event name as key and a coderef as value:
394
395 my $api = new AnyEvent::Porttracker
396 host => ...,
397 user => ..., pass => ...,
398 on_error => sub {
399 my ($api, $msg) = @_;
400 warn $msg;
401 exit 1;
402 },
403 ;
404
405 Or by subclassing C<AnyEvent::Porttracker> and overriding methods of the
406 same name:
407
408 package MyClass;
409
410 use base AnyEvent::Porttracker;
411
412 sub on_error {
413 my ($api, $msg) = @_;
414 warn $msg;
415 exit 1;
416 }
417
418 Event callbacks are not expected to return anything and are always passed
419 the API object as first argument. Some might have default implementations
420 (for example, C<on_error>), others are ignored unless overriden.
421
422 Description of individual events follow:
423
424 =over 4
425
426 =item on_error $api, $msg
427
428 Is called for every (fatal) error, including C<error> notifies. The
429 default prints the message and destroys the object, so it is highly
430 advisable to override this event.
431
432 =item on_login $api, $method
433
434 Called after a successful login, after which commands can be send. It is
435 permissible to send commands before a successful login: those will be
436 queued and sent just before this event is invoked. C<$method> is the auth
437 method that was used.
438
439 =item on_login_failure $api, $msg
440
441 Called when all login attempts have failed - the default raises a fatal
442 error with the error message from the server.
443
444 =item on_hello_notify $api, $version, $authtypes, $nonce
445
446 This protocol notification is used internally by AnyEvent::Porttracker -
447 you can override it, but the module will most likely not work.
448
449 =item on_info_notify $api, $msg
450
451 Called for informational messages from the server - the default
452 implementation calls C<warn> but otherwise ignores this notification.
453
454 =item on_error_notify $api, $msg
455
456 Called for fatal errors from the server - the default implementation calls
457 C<warn> and destroys the API object.
458
459 =item on_start_tls_notify $api
460
461 Called when the server wants to start TLS negotiation. This is used
462 internally and - while it is possible to override it - should not be
463 overriden.
464
465 =item on_XYZ_notify $api, ...
466
467 In general, any protocol notification will result in an event of the form
468 C<on_NOTIFICATION_notify>.
469
470 =back
471
472 =head1 SEE ALSO
473
474 L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>.
475
476 =head1 AUTHOR
477
478 Marc Lehmann <marc@porttracker.net>
479
480 =cut
481
482 1