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

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    => [],
      rframe => "json",
      wframe => "json",
      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;
               });
            }
         },
      ;

      $self->{cb_read} = sub {
         my ($hdl, $msg) = @_;
         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;
         }

         $hdl->push_read ($self->{rframe} => $self->{cb_read});
      };

      $self->{hdl}->push_read ($self->{rframe} => $self->{cb_read});
   }

   $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;

   $self->{hdl}->push_write ($self->{wframe} => \@_);
}

=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_start_cbor_notify {
   my ($self) = @_;

   $self->{rframe} = "cbor";
}

sub on_hello_notify {
   my ($self, $version, $features, $nonce) = @_;

   $version == 1
      or return $self->error ("protocol mismatch, got $version, expected/supported 1");

   $nonce = MIME::Base64::decode_base64 $nonce;

   $self->{hello} = [$features, $nonce];

   if (grep $_ eq "start_cbor", @$features and eval 'require CBOR::XS') {
      $self->_req (start_cbor => sub {
         $_[1]
            or $self->error ("start_cbor failed despite announced");
      });

      $self->{hdl}{cbor} =
         CBOR::XS
         ->new
         ->max_depth (16)
         ->max_size (1 << 30)
         ->filter (sub { });

      $self->{wframe} = "cbor";
   }

   $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 ($features, $nonce) = @{ $self->{hello} or return };

   if (grep $_ eq "none", @$features) {
      $self->_login_success ("none");
   } elsif (grep $_ eq "login_cram_sha3", @$features and eval 'require Digest::SHA3; require Digest::HMAC') {
      my $cc = join "", map chr 256 * rand, 0..63;

      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", @$features and eval 'require Digest::HMAC_MD6') {
      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 ($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", @$features) {
      $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 (@$features)";
   }

   # 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, $features, $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_start_cbor_notify $api

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