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 JSON ();

our $VERSION = 1.02;

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_sha3>,
C<login_cram_md6> or C<login> methods, in this order of preference
(typically, C<login_cram_sha3> 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 };
   use Data::Dump; ddx $auths;#d#

   if (grep $_ eq "none", @$auths) {
      $self->_login_success ("none");
   } elsif (grep $_ eq "login_cram_sha3", @$auths) {
      my $cc = join "", map chr 256 * rand, 0..63;

      require Digest::SHA3;
      require Digest::HMAC;

      my $hmac_sha3 = sub ($$){ # $key, $text
         Digest::HMAC::hmac ($_[1], $_[0], \&Digest::SHA3::sha3_512, 72)
      };

      my $key = $hmac_sha3->($self->{pass}, $self->{user});
      my $cr  = $hmac_sha3->($key, "$cc$nonce");
      my $sr  = $hmac_sha3->($key, "$nonce$cc");

      $cc = MIME::Base64::encode_base64 $cc;
      $cr = MIME::Base64::encode_base64 $cr;

      $self->_req (login_cram_sha3 => $self->{user}, $cr, $cc, sub {
         my ($self, $ok, $msg) = @_;

         $ok
            or return call $self, on_login_failure => $msg;

         (MIME::Base64::decode_base64 $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_sha3");
      });
   } elsif (grep $_ eq "login_cram_md6", @$auths) {
      my $cc = join "", map chr 256 * rand, 0..63;

      require Digest::HMAC_MD6;

      my $key = Digest::HMAC_MD6::hmac_md6 ($self->{pass}, $self->{user}, 64, 256);
      my $cr  = Digest::HMAC_MD6::hmac_md6 ($key, "$cc$nonce", 64, 256);
      my $sr  = Digest::HMAC_MD6::hmac_md6 ($key, "$nonce$cc", 64, 256);

      $cc = MIME::Base64::encode_base64 $cc;
      $cr = MIME::Base64::encode_base64 $cr;

      $self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub {
         my ($self, $ok, $msg) = @_;

         $ok
            or return call $self, on_login_failure => $msg;

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