[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.11 by root, Tue Nov 16 02:09:00 2010 UTC

…		…
3	AnyEvent::Porttracker - Porttracker/PortIQ API client interface.	3	AnyEvent::Porttracker - Porttracker/PortIQ API client interface.
4		4
5	=head1 SYNOPSIS	5	=head1 SYNOPSIS
6		6
7	use AnyEvent::Porttracker;	7	use AnyEvent::Porttracker;
		8
		9	my $api = new AnyEvent::Porttracker
		10	host => "10.0.0.1",
		11	user => "admin",
		12	pass => "31331",
		13	tls => 1,
		14	;
		15
		16	# Example 1
		17	# a simple request: ping the server
		18
		19	$api->req ("ping", sub {
		20	my ($api, $ok, $timestamp, $pid) = @_;
		21	...
		22	});
		23
		24	# Example 2
		25	# find all realms, start a discovery on all of them
		26	# and wait until all discovery processes have finished
		27
		28	my $cv = AE::cv;
		29
		30	$cv->begin;
		31	# find all realms
		32	$api->req (realm_info => ["gid", "name"], sub {
		33	my ($api, @realms) = @_;
		34
		35	# start discovery on all realms
		36	for my $realm (@realms) {
		37	my ($gid, $name) = @$realm;
		38
		39	$cv->begin;
		40	$api->req (realm_discover => $realm->[0], sub {
		41	warn "discovery for realm '$realm->[1]' finished\n";
		42	$cv->end;
		43	});
		44	}
		45
		46	$cv->end;
		47	});
		48
		49	$cv->recv;
		50
		51	# Example 3
		52	# subscribe to realm_poll_stop events and report each occurance
		53
		54	$api->req (subscribe => "realm_poll_stop", sub {});
		55	$api->on (realm_poll_stop_event => sub {
		56	my ($api, $gid) = @_;
		57	warn "this just in: poll for realm <$gid> finished.\n";
		58	});
8		59
9	=head1 DESCRIPTION	60	=head1 DESCRIPTION
10		61
11	Porttracker (L<http://www.porttracker.com/>) is a product that (among	62	Porttracker (L<http://www.porttracker.com/>) is a product that (among
12	other things) scans switches and routers in a network and gives a coherent	63	other things) scans switches and routers in a network and gives a coherent
…		…
21	module will be of little value to you.	72	module will be of little value to you.
22		73
23	This module is an L<AnyEvent> user, you need to make sure that you use and	74	This module is an L<AnyEvent> user, you need to make sure that you use and
24	run a supported event loop.	75	run a supported event loop.
25		76
		77	To quickly understand how this module works you should read how to
		78	construct a new connection object and then read about the event/callback
		79	system.
		80
		81	The actual low-level protocol and, more importantly, the existing
		82	requests and responses, are documented in the official Porttracker
		83	API documentation (a copy of which is included in this module as
		84	L<AnyEvent::Porttracker::protocol>.
		85
26	=head1 THE AnyEvent::Porttracker CLASS	86	=head1 THE AnyEvent::Porttracker CLASS
		87
		88	The AnyEvent::Porttracker class represents a single connection.
27		89
28	=over 4	90	=over 4
29		91
30	=cut	92	=cut
31		93
…		…
52	: ($type = (UNIVERSAL::can $self, $type))	114	: ($type = (UNIVERSAL::can $self, $type))
53	? $type->($self, @args)	115	? $type->($self, @args)
54	: ()	116	: ()
55	}	117	}
56		118
57	=item new AnyEvent::Porttracker	119	=item $api = new AnyEvent::Porttracker [key => value...]
		120
		121	Creates a new porttracker API connection object and tries to connect to
		122	the specified host (see below). After the connection has been established,
		123	the TLS handshake (if requested) will take place, followed by a login
		124	attempt using either the C<none>, C<login_cram_md6> or C<login> methods,
		125	in this order of preference (typically, C<login_cram_md6> is used, which
		126	shields against some man-in-the-middle attacks and avoids transferring the
		127	password).
		128
		129	It is permissible to send requests immediately after creating the object -
		130	they will be queued until after successful login.
		131
		132	Possible key-value pairs are:
		133
		134	=over 4
		135
		136	=item host => $hostname [MANDATORY]
		137
		138	The hostname or IP address of the Porttracker box.
		139
		140	=item port => $service
		141
		142	The service (port) to use (default: C<porttracker=55>).
		143
		144	=item user => $string, pass => $string
		145
		146	These are the username and password to use when authentication is required
		147	(which it is in almost all cases, so these keys are normally mandatory).
		148
		149	=item tls => $bool
		150
		151	Enables or disables TLS (default: disables). When enabled, then the
		152	connection will try to handshake a TLS connection before logging in. If
		153	unsuccessful a fatal error will be raised.
		154
		155	Since most Porttracker/PortIQ boxes will not have a sensible/verifiable
		156	certificate, no attempt at verifying it will be done (which means
		157	man-in-the-middle-attacks will be trivial). If you want some form of
		158	verification you need to provide your own C<tls_ctx> object with C<<
		159	verify => 1, verify_peername => [1, 1, 1] >> or whatever verification mode
		160	you wish to use.
		161
		162	=item tls_ctx => $tls_ctx
		163
		164	The L<AnyEvent::TLS> object to use. See C<tls>, above.
		165
		166	=item on_XYZ => $coderef
		167
		168	You can specify event callbacks either by sub-classing and overriding the
		169	respective methods or by specifying code-refs as key-value pairs when
		170	constructing the object. You add or remove event handlers at any time with
		171	the C<event> method.
		172
		173	=back
