cvsroot/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.

=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.

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