cvsroot/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,
      on_error => sub {
         die $_[1];
      },
   ;

   # Example 1
   # a simple request: ping the server synchronously

   my ($timestamp, $pid) = $api->req_sync ("ping");

   # Example 2
   # find all realms, start a discovery on all of them
   # and wait until all discovery processes have finished
   # but execute individual discoveries in parallel,
   # asynchronously

   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 => $gid, sub {
            warn "discovery for realm '$name' 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";
   });

   AE::cv->recv; # wait forever

=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 Carp ();
use Scalar::Util ();

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

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

our $VERSION = '1.01';

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 sub-classing and overriding the
respective methods or by specifying code-refs 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 => [], # initially 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 @res = $api->req_sync ($type => @args)

Similar to C<< ->req >>, but waits for the results of the request and on
success, returns the values instead (without the success flag, and only
the first value in scalar context). On failure, the method will C<croak>
with the error message.

=cut

sub req_sync {
   push @_, my $cv = AE::cv;
   &req;
   my ($ok, @res) = $cv->recv;

   $ok
      or Carp::croak $res[0];

   wantarray ? @res : $res[0]
}

=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/CALLBACKS

AnyEvent::Porttracker connections 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 code-ref as value:

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

Or by sub-classing 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
overridden.

=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@nethype.de>

=cut

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