AnyEvent-Porttracker/Porttracker.pm

=head1 NAME

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

=head1 SYNOPSIS

   use AnyEvent::Porttracker;

   my $api = new AnyEvent::Porttracker
      host => "10.0.0.1",
      user => "admin",
      pass => "31331",
      tls  => 1,
   ;

   # Example 1
   # a simple request: ping the server

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

   # Example 2
   # find all realms, start a discovery on all of them
   # and wait until all discovery processes have finished

   my $cv = AE::cv;

   $cv->begin;
   # find all realms
   $api->req (realm_info => ["gid", "name"], sub {
      my ($api, @realms) = @_;

      # start discovery on all realms
      for my $realm (@realms) {
         my ($gid, $name) = @$realm;

         $cv->begin;
         $api->req (realm_discover => $realm->[0], sub {
            warn "discovery for realm '$realm->[1]' finished\n";
            $cv->end;
         });
      }

      $cv->end;
   });

   $cv->recv;

   # Example 3
   # subscribe to realm_poll_stop events and report each occurance

   $api->req (subscribe => "realm_poll_stop", sub {});
   $api->on (realm_poll_stop_event => sub {
      my ($api, $gid) = @_;
      warn "this just in: poll for realm <$gid> finished.\n";
   });

=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 => $bool

Enables or disables TLS (default: disables). When enabled, then the
connection will try to handshake a TLS connection before logging in. If
unsuccessful a fatal error will be raised.

Since most Porttracker/PortIQ boxes will not have a sensible/verifiable
certificate, no attempt at verifying it will be done (which means
man-in-the-middle-attacks will be trivial). If you want some form of
verification you need to provide your own C<tls_ctx> object with C<<
verify => 1, verify_peername => [1, 1, 1] >> or whatever verification mode
you wish to use.

=item tls_ctx => $tls_ctx

The L<AnyEvent::TLS> object to use. See C<tls>, above.

=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. You add or remove event handlers at any time with
the C<event> method.

=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 ($_[2]);
         },
         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 $self, 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, @reply))

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

If the request fails, then a fatal error will be raised. If you want to
handle failures gracefully, you need to use C<< ->req_failok >> instead.

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 {
   my $cb = pop;
   push @_, sub {
      splice @_, 1, 1
         or $_[0]->error ($_[1]);

      &$cb
   };

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

=item $api->req_failok ($type => @args, $callback->($api, $success, @reply))

Just like C<< ->req >>, with two differences: first, a failure will not
raise an error, second, the initial status reply which indicates success
or failure is not removed before calling the callback.

=cut

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

=item $api->on (XYZ => $callback)

Overwrites any currently registered handler for C<on_XYZ> or
installs a new one. Or, when C<$callback> is undef, unregisters any
currently-registered handler.

Example: replace/set the handler for C<on_discover_stop_event>.

   $api->on (discover_stop_event => sub {
      my ($api, $gid) = @_;
      ...
   });

=cut

sub on {
   my $self = shift;

   while (@_) {
      my ($event, $cb) = splice @_, 0, 2;
      $event =~ s/^on_//;

      $self->{"on_$event"} = $cb;
   }
}

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

   $self->{hdl}->starttls (connect => $self->{tls_ctx});
   $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");
}

sub on_event_notify {
   my ($self, $event, @args) = @_;

   call $self, "on_${event}_event", @args;
}

=back

=head1 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_event_notify $api, $eventname, @args

Called when the server broadcasts an event the API object is subscribed
to. The default implementation (which should not be overridden) simply
re-issues an "on_eventname_event" event with the @args.

=item on_XYZ_notify $api, ...

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

=item on_XYZ_event $api, ...

Called when the server broadcasts the named (XYZ) event.

