[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.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
…		…
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);
…		…
74	on_error => sub {	127	on_error => sub {
75	$self->error ();	128	$self->error ();
76	},	129	},
77	on_connect => sub {	130	on_connect => sub {
78	if ($self->{tls}) {	131	if ($self->{tls}) {
79	$self->{queue} \|\|= [];
80	$self->_req (start_tls => sub {	132	$self->_req (start_tls => sub {
81	$_[1]	133	$_[1]
82	or return $self->error ("TLS rejected by server");	134	or return $self->error ("TLS rejected by server");
83		135
84	$self->unqueue;	136	$self->_login;
85	});	137	});
86	}	138	}
87	},	139	},
88	on_read => sub {	140	on_read => sub {
89	while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {	141	while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {
…		…
91	my $id = shift @$msg;	143	my $id = shift @$msg;
92		144
93	if (defined $id) {	145	if (defined $id) {
94	my $cb = delete $self->{cb}{$id}	146	my $cb = delete $self->{cb}{$id}
95	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;
96		150
97	$cb->($self, @$msg);	151	$cb->($self, @$msg);
98	} else {	152	} else {
99	$msg->[0] = "on_$msg->[0]_notify";	153	$msg->[0] = "on_$msg->[0]_notify";
100	call $self, @$msg;	154	call $self, @$msg;
…		…
115	}	169	}
116		170
117	sub error {	171	sub error {
118	my ($self, $msg) = @_;	172	my ($self, $msg) = @_;
119		173
120	warn $msg;	174	call on_error => $msg;
121		175
122	()	176	()
123	}	177	}
124		178
125	sub _req {	179	sub _req {
126	my $self = shift;	180	my $self = shift;
127	my $cb = pop;	181	my $cb = pop;
128		182
129	my $id = ++$self->{id};	183	my $id = (pop @{ $self->{ids} }) \|\| $self->{id}++;
130		184
131	unshift @_, $id;	185	unshift @_, $id;
132	$self->{cb}{$id} = $cb;	186	$self->{cb}{$id} = $cb;
133		187
134	my $msg = JSON::encode_json \@_;	188	my $msg = JSON::encode_json \@_;
135		189
136	$self->{hdl}->push_write ($msg);	190	$self->{hdl}->push_write ($msg);
137	}	191	}
		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
138		231
139	sub req {	232	sub req {
140	$_[0]{queue}	233	$_[0]{queue}
141	? push @{ $_[0]{queue} }, [@_]	234	? push @{ $_[0]{queue} }, [@_]
142	: &_req	235	: &_req
143	}	236	}
144		237
145	sub unqueue {
146	my ($self) = @_;
147
148	my $queue = delete $self->{queue}
149	or return;
150
151	_req @$_
152	for @$queue;
153	}
154
155	sub on_start_tls_notify {	238	sub on_start_tls_notify {
156	my ($self) = @_;	239	my ($self) = @_;
157		240
158	$self->{hdl}->starttls ("connect");	241	$self->{hdl}->starttls ("connect");
		242	$self->{tls} \|\|= 1;
159		243
160	$self->unqueue;	244	$self->_login;
161	}	245	}
162		246
163	sub on_hello_notify {	247	sub on_hello_notify {
164	my ($self, $version, $auths, $nonce) = @_;	248	my ($self, $version, $auths, $nonce) = @_;
165		249
166	$version == 1	250	$version == 1
167	or return $self->error ("protocol mismatch, got $version, expected/supported 1");	251	or return $self->error ("protocol mismatch, got $version, expected/supported 1");
168		252
169	$nonce = MIME::Base64::decode_base64 $nonce;	253	$nonce = MIME::Base64::decode_base64 $nonce;
170		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
171	if (grep $_ eq "none", @$auths) {	275	if (grep $_ eq "none", @$auths) {
172	call $self, "on_login";	276	$self->_login_success ("none");
173		277
174	} elsif (grep $_ eq "login_cram_md6", @$auths) {	278	} elsif (grep $_ eq "login_cram_md6", @$auths) {
175	my $cc = join "", map chr 256 * rand, 0..63;	279	my $cc = join "", map chr 256 * rand, 0..63;
176		280
177	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;
178	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;
179	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;
180		284
181	$cc = MIME::Base64::encode_base64 $cc;	285	$cc = MIME::Base64::encode_base64 $cc;
182		286
183	$self->req (login_cram_md6 => $self->{username}, $cr, $cc, sub {	287	$self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub {
184	my ($self, $ok, $msg) = @_;	288	my ($self, $ok, $msg) = @_;
185		289
186	$ok	290	$ok
187	or return call $self, on_login_failure => $msg;	291	or return call $self, on_login_failure => $msg;
188		292
189	$msg eq $sr	293	$msg eq $sr
190	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";
191		295
192	call $self, "on_login";	296	$self->_login_success ("login_cram_md6");
193	});	297	});
194	} elsif (grep $_ eq "login", @$auths) {	298	} elsif (grep $_ eq "login", @$auths) {
195	$self->req (login => $self->{username}, $self->{password}, sub {	299	$self->_req (login => $self->{user}, $self->{pass}, sub {
196	my ($self, $ok, $msg) = @_;	300	my ($self, $ok, $msg) = @_;
197		301
198	$ok	302	$ok
199	or return call $self, on_login_failure => $msg;	303	or return call $self, on_login_failure => $msg;
200		304
201	call $self, "on_login";	305	$self->_login_success ("login");
202	});	306	});
203	} else {	307	} else {
204	call $self, on_login_failure => "no supported auth method (@$auths)";	308	call $self, on_login_failure => "no supported auth method (@$auths)";
205	}	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 = ();
206	}	334	}
207		335
208	sub on_login_failure {	336	sub on_login_failure {
209	my ($self, $msg) = @_;	337	my ($self, $msg) = @_;
210		338
211	$msg =~ s/\n$//;	339	$msg =~ s/\n$//;
212	$self->error ("login failed: $msg");	340	$self->error ("login failed: $msg");
213	}	341	}
214		342
215	sub on_error_notify {
216	my ($self, $msg) = @_;
217
218	$self->error ($msg);
219	}
220
221	=back	343	=back
222		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
223	=head1 SEE ALSO	431	=head1 SEE ALSO
224		432
225	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>.
226		434
227	=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.2 by root, Mon Nov 15 04:57:39 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.2 by root, Mon Nov 15 04:57:39 2010 UTC vs.
Revision 1.5 by root, Mon Nov 15 20:43:11 2010 UTC