58		174
59	=cut	175	=cut
60		176
61	sub new {	177	sub new {
62	my $class = shift;	178	my $class = shift;
63		179
64	my $self = bless {	180	my $self = bless {
65	id => "a",	181	id => "a",
		182	ids => [],
		183	queue => [], # initially queue everything
66	@_,	184	@_,
67	}, $class;	185	}, $class;
68		186
69	{	187	{
70	Scalar::Util::weaken (my $self = $self);	188	Scalar::Util::weaken (my $self = $self);
71		189
72	$self->{hdl} = new AnyEvent::Handle	190	$self->{hdl} = new AnyEvent::Handle
73	connect => [$self->{host}, $self->{port} \|\| "porttracker=55"],	191	connect => [$self->{host}, $self->{port} \|\| "porttracker=55"],
74	on_error => sub {	192	on_error => sub {
75	$self->error ();	193	$self->error ($_[2]);
76	},	194	},
77	on_connect => sub {	195	on_connect => sub {
78	if ($self->{tls}) {	196	if ($self->{tls}) {
79	$self->{queue} \|\|= [];
80	$self->_req (start_tls => sub {	197	$self->_req (start_tls => sub {
81	$_[1]	198	$_[1]
82	or return $self->error ("TLS rejected by server");	199	or return $self->error ("TLS rejected by server");
83		200
84	$self->unqueue;	201	$self->_login;
85	});	202	});
86	}	203	}
87	},	204	},
88	on_read => sub {	205	on_read => sub {
89	while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {	206	while ($_[0]{rbuf} =~ s/^([^\x0a]*)\x0a//) {
…		…
91	my $id = shift @$msg;	208	my $id = shift @$msg;
92		209
93	if (defined $id) {	210	if (defined $id) {
94	my $cb = delete $self->{cb}{$id}	211	my $cb = delete $self->{cb}{$id}
95	or return $self->error ("received unexpected reply msg with id $id");	212	or return $self->error ("received unexpected reply msg with id $id");
		213
		214	push @{ $self->{ids} }, $id;
96		215
97	$cb->($self, @$msg);	216	$cb->($self, @$msg);
98	} else {	217	} else {
99	$msg->[0] = "on_$msg->[0]_notify";	218	$msg->[0] = "on_$msg->[0]_notify";
100	call $self, @$msg;	219	call $self, @$msg;
…		…
115	}	234	}
116		235
117	sub error {	236	sub error {
118	my ($self, $msg) = @_;	237	my ($self, $msg) = @_;
119		238
120	warn $msg;	239	call $self, on_error => $msg;
121		240
122	()	241	()
123	}	242	}
124		243
125	sub _req {	244	sub _req {
126	my $self = shift;	245	my $self = shift;
127	my $cb = pop;	246	my $cb = pop;
128		247
129	my $id = ++$self->{id};	248	my $id = (pop @{ $self->{ids} }) \|\| $self->{id}++;
130		249
131	unshift @_, $id;	250	unshift @_, $id;
132	$self->{cb}{$id} = $cb;	251	$self->{cb}{$id} = $cb;
133		252
134	my $msg = JSON::encode_json \@_;	253	my $msg = JSON::encode_json \@_;
135		254
136	$self->{hdl}->push_write ($msg);	255	$self->{hdl}->push_write ($msg);
137	}	256	}
138		257
		258	=item $api->req ($type => @args, $callback->($api, @reply))
		259
		260	Sends a generic request of type C<$type> to the server. When the server
		261	responds, the API object and the response arguments (without the success
		262	status) are passed to the callback, which is the last argument to this
		263	method.
		264
		265	If the request fails, then a fatal error will be raised. If you want to
		266	handle failures gracefully, you need to use C<< ->req_failok >> instead.
		267
		268	The available requests are documented in the Porttracker API
		269	documentation (a copy of which is included in this module as
		270	L<AnyEvent::Porttracker::protocol>.
		271
		272	It is permissible to call this (or any other request function) at any
		273	time, even before the connection has been established - the API object
		274	always waits until after login before it actually sends the requests, and
		275	queues them until then.
		276
		277	Example: ping the porttracker server.
		278
		279	$api->req ("ping", sub {
		280	my ($api, $ok, $timestamp, $pid) = @_;
		281	...
		282	});
		283
		284	Example: determine the product ID.
		285
		286	$api->req (product_id => sub {
		287	my ($api, $ok, $branding, $product_id) = @_;
		288	...
		289	});
		290
		291	Example: set a new license.
		292
		293	$api->req (set_license => $LICENSE_STRING, sub {
		294	my ($api, $ok) = @_;
		295
		296	$ok or die "failed to set license";
		297	});
		298
		299	=cut
		300
139	sub req {	301	sub req {
		302	my $cb = pop;
		303	push @_, sub {
		304	splice @_, 1, 1
		305	or $_[0]->error ($_[1]);
		306
		307	&$cb
		308	};
		309
140	$_[0]{queue}	310	$_[0]{queue}
141	? push @{ $_[0]{queue} }, [@_]	311	? push @{ $_[0]{queue} }, [@_]
142	: &_req	312	: &_req
143	}	313	}
144		314
145	sub unqueue {	315	=item $api->req_failok ($type => @args, $callback->($api, $success, @reply))
		316
		317	Just like C<< ->req >>, with two differences: first, a failure will not
		318	raise an error, second, the initial status reply which indicates success
		319	or failure is not removed before calling the callback.
		320
		321	=cut
		322
		323	sub req_failok {
		324	$_[0]{queue}
		325	? push @{ $_[0]{queue} }, [@_]
		326	: &_req
		327	}
		328
		329	=item $api->on (XYZ => $callback)
		330
		331	Overwrites any currently registered handler for C<on_XYZ> or
		332	installs a new one. Or, when C<$callback> is undef, unregisters any
		333	currently-registered handler.
		334
		335	Example: replace/set the handler for C<on_discover_stop_event>.
		336
		337	$api->on (discover_stop_event => sub {
		338	my ($api, $gid) = @_;
		339	...
		340	});
		341
		342	=cut
		343
		344	sub on {
146	my ($self) = @_;	345	my $self = shift;
147		346
148	my $queue = delete $self->{queue}	347	while (@_) {
149	or return;	348	my ($event, $cb) = splice @_, 0, 2;
		349	$event =~ s/^on_//;
150		350
151	_req @$_	351	$self->{"on_$event"} = $cb;
152	for @$queue;	352	}
153	}	353	}
154		354
155	sub on_start_tls_notify {	355	sub on_start_tls_notify {
156	my ($self) = @_;	356	my ($self) = @_;
157		357
158	$self->{hdl}->starttls ("connect");	358	$self->{hdl}->starttls (connect => $self->{tls_ctx});
		359	$self->{tls} \|\|= 1;
159		360
160	$self->unqueue;	361	$self->_login;
161	}	362	}
162		363
163	sub on_hello_notify {	364	sub on_hello_notify {
164	my ($self, $version, $auths, $nonce) = @_;	365	my ($self, $version, $auths, $nonce) = @_;
165		366
166	$version == 1	367	$version == 1
167	or return $self->error ("protocol mismatch, got $version, expected/supported 1");	368	or return $self->error ("protocol mismatch, got $version, expected/supported 1");
168		369
169	$nonce = MIME::Base64::decode_base64 $nonce;	370	$nonce = MIME::Base64::decode_base64 $nonce;
170		371
		372	$self->{hello} = [$auths, $nonce];
		373
		374	$self->_login
		375	unless $self->{tls}; # delay login when trying to handshake tls
		376	}
		377
		378	sub _login_success {
		379	my ($self, $method) = @_;
		380
		381	_req @$_
		382	for @{ delete $self->{queue} };
		383
		384	call $self, on_login => $method;
		385	}
		386
		387	sub _login {
		388	my ($self) = @_;
		389
		390	my ($auths, $nonce) = @{ delete $self->{hello} or return };
		391
171	if (grep $_ eq "none", @$auths) {	392	if (grep $_ eq "none", @$auths) {
172	call $self, "on_login";	393	$self->_login_success ("none");
173		394
174	} elsif (grep $_ eq "login_cram_md6", @$auths) {	395	} elsif (grep $_ eq "login_cram_md6", @$auths) {
175	my $cc = join "", map chr 256 * rand, 0..63;	396	my $cc = join "", map chr 256 * rand, 0..63;
176		397
177	my $key = Digest::HMAC_MD6::hmac_md6 $self->{password}, $self->{username}, 64, 256;	398	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;	399	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;	400	my $sr = Digest::HMAC_MD6::hmac_md6_base64 $key, "$nonce$cc", 64, 256;
180		401
181	$cc = MIME::Base64::encode_base64 $cc;	402	$cc = MIME::Base64::encode_base64 $cc;
182		403
183	$self->req (login_cram_md6 => $self->{username}, $cr, $cc, sub {	404	$self->_req (login_cram_md6 => $self->{user}, $cr, $cc, sub {
184	my ($self, $ok, $msg) = @_;	405	my ($self, $ok, $msg) = @_;
185		406
186	$ok	407	$ok
187	or return call $self, on_login_failure => $msg;	408	or return call $self, on_login_failure => $msg;
188		409
189	$msg eq $sr	410	$msg eq $sr
190	or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";	411	or return call $self, on_login_failure => "sr and cr mismatch, possible man in the middle attack";
191		412
192	call $self, "on_login";	413	$self->_login_success ("login_cram_md6");
193	});	414	});
194	} elsif (grep $_ eq "login", @$auths) {	415	} elsif (grep $_ eq "login", @$auths) {
195	$self->req (login => $self->{username}, $self->{password}, sub {	416	$self->_req (login => $self->{user}, $self->{pass}, sub {
196	my ($self, $ok, $msg) = @_;	417	my ($self, $ok, $msg) = @_;
197		418
198	$ok	419	$ok
199	or return call $self, on_login_failure => $msg;	420	or return call $self, on_login_failure => $msg;
200		421
201	call $self, "on_login";	422	$self->_login_success ("login");
202	});	423	});
203	} else {	424	} else {
204	call $self, on_login_failure => "no supported auth method (@$auths)";	425	call $self, on_login_failure => "no supported auth method (@$auths)";
205	}	426	}
		427
		428	# we no longer need these, make it a bit harder to get them
		429	delete $self->{user};
		430	delete $self->{pass};
		431	}
		432
		433	sub on_info_notify {
		434	my ($self, $msg) = @_;
		435
		436	warn $msg;
		437	}
		438
		439	sub on_error_notify {
		440	my ($self, $msg) = @_;
		441
		442	$self->error ($msg);
		443	}
		444
		445	sub on_error {
		446	my ($self, $msg) = @_;
		447
		448	warn $msg;
		449
		450	%$self = ();
206	}	451	}
207		452
208	sub on_login_failure {	453	sub on_login_failure {
209	my ($self, $msg) = @_;	454	my ($self, $msg) = @_;
210		455
211	$msg =~ s/\n$//;	456	$msg =~ s/\n$//;
212	$self->error ("login failed: $msg");	457	$self->error ("login failed: $msg");
213	}	458	}
214		459
215	sub on_error_notify {	460	sub on_event_notify {
216	my ($self, $msg) = @_;	461	my ($self, $event, @args) = @_;
217		462
218	$self->error ($msg);	463	call $self, "on_${event}_event", @args;
219	}	464	}
220		465
221	=back	466	=back
222		467
		468	=head1 EVENTS
		469
		470	AnyEvent::Porttracker connections are fully event-driven, and naturally
		471	there are a number of events that can occur. All these events have a name
		472	starting with C<on_> (example: C<on_login_failure>).
		473
		474	Programs can catch these events in two ways: either by providing
		475	constructor arguments with the event name as key and a code-ref as value:
		476
		477	my $api = new AnyEvent::Porttracker
		478	host => ...,
		479	user => ..., pass => ...,
		480	on_error => sub {
		481	my ($api, $msg) = @_;
		482	warn $msg;
		483	exit 1;
		484	},
		485	;
		486
		487	Or by sub-classing C<AnyEvent::Porttracker> and overriding methods of the
		488	same name:
		489
		490	package MyClass;
		491
		492	use base AnyEvent::Porttracker;
		493
		494	sub on_error {
		495	my ($api, $msg) = @_;
		496	warn $msg;
		497	exit 1;
		498	}
		499
		500	Event callbacks are not expected to return anything and are always passed
		501	the API object as first argument. Some might have default implementations
		502	(for example, C<on_error>), others are ignored unless overriden.
		503
		504	Description of individual events follow:
		505
		506	=over 4
		507
		508	=item on_error $api, $msg
		509
		510	Is called for every (fatal) error, including C<error> notifies. The
		511	default prints the message and destroys the object, so it is highly
		512	advisable to override this event.
		513
		514	=item on_login $api, $method
		515
		516	Called after a successful login, after which commands can be send. It is
		517	permissible to send commands before a successful login: those will be
		518	queued and sent just before this event is invoked. C<$method> is the auth
		519	method that was used.
		520
		521	=item on_login_failure $api, $msg
		522
		523	Called when all login attempts have failed - the default raises a fatal
		524	error with the error message from the server.
		525
		526	=item on_hello_notify $api, $version, $authtypes, $nonce
		527
		528	This protocol notification is used internally by AnyEvent::Porttracker -
		529	you can override it, but the module will most likely not work.
		530
		531	=item on_info_notify $api, $msg
		532
		533	Called for informational messages from the server - the default
		534	implementation calls C<warn> but otherwise ignores this notification.
		535
		536	=item on_error_notify $api, $msg
		537
		538	Called for fatal errors from the server - the default implementation calls
		539	C<warn> and destroys the API object.
		540
		541	=item on_start_tls_notify $api
		542
		543	Called when the server wants to start TLS negotiation. This is used
		544	internally and - while it is possible to override it - should not be
		545	overridden.
		546
		547	=item on_event_notify $api, $eventname, @args
		548
		549	Called when the server broadcasts an event the API object is subscribed
		550	to. The default implementation (which should not be overridden) simply
		551	re-issues an "on_eventname_event" event with the @args.
		552
		553	=item on_XYZ_notify $api, ...
		554
		555	In general, any protocol notification will result in an event of the form
		556	C<on_NOTIFICATION_notify>.
		557
		558	=item on_XYZ_event $api, ...
		559
		560	Called when the server broadcasts the named (XYZ) event.
		561
		562	=back
		563
223	=head1 SEE ALSO	564	=head1 SEE ALSO
224		565
225	L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>.	566	L<AnyEvent>, L<http://www.porttracker.com/>, L<http://www.infoblox.com/en/products/portiq.html>.
226		567
227	=head1 AUTHOR	568	=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.11 by root, Tue Nov 16 02:09:00 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.11 by root, Tue Nov 16 02:09:00 2010 UTC