ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/cvsroot/AnyEvent-Porttracker/Porttracker.pm
Revision: 1.19
Committed: Tue Jul 26 16:12:46 2016 UTC (7 years, 11 months ago) by root
Branch: MAIN
Changes since 1.18: +43 -13 lines
Log Message:
*** empty log message ***

File Contents

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