[ViewVC] Diff of: cvs/cvsroot/AnyEvent-Porttracker/Porttracker.pm

Comparing cvsroot/AnyEvent-Porttracker/Porttracker.pm (file contents):
Revision 1.1 by root, Mon Nov 15 04:39:36 2010 UTC vs.
Revision 1.5 by root, Mon Nov 15 20:43:11 2010 UTC

…		…
21	module will be of little value to you.	21	module will be of little value to you.
22		22
23	This module is an L<AnyEvent> user, you need to make sure that you use and	23	This module is an L<AnyEvent> user, you need to make sure that you use and
24	run a supported event loop.	24	run a supported event loop.
25		25
		26	To quickly understand how this module works you should read how to
		27	construct a new connection object and then read about the event/callback
		28	system.
		29
		30	The actual low-level protocol and, more importantly, the existing
		31	requests and responses, are documented in the official Porttracker
		32	API documentation (a copy of which is included in this module as
		33	L<AnyEvent::Porttracker::protocol>.
		34
26	=head1 THE AnyEvent::Porttracker CLASS	35	=head1 THE AnyEvent::Porttracker CLASS
		36
		37	The AnyEvent::Porttracker class represents a single connection.
27		38
28	=over 4	39	=over 4
29		40
30	=cut	41	=cut
31		42
…		…
47	sub call {	58	sub call {
48	my ($self, $type, @args) = @_;	59	my ($self, $type, @args) = @_;
49		60
50	$self->{$type}	61	$self->{$type}
51	? $self->{$type}($self, @args)	62	? $self->{$type}($self, @args)
52	: $type = (UNIVERSAL::can $self, $type)	63	: ($type = (UNIVERSAL::can $self, $type))
53	? $type->($self, @args)	64	? $type->($self, @args)
54	: ()	65	: ()
55	}	66	}
56		67
57	=item new AnyEvent::Porttracker	68	=item $api = new AnyEvent::Porttracker [key => value...]
		69
		70	Creates a new porttracker API connection object and tries to connect to
		71	the specified host (see below). After the connection has been established,
		72	the TLS handshake (if requested) will take place, followed by a login
		73	attempt using either the C<none>, C<login_cram_md6> or C<login> methods,
		74	in this order of preference (typically, C<login_cram_md6> is used, which
		75	shields against some man-in-the-middle attacks and avoids transferring the
		76	password).
		77
		78	It is permissible to send requests immediately after creating the object -
		79	they will be queued until after successful login.
		80
		81	Possible key-value pairs are:
		82
		83	=over 4
		84
		85	=item host => $hostname [MANDATORY]
		86
		87	The hostname or IP address of the Porttracker box.
		88
		89	=item port => $service
		90
		91	The service (port) to use (default: C<porttracker=55>).
		92
		93	=item user => $string, pass => $string
		94
		95	These are the username and password to use when authentication is required
		96	(which it is in almost all cases, so these keys are normally mandatory).
		97
		98	=item tls => ...
		99
		100	#TODO#
		101
		102	=item on_XYZ => $coderef
		103
		104	You can specify event callbacks either by subclassing and overriding the
		105	respective methods or by specifying coderefs as key-value pairs when
		106	constructing the object.
		107
		108	=back
58		109
59	=cut	110	=cut
60		111
61	sub new {	112	sub new {
62	my $class = shift;	113	my $class = shift;
63		114
64	my $self = bless {	115	my $self = bless {
65	id => "a",	116	id => "a",
		117	ids => [],
		118	queue => [], # ininitially queue everything
66	@_,	119	@_,
67	}, $class;	120	}, $class;
68		121
69	{	122	{
70	Scalar::Util::weaken (my $self = $self);	123	Scalar::Util::weaken (my $self = $self);
…		…
72	$self->{hdl} = new AnyEvent::Handle	125	$self->{hdl} = new AnyEvent::Handle
73	connect => [$self->{host}, $self->{port} \|\| "porttracker=55"],	126	connect => [$self->{host}, $self->{port} \|\| "porttracker=55"],
74	on_error => sub {	127	on_error => sub {
75	$self->error ();	128	$self->error ();
76	},	129	},
		130	on_connect => sub {
		131	if ($self->{tls}) {
		132	$self->_req (start_tls => sub {
		133	$_[1]
		134	or return $self->error ("TLS rejected by server");
		135
		136	$self->_login;
		137	});
		138	}
		139	},
77	on_read => sub {	140	on_read => sub {
78	while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {	141	while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {
79	my $msg = JSON::decode_json $1;	142	my $msg = JSON::decode_json $1;
80	my $id = shift @$msg;	143	my $id = shift @$msg;
81		144
82	if (defined $id) {	145	if (defined $id) {
83	my $cb = delete $self->{cb}{$id}	146	my $cb = delete $self->{cb}{$id}
84	or return $self->error ("received unexpected reply msg with id $id");	147	or return $self->error ("received unexpected reply msg with id $id");
		148
		149	push @{ $self->{ids} }, $id;
85		150
86	$cb->($self, @$msg);	151	$cb->($self, @$msg);
87	} else {	152	} else {
88	$msg->[0] = "on_$msg->[0]_notify";	153	$msg->[0] = "on_$msg->[0]_notify";
89	call $self, @$msg;	154	call $self, @$msg;
…		…
104	}	169	}
105		170
106	sub error {	171	sub error {
107	my ($self, $msg) = @_;	172	my ($self, $msg) = @_;
108		173
109	warn $msg;	174	call on_error => $msg;
110		175
111	()	176	()
112	}	177	}
113		178
114	sub send {	179	sub _req {
115	my $self = shift;	180	my $self = shift;
116	my $cb = pop;	181	my $cb = pop;
117		182
118	my $id = ++$self->{id};	183	my $id = (pop @{ $self->{ids} }) \|\| $self->{id}++;
119		184
120	unshift @_, $id;	185	unshift @_, $id;
121	$self->{cb}{$id} = $cb;	186	$self->{cb}{$id} = $cb;
122		187
123	my $msg = JSON::encode_json \@_;	188	my $msg = JSON::encode_json \@_;
124		189
125	$self->{hdl}->push_write ($msg);	190	$self->{hdl}->push_write ($msg);
126	}	191	}
127		192
		193	=item $api->req ($type => @args, $callback->($api, @args))
		194
		195	Sends a generic request of type C<$type> to the server. When the server
		196	responds, the API object and the response arguments are passed to the
		197	callback, which is the last argument to this method.
		198
		199	The available requests are documented in the Porttracker API
		200	documentation (a copy of which is included in this module as
		201	L<AnyEvent::Porttracker::protocol>.
		202
		203	It is permissible to call this (or any other request function) at any
		204	time, even before the connection has been established - the API object
		205	always waits until after login before it actually sends the requests, and
		206	queues them until then.
		207
		208	Example: ping the porttracker server.
		209
		210	$api->req ("ping", sub {
		211	my ($api, $ok, $timestamp, $pid) = @_;
		212	...
		213	});
		214
		215	Example: determine the product ID.
		216
		217	$api->req (product_id => sub {
		218	my ($api, $ok, $branding, $product_id) = @_;
		219	...
		220	});
		221
		222	Example: set a new license.
		223
		224	$api->req (set_license => $LICENSE_STRING, sub {
		225	my ($api, $ok) = @_;
		226
		227	$ok or die "failed to set license";
		228	});
		229
		230	=cut
		231
		232	sub req {
		233	$_[0]{queue}
		234	? push @{ $_[0]{queue} }, [@_]
		235	: &_req
		236	}
		237
		238	sub on_start_tls_notify {
		239	my ($self) = @_;
		240
		241	$self->{hdl}->starttls ("connect");
		242	$self->{tls} \|\|= 1;
		243
		244	$self->_login;
		245	}
		246
128	sub on_hello_notify {	247	sub on_hello_notify {
129	my ($self, $version, $auths, $nonce) = @_;	248	my ($self, $version, $auths, $nonce) = @_;
130		249
131	$version == 1	250	$version == 1
132	or return $self->error ("protocol mismatch, got $version, expected/supported 1");	251	or return $self->error ("protocol mismatch, got $version, expected/supported 1");
133		252
134	$nonce = MIME::Base64::decode_base64 $nonce;	253	$nonce = MIME::Base64::decode_base64 $nonce;
135		254
		255	$self->{hello} = [$auths, $nonce];
		256
		257	$self->_login
		258	unless $self->{tls}; # delay login when trying to handshake tls
		259	}
		260
		261	sub _login_success {
		262	my ($self, $method) = @_;
		263
		264	_req @$_
		265	for @{ delete $self->{queue} };
		266
		267	call $self, on_login => $method;
		268	}
		269
		270	sub _login {
		271	my ($self) = @_;
		272
		273	my ($auths, $nonce) = @{ delete $self->{hello} or return };
		274
136	if (grep $_ eq "none", @$auths) {	275	if (grep $_ eq "none", @$auths) {
137	# successfully authenticated...	276	$self->_login_success ("none");
		277
138	} elsif (grep $_ eq "login_cram_md6", @$auths) {	278	} elsif (grep $_ eq "login_cram_md6", @$auths) {
139	my $cc = join "", map chr 256 * rand, 0..63;	279	my $cc = join "", map chr 256 * rand, 0..63;
140		280
141	my $key = Digest::HMAC_MD6::hmac_md6 $self->{password}, $self->{username}, 64, 256;	281	my $key = Digest::HMAC_MD6::hmac_md6 $self->{pass}, $self->{user}, 64, 256;
142	my $cr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256;	282	my $cr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256;
143	my $sr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$nonce$cc", 64, 256;	283	my $sr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$nonce$cc", 64, 256;
144		284
145	$cc = MIME::Base64::encode_base64 $cc;	285	$cc = MIME::Base64::encode_base64 $cc;
146		286
147	$self->send (login_cram_md6 => $self->{username}, $cr, $cc, sub {	287	$self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub {
148	my ($self, $ok, $msg) = @_;	288	my ($self, $ok, $msg) = @_;
149		289
150	$ok	290	$ok
151	or return call $self, on_login_failure => $msg;	291	or return call $self, on_login_failure => $msg;
152		292
153	$msg eq $sr	293	$msg eq $sr
154	or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";	294	or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";
155		295
156	call $self, "on_login"	296	$self->_login_success ("login_cram_md6");
157	});	297	});
158	} elsif (grep $_ eq "login", @$auths) {	298	} elsif (grep $_ eq "login", @$auths) {
159	$self->send (login => $self->{username}, $self->{password}, sub {	299	$self->_req (login => $self->{user}, $self->{pass}, sub {
160	my ($self, $ok, $msg) = @_;	300	my ($self, $ok, $msg) = @_;
161		301
162	$ok	302	$ok
163	or return call $self, on_login_failure => $msg;	303	or return call $self, on_login_failure => $msg;
164		304
165	call $self, "on_login"	305	$self->_login_success ("login");
166	});	306	});
167	} else {	307	} else {
168	return $self->error ("no supported auth method (@$auths)");	308	call $self, on_login_failure => "no supported auth method (@$auths)";
169	}	309	}
		310
		311	# we no longer need these, make it a bit harder to get them
		312	delete $self->{user};
		313	delete $self->{pass};
		314	}
		315
		316	sub on_info_notify {
		317	my ($self, $msg) = @_;
		318
		319	warn $msg;
		320	}
		321
		322	sub on_error_notify {
		323	my ($self, $msg) = @_;
		324
		325	$self->error ($msg);
		326	}
		327
		328	sub on_error {
		329	my ($self, $msg) = @_;
		330
		331	warn $msg;
		332
		333	%$self = ();
170	}	334	}
171		335
172	sub on_login_failure {	336	sub on_login_failure {
173	my ($self, $msg) = @_;	337	my ($self, $msg) = @_;
174		338
…		…
176	$self->error ("login failed: $msg");	340	$self->error ("login failed: $msg");
177	}	341	}
178		342
179	=back	343	=back
180		344
		345	=head2 EVENTS
		346
		347	AnyEvent::Porttracker conenctions are fully event-driven, and naturally
		348	there are a number of events that can occur. All these events have a name
		349	starting with C<on_> (example: C<on_login_failure>).
		350
		351	Programs can catch these events in two ways: either by providing
		352	constructor arguments with the event name as key and a coderef as value:
		353
		354	my $api = new AnyEvent::Porttracker
		355	host => ...,
		356	user => ..., pass => ...,
		357	on_error => sub {
		358	my ($api, $msg) = @_;
		359	warn $msg;
		360	exit 1;
		361	},
		362	;
		363
		364	Or by subclassing C<AnyEvent::Porttracker> and overriding methods of the
		365	same name:
		366
		367	package MyClass;
		368
		369	use base AnyEvent::Porttracker;
		370
		371	sub on_error {
		372	my ($api, $msg) = @_;
		373	warn $msg;
		374	exit 1;
		375	}
		376
		377	Event callbacks are not expected to return anything and are always passed
		378	the API object as first argument. Some might have default implementations
		379	(for example, C<on_error>), others are ignored unless overriden.
		380
		381	Description of individual events follow:
		382
		383	=over 4
		384
		385	=item on_error $api, $msg
		386
		387	Is called for every (fatal) error, including C<error> notifies. The
		388	default prints the message and destroys the object, so it is highly
		389	advisable to override this event.
		390
		391	=item on_login $api, $method
		392
		393	Called after a successful login, after which commands can be send. It is
		394	permissible to send commands before a successful login: those will be
		395	queued and sent just before this event is invoked. C<$method> is the auth
		396	method that was used.
		397
		398	=item on_login_failure $api, $msg
		399
		400	Called when all login attempts have failed - the default raises a fatal
		401	error with the error message from the server.
		402
		403	=item on_hello_notify $api, $version, $authtypes, $nonce
		404
		405	This protocol notification is used internally by AnyEvent::Porttracker -
		406	you can override it, but the module will most likely not work.
		407
		408	=item on_info_notify $api, $msg
		409
		410	Called for informational messages from the server - the default
		411	implementation calls C<warn> but otherwise ignores this notification.
		412
		413	=item on_error_notify $api, $msg
		414
		415	Called for fatal errors from the server - the default implementation calls
		416	C<warn> and destroys the API object.
		417
		418	=item on_start_tls_notify $api
		419
		420	Called when the server wants to start TLS negotiation. This is used
		421	internally and - while it is possible to override it - should not be
		422	overriden.
		423
		424	=item on_XYZ_notify $api, ...
		425
		426	In general, any protocol notification will result in an event of the form
		427	C<on_NOTIFICATION_notify>.
		428
		429	=back
		430
181	=head1 SEE ALSO	431	=head1 SEE ALSO
182		432
183	L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>.	433	L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>.
184		434
185	=head1 AUTHOR	435	=head1 AUTHOR

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing cvsroot/AnyEvent-Porttracker/Porttracker.pm (file contents): Revision 1.1 by root, Mon Nov 15 04:39:36 2010 UTC vs. Revision 1.5 by root, Mon Nov 15 20:43:11 2010 UTC

Diff Legend

Comparing cvsroot/AnyEvent-Porttracker/Porttracker.pm (file contents):
Revision 1.1 by root, Mon Nov 15 04:39:36 2010 UTC vs.
Revision 1.5 by root, Mon Nov 15 20:43:11 2010 UTC