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