AnyEvent-Porttracker/Porttracker.pm

=head1 NAME

AnyEvent::Porttracker - Porttracker/PortIQ API client interface.

=head1 SYNOPSIS

   use AnyEvent::Porttracker;

=head1 DESCRIPTION

Porttracker (L<http://www.porttracker.com/>) is a product that (among
other things) scans switches and routers in a network and gives a coherent
view of which end devices are connected to which switch ports on which
switches and routers. It also offers a JSON-based client API, for which
this module is an implementation.

In addition to Porttracker, the PortIQ product is also supported, as it
uses the same protocol.

If you do not have access to either a Porttracker or PortIQ box then this
module will be of little value to you.

This module is an L<AnyEvent> user, you need to make sure that you use and
run a supported event loop.

To quickly understand how this module works you should read how to
construct a new connection object and then read about the event/callback
system.

The actual low-level protocol and, more importantly, the existing
requests and responses, are documented in the official Porttracker
API documentation (a copy of which is included in this module as
L<AnyEvent::Porttracker::protocol>.

=head1 THE AnyEvent::Porttracker CLASS

The AnyEvent::Porttracker class represents a single connection.

=over 4

=cut

package AnyEvent::Porttracker;

use common::sense;

use Scalar::Util ();

use AnyEvent ();
use AnyEvent::Handle ();

use MIME::Base64 ();
use Digest::HMAC_MD6 ();
use JSON ();

our $VERSION = '0.0';

sub call {
   my ($self, $type, @args) = @_;

   $self->{$type}
      ? $self->{$type}($self, @args)
      : ($type = (UNIVERSAL::can $self, $type))
         ? $type->($self, @args)
         : ()
}

=item $api = new AnyEvent::Porttracker [key => value...]

Creates a new porttracker API connection object and tries to connect to
the specified host (see below). After the connection has been established,
the TLS handshake (if requested) will take place, followed by a login
attempt using either the C<none>, C<login_cram_md6> or C<login> methods,
in this order of preference (typically, C<login_cram_md6> is used, which
shields against some man-in-the-middle attacks and avoids transferring the
password).

It is permissible to send requests immediately after creating the object -
they will be queued until after successful login.

Possible key-value pairs are:

=over 4

=item host => $hostname [MANDATORY]

The hostname or IP address of the Porttracker box.

=item port => $service

The service (port) to use (default: C<porttracker=55>).

=item user => $string, pass => $string

These are the username and password to use when authentication is required
(which it is in almost all cases, so these keys are normally mandatory).

=item tls => ...

#TODO#

=item on_XYZ => $coderef

You can specify event callbacks either by subclassing and overriding the
respective methods or by specifying coderefs as key-value pairs when
constructing the object.

=back

=cut

sub new {
   my $class = shift;

   my $self = bless {
      id    => "a",
      ids   => [],
      queue => [], # ininitially queue everything
      @_,
   }, $class;

   {
      Scalar::Util::weaken (my $self = $self);

      $self->{hdl} = new AnyEvent::Handle
         connect  => [$self->{host}, $self->{port} || "porttracker=55"],
         on_error => sub {
            $self->error ();
         },
         on_connect => sub {
            if ($self->{tls}) {
               $self->_req (start_tls => sub {
                  $_[1]
                     or return $self->error ("TLS rejected by server");

                  $self->_login;
               });
            }
         },
         on_read  => sub {
            while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {
               my $msg = JSON::decode_json $1;
               my $id = shift @$msg;

               if (defined $id) {
                  my $cb = delete $self->{cb}{$id}
                     or return $self->error ("received unexpected reply msg with id $id");

                  push @{ $self->{ids} }, $id;

                  $cb->($self, @$msg);
               } else {
                  $msg->[0] = "on_$msg->[0]_notify";
                  call $self, @$msg;
               }
            }
         },
      ;
   }

   $self
}

sub DESTROY {
   my ($self) = @_;

   $self->{hdl}->destroy
      if $self->{hdl};
}

sub error {
   my ($self, $msg) = @_;

   call on_error => $msg;

   ()
}

sub _req {
   my $self = shift;
   my $cb   = pop;

   my $id   = (pop @{ $self->{ids} }) || $self->{id}++;

   unshift @_, $id;
   $self->{cb}{$id} = $cb;

   my $msg = JSON::encode_json \@_;

   $self->{hdl}->push_write ($msg);
}

=item $api->req ($type => @args, $callback->($api, @args))

Sends a generic request of type C<$type> to the server. When the server
responds, the API object and the response arguments are passed to the
callback, which is the last argument to this method.

The available requests are documented in the Porttracker API
documentation (a copy of which is included in this module as
L<AnyEvent::Porttracker::protocol>.

It is permissible to call this (or any other request function) at any
time, even before the connection has been established - the API object
always waits until after login before it actually sends the requests, and
queues them until then.

Example: ping the porttracker server.

   $api->req ("ping", sub {
      my ($api, $ok, $timestamp, $pid) = @_;
      ...
   });

Example: determine the product ID.

   $api->req (product_id => sub {
      my ($api, $ok, $branding, $product_id) = @_;
      ...
   });

Example: set a new license.

   $api->req (set_license => $LICENSE_STRING, sub {
      my ($api, $ok) = @_;

      $ok or die "failed to set license";
   });

=cut

sub req {
   $_[0]{queue}
      ? push @{ $_[0]{queue} }, [@_]
      : &_req
}

sub on_start_tls_notify {
   my ($self) = @_;

   $self->{hdl}->starttls ("connect");
   $self->{tls} ||= 1;

   $self->_login;
}

sub on_hello_notify {
   my ($self, $version, $auths, $nonce) = @_;

   $version == 1
      or return $self->error ("protocol mismatch, got $version, expected/supported 1");

   $nonce = MIME::Base64::decode_base64 $nonce;

   $self->{hello} = [$auths, $nonce];

   $self->_login
      unless $self->{tls}; # delay login when trying to handshake tls
}

sub _login_success {
   my ($self, $method) = @_;

   _req @$_
      for @{ delete $self->{queue} };

   call $self, on_login => $method;
}

sub _login {
   my ($self) = @_;

   my ($auths, $nonce) = @{ delete $self->{hello} or return };

   if (grep $_ eq "none", @$auths) {
      $self->_login_success ("none");

   } elsif (grep $_ eq "login_cram_md6", @$auths) {
      my $cc = join "", map chr 256 * rand, 0..63;

      my $key = Digest::HMAC_MD6::hmac_md6 $self->{pass}, $self->{user}, 64, 256;
      my $cr  = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256;
      my $sr  = Digest::HMAC_MD6::hmac_md6_base64 $key, "$nonce$cc", 64, 256;

      $cc = MIME::Base64::encode_base64 $cc;

      $self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub {
         my ($self, $ok, $msg) = @_;

         $ok
            or return call $self, on_login_failure => $msg;

         $msg eq $sr
            or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";

         $self->_login_success ("login_cram_md6");
      });
   } elsif (grep $_ eq "login", @$auths) {
      $self->_req (login => $self->{user}, $self->{pass}, sub {
         my ($self, $ok, $msg) = @_;

         $ok
            or return call $self, on_login_failure => $msg;

         $self->_login_success ("login");
      });
   } else {
      call $self, on_login_failure => "no supported auth method (@$auths)";
   }

   # we no longer need these, make it a bit harder to get them
   delete $self->{user};
   delete $self->{pass};
}

sub on_info_notify {
   my ($self, $msg) = @_;

   warn $msg;
}

sub on_error_notify {
   my ($self, $msg) = @_;

   $self->error ($msg);
}

sub on_error {
   my ($self, $msg) = @_;

   warn $msg;

   %$self = ();
}

sub on_login_failure {
   my ($self, $msg) = @_;

   $msg =~ s/\n$//;
   $self->error ("login failed: $msg");
}

=back

=head2 EVENTS

AnyEvent::Porttracker conenctions are fully event-driven, and naturally
there are a number of events that can occur. All these events have a name
starting with C<on_> (example: C<on_login_failure>).

Programs can catch these events in two ways: either by providing
constructor arguments with the event name as key and a coderef as value:

   my $api = new AnyEvent::Porttracker
      host => ...,
      user => ..., pass => ...,
      on_error => sub {
         my ($api, $msg) = @_;
         warn $msg;
         exit 1;
      },
   ;

Or by subclassing C<AnyEvent::Porttracker> and overriding methods of the
same name:

   package MyClass;

   use base AnyEvent::Porttracker;

   sub on_error {
      my ($api, $msg) = @_;
      warn $msg;
      exit 1;
   }

Event callbacks are not expected to return anything and are always passed
the API object as first argument. Some might have default implementations
(for example, C<on_error>), others are ignored unless overriden.

Description of individual events follow:

=over 4

=item on_error $api, $msg

Is called for every (fatal) error, including C<error> notifies. The
default prints the message and destroys the object, so it is highly
advisable to override this event.

=item on_login $api, $method

Called after a successful login, after which commands can be send. It is
permissible to send commands before a successful login: those will be
queued and sent just before this event is invoked. C<$method> is the auth
method that was used.

=item on_login_failure $api, $msg

Called when all login attempts have failed - the default raises a fatal
error with the error message from the server.

=item on_hello_notify $api, $version, $authtypes, $nonce

This protocol notification is used internally by AnyEvent::Porttracker -
you can override it, but the module will most likely not work.

=item on_info_notify $api, $msg

Called for informational messages from the server - the default
implementation calls C<warn> but otherwise ignores this notification.

=item on_error_notify $api, $msg

Called for fatal errors from the server - the default implementation calls
C<warn> and destroys the API object.

=item on_start_tls_notify $api

Called when the server wants to start TLS negotiation. This is used
internally and - while it is possible to override it - should not be
overriden.

=item on_XYZ_notify $api, ...

In general, any protocol notification will result in an event of the form
C<on_NOTIFICATION_notify>.

=back

=head1 SEE ALSO

L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>.

=head1 AUTHOR

 Marc Lehmann <marc@porttracker.net>

=cut

1
Revision:	1.5
Committed:	Mon Nov 15 20:43:11 2010 UTC (13 years, 7 months ago) by root
Branch:	MAIN
Changes since 1.4:	+9 -0 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.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	root	1.3	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	root	1.5	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	root	1.1	=head1 THE AnyEvent::Porttracker CLASS
36
37	root	1.3	The AnyEvent::Porttracker class represents a single connection.
38
39	root	1.1	=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	root	1.2	: ($type = (UNIVERSAL::can $self, $type))
64	root	1.1	? $type->($self, @args)
65			: ()
66			}
67
68	root	1.4	=item $api = new AnyEvent::Porttracker [key => value...]
69	root	1.3
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 => ...
99
100			#TODO#
101
102			=item on_XYZ => $coderef
103
104			You can specify event callbacks either by subclassing and overriding the
105			respective methods or by specifying coderefs as key-value pairs when
106			constructing the object.
107
108			=back
109	root	1.1
110			=cut
111
112			sub new {
113			my $class = shift;
114
115			my $self = bless {
116	root	1.3	id => "a",
117	root	1.4	ids => [],
118	root	1.3	queue => [], # ininitially queue everything
119	root	1.1	@_,
120			}, $class;
121
122			{
123			Scalar::Util::weaken (my $self = $self);
124
125			$self->{hdl} = new AnyEvent::Handle
126			connect => [$self->{host}, $self->{port} \|\| "porttracker=55"],
127			on_error => sub {
128			$self->error ();
129			},
130	root	1.2	on_connect => sub {
131			if ($self->{tls}) {
132			$self->_req (start_tls => sub {
133			$_[1]
134			or return $self->error ("TLS rejected by server");
135
136	root	1.3	$self->_login;
137	root	1.2	});
138			}
139			},
140	root	1.1	on_read => sub {
141			while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {
142			my $msg = JSON::decode_json $1;
143			my $id = shift @$msg;
144
145			if (defined $id) {
146			my $cb = delete $self->{cb}{$id}
147			or return $self->error ("received unexpected reply msg with id $id");
148
149	root	1.4	push @{ $self->{ids} }, $id;
150
151	root	1.1	$cb->($self, @$msg);
152			} else {
153			$msg->[0] = "on_$msg->[0]_notify";
154			call $self, @$msg;
155			}
156			}
157			},
158			;
159			}
160
161			$self
162			}
163
164			sub DESTROY {
165			my ($self) = @_;
166
167			$self->{hdl}->destroy
168			if $self->{hdl};
169			}
170
171			sub error {
172			my ($self, $msg) = @_;
173
174	root	1.3	call on_error => $msg;
175	root	1.1
176			()
177			}
178
179	root	1.2	sub _req {
180	root	1.1	my $self = shift;
181			my $cb = pop;
182
183	root	1.4	my $id = (pop @{ $self->{ids} }) \|\| $self->{id}++;
184	root	1.1
185			unshift @_, $id;
186			$self->{cb}{$id} = $cb;
187
188			my $msg = JSON::encode_json \@_;
189
190			$self->{hdl}->push_write ($msg);
191			}
192
193	root	1.4	=item $api->req ($type => @args, $callback->($api, @args))
194
195			Sends a generic request of type C<$type> to the server. When the server
196			responds, the API object and the response arguments are passed to the
197			callback, which is the last argument to this method.
198
199	root	1.5	The available requests are documented in the Porttracker API
200			documentation (a copy of which is included in this module as
201			L<AnyEvent::Porttracker::protocol>.
202
203	root	1.4	It is permissible to call this (or any other request function) at any
204			time, even before the connection has been established - the API object
205			always waits until after login before it actually sends the requests, and
206			queues them until then.
207
208			Example: ping the porttracker server.
209
210			$api->req ("ping", sub {
211			my ($api, $ok, $timestamp, $pid) = @_;
212			...
213			});
214
215			Example: determine the product ID.
216
217			$api->req (product_id => sub {
218			my ($api, $ok, $branding, $product_id) = @_;
219			...
220			});
221
222			Example: set a new license.
223
224			$api->req (set_license => $LICENSE_STRING, sub {
225			my ($api, $ok) = @_;
226
227			$ok or die "failed to set license";
228			});
229
230			=cut
231
232	root	1.2	sub req {
233			$_[0]{queue}
234			? push @{ $_[0]{queue} }, [@_]
235			: &_req
236			}
237
238			sub on_start_tls_notify {
239			my ($self) = @_;
240
241			$self->{hdl}->starttls ("connect");
242	root	1.3	$self->{tls} \|\|= 1;
243	root	1.2
244	root	1.3	$self->_login;
245	root	1.2	}
246
247	root	1.1	sub on_hello_notify {
248			my ($self, $version, $auths, $nonce) = @_;
249
250			$version == 1
251			or return $self->error ("protocol mismatch, got $version, expected/supported 1");
252
253			$nonce = MIME::Base64::decode_base64 $nonce;
254
255	root	1.3	$self->{hello} = [$auths, $nonce];
256
257			$self->_login
258			unless $self->{tls}; # delay login when trying to handshake tls
259			}
260
261			sub _login_success {
262			my ($self, $method) = @_;
263
264			_req @$_
265			for @{ delete $self->{queue} };
266
267			call $self, on_login => $method;
268			}
269
270			sub _login {
271			my ($self) = @_;
272
273			my ($auths, $nonce) = @{ delete $self->{hello} or return };
274
275	root	1.1	if (grep $_ eq "none", @$auths) {
276	root	1.3	$self->_login_success ("none");
277	root	1.2
278	root	1.1	} elsif (grep $_ eq "login_cram_md6", @$auths) {
279			my $cc = join "", map chr 256 * rand, 0..63;
280
281	root	1.3	my $key = Digest::HMAC_MD6::hmac_md6 $self->{pass}, $self->{user}, 64, 256;
282	root	1.1	my $cr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256;
283			my $sr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$nonce$cc", 64, 256;
284
285			$cc = MIME::Base64::encode_base64 $cc;
286
287	root	1.3	$self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub {
288	root	1.1	my ($self, $ok, $msg) = @_;
289
290			$ok
291			or return call $self, on_login_failure => $msg;
292
293			$msg eq $sr
294			or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";
295
296	root	1.3	$self->_login_success ("login_cram_md6");
297	root	1.1	});
298			} elsif (grep $_ eq "login", @$auths) {
299	root	1.3	$self->_req (login => $self->{user}, $self->{pass}, sub {
300	root	1.1	my ($self, $ok, $msg) = @_;
301
302			$ok
303			or return call $self, on_login_failure => $msg;
304
305	root	1.3	$self->_login_success ("login");
306	root	1.1	});
307			} else {
308	root	1.2	call $self, on_login_failure => "no supported auth method (@$auths)";
309	root	1.1	}
310	root	1.3
311			# we no longer need these, make it a bit harder to get them
312			delete $self->{user};
313			delete $self->{pass};
314	root	1.1	}
315
316	root	1.3	sub on_info_notify {
317	root	1.1	my ($self, $msg) = @_;
318
319	root	1.3	warn $msg;
320	root	1.1	}
321
322	root	1.2	sub on_error_notify {
323			my ($self, $msg) = @_;
324
325			$self->error ($msg);
326			}
327
328	root	1.3	sub on_error {
329			my ($self, $msg) = @_;
330
331			warn $msg;
332
333			%$self = ();
334			}
335
336			sub on_login_failure {
337			my ($self, $msg) = @_;
338
339			$msg =~ s/\n$//;
340			$self->error ("login failed: $msg");
341			}
342
343			=back
344
345			=head2 EVENTS
346
347			AnyEvent::Porttracker conenctions are fully event-driven, and naturally
348			there are a number of events that can occur. All these events have a name
349			starting with C<on_> (example: C<on_login_failure>).
350
351			Programs can catch these events in two ways: either by providing
352			constructor arguments with the event name as key and a coderef as value:
353
354			my $api = new AnyEvent::Porttracker
355			host => ...,
356			user => ..., pass => ...,
357			on_error => sub {
358			my ($api, $msg) = @_;
359			warn $msg;
360			exit 1;
361			},
362			;
363
364			Or by subclassing C<AnyEvent::Porttracker> and overriding methods of the
365			same name:
366
367			package MyClass;
368
369			use base AnyEvent::Porttracker;
370
371			sub on_error {
372			my ($api, $msg) = @_;
373			warn $msg;
374			exit 1;
375			}
376
377			Event callbacks are not expected to return anything and are always passed
378			the API object as first argument. Some might have default implementations
379			(for example, C<on_error>), others are ignored unless overriden.
380
381			Description of individual events follow:
382
383			=over 4
384
385			=item on_error $api, $msg
386
387			Is called for every (fatal) error, including C<error> notifies. The
388			default prints the message and destroys the object, so it is highly
389			advisable to override this event.
390
391			=item on_login $api, $method
392
393			Called after a successful login, after which commands can be send. It is
394			permissible to send commands before a successful login: those will be
395			queued and sent just before this event is invoked. C<$method> is the auth
396			method that was used.
397
398			=item on_login_failure $api, $msg
399
400			Called when all login attempts have failed - the default raises a fatal
401			error with the error message from the server.
402
403			=item on_hello_notify $api, $version, $authtypes, $nonce
404
405			This protocol notification is used internally by AnyEvent::Porttracker -
406			you can override it, but the module will most likely not work.
407
408			=item on_info_notify $api, $msg
409
410			Called for informational messages from the server - the default
411			implementation calls C<warn> but otherwise ignores this notification.
412
413			=item on_error_notify $api, $msg
414
415			Called for fatal errors from the server - the default implementation calls
416			C<warn> and destroys the API object.
417
418			=item on_start_tls_notify $api
419
420			Called when the server wants to start TLS negotiation. This is used
421			internally and - while it is possible to override it - should not be
422			overriden.
423
424			=item on_XYZ_notify $api, ...
425
426			In general, any protocol notification will result in an event of the form
427			C<on_NOTIFICATION_notify>.
428
429	root	1.1	=back
430
431			=head1 SEE ALSO
432
433			L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>.
434
435			=head1 AUTHOR
436
437			Marc Lehmann <marc@porttracker.net>
438
439			=cut
440
441			1