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