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

Comparing cvsroot/AnyEvent-Porttracker/Porttracker.pm (file contents):
Revision 1.2 by root, Mon Nov 15 04:57:39 2010 UTC vs.
Revision 1.6 by root, Tue Nov 16 01:10:50 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
…		…
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 => $bool
		99
		100	Enables or disables TLS (default: disables). When enabled, then the
		101	connection will try to handshake a TLS connection before logging in. If
		102	unsuccessful a fatal error will be raised.
		103
		104	Since most Porttracker/PortIQ boxes will not have a sensible/verifiable
		105	certificate, no attempt at verifying it will be done (which means
		106	man-in-the-middle-attacks will be trivial). If you want some form of
		107	verification you need to provide your own C<tls_ctx> object with C<<
		108	verify => 1, verify_peername => [1, 1, 1] >> or whatever verification mode
		109	you wish to use.
		110
		111	=item tls_ctx => $tls_ctx
		112
		113	The L<AnyEvent::TLS> object to use.
		114
		115	#TODO#
		116
		117	=item on_XYZ => $coderef
		118
		119	You can specify event callbacks either by subclassing and overriding the
		120	respective methods or by specifying coderefs as key-value pairs when
		121	constructing the object.
		122
		123	=back
58		124
59	=cut	125	=cut
60		126
61	sub new {	127	sub new {
62	my $class = shift;	128	my $class = shift;
63		129
64	my $self = bless {	130	my $self = bless {
65	id => "a",	131	id => "a",
		132	ids => [],
		133	queue => [], # ininitially queue everything
66	@_,	134	@_,
67	}, $class;	135	}, $class;
68		136
69	{	137	{
70	Scalar::Util::weaken (my $self = $self);	138	Scalar::Util::weaken (my $self = $self);
71		139
72	$self->{hdl} = new AnyEvent::Handle	140	$self->{hdl} = new AnyEvent::Handle
73	connect => [$self->{host}, $self->{port} \|\| "porttracker=55"],	141	connect => [$self->{host}, $self->{port} \|\| "porttracker=55"],
74	on_error => sub {	142	on_error => sub {
75	$self->error ();	143	$self->error ($_[2]);
76	},	144	},
77	on_connect => sub {	145	on_connect => sub {
78	if ($self->{tls}) {	146	if ($self->{tls}) {
79	$self->{queue} \|\|= [];
80	$self->_req (start_tls => sub {	147	$self->_req (start_tls => sub {
81	$_[1]	148	$_[1]
82	or return $self->error ("TLS rejected by server");	149	or return $self->error ("TLS rejected by server");
83		150
84	$self->unqueue;	151	$self->_login;
85	});	152	});
86	}	153	}
87	},	154	},
88	on_read => sub {	155	on_read => sub {
89	while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {	156	while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {
…		…
91	my $id = shift @$msg;	158	my $id = shift @$msg;
92		159
93	if (defined $id) {	160	if (defined $id) {
94	my $cb = delete $self->{cb}{$id}	161	my $cb = delete $self->{cb}{$id}
95	or return $self->error ("received unexpected reply msg with id $id");	162	or return $self->error ("received unexpected reply msg with id $id");
		163
		164	push @{ $self->{ids} }, $id;
96		165
97	$cb->($self, @$msg);	166	$cb->($self, @$msg);
98	} else {	167	} else {
99	$msg->[0] = "on_$msg->[0]_notify";	168	$msg->[0] = "on_$msg->[0]_notify";
100	call $self, @$msg;	169	call $self, @$msg;
…		…
115	}	184	}
116		185
117	sub error {	186	sub error {
118	my ($self, $msg) = @_;	187	my ($self, $msg) = @_;
119		188
120	warn $msg;	189	call $self, on_error => $msg;
121		190
122	()	191	()
123	}	192	}
124		193
125	sub _req {	194	sub _req {
126	my $self = shift;	195	my $self = shift;
127	my $cb = pop;	196	my $cb = pop;
128		197
129	my $id = ++$self->{id};	198	my $id = (pop @{ $self->{ids} }) \|\| $self->{id}++;
130		199
131	unshift @_, $id;	200	unshift @_, $id;
132	$self->{cb}{$id} = $cb;	201	$self->{cb}{$id} = $cb;
133		202
134	my $msg = JSON::encode_json \@_;	203	my $msg = JSON::encode_json \@_;
135		204
136	$self->{hdl}->push_write ($msg);	205	$self->{hdl}->push_write ($msg);
137	}	206	}
138		207
		208	=item $api->req ($type => @args, $callback->($api, @reply))
		209
		210	Sends a generic request of type C<$type> to the server. When the server
		211	responds, the API object and the response arguments (without the success
		212	status) are passed to the callback, which is the last argument to this
		213	method.
		214
		215	If the request fails, then a fatal error will be raised. If you want to
		216	handle failures gracefully, you need to use C<< ->req_failok >> instead.
		217
		218	The available requests are documented in the Porttracker API
		219	documentation (a copy of which is included in this module as
		220	L<AnyEvent::Porttracker::protocol>.
		221
		222	It is permissible to call this (or any other request function) at any
		223	time, even before the connection has been established - the API object
		224	always waits until after login before it actually sends the requests, and
		225	queues them until then.
		226
		227	Example: ping the porttracker server.
		228
		229	$api->req ("ping", sub {
		230	my ($api, $ok, $timestamp, $pid) = @_;
		231	...
		232	});
		233
		234	Example: determine the product ID.
		235
		236	$api->req (product_id => sub {
		237	my ($api, $ok, $branding, $product_id) = @_;
		238	...
		239	});
		240
		241	Example: set a new license.
		242
		243	$api->req (set_license => $LICENSE_STRING, sub {
		244	my ($api, $ok) = @_;
		245
		246	$ok or die "failed to set license";
		247	});
		248
		249	=cut
		250
139	sub req {	251	sub req {
		252	my $cb = pop;
		253	push @_, sub {
		254	shift
		255	or $_[0]->error ($_[1]);
		256
		257	&$cb
		258	};
		259
140	$_[0]{queue}	260	$_[0]{queue}
141	? push @{ $_[0]{queue} }, [@_]	261	? push @{ $_[0]{queue} }, [@_]
142	: &_req	262	: &_req
143	}	263	}
144		264
145	sub unqueue {	265	=item $api->req_failok ($type => @args, $callback->($api, $success, @reply))
146	my ($self) = @_;
147		266
148	my $queue = delete $self->{queue}	267	Just like C<< ->req >>, with two differences: first, a failure will not
149	or return;	268	raise an error, second, the initial status reply which indicates success
		269	or failure is not removed before calling the callback.
150		270
151	_req @$_	271	=cut
152	for @$queue;	272
		273	sub req_failok {
		274	$_[0]{queue}
		275	? push @{ $_[0]{queue} }, [@_]
		276	: &_req
153	}	277	}
154		278
155	sub on_start_tls_notify {	279	sub on_start_tls_notify {
156	my ($self) = @_;	280	my ($self) = @_;
157		281
158	$self->{hdl}->starttls ("connect");	282	$self->{hdl}->starttls (connect => $self->{tls_ctx});
		283	$self->{tls} \|\|= 1;
159		284
160	$self->unqueue;	285	$self->_login;
161	}	286	}
162		287
163	sub on_hello_notify {	288	sub on_hello_notify {
164	my ($self, $version, $auths, $nonce) = @_;	289	my ($self, $version, $auths, $nonce) = @_;
165		290
166	$version == 1	291	$version == 1
167	or return $self->error ("protocol mismatch, got $version, expected/supported 1");	292	or return $self->error ("protocol mismatch, got $version, expected/supported 1");
168		293
169	$nonce = MIME::Base64::decode_base64 $nonce;	294	$nonce = MIME::Base64::decode_base64 $nonce;
170		295
		296	$self->{hello} = [$auths, $nonce];
		297
		298	$self->_login
		299	unless $self->{tls}; # delay login when trying to handshake tls
		300	}
		301
		302	sub _login_success {
		303	my ($self, $method) = @_;
		304
		305	_req @$_
		306	for @{ delete $self->{queue} };
		307
		308	call $self, on_login => $method;
		309	}
		310
		311	sub _login {
		312	my ($self) = @_;
		313
		314	my ($auths, $nonce) = @{ delete $self->{hello} or return };
		315
171	if (grep $_ eq "none", @$auths) {	316	if (grep $_ eq "none", @$auths) {
172	call $self, "on_login";	317	$self->_login_success ("none");
173		318
174	} elsif (grep $_ eq "login_cram_md6", @$auths) {	319	} elsif (grep $_ eq "login_cram_md6", @$auths) {
175	my $cc = join "", map chr 256 * rand, 0..63;	320	my $cc = join "", map chr 256 * rand, 0..63;
176		321
177	my $key = Digest::HMAC_MD6::hmac_md6 $self->{password}, $self->{username}, 64, 256;	322	my $key = Digest::HMAC_MD6::hmac_md6 $self->{pass}, $self->{user}, 64, 256;
178	my $cr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256;	323	my $cr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$cc$nonce", 64, 256;
179	my $sr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$nonce$cc", 64, 256;	324	my $sr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$nonce$cc", 64, 256;
180		325
181	$cc = MIME::Base64::encode_base64 $cc;	326	$cc = MIME::Base64::encode_base64 $cc;
182		327
183	$self->req (login_cram_md6 => $self->{username}, $cr, $cc, sub {	328	$self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub {
184	my ($self, $ok, $msg) = @_;	329	my ($self, $ok, $msg) = @_;
185		330
186	$ok	331	$ok
187	or return call $self, on_login_failure => $msg;	332	or return call $self, on_login_failure => $msg;
188		333
189	$msg eq $sr	334	$msg eq $sr
190	or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";	335	or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";
191		336
192	call $self, "on_login";	337	$self->_login_success ("login_cram_md6");
193	});	338	});
194	} elsif (grep $_ eq "login", @$auths) {	339	} elsif (grep $_ eq "login", @$auths) {
195	$self->req (login => $self->{username}, $self->{password}, sub {	340	$self->_req (login => $self->{user}, $self->{pass}, sub {
196	my ($self, $ok, $msg) = @_;	341	my ($self, $ok, $msg) = @_;
197		342
198	$ok	343	$ok
199	or return call $self, on_login_failure => $msg;	344	or return call $self, on_login_failure => $msg;
200		345
201	call $self, "on_login";	346	$self->_login_success ("login");
202	});	347	});
203	} else {	348	} else {
204	call $self, on_login_failure => "no supported auth method (@$auths)";	349	call $self, on_login_failure => "no supported auth method (@$auths)";
205	}	350	}
		351
		352	# we no longer need these, make it a bit harder to get them
		353	delete $self->{user};
		354	delete $self->{pass};
		355	}
		356
		357	sub on_info_notify {
		358	my ($self, $msg) = @_;
		359
		360	warn $msg;
		361	}
		362
		363	sub on_error_notify {
		364	my ($self, $msg) = @_;
		365
		366	$self->error ($msg);
		367	}
		368
		369	sub on_error {
		370	my ($self, $msg) = @_;
		371
		372	warn $msg;
		373
		374	%$self = ();
206	}	375	}
207		376
208	sub on_login_failure {	377	sub on_login_failure {
209	my ($self, $msg) = @_;	378	my ($self, $msg) = @_;
210		379
211	$msg =~ s/\n$//;	380	$msg =~ s/\n$//;
212	$self->error ("login failed: $msg");	381	$self->error ("login failed: $msg");
213	}	382	}
214		383
215	sub on_error_notify {
216	my ($self, $msg) = @_;
217
218	$self->error ($msg);
219	}
220
221	=back	384	=back
222		385
		386	=head2 EVENTS
		387
		388	AnyEvent::Porttracker conenctions are fully event-driven, and naturally
		389	there are a number of events that can occur. All these events have a name
		390	starting with C<on_> (example: C<on_login_failure>).
		391
		392	Programs can catch these events in two ways: either by providing
		393	constructor arguments with the event name as key and a coderef as value:
		394
		395	my $api = new AnyEvent::Porttracker
		396	host => ...,
		397	user => ..., pass => ...,
		398	on_error => sub {
		399	my ($api, $msg) = @_;
		400	warn $msg;
		401	exit 1;
		402	},
		403	;
		404
		405	Or by subclassing C<AnyEvent::Porttracker> and overriding methods of the
		406	same name:
		407
		408	package MyClass;
		409
		410	use base AnyEvent::Porttracker;
		411
		412	sub on_error {
		413	my ($api, $msg) = @_;
		414	warn $msg;
		415	exit 1;
		416	}
		417
		418	Event callbacks are not expected to return anything and are always passed
		419	the API object as first argument. Some might have default implementations
		420	(for example, C<on_error>), others are ignored unless overriden.
		421
		422	Description of individual events follow:
		423
		424	=over 4
		425
		426	=item on_error $api, $msg
		427
		428	Is called for every (fatal) error, including C<error> notifies. The
		429	default prints the message and destroys the object, so it is highly
		430	advisable to override this event.
		431
		432	=item on_login $api, $method
		433
		434	Called after a successful login, after which commands can be send. It is
		435	permissible to send commands before a successful login: those will be
		436	queued and sent just before this event is invoked. C<$method> is the auth
		437	method that was used.
		438
		439	=item on_login_failure $api, $msg
		440
		441	Called when all login attempts have failed - the default raises a fatal
		442	error with the error message from the server.
		443
		444	=item on_hello_notify $api, $version, $authtypes, $nonce
		445
		446	This protocol notification is used internally by AnyEvent::Porttracker -
		447	you can override it, but the module will most likely not work.
		448
		449	=item on_info_notify $api, $msg
		450
		451	Called for informational messages from the server - the default
		452	implementation calls C<warn> but otherwise ignores this notification.
		453
		454	=item on_error_notify $api, $msg
		455
		456	Called for fatal errors from the server - the default implementation calls
		457	C<warn> and destroys the API object.
		458
		459	=item on_start_tls_notify $api
		460
		461	Called when the server wants to start TLS negotiation. This is used
		462	internally and - while it is possible to override it - should not be
		463	overriden.
		464
		465	=item on_XYZ_notify $api, ...
		466
		467	In general, any protocol notification will result in an event of the form
		468	C<on_NOTIFICATION_notify>.
		469
		470	=back
		471
223	=head1 SEE ALSO	472	=head1 SEE ALSO
224		473
225	L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>.	474	L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>.
226		475
227	=head1 AUTHOR	476	=head1 AUTHOR

Diff Legend

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

Comparing cvsroot/AnyEvent-Porttracker/Porttracker.pm (file contents): Revision 1.2 by root, Mon Nov 15 04:57:39 2010 UTC vs. Revision 1.6 by root, Tue Nov 16 01:10:50 2010 UTC

Diff Legend

Comparing cvsroot/AnyEvent-Porttracker/Porttracker.pm (file contents):
Revision 1.2 by root, Mon Nov 15 04:57:39 2010 UTC vs.
Revision 1.6 by root, Tue Nov 16 01:10:50 2010 UTC