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 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",
      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");

                  $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   = ++$self->{id};

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

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

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

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