=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.10
Committed:	Tue Nov 16 02:07:31 2010 UTC (15 years, 10 months ago) by root
Branch:	MAIN
Changes since 1.9:	+1 -1 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	root	1.9	my $api = new AnyEvent::Porttracker
10			host => "10.0.0.1",
11			user => "admin",
12			pass => "31331",
13			tls => 1,
14			;
15
16			# Example 1
17			# a simple request: ping the server
18
19			$api->req ("ping", sub {
20			my ($api, $ok, $timestamp, $pid) = @_;
21			...
22			});
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
28			my $cv = AE::cv;
29
30			$cv->begin;
31			# find all realms
32			$api->req (realm_info => ["gid", "name"], sub {
33			my ($api, @realms) = @_;
34
35			# start discovery on all realms
36			for my $realm (@realms) {
37			my ($gid, $name) = @$realm;
38
39			$cv->begin;
40			$api->req (realm_discover => $realm->[0], sub {
41			warn "discovery for realm '$realm->[1]' finished\n";
42			$cv->end;
43			});
44			}
45
46			$cv->end;
47			});
48
49			$cv->recv;
50
51			# Example 3
52			# subscribe to realm_poll_stop events and report each occurance
53
54			$api->req (subscribe => "realm_poll_stop", sub {});
55			$api->on (realm_poll_stop_event => sub {
56			my ($api, $gid) = @_;
57			warn "this just in: poll for realm <$gid> finished.\n";
58			});
59
60	root	1.1	=head1 DESCRIPTION
61
62			Porttracker (L<http://www.porttracker.com/>) is a product that (among
63			other things) scans switches and routers in a network and gives a coherent
64			view of which end devices are connected to which switch ports on which
65			switches and routers. It also offers a JSON-based client API, for which
66			this module is an implementation.
67
68			In addition to Porttracker, the PortIQ product is also supported, as it
69			uses the same protocol.
70
71			If you do not have access to either a Porttracker or PortIQ box then this
72			module will be of little value to you.
73
74			This module is an L<AnyEvent> user, you need to make sure that you use and
75			run a supported event loop.
76
77	root	1.3	To quickly understand how this module works you should read how to
78			construct a new connection object and then read about the event/callback
79			system.
80
81	root	1.5	The actual low-level protocol and, more importantly, the existing
82			requests and responses, are documented in the official Porttracker
83			API documentation (a copy of which is included in this module as
84			L<AnyEvent::Porttracker::protocol>.
85
86	root	1.1	=head1 THE AnyEvent::Porttracker CLASS
87
88	root	1.3	The AnyEvent::Porttracker class represents a single connection.
89
90	root	1.1	=over 4
91
92			=cut
93
94			package AnyEvent::Porttracker;
95
96			use common::sense;
97
98			use Scalar::Util ();
99
100			use AnyEvent ();
101			use AnyEvent::Handle ();
102
103			use MIME::Base64 ();
104			use Digest::HMAC_MD6 ();
105			use JSON ();
106
107			our $VERSION = '0.0';
108
109			sub call {
110			my ($self, $type, @args) = @_;
111
112			$self->{$type}
113			? $self->{$type}($self, @args)
114	root	1.2	: ($type = (UNIVERSAL::can $self, $type))
115	root	1.1	? $type->($self, @args)
116			: ()
117			}
118
119	root	1.4	=item $api = new AnyEvent::Porttracker [key => value...]
120	root	1.3
121			Creates a new porttracker API connection object and tries to connect to
122			the specified host (see below). After the connection has been established,
123			the TLS handshake (if requested) will take place, followed by a login
124			attempt using either the C<none>, C<login_cram_md6> or C<login> methods,
125			in this order of preference (typically, C<login_cram_md6> is used, which
126			shields against some man-in-the-middle attacks and avoids transferring the
127			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	root	1.6	=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/PortIQ 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	root	1.9	The L<AnyEvent::TLS> object to use. See C<tls>, above.
165	root	1.3
166			=item on_XYZ => $coderef
167
168			You can specify event callbacks either by subclassing and overriding the
169			respective methods or by specifying coderefs as key-value pairs when
170	root	1.9	constructing the object. You add or remove event handlers at any time with
171			the C<event> method.
172	root	1.3
173			=back
174	root	1.1
175			=cut
176
177			sub new {
178			my $class = shift;
179
180			my $self = bless {
181	root	1.3	id => "a",
182	root	1.4	ids => [],
183	root	1.3	queue => [], # ininitially queue everything
184	root	1.1	@_,
185			}, $class;
186
187			{
188			Scalar::Util::weaken (my $self = $self);
189
190			$self->{hdl} = new AnyEvent::Handle
191			connect => [$self->{host}, $self->{port} \|\| "porttracker=55"],
192			on_error => sub {
193	root	1.6	$self->error ($_[2]);
194	root	1.1	},
195	root	1.2	on_connect => sub {
196			if ($self->{tls}) {
197			$self->_req (start_tls => sub {
198			$_[1]
199			or return $self->error ("TLS rejected by server");
200
201	root	1.3	$self->_login;
202	root	1.2	});
203			}
204			},
205	root	1.1	on_read => sub {
206			while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {
207			my $msg = JSON::decode_json $1;
208			my $id = shift @$msg;
209
210			if (defined $id) {
211			my $cb = delete $self->{cb}{$id}
212			or return $self->error ("received unexpected reply msg with id $id");
213
214	root	1.4	push @{ $self->{ids} }, $id;
215
216	root	1.1	$cb->($self, @$msg);
217			} else {
218			$msg->[0] = "on_$msg->[0]_notify";
219			call $self, @$msg;
220			}
221			}
222			},
223			;
224			}
225
226			$self
227			}
228
229			sub DESTROY {
230			my ($self) = @_;
231
232			$self->{hdl}->destroy
233			if $self->{hdl};
234			}
235
236			sub error {
237			my ($self, $msg) = @_;
238
239	root	1.6	call $self, on_error => $msg;
240	root	1.1
241			()
242			}
243
244	root	1.2	sub _req {
245	root	1.1	my $self = shift;
246			my $cb = pop;
247
248	root	1.4	my $id = (pop @{ $self->{ids} }) \|\| $self->{id}++;
249	root	1.1
250			unshift @_, $id;
251			$self->{cb}{$id} = $cb;
252
253			my $msg = JSON::encode_json \@_;
254
255			$self->{hdl}->push_write ($msg);
256			}
257
258	root	1.6	=item $api->req ($type => @args, $callback->($api, @reply))
259	root	1.4
260			Sends a generic request of type C<$type> to the server. When the server
261	root	1.6	responds, the API object and the response arguments (without the success
262			status) are passed to the callback, which is the last argument to this
263			method.
264
265			If the request fails, then a fatal error will be raised. If you want to
266			handle failures gracefully, you need to use C<< ->req_failok >> instead.
267	root	1.4
268	root	1.5	The available requests are documented in the Porttracker API
269			documentation (a copy of which is included in this module as
270			L<AnyEvent::Porttracker::protocol>.
271
272	root	1.4	It is permissible to call this (or any other request function) at any
273			time, even before the connection has been established - the API object
274			always waits until after login before it actually sends the requests, and
275			queues them until then.
276
277			Example: ping the porttracker server.
278
279			$api->req ("ping", sub {
280			my ($api, $ok, $timestamp, $pid) = @_;
281			...
282			});
283
284			Example: determine the product ID.
285
286			$api->req (product_id => sub {
287			my ($api, $ok, $branding, $product_id) = @_;
288			...
289			});
290
291			Example: set a new license.
292
293			$api->req (set_license => $LICENSE_STRING, sub {
294			my ($api, $ok) = @_;
295
296			$ok or die "failed to set license";
297			});
298
299			=cut
300
301	root	1.2	sub req {
302	root	1.6	my $cb = pop;
303			push @_, sub {
304	root	1.7	splice @_, 1, 1
305	root	1.6	or $_[0]->error ($_[1]);
306
307			&$cb
308			};
309
310			$_[0]{queue}
311			? push @{ $_[0]{queue} }, [@_]
312			: &_req
313			}
314
315			=item $api->req_failok ($type => @args, $callback->($api, $success, @reply))
316
317			Just like C<< ->req >>, with two differences: first, a failure will not
318			raise an error, second, the initial status reply which indicates success
319			or failure is not removed before calling the callback.
320
321			=cut
322
323			sub req_failok {
324	root	1.2	$_[0]{queue}
325			? push @{ $_[0]{queue} }, [@_]
326			: &_req
327			}
328
329	root	1.9	=item $api->on (XYZ => $callback)
330
331			Overwrites any currently registered handler for C<on_XYZ> or
332			installs a new one. Or, when C<$callback> is undef, unregisters any
333			currently-registered handler.
334
335			Example: replace/set the handler for C<on_discover_stop_event>.
336
337			$api->on (discover_stop_event => sub {
338			my ($api, $gid) = @_;
339			...
340			});
341
342			=cut
343
344			sub on {
345			my $self = shift;
346
347			while (@_) {
348			my ($event, $cb) = splice @_, 0, 2;
349			$event =~ s/^on_//;
350
351			$self->{"on_$event"} = $cb;
352			}
353			}
354
355	root	1.2	sub on_start_tls_notify {
356			my ($self) = @_;
357
358	root	1.6	$self->{hdl}->starttls (connect => $self->{tls_ctx});
359	root	1.3	$self->{tls} \|\|= 1;
360	root	1.2
361	root	1.3	$self->_login;
362	root	1.2	}
363
364	root	1.1	sub on_hello_notify {
365			my ($self, $version, $auths, $nonce) = @_;
366
367			$version == 1
368			or return $self->error ("protocol mismatch, got $version, expected/supported 1");
369
370			$nonce = MIME::Base64::decode_base64 $nonce;
371
372	root	1.3	$self->{hello} = [$auths, $nonce];
373
374			$self->_login
375			unless $self->{tls}; # delay login when trying to handshake tls
376			}
377
378			sub _login_success {
379			my ($self, $method) = @_;
380
381			_req @$_
382			for @{ delete $self->{queue} };
383
384			call $self, on_login => $method;
385			}
386
387			sub _login {
388			my ($self) = @_;
389
390			my ($auths, $nonce) = @{ delete $self->{hello} or return };
391
392	root	1.1	if (grep $_ eq "none", @$auths) {
393	root	1.3	$self->_login_success ("none");
394	root	1.2
395	root	1.1	} elsif (grep $_ eq "login_cram_md6", @$auths) {
396			my $cc = join "", map chr 256 * rand, 0..63;
397
398	root	1.3	my $key = Digest::HMAC_MD6::hmac_md6 $self->{pass}, $self->{user}, 64, 256;
399	root	1.1	my $cr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256;
400			my $sr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$nonce$cc", 64, 256;
401
402			$cc = MIME::Base64::encode_base64 $cc;
403
404	root	1.3	$self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub {
405	root	1.1	my ($self, $ok, $msg) = @_;
406
407			$ok
408			or return call $self, on_login_failure => $msg;
409
410			$msg eq $sr
411			or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";
412
413	root	1.3	$self->_login_success ("login_cram_md6");
414	root	1.1	});
415			} elsif (grep $_ eq "login", @$auths) {
416	root	1.3	$self->_req (login => $self->{user}, $self->{pass}, sub {
417	root	1.1	my ($self, $ok, $msg) = @_;
418
419			$ok
420			or return call $self, on_login_failure => $msg;
421
422	root	1.3	$self->_login_success ("login");
423	root	1.1	});
424			} else {
425	root	1.2	call $self, on_login_failure => "no supported auth method (@$auths)";
426	root	1.1	}
427	root	1.3
428			# we no longer need these, make it a bit harder to get them
429			delete $self->{user};
430			delete $self->{pass};
431	root	1.1	}
432
433	root	1.3	sub on_info_notify {
434	root	1.1	my ($self, $msg) = @_;
435
436	root	1.3	warn $msg;
437	root	1.1	}
438
439	root	1.2	sub on_error_notify {
440			my ($self, $msg) = @_;
441
442			$self->error ($msg);
443			}
444
445	root	1.3	sub on_error {
446			my ($self, $msg) = @_;
447
448			warn $msg;
449
450			%$self = ();
451			}
452
453			sub on_login_failure {
454			my ($self, $msg) = @_;
455
456			$msg =~ s/\n$//;
457			$self->error ("login failed: $msg");
458			}
459
460	root	1.8	sub on_event_notify {
461			my ($self, $event, @args) = @_;
462
463			call $self, "on_${event}_event", @args;
464			}
465
466	root	1.3	=back
467
468	root	1.10	=head1 EVENTS
469	root	1.3
470			AnyEvent::Porttracker conenctions are fully event-driven, and naturally
471			there are a number of events that can occur. All these events have a name
472			starting with C<on_> (example: C<on_login_failure>).
473
474			Programs can catch these events in two ways: either by providing
475			constructor arguments with the event name as key and a coderef as value:
476
477			my $api = new AnyEvent::Porttracker
478			host => ...,
479			user => ..., pass => ...,
480			on_error => sub {
481			my ($api, $msg) = @_;
482			warn $msg;
483			exit 1;
484			},
485			;
486
487			Or by subclassing C<AnyEvent::Porttracker> and overriding methods of the
488			same name:
489
490			package MyClass;
491
492			use base AnyEvent::Porttracker;
493
494			sub on_error {
495			my ($api, $msg) = @_;
496			warn $msg;
497			exit 1;
498			}
499
500			Event callbacks are not expected to return anything and are always passed
501			the API object as first argument. Some might have default implementations
502			(for example, C<on_error>), others are ignored unless overriden.
503
504			Description of individual events follow:
505
506			=over 4
507
508			=item on_error $api, $msg
509
510			Is called for every (fatal) error, including C<error> notifies. The
511			default prints the message and destroys the object, so it is highly
512			advisable to override this event.
513
514			=item on_login $api, $method
515
516			Called after a successful login, after which commands can be send. It is
517			permissible to send commands before a successful login: those will be
518			queued and sent just before this event is invoked. C<$method> is the auth
519			method that was used.
520
521			=item on_login_failure $api, $msg
522
523			Called when all login attempts have failed - the default raises a fatal
524			error with the error message from the server.
525
526			=item on_hello_notify $api, $version, $authtypes, $nonce
527
528			This protocol notification is used internally by AnyEvent::Porttracker -
529			you can override it, but the module will most likely not work.
530
531			=item on_info_notify $api, $msg
532
533			Called for informational messages from the server - the default
534			implementation calls C<warn> but otherwise ignores this notification.
535
536			=item on_error_notify $api, $msg
537
538			Called for fatal errors from the server - the default implementation calls
539			C<warn> and destroys the API object.
540
541			=item on_start_tls_notify $api
542
543			Called when the server wants to start TLS negotiation. This is used
544			internally and - while it is possible to override it - should not be
545			overriden.
546
547	root	1.8	=item on_event_notify $api, $eventname, @args
548
549			Called when the server broadcasts an event the API object is subscribed
550			to. The default implementation (which should not be overridden) simply
551	root	1.9	re-issues an "on_eventname_event" event with the @args.
552	root	1.8
553	root	1.3	=item on_XYZ_notify $api, ...
554
555			In general, any protocol notification will result in an event of the form
556			C<on_NOTIFICATION_notify>.
557
558	root	1.8	=item on_XYZ_event $api, ...
559
560			Called when the server broadcasts the named (XYZ) event.
561
562	root	1.1	=back
563
564			=head1 SEE ALSO
565
566			L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>.
567
568			=head1 AUTHOR
569
570			Marc Lehmann <marc@porttracker.net>
571
572			=cut
573
574			1