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

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.16 by root, Thu Jun 2 01:27:46 2011 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.16 by root, Thu Jun 2 01:27:46 2011 UTC