cvsroot/AnyEvent-Porttracker/Porttracker.pm

=head1 NAME

AnyEvent::Porttracker - Porttracker 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.

If you do not have access to a Porttracker 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 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/>.

=head1 AUTHOR

 Marc Lehmann <marc@nethype.de>

=cut

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