[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.8 by root, Tue Nov 16 01:22:03 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 => $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]);
		144	},
		145	on_connect => sub {
		146	if ($self->{tls}) {
		147	$self->_req (start_tls => sub {
		148	$_[1]
		149	or return $self->error ("TLS rejected by server");
		150
		151	$self->_login;
		152	});
		153	}
76	},	154	},
77	on_read => sub {	155	on_read => sub {
78	while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {	156	while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {
79	my $msg = JSON::decode_json $1;	157	my $msg = JSON::decode_json $1;
80	my $id = shift @$msg;	158	my $id = shift @$msg;
81		159
82	if (defined $id) {	160	if (defined $id) {
83	my $cb = delete $self->{cb}{$id}	161	my $cb = delete $self->{cb}{$id}
84	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;
85		165
86	$cb->($self, @$msg);	166	$cb->($self, @$msg);
87	} else {	167	} else {
88	$msg->[0] = "on_$msg->[0]_notify";	168	$msg->[0] = "on_$msg->[0]_notify";
89	call $self, @$msg;	169	call $self, @$msg;
…		…
104	}	184	}
105		185
106	sub error {	186	sub error {
107	my ($self, $msg) = @_;	187	my ($self, $msg) = @_;
108		188
109	warn $msg;	189	call $self, on_error => $msg;
110		190
111	()	191	()
112	}	192	}
113		193
114	sub send {	194	sub _req {
115	my $self = shift;	195	my $self = shift;
116	my $cb = pop;	196	my $cb = pop;
117		197
118	my $id = ++$self->{id};	198	my $id = (pop @{ $self->{ids} }) \|\| $self->{id}++;
119		199
120	unshift @_, $id;	200	unshift @_, $id;
121	$self->{cb}{$id} = $cb;	201	$self->{cb}{$id} = $cb;
122		202
123	my $msg = JSON::encode_json \@_;	203	my $msg = JSON::encode_json \@_;
124		204
125	$self->{hdl}->push_write ($msg);	205	$self->{hdl}->push_write ($msg);
126	}	206	}
127		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
		251	sub req {
		252	my $cb = pop;
		253	push @_, sub {
		254	splice @_, 1, 1
		255	or $_[0]->error ($_[1]);
		256
		257	&$cb
		258	};
		259
		260	$_[0]{queue}
		261	? push @{ $_[0]{queue} }, [@_]
		262	: &_req
		263	}
		264
		265	=item $api->req_failok ($type => @args, $callback->($api, $success, @reply))
		266
		267	Just like C<< ->req >>, with two differences: first, a failure will not
		268	raise an error, second, the initial status reply which indicates success
		269	or failure is not removed before calling the callback.
		270
		271	=cut
		272
		273	sub req_failok {
		274	$_[0]{queue}
		275	? push @{ $_[0]{queue} }, [@_]
		276	: &_req
		277	}
		278
		279	sub on_start_tls_notify {
		280	my ($self) = @_;
		281
		282	$self->{hdl}->starttls (connect => $self->{tls_ctx});
		283	$self->{tls} \|\|= 1;
		284
		285	$self->_login;
		286	}
		287
128	sub on_hello_notify {	288	sub on_hello_notify {
129	my ($self, $version, $auths, $nonce) = @_;	289	my ($self, $version, $auths, $nonce) = @_;
130		290
131	$version == 1	291	$version == 1
132	or return $self->error ("protocol mismatch, got $version, expected/supported 1");	292	or return $self->error ("protocol mismatch, got $version, expected/supported 1");
133		293
134	$nonce = MIME::Base64::decode_base64 $nonce;	294	$nonce = MIME::Base64::decode_base64 $nonce;
135		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
136	if (grep $_ eq "none", @$auths) {	316	if (grep $_ eq "none", @$auths) {
137	# successfully authenticated...	317	$self->_login_success ("none");
		318
138	} elsif (grep $_ eq "login_cram_md6", @$auths) {	319	} elsif (grep $_ eq "login_cram_md6", @$auths) {
139	my $cc = join "", map chr 256 * rand, 0..63;	320	my $cc = join "", map chr 256 * rand, 0..63;
140		321
141	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;
142	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;
143	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;
144		325
145	$cc = MIME::Base64::encode_base64 $cc;	326	$cc = MIME::Base64::encode_base64 $cc;
146		327
147	$self->send (login_cram_md6 => $self->{username}, $cr, $cc, sub {	328	$self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub {
148	my ($self, $ok, $msg) = @_;	329	my ($self, $ok, $msg) = @_;
149		330
150	$ok	331	$ok
151	or return call $self, on_login_failure => $msg;	332	or return call $self, on_login_failure => $msg;
152		333
153	$msg eq $sr	334	$msg eq $sr
154	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";
155		336
156	call $self, "on_login"	337	$self->_login_success ("login_cram_md6");
157	});	338	});
158	} elsif (grep $_ eq "login", @$auths) {	339	} elsif (grep $_ eq "login", @$auths) {
159	$self->send (login => $self->{username}, $self->{password}, sub {	340	$self->_req (login => $self->{user}, $self->{pass}, sub {
160	my ($self, $ok, $msg) = @_;	341	my ($self, $ok, $msg) = @_;
161		342
162	$ok	343	$ok
163	or return call $self, on_login_failure => $msg;	344	or return call $self, on_login_failure => $msg;
164		345
165	call $self, "on_login"	346	$self->_login_success ("login");
166	});	347	});
167	} else {	348	} else {
168	return $self->error ("no supported auth method (@$auths)");	349	call $self, on_login_failure => "no supported auth method (@$auths)";
169	}	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 = ();
170	}	375	}
171		376
172	sub on_login_failure {	377	sub on_login_failure {
173	my ($self, $msg) = @_;	378	my ($self, $msg) = @_;
174		379
175	$msg =~ s/\n$//;	380	$msg =~ s/\n$//;
176	$self->error ("login failed: $msg");	381	$self->error ("login failed: $msg");
177	}	382	}
178		383
		384	sub on_event_notify {
		385	my ($self, $event, @args) = @_;
		386
		387	call $self, "on_${event}_event", @args;
		388	}
		389
179	=back	390	=back
180		391
		392	=head2 EVENTS
		393
		394	AnyEvent::Porttracker conenctions are fully event-driven, and naturally
		395	there are a number of events that can occur. All these events have a name
		396	starting with C<on_> (example: C<on_login_failure>).
		397
		398	Programs can catch these events in two ways: either by providing
		399	constructor arguments with the event name as key and a coderef as value:
		400
		401	my $api = new AnyEvent::Porttracker
		402	host => ...,
		403	user => ..., pass => ...,
		404	on_error => sub {
		405	my ($api, $msg) = @_;
		406	warn $msg;
		407	exit 1;
		408	},
		409	;
		410
		411	Or by subclassing C<AnyEvent::Porttracker> and overriding methods of the
		412	same name:
		413
		414	package MyClass;
		415
		416	use base AnyEvent::Porttracker;
		417
		418	sub on_error {
		419	my ($api, $msg) = @_;
		420	warn $msg;
		421	exit 1;
		422	}
		423
		424	Event callbacks are not expected to return anything and are always passed
		425	the API object as first argument. Some might have default implementations
		426	(for example, C<on_error>), others are ignored unless overriden.
		427
		428	Description of individual events follow:
		429
		430	=over 4
		431
		432	=item on_error $api, $msg
		433
		434	Is called for every (fatal) error, including C<error> notifies. The
		435	default prints the message and destroys the object, so it is highly
		436	advisable to override this event.
		437
		438	=item on_login $api, $method
		439
		440	Called after a successful login, after which commands can be send. It is
		441	permissible to send commands before a successful login: those will be
		442	queued and sent just before this event is invoked. C<$method> is the auth
		443	method that was used.
		444
		445	=item on_login_failure $api, $msg
		446
		447	Called when all login attempts have failed - the default raises a fatal
		448	error with the error message from the server.
		449
		450	=item on_hello_notify $api, $version, $authtypes, $nonce
		451
		452	This protocol notification is used internally by AnyEvent::Porttracker -
		453	you can override it, but the module will most likely not work.
		454
		455	=item on_info_notify $api, $msg
		456
		457	Called for informational messages from the server - the default
		458	implementation calls C<warn> but otherwise ignores this notification.
		459
		460	=item on_error_notify $api, $msg
		461
		462	Called for fatal errors from the server - the default implementation calls
		463	C<warn> and destroys the API object.
		464
		465	=item on_start_tls_notify $api
		466
		467	Called when the server wants to start TLS negotiation. This is used
		468	internally and - while it is possible to override it - should not be
		469	overriden.
		470
		471	=item on_event_notify $api, $eventname, @args
		472
		473	Called when the server broadcasts an event the API object is subscribed
		474	to. The default implementation (which should not be overridden) simply
		475	re-issues an "on_evenname_event" event with the @args.
		476
		477	=item on_XYZ_notify $api, ...
		478
		479	In general, any protocol notification will result in an event of the form
		480	C<on_NOTIFICATION_notify>.
		481
		482	=item on_XYZ_event $api, ...
		483
		484	Called when the server broadcasts the named (XYZ) event.
		485
		486	=back
		487
181	=head1 SEE ALSO	488	=head1 SEE ALSO
182		489
183	L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>.	490	L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>.
184		491
185	=head1 AUTHOR	492	=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.8 by root, Tue Nov 16 01:22:03 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.8 by root, Tue Nov 16 01:22:03 2010 UTC