ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent-Porttracker/Porttracker.pm
Revision: 1.21
Committed: Sat May 30 05:41:02 2020 UTC (4 years ago) by root
Branch: MAIN
CVS Tags: HEAD
Changes since 1.20: +1 -1 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
107 our $VERSION = 1.02;
108
109 sub call {
110 my ($self, $type, @args) = @_;
111
112 $self->{$type}
113 ? $self->{$type}($self, @args)
114 : ($type = (UNIVERSAL::can $self, $type))
115 ? $type->($self, @args)
116 : ()
117 }
118
119 =item $api = new AnyEvent::Porttracker [key => value...]
120
121 Creates a new porttracker API connection object and tries to connect
122 to the specified host (see below). After the connection has been
123 established, the TLS handshake (if requested) will take place, followed
124 by a login attempt using either the C<none>, C<login_cram_sha3>,
125 C<login_cram_md6> or C<login> methods, in this order of preference
126 (typically, C<login_cram_sha3> is used, which shields against some
127 man-in-the-middle attacks and avoids transferring the password).
128
129 It is permissible to send requests immediately after creating the object -
130 they will be queued until after successful login.
131
132 Possible key-value pairs are:
133
134 =over 4
135
136 =item host => $hostname [MANDATORY]
137
138 The hostname or IP address of the Porttracker box.
139
140 =item port => $service
141
142 The service (port) to use (default: C<porttracker=55>).
143
144 =item user => $string, pass => $string
145
146 These 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
151 Enables or disables TLS (default: disables). When enabled, then the
152 connection will try to handshake a TLS connection before logging in. If
153 unsuccessful a fatal error will be raised.
154
155 Since most Porttracker boxes will not have a sensible/verifiable
156 certificate, no attempt at verifying it will be done (which means
157 man-in-the-middle-attacks will be trivial). If you want some form of
158 verification you need to provide your own C<tls_ctx> object with C<<
159 verify => 1, verify_peername => [1, 1, 1] >> or whatever verification mode
160 you wish to use.
161
162 =item tls_ctx => $tls_ctx
163
164 The L<AnyEvent::TLS> object to use. See C<tls>, above.
165
166 =item on_XYZ => $coderef
167
168 You can specify event callbacks either by sub-classing and overriding the
169 respective methods or by specifying code-refs as key-value pairs when
170 constructing the object. You add or remove event handlers at any time with
171 the C<event> method.
172
173 =back
174
175 =cut
176
177 sub new {
178 my $class = shift;
179
180 my $self = bless {
181 @_,
182 id => "a",
183 ids => [],
184 rframe => "json",
185 wframe => "json",
186 queue => [], # initially queue everything
187 }, $class;
188
189 {
190 Scalar::Util::weaken (my $self = $self);
191
192 $self->{hdl} = new AnyEvent::Handle
193 connect => [$self->{host}, $self->{port} || "porttracker=55"],
194 on_error => sub {
195 $self->error ($_[2]);
196 },
197 on_connect => sub {
198 if ($self->{tls}) {
199 $self->_req (start_tls => sub {
200 $_[1]
201 or return $self->error ("TLS rejected by server");
202
203 $self->_login;
204 });
205 }
206 },
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});
229 }
230
231 $self
232 }
233
234 sub DESTROY {
235 my ($self) = @_;
236
237 $self->{hdl}->destroy
238 if $self->{hdl};
239 }
240
241 sub error {
242 my ($self, $msg) = @_;
243
244 call $self, on_error => $msg;
245
246 ()
247 }
248
249 sub _req {
250 my $self = shift;
251 my $cb = pop;
252
253 my $id = (pop @{ $self->{ids} }) || $self->{id}++;
254
255 unshift @_, $id;
256 $self->{cb}{$id} = $cb;
257
258 $self->{hdl}->push_write ($self->{wframe} => \@_);
259 }
260
261 =item $api->req ($type => @args, $callback->($api, @reply))
262
263 Sends a generic request of type C<$type> to the server. When the server
264 responds, the API object and the response arguments (without the success
265 status) are passed to the callback, which is the last argument to this
266 method.
267
268 If the request fails, then a fatal error will be raised. If you want to
269 handle failures gracefully, you need to use C<< ->req_failok >> instead.
270
271 The available requests are documented in the Porttracker API
272 documentation (a copy of which is included in this module as
273 L<AnyEvent::Porttracker::protocol>.
274
275 It is permissible to call this (or any other request function) at any
276 time, even before the connection has been established - the API object
277 always waits until after login before it actually sends the requests, and
278 queues them until then.
279
280 Example: ping the porttracker server.
281
282 $api->req ("ping", sub {
283 my ($api, $ok, $timestamp, $pid) = @_;
284 ...
285 });
286
287 Example: determine the product ID.
288
289 $api->req (product_id => sub {
290 my ($api, $ok, $branding, $product_id) = @_;
291 ...
292 });
293
294 Example: 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
304 sub 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
320 Similar to C<< ->req >>, but waits for the results of the request and on
321 success, returns the values instead (without the success flag, and only
322 the first value in scalar context). On failure, the method will C<croak>
323 with the error message.
324
325 =cut
326
327 sub 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
340 Just like C<< ->req >>, with two differences: first, a failure will not
341 raise an error, second, the initial status reply which indicates success
342 or failure is not removed before calling the callback.
343
344 =cut
345
346 sub req_failok {
347 $_[0]{queue}
348 ? push @{ $_[0]{queue} }, [@_]
349 : &_req
350 }
351
352 =item $api->on (XYZ => $callback)
353
354 Overwrites any currently registered handler for C<on_XYZ> or
355 installs a new one. Or, when C<$callback> is undef, unregisters any
356 currently-registered handler.
357
358 Example: 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
367 sub 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
378 sub 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
387 sub on_start_cbor_notify {
388 my ($self) = @_;
389
390 $self->{rframe} = "cbor";
391 }
392
393 sub on_hello_notify {
394 my ($self, $version, $features, $nonce) = @_;
395
396 $version == 1
397 or return $self->error ("protocol mismatch, got $version, expected/supported 1");
398
399 $nonce = MIME::Base64::decode_base64 $nonce;
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
423 sub _login_success {
424 my ($self, $method) = @_;
425
426 _req @$_
427 for @{ delete $self->{queue} };
428
429 call $self, on_login => $method;
430 }
431
432 sub _login {
433 my ($self) = @_;
434
435 my ($features, $nonce) = @{ $self->{hello} or return };
436
437 if (grep $_ eq "none", @$features) {
438 $self->_login_success ("none");
439 } elsif (grep $_ eq "login_cram_sha3", @$features and eval 'require Digest::SHA3; require Digest::HMAC') {
440 my $cc = join "", map chr 256 * rand, 0..63;
441
442 my $hmac_sha3 = sub ($$){ # $key, $text
443 Digest::HMAC::hmac ($_[1], $_[0], \&Digest::SHA3::sha3_512, 72)
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");
449
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;
473
474 $self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub {
475 my ($self, $ok, $msg) = @_;
476
477 $ok
478 or return call $self, on_login_failure => $msg;
479
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");
493 });
494 } else {
495 call $self, on_login_failure => "no supported auth method (@$features)";
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
503 sub on_info_notify {
504 my ($self, $msg) = @_;
505
506 warn $msg;
507 }
508
509 sub on_error_notify {
510 my ($self, $msg) = @_;
511
512 $self->error ($msg);
513 }
514
515 sub on_error {
516 my ($self, $msg) = @_;
517
518 warn $msg;
519
520 %$self = ();
521 }
522
523 sub on_login_failure {
524 my ($self, $msg) = @_;
525
526 $msg =~ s/\n$//;
527 $self->error ("login failed: $msg");
528 }
529
530 sub on_event_notify {
531 my ($self, $event, @args) = @_;
532
533 call $self, "on_${event}_event", @args;
534 }
535
536 =back
537
538 =head1 EVENTS/CALLBACKS
539
540 AnyEvent::Porttracker connections are fully event-driven, and naturally
541 there are a number of events that can occur. All these events have a name
542 starting with C<on_> (example: C<on_login_failure>).
543
544 Programs can catch these events in two ways: either by providing
545 constructor 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
557 Or by sub-classing C<AnyEvent::Porttracker> and overriding methods of the
558 same 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
570 Event callbacks are not expected to return anything and are always passed
571 the API object as first argument. Some might have default implementations
572 (for example, C<on_error>), others are ignored unless overriden.
573
574 Description of individual events follow:
575
576 =over 4
577
578 =item on_error $api, $msg
579
580 Is called for every (fatal) error, including C<error> notifies. The
581 default prints the message and destroys the object, so it is highly
582 advisable to override this event.
583
584 =item on_login $api, $method
585
586 Called after a successful login, after which commands can be send. It is
587 permissible to send commands before a successful login: those will be
588 queued and sent just before this event is invoked. C<$method> is the auth
589 method that was used.
590
591 =item on_login_failure $api, $msg
592
593 Called when all login attempts have failed - the default raises a fatal
594 error with the error message from the server.
595
596 =item on_hello_notify $api, $version, $features, $nonce
597
598 This protocol notification is used internally by AnyEvent::Porttracker -
599 you can override it, but the module will most likely not work.
600
601 =item on_info_notify $api, $msg
602
603 Called for informational messages from the server - the default
604 implementation calls C<warn> but otherwise ignores this notification.
605
606 =item on_error_notify $api, $msg
607
608 Called for fatal errors from the server - the default implementation calls
609 C<warn> and destroys the API object.
610
611 =item on_start_tls_notify $api
612
613 Called when the server wants to start TLS negotiation. This is used
614 internally and - while it is possible to override it - should not be
615 overridden.
616
617 =item on_start_cbor_notify $api
618
619 Called when the server switched to CBOR framing. This is used internally
620 and - while it is possible to override it - should not be overridden.
621
622 =item on_event_notify $api, $eventname, @args
623
624 Called when the server broadcasts an event the API object is subscribed
625 to. The default implementation (which should not be overridden) simply
626 re-issues an "on_eventname_event" event with the @args.
627
628 =item on_XYZ_notify $api, ...
629
630 In general, any protocol notification will result in an event of the form
631 C<on_NOTIFICATION_notify>.
632
633 =item on_XYZ_event $api, ...
634
635 Called when the server broadcasts the named (XYZ) event.
636
637 =back
638
639 =head1 SEE ALSO
640
641 L<AnyEvent>, L<http://www.porttracker.com/>.
642
643 =head1 AUTHOR
644
645 Marc Lehmann <marc@nethype.de>
646
647 =cut
648
649 1