[ViewVC] Diff of: cvs/AnyEvent-FCP/FCP.pm

Comparing AnyEvent-FCP/FCP.pm (file contents):
Revision 1.10 by root, Tue Aug 4 00:50:25 2015 UTC vs.
Revision 1.27 by root, Wed Jun 15 11:18:25 2016 UTC

…		…
18	=head1 DESCRIPTION	18	=head1 DESCRIPTION
19		19
20	This module implements the freenet client protocol version 2.0, as used by	20	This module implements the freenet client protocol version 2.0, as used by
21	freenet 0.7. See L<Net::FCP> for the earlier freenet 0.5 version.	21	freenet 0.7. See L<Net::FCP> for the earlier freenet 0.5 version.
22		22
23	See L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0> for a	23	See L<https://wiki.freenetproject.org/FCP> for a description of what the
24	description of what the messages do.	24	messages do.
25		25
26	The module uses L<AnyEvent> to find a suitable event module.	26	The module uses L<AnyEvent> to find a suitable event module.
27		27
28	Only very little is implemented, ask if you need more, and look at the	28	Only very little is implemented, ask if you need more, and look at the
29	example program later in this section.	29	example program later in this section.
…		…
35		35
36	use AnyEvent::FCP;	36	use AnyEvent::FCP;
37		37
38	my $fcp = new AnyEvent::FCP;	38	my $fcp = new AnyEvent::FCP;
39		39
40	$fcp->watch_global_sync (1, 0);	40	$fcp->watch_global (1, 0);
41	my $req = $fcp->list_persistent_requests_sync;	41	my $req = $fcp->list_persistent_requests;
42		42
		43	TODO
43	for my $req (values %$req) {	44	for my $req (values %$req) {
44	if ($req->{filename} =~ /a/) {	45	if ($req->{filename} =~ /a/) {
45	$fcp->modify_persistent_request_sync (1, $req->{identifier}, undef, 0);	46	$fcp->modify_persistent_request (1, $req->{identifier}, undef, 0);
46	}	47	}
47	}	48	}
48		49
49	=head2 IMPORT TAGS	50	=head2 IMPORT TAGS
50		51
51	Nothing much can be "imported" from this module right now.	52	Nothing much can be "imported" from this module right now.
52		53
53	=head2 THE AnyEvent::FCP CLASS	54	=head1 THE AnyEvent::FCP CLASS
54		55
55	=over 4	56	=over 4
56		57
57	=cut	58	=cut
58		59
…		…
60		61
61	use common::sense;	62	use common::sense;
62		63
63	use Carp;	64	use Carp;
64		65
65	our $VERSION = '0.3';	66	our $VERSION = 0.5;
66		67
67	use Scalar::Util ();	68	use Scalar::Util ();
68		69
69	use AnyEvent;	70	use AnyEvent;
70	use AnyEvent::Handle;	71	use AnyEvent::Handle;
71	use AnyEvent::Util ();	72	use AnyEvent::Util ();
		73
		74	our %TOLC; # tolc cache
72		75
73	sub touc($) {	76	sub touc($) {
74	local $_ = shift;	77	local $_ = shift;
75	1 while s/((?:^\|_)(?:svk\|chk\|uri\|fcp\|ds\|mime\|dda)(?:_\|$))/\U$1/;	78	1 while s/((?:^\|_)(?:svk\|chk\|uri\|fcp\|ds\|mime\|dda)(?:_\|$))/\U$1/;
76	s/(?:^\|_)(.)/\U$1/g;	79	s/(?:^\|_)(.)/\U$1/g;
77	$_	80	$_
78	}	81	}
79		82
80	sub tolc($) {	83	sub tolc($) {
81	local $_ = shift;	84	local $_ = shift;
82	1 while s/(SVK\|CHK\|URI\|FCP\|DS\|MIME\|DDA)([^_])/$1\_$2/i;	85	1 while s/(SVK\|CHK\|URI\|FCP\|DS\|MIME\|DDA)([^_])/$1\_$2/;
83	1 while s/([^_])(SVK\|CHK\|URI\|FCP\|DS\|MIME\|DDA)/$1\_$2/i;	86	1 while s/([^_])(SVK\|CHK\|URI\|FCP\|DS\|MIME\|DDA)/$1\_$2/;
84	s/(?<=[a-z])(?=[A-Z])/_/g;	87	s/(?<=[a-z])(?=[A-Z])/_/g;
85	lc	88	lc
86	}	89	}
87		90
88	=item $fcp = new AnyEvent::FCP [host => $host][, port => $port][, progress => \&cb][, name => $name]	91	=item $fcp = new AnyEvent::FCP key => value...;
89		92
90	Create a new FCP connection to the given host and port (default	93	Create a new FCP connection to the given host and port (default
91	127.0.0.1:9481, or the environment variables C<FREDHOST> and C<FREDPORT>).	94	127.0.0.1:9481, or the environment variables C<FREDHOST> and C<FREDPORT>).
92		95
93	If no C<name> was specified, then AnyEvent::FCP will generate a	96	If no C<name> was specified, then AnyEvent::FCP will generate a
94	(hopefully) unique client name for you.	97	(hopefully) unique client name for you.
95		98
96	You can install a progress callback that is being called with the AnyEvent::FCP	99	The following keys can be specified (they are all optional):
97	object, the type, a hashref with key-value pairs and a reference to any received data,
98	for all unsolicited messages.
99		100
100	Example:	101	=over 4
101		102
102	sub progress_cb {	103	=item name => $string
103	my ($self, $type, $kv, $rdata) = @_;
104		104
105	if ($type eq "simple_progress") {	105	A unique name to identify this client. If none is specified, a randomly
106	warn "$kv->{identifier} $kv->{succeeded}/$kv->{required}\n";	106	generated name will be used.
107	}	107
108	}	108	=item host => $hostname
		109
		110	The hostname or IP address of the freenet node. Default is C<$ENV{FREDHOST}>
		111	or C<127.0.0.1>.
		112
		113	=item port => $portnumber
		114
		115	The port number of the FCP port. Default is C<$ENV{FREDPORT}> or C<9481>.
		116
		117	=item timeout => $seconds
		118
		119	The timeout, in seconds, after which a connection error is assumed when
		120	there is no activity. Default is C<7200>, i.e. two hours.
		121
		122	=item keepalive => $seconds
		123
		124	The interval, in seconds, at which keepalive messages will be
		125	sent. Default is C<540>, i.e. nine minutes.
		126
		127	These keepalive messages are useful both to detect that a connection is
		128	no longer working and to keep any (home) routers from expiring their
		129	masquerading entry.
		130
		131	=item on_eof => $callback->($fcp)
		132
		133	Invoked when the underlying L<AnyEvent::Handle> signals EOF, currently
		134	regardless of whether the EOF was expected or not.
		135
		136	=item on_error => $callback->($fcp, $message)
		137
		138	Invoked on any (fatal) errors, such as unexpected connection close. The
		139	callback receives the FCP object and a textual error message.
		140
		141	=item on_failure => $callback->($fcp, $type, $args, $backtrace, $error)
		142
		143	Invoked when an FCP request fails that didn't have a failure callback. See
		144	L<FCP REQUESTS> for details.
		145
		146	=back
109		147
110	=cut	148	=cut
111		149
112	sub new {	150	sub new {
113	my $class = shift;	151	my $class = shift;
		152
		153	my $rand = join "", map chr 0x21 + rand 94, 1..40; # ~ 262 bits entropy
		154
114	my $self = bless { @_ }, $class;	155	my $self = bless {
115		156	host => $ENV{FREDHOST} \|\| "127.0.0.1",
116	$self->{host} \|\|= $ENV{FREDHOST} \|\| "127.0.0.1";	157	port => $ENV{FREDPORT} \|\| 9481,
117	$self->{port} \|\|= $ENV{FREDPORT} \|\| 9481;	158	timeout => 3600 * 2,
118	$self->{name} \|\|= time.rand.rand.rand; # lame	159	keepalive => 9 * 60,
119	$self->{timeout} \|\|= 3600*2;	160	name => time.rand.rand.rand, # lame
120	$self->{progress} \|\|= sub { };	161	@_,
121		162	queue => [],
122	$self->{id} = "a0";	163	req => {},
		164	prefix => "..:aefcpid:$rand:",
		165	idseq => "a0",
		166	}, $class;
123		167
124	{	168	{
125	Scalar::Util::weaken (my $self = $self);	169	Scalar::Util::weaken (my $self = $self);
		170
		171	$self->{kw} = AE::timer $self->{keepalive}, $self->{keepalive}, sub {
		172	$self->{hdl}->push_write ("\n");
		173	};
		174
		175	our $ENDMESSAGE = qr<\012(EndMessage\|Data)\012>;
		176
		177	# these are declared here for performance reasons
		178	my ($k, $v, $type);
		179	my $rdata;
		180
		181	my $on_read = sub {
		182	my ($hdl) = @_;
		183
		184	# we only carve out whole messages here
		185	while ($hdl->{rbuf} =~ /\012(EndMessage\|Data)\012/) {
		186	# remember end marker
		187	$rdata = $1 eq "Data"
		188	or $1 eq "EndMessage"
		189	or return $self->fatal ("protocol error, expected message end, got $1\n");
		190
		191	my @lines = split /\012/, substr $hdl->{rbuf}, 0, $-[0];
		192
		193	substr $hdl->{rbuf}, 0, $+[0], ""; # remove pkg
		194
		195	$type = shift @lines;
		196	$type = ($TOLC{$type} \|\|= tolc $type);
		197
		198	my %kv;
		199
		200	for (@lines) {
		201	($k, $v) = split /=/, $_, 2;
		202	$k = ($TOLC{$k} \|\|= tolc $k);
		203
		204	if ($k =~ /\./) {
		205	# generic, slow case
		206	my @k = split /\./, $k;
		207	my $ro = \\%kv;
		208
		209	while (@k) {
		210	$k = shift @k;
		211	if ($k =~ /^\d+$/) {
		212	$ro = \$$ro->[$k];
		213	} else {
		214	$ro = \$$ro->{$k};
		215	}
		216	}
		217
		218	$$ro = $v;
		219
		220	next;
		221	}
		222
		223	# special comon case, for performance only
		224	$kv{$k} = $v;
		225	}
		226
		227	if ($rdata) {
		228	$_[0]->push_read (chunk => delete $kv{data_length}, sub {
		229	$rdata = \$_[1];
		230	$self->recv ($type, \%kv, $rdata);
		231	});
		232
		233	last; # do not tgry to parse more messages
		234	} else {
		235	$self->recv ($type, \%kv);
		236	}
		237	}
		238	};
126		239
127	$self->{hdl} = new AnyEvent::Handle	240	$self->{hdl} = new AnyEvent::Handle
128	connect => [$self->{host} => $self->{port}],	241	connect => [$self->{host} => $self->{port}],
129	timeout => $self->{timeout},	242	timeout => $self->{timeout},
		243	on_read => $on_read,
		244	on_eof => sub {
		245	if ($self->{on_eof}) {
		246	$self->{on_eof}($self);
		247	} else {
		248	$self->fatal ("EOF");
		249	}
		250	},
130	on_error => sub {	251	on_error => sub {
131	warn "@_\n";#d#	252	$self->fatal ($_[2]);
132	exit 1;
133	},	253	},
134	on_read => sub { $self->on_read (@_) },	254	;
135	on_eof => $self->{on_eof} \|\| sub { };
136		255
137	Scalar::Util::weaken ($self->{hdl}{fcp} = $self);	256	Scalar::Util::weaken ($self->{hdl}{fcp} = $self);
138	}	257	}
139		258
140	$self->send_msg (	259	$self->send_msg (client_hello =>
141	client_hello =>
142	name => $self->{name},	260	name => $self->{name},
143	expected_version => "2.0",	261	expected_version => "2.0",
144	);	262	);
145		263
146	$self	264	$self
147	}	265	}
148		266
		267	sub fatal {
		268	my ($self, $msg) = @_;
		269
		270	$self->{hdl}->shutdown;
		271	delete $self->{kw};
		272
		273	if ($self->{on_error}) {
		274	$self->{on_error}->($self, $msg);
		275	} else {
		276	die $msg;
		277	}
		278	}
		279
		280	sub identifier {
		281	$_[0]{prefix} . ++$_[0]{idseq}
		282	}
		283
149	sub send_msg {	284	sub send_msg {
150	my ($self, $type, %kv) = @_;	285	my ($self, $type, %kv) = @_;
151		286
152	my $data = delete $kv{data};	287	my $data = delete $kv{data};
153		288
154	if (exists $kv{id_cb}) {	289	if (exists $kv{id_cb}) {
155	my $id = $kv{identifier} \|\|= ++$self->{id};	290	my $id = $kv{identifier} \|\|= $self->identifier;
156	$self->{id}{$id} = delete $kv{id_cb};	291	$self->{id}{$id} = delete $kv{id_cb};
157	}	292	}
158		293
159	my $msg = (touc $type) . "\012"	294	my $msg = (touc $type) . "\012"
160	. join "", map +(touc $_) . "=$kv{$_}\012", keys %kv;	295	. join "", map +(touc $_) . "=$kv{$_}\012", keys %kv;
…		…
202	push @$queue, $cb;	337	push @$queue, $cb;
203	$cb->($self, AnyEvent::Util::guard { $self->_push_queue ($queue) })	338	$cb->($self, AnyEvent::Util::guard { $self->_push_queue ($queue) })
204	unless $#$queue;	339	unless $#$queue;
205	}	340	}
206		341
207	sub on_read {	342	# how to merge these types into $self->{persistent}
208	my ($self) = @_;	343	our %PERSISTENT_TYPE = (
		344	persistent_get => sub { %{ $_[1] } = (type => "persistent_get" , %{ $_[2] }) },
		345	persistent_put => sub { %{ $_[1] } = (type => "persistent_put" , %{ $_[2] }) },
		346	persistent_put_dir => sub { %{ $_[1] } = (type => "persistent_put_dir", %{ $_[2] }) },
		347	persistent_request_modified => sub { %{ $_[1] } = (%{ $_[1] }, %{ $_[2] }) },
		348	persistent_request_removed => sub { delete $_[0]{req}{$_[2]{identifier}} },
209		349
210	my $type;	350	simple_progress => sub { $_[1]{simple_progress} = $_[2] }, # get/put
211	my %kv;
212	my $rdata;
213		351
214	my $done_cb = sub {	352	uri_generated => sub { $_[1]{uri_generated} = $_[2] }, # put
215	$kv{pkt_type} = $type;	353	generated_metadata => sub { $_[1]{generated_metadata} = $_[2] }, # put
		354	started_compression => sub { $_[1]{started_compression} = $_[2] }, # put
		355	finished_compression => sub { $_[1]{finished_compression} = $_[2] }, # put
		356	put_fetchable => sub { $_[1]{put_fetchable} = $_[2] }, # put
		357	put_failed => sub { $_[1]{put_failed} = $_[2] }, # put
		358	put_successful => sub { $_[1]{put_successful} = $_[2] }, # put
216		359
		360	sending_to_network => sub { $_[1]{sending_to_network} = $_[2] }, # get
		361	compatibility_mode => sub { $_[1]{compatibility_mode} = $_[2] }, # get
		362	expected_hashes => sub { $_[1]{expected_hashes} = $_[2] }, # get
		363	expected_mime => sub { $_[1]{expected_mime} = $_[2] }, # get
		364	expected_data_length => sub { $_[1]{expected_data_length} = $_[2] }, # get
		365	get_failed => sub { $_[1]{get_failed} = $_[2] }, # get
		366	data_found => sub { $_[1]{data_found} = $_[2] }, # get
		367	enter_finite_cooldown => sub { $_[1]{enter_finite_cooldown} = $_[2] }, # get
		368	);
		369
		370	sub recv {
		371	my ($self, $type, $kv, @extra) = @_;
		372
		373	if (my $cb = $PERSISTENT_TYPE{$type}) {
		374	my $id = $kv->{identifier};
		375	my $req = $_[0]{req}{$id} \|\|= {};
		376	$cb->($self, $req, $kv);
		377	$self->recv (request_changed => $kv, $type, @extra);
		378	}
		379
217	my $on = $self->{on};	380	my $on = $self->{on};
218	for (0 .. $#$on) {	381	for (0 .. $#$on) {
219	unless (my $res = $on->[$_]($self, $type, \%kv, $rdata)) {	382	unless (my $res = $on->[$_]($self, $type, $kv, @extra)) {
220	splice @$on, $_, 1 unless defined $res;	383	splice @$on, $_, 1 unless defined $res;
221	return;	384	return;
222	}
223	}	385	}
		386	}
224		387
225	if (my $cb = $self->{queue}[0]) {	388	if (my $cb = $self->{queue}[0]) {
226	$cb->($self, $type, \%kv, $rdata)	389	$cb->($self, $type, $kv, @extra)
227	and shift @{ $self->{queue} };	390	and shift @{ $self->{queue} };
228	} else {	391	} else {
229	$self->default_recv ($type, \%kv, $rdata);	392	$self->default_recv ($type, $kv, @extra);
230	}
231	};	393	}
232
233	my $hdr_cb; $hdr_cb = sub {
234	if ($_[1] =~ /^([^=]+)=(.*)$/) {
235	my ($k, $v) = ($1, $2);
236	my @k = split /\./, tolc $k;
237	my $ro = \\%kv;
238
239	while (@k) {
240	my $k = shift @k;
241	if ($k =~ /^\d+$/) {
242	$ro = \$$ro->[$k];
243	} else {
244	$ro = \$$ro->{$k};
245	}
246	}
247
248	$$ro = $v;
249
250	$_[0]->push_read (line => $hdr_cb);
251	} elsif ($_[1] eq "Data") {
252	$_[0]->push_read (chunk => delete $kv{data_length}, sub {
253	$rdata = \$_[1];
254	$done_cb->();
255	});
256	} elsif ($_[1] eq "EndMessage") {
257	$done_cb->();
258	} else {
259	die "protocol error, expected message end, got $_[1]\n";#d#
260	}
261	};
262
263	$self->{hdl}->push_read (line => sub {
264	$type = tolc $_[1];
265	$_[0]->push_read (line => $hdr_cb);
266	});
267	}	394	}
268		395
269	sub default_recv {	396	sub default_recv {
270	my ($self, $type, $kv, $rdata) = @_;	397	my ($self, $type, $kv, $rdata) = @_;
271		398
272	if ($type eq "node_hello") {	399	if ($type eq "node_hello") {
273	$self->{node_hello} = $kv;	400	$self->{node_hello} = $kv;
274	} elsif (exists $self->{id}{$kv->{identifier}}) {	401	} elsif (exists $self->{id}{$kv->{identifier}}) {
275	$self->{id}{$kv->{identifier}}($self, $type, $kv, $rdata)	402	$self->{id}{$kv->{identifier}}($self, $type, $kv, $rdata)
276	and delete $self->{id}{$kv->{identifier}};	403	and delete $self->{id}{$kv->{identifier}};
277	} else {
278	&{ $self->{progress} };
279	}	404	}
280	}	405	}
		406
		407	=back
		408
		409	=head2 FCP REQUESTS
		410
		411	The following methods implement various requests. Most of them map
		412	directory to the FCP message of the same name. The added benefit of
		413	these over sending requests yourself is that they handle the necessary
		414	serialisation, protocol quirks, and replies.
		415
		416	All of them exist in two versions, the variant shown in this manpage, and
		417	a variant with an extra C<_> at the end, and an extra C<$cb> argument. The
		418	version as shown is I<synchronous> - it will wait for any replies, and
		419	either return the reply, or croak with an error. The underscore variant
		420	returns immediately and invokes one or more callbacks or condvars later.
		421
		422	For example, the call
		423
		424	$info = $fcp->get_plugin_info ($name, $detailed);
		425
		426	Also comes in this underscore variant:
		427
		428	$fcp->get_plugin_info_ ($name, $detailed, $cb);
		429
		430	You can think of the underscore as a kind of continuation indicator - the
		431	normal function waits and returns with the data, the C<_> indicates that
		432	you pass the continuation yourself, and the continuation will be invoked
		433	with the results.
		434
		435	This callback/continuation argument (C<$cb>) can come in three forms itself:
		436
		437	=over 4
		438
		439	=item A code reference (or rather anything not matching some other alternative)
		440
		441	This code reference will be invoked with the result on success. On an
		442	error, it will invoke the C<on_failure> callback of the FCP object, or,
		443	if none was defined, will die (in the event loop) with a backtrace of the
		444	call site.
		445
		446	This is a popular choice, but it makes handling errors hard - make sure
		447	you never generate protocol errors!
		448
		449	In the failure case, if an C<on_failure> hook exists, it will be invoked
		450	with the FCP object, the request type (the name of the method, an arrayref
		451	containing the arguments from the original request invocation, a (textual)
		452	backtrace as generated by C<Carp::longmess>, and the error object from the
		453	server, in this order, e.g.:
		454
		455	on_failure => sub {
		456	my ($fcp, $request_type, $orig_args, $backtrace, $error_object) = @_;
		457
		458	warn "FCP failure ($type @$args), $error_object->{code_description} ($error_object->{extra_description})$backtrace";
		459	exit 1;
		460	},
		461
		462	=item A condvar (as returned by e.g. C<< AnyEvent->condvar >>)
		463
		464	When a condvar is passed, it is sent (C<< $cv->send ($results) >>) the
		465	results when the request has finished. Should an error occur, the error
		466	will instead result in C<< $cv->croak ($error) >>.
		467
		468	This is also a popular choice.
		469
		470	=item An array with two callbacks C<[$success, $failure]>
		471
		472	The C<$success> callback will be invoked with the results, while the
		473	C<$failure> callback will be invoked on any errors.
		474
		475	The C<$failure> callback will be invoked with the error object from the
		476	server.
		477
		478	=item C<undef>
		479
		480	This is the same thing as specifying C<sub { }> as callback, i.e. on
		481	success, the results are ignored, while on failure, the C<on_failure> hook
		482	is invoked or the module dies with a backtrace.
		483
		484	This is good for quick scripts, or when you really aren't interested in
		485	the results.
		486
		487	=back
		488
		489	=cut
		490
		491	our $NOP_CB = sub { };
281		492
282	sub _txn {	493	sub _txn {
283	my ($name, $sub) = @_;	494	my ($name, $sub) = @_;
284		495
285	*{$name} = sub {	496	*{$name} = sub {
286	splice @_, 1, 0, (my $cv = AnyEvent->condvar);	497	my $cv = AE::cv;
287	&$sub;
288	$cv
289	};
290		498
291	*{"$name\_sync"} = sub {	499	splice @_, 1, 0, $cv, sub { $cv->croak ($_[0]{extra_description}) };
292	splice @_, 1, 0, (my $cv = AnyEvent->condvar);
293	&$sub;	500	&$sub;
294	$cv->recv	501	$cv->recv
295	};	502	};
296	}
297		503
298	=item $cv = $fcp->list_peers ([$with_metdata[, $with_volatile]])	504	*{"$name\_"} = sub {
		505	my ($ok, $err) = pop;
299		506
		507	if (ARRAY:: eq ref $ok) {
		508	($ok, $err) = @$ok;
		509	} elsif (UNIVERSAL::isa $ok, AnyEvent::CondVar::) {
		510	$err = sub { $ok->croak ($_[0]{extra_description}) };
		511	} else {
		512	my $bt = Carp::longmess "AnyEvent::FCP request $name";
		513	Scalar::Util::weaken (my $self = $_[0]);
		514	my $args = [@_]; shift @$args;
		515	$err = sub {
		516	if ($self->{on_failure}) {
		517	$self->{on_failure}($self, $name, $args, $bt, $_[0]);
		518	} else {
		519	die "$_[0]{code_description} ($_[0]{extra_description})$bt";
		520	}
		521	};
		522	}
		523
		524	$ok \|\|= $NOP_CB;
		525
		526	splice @_, 1, 0, $ok, $err;
		527	&$sub;
		528	};
		529	}
		530
		531	=over 4
		532
300	=item $peers = $fcp->list_peers_sync ([$with_metdata[, $with_volatile]])	533	=item $peers = $fcp->list_peers ([$with_metdata[, $with_volatile]])
301		534
302	=cut	535	=cut
303		536
304	_txn list_peers => sub {	537	_txn list_peers => sub {
305	my ($self, $cv, $with_metadata, $with_volatile) = @_;	538	my ($self, $ok, undef, $with_metadata, $with_volatile) = @_;
306		539
307	my @res;	540	my @res;
308		541
309	$self->send_msg (list_peers =>	542	$self->send_msg (list_peers =>
310	with_metadata => $with_metadata ? "true" : "false",	543	with_metadata => $with_metadata ? "true" : "false",
311	with_volatile => $with_volatile ? "true" : "false",	544	with_volatile => $with_volatile ? "true" : "false",
312	id_cb => sub {	545	id_cb => sub {
313	my ($self, $type, $kv, $rdata) = @_;	546	my ($self, $type, $kv, $rdata) = @_;
314		547
315	if ($type eq "end_list_peers") {	548	if ($type eq "end_list_peers") {
316	$cv->(\@res);	549	$ok->(\@res);
317	1	550	1
318	} else {	551	} else {
319	push @res, $kv;	552	push @res, $kv;
320	0	553	0
321	}	554	}
322	},	555	},
323	);	556	);
324	};	557	};
325		558
326	=item $cv = $fcp->list_peer_notes ($node_identifier)
327
328	=item $notes = $fcp->list_peer_notes_sync ($node_identifier)	559	=item $notes = $fcp->list_peer_notes ($node_identifier)
329		560
330	=cut	561	=cut
331		562
332	_txn list_peer_notes => sub {	563	_txn list_peer_notes => sub {
333	my ($self, $cv, $node_identifier) = @_;	564	my ($self, $ok, undef, $node_identifier) = @_;
334		565
335	$self->send_msg (list_peer_notes =>	566	$self->send_msg (list_peer_notes =>
336	node_identifier => $node_identifier,	567	node_identifier => $node_identifier,
337	id_cb => sub {	568	id_cb => sub {
338	my ($self, $type, $kv, $rdata) = @_;	569	my ($self, $type, $kv, $rdata) = @_;
339		570
340	$cv->($kv);	571	$ok->($kv);
341	1	572	1
342	},	573	},
343	);	574	);
344	};	575	};
345		576
346	=item $cv = $fcp->watch_global ($enabled[, $verbosity_mask])
347
348	=item $fcp->watch_global_sync ($enabled[, $verbosity_mask])	577	=item $fcp->watch_global ($enabled[, $verbosity_mask])
349		578
350	=cut	579	=cut
351		580
352	_txn watch_global => sub {	581	_txn watch_global => sub {
353	my ($self, $cv, $enabled, $verbosity_mask) = @_;	582	my ($self, $ok, $err, $enabled, $verbosity_mask) = @_;
354		583
355	$self->send_msg (watch_global =>	584	$self->send_msg (watch_global =>
356	enabled => $enabled ? "true" : "false",	585	enabled => $enabled ? "true" : "false",
357	defined $verbosity_mask ? (verbosity_mask => $verbosity_mask+0) : (),	586	defined $verbosity_mask ? (verbosity_mask => $verbosity_mask+0) : (),
358	);	587	);
359		588
360	$cv->();	589	$ok->();
361	};	590	};
362		591
363	=item $cv = $fcp->list_persistent_requests
364
365	=item $reqs = $fcp->list_persistent_requests_sync	592	=item $reqs = $fcp->list_persistent_requests
366		593
367	=cut	594	=cut
368		595
369	_txn list_persistent_requests => sub {	596	_txn list_persistent_requests => sub {
370	my ($self, $cv) = @_;	597	my ($self, $ok, $err) = @_;
371		598
372	$self->serialise (list_persistent_requests => sub {	599	$self->serialise (list_persistent_requests => sub {
373	my ($self, $guard) = @_;	600	my ($self, $guard) = @_;
374		601
375	my %res;	602	my @res;
376		603
377	$self->send_msg ("list_persistent_requests");	604	$self->send_msg ("list_persistent_requests");
378		605
379	$self->on (sub {	606	$self->on (sub {
380	my ($self, $type, $kv, $rdata) = @_;	607	my ($self, $type, $kv, $rdata) = @_;
381		608
382	$guard if 0;	609	$guard if 0;
383		610
384	if ($type eq "end_list_persistent_requests") {	611	if ($type eq "end_list_persistent_requests") {
385	$cv->(\%res);	612	$ok->(\@res);
386	return;	613	return;
387	} else {	614	} else {
388	my $id = $kv->{identifier};	615	my $id = $kv->{identifier};
389		616
390	if ($type =~ /^persistent_(get\|put\|put_dir)$/) {	617	if ($type =~ /^persistent_(get\|put\|put_dir)$/) {
391	$res{$id} = {	618	push @res, [$type, $kv];
392	type => $1,
393	%{ $res{$id} },
394	%$kv,
395	};
396	} elsif ($type eq "simple_progress") {
397	delete $kv->{pkt_type}; # save memory
398	push @{ $res{delete $kv->{identifier}}{simple_progress} }, $kv;
399	} else {
400	$res{delete $kv->{identifier}}{delete $kv->{pkt_type}} = $kv;
401	}	619	}
402	}	620	}
403		621
404	1	622	1
405	});	623	});
406	});	624	});
407	};	625	};
408		626
409	=item $cv = $fcp->remove_request ($global, $identifier)	627	=item $sync = $fcp->modify_persistent_request ($global, $identifier[, $client_token[, $priority_class]])
410		628
411	=item $status = $fcp->remove_request_sync ($global, $identifier)	629	Update either the C<client_token> or C<priority_class> of a request
		630	identified by C<$global> and C<$identifier>, depending on which of
		631	C<$client_token> and C<$priority_class> are not C<undef>.
412		632
413	=cut	633	=cut
414		634
415	_txn remove_request => sub {	635	_txn modify_persistent_request => sub {
416	my ($self, $cv, $global, $identifier) = @_;	636	my ($self, $ok, $err, $global, $identifier, $client_token, $priority_class) = @_;
417		637
		638	$self->serialise ($identifier => sub {
		639	my ($self, $guard) = @_;
		640
418	$self->send_msg (remove_request =>	641	$self->send_msg (modify_persistent_request =>
419	global => $global ? "true" : "false",	642	global => $global ? "true" : "false",
420	identifier => $identifier,	643	identifier => $identifier,
421	id_cb => sub {	644	defined $client_token ? (client_token => $client_token ) : (),
		645	defined $priority_class ? (priority_class => $priority_class) : (),
		646	);
		647
		648	$self->on (sub {
422	my ($self, $type, $kv, $rdata) = @_;	649	my ($self, $type, $kv, @extra) = @_;
423		650
		651	$guard if 0;
		652
		653	if ($kv->{identifier} eq $identifier) {
		654	if ($type eq "persistent_request_modified") {
424	$cv->($kv);	655	$ok->($kv);
		656	return;
		657	} elsif ($type eq "protocol_error") {
		658	$err->($kv);
		659	return;
		660	}
		661	}
		662
425	1	663	1
426	},	664	});
427	);	665	});
428	};	666	};
429		667
430	=item $cv = $fcp->modify_persistent_request ($global, $identifier[, $client_token[, $priority_class]])
431
432	=item $sync = $fcp->modify_persistent_request_sync ($global, $identifier[, $client_token[, $priority_class]])
433
434	=cut
435
436	_txn modify_persistent_request => sub {
437	my ($self, $cv, $global, $identifier, $client_token, $priority_class) = @_;
438
439	$self->send_msg (modify_persistent_request =>
440	global => $global ? "true" : "false",
441	defined $client_token ? (client_token => $client_token ) : (),
442	defined $priority_class ? (priority_class => $priority_class) : (),
443	identifier => $identifier,
444	id_cb => sub {
445	my ($self, $type, $kv, $rdata) = @_;
446
447	$cv->($kv);
448	1
449	},
450	);
451	};
452
453	=item $cv = $fcp->get_plugin_info ($name, $detailed)
454
455	=item $info = $fcp->get_plugin_info_sync ($name, $detailed)	668	=item $info = $fcp->get_plugin_info ($name, $detailed)
456		669
457	=cut	670	=cut
458		671
459	_txn get_plugin_info => sub {	672	_txn get_plugin_info => sub {
460	my ($self, $cv, $name, $detailed) = @_;	673	my ($self, $ok, $err, $name, $detailed) = @_;
		674
		675	my $id = $self->identifier;
461		676
462	$self->send_msg (get_plugin_info =>	677	$self->send_msg (get_plugin_info =>
		678	identifier => $id,
463	plugin_name => $name,	679	plugin_name => $name,
464	detailed => $detailed ? "true" : "false",	680	detailed => $detailed ? "true" : "false",
465	id_cb => sub {
466	my ($self, $type, $kv, $rdata) = @_;
467
468	$cv->($kv);
469	1
470	},
471	);	681	);
		682	$self->on (sub {
		683	my ($self, $type, $kv) = @_;
		684
		685	if ($kv->{identifier} eq $id) {
		686	if ($type eq "get_plugin_info") {
		687	$ok->($kv);
		688	} else {
		689	$err->($kv, $type);
		690	}
		691	return;
		692	}
		693
		694	1
		695	});
472	};	696	};
473		697
474	=item $cv = $fcp->client_get ($uri, $identifier, %kv)
475
476	=item $status = $fcp->client_get_sync ($uri, $identifier, %kv)	698	=item $status = $fcp->client_get ($uri, $identifier, %kv)
477		699
478	%kv can contain (L<http://wiki.freenetproject.org/FCP2p0ClientGet>).	700	%kv can contain (L<http://wiki.freenetproject.org/FCP2p0ClientGet>).
479		701
480	ignore_ds, ds_only, verbosity, max_size, max_temp_size, max_retries,	702	ignore_ds, ds_only, verbosity, max_size, max_temp_size, max_retries,
481	priority_class, persistence, client_token, global, return_type,	703	priority_class, persistence, client_token, global, return_type,
482	binary_blob, allowed_mime_types, filename, temp_filename	704	binary_blob, allowed_mime_types, filename, temp_filename
483		705
484	=cut	706	=cut
485		707
486	_txn client_get => sub {	708	_txn client_get => sub {
487	my ($self, $cv, $uri, $identifier, %kv) = @_;	709	my ($self, $ok, $err, $uri, $identifier, %kv) = @_;
488		710
		711	$self->serialise ($identifier => sub {
		712	my ($self, $guard) = @_;
		713
489	$self->send_msg (client_get =>	714	$self->send_msg (client_get =>
490	%kv,	715	%kv,
491	uri => $uri,	716	uri => $uri,
492	identifier => $identifier,	717	identifier => $identifier,
493	id_cb => sub {	718	);
		719
		720	$self->on (sub {
494	my ($self, $type, $kv, $rdata) = @_;	721	my ($self, $type, $kv, @extra) = @_;
495		722
		723	$guard if 0;
		724
		725	if ($kv->{identifier} eq $identifier) {
		726	if ($type eq "persistent_get") {
496	$cv->($kv);	727	$ok->($kv);
		728	return;
		729	} elsif ($type eq "protocol_error") {
		730	$err->($kv);
		731	return;
		732	}
		733	}
		734
497	1	735	1
498	},	736	});
499	);	737	});
500	};	738	};
501		739
502	=item $cv = $fcp->test_dda_sync ($local_directory, $remote_directory, $want_read, $want_write)	740	=item $status = $fcp->remove_request ($identifier[, $global])
503		741
		742	Remove the request with the given identifier. Returns true if successful,
		743	false on error.
		744
		745	=cut
		746
		747	_txn remove_request => sub {
		748	my ($self, $ok, $err, $identifier, $global) = @_;
		749
		750	$self->serialise ($identifier => sub {
		751	my ($self, $guard) = @_;
		752
		753	$self->send_msg (remove_request =>
		754	identifier => $identifier,
		755	global => $global ? "true" : "false",
		756	);
		757	$self->on (sub {
		758	my ($self, $type, $kv, @extra) = @_;
		759
		760	$guard if 0;
		761
		762	if ($kv->{identifier} eq $identifier) {
		763	if ($type eq "persistent_request_removed") {
		764	$ok->(1);
		765	return;
		766	} elsif ($type eq "protocol_error") {
		767	$err->($kv);
		768	return;
		769	}
		770	}
		771
		772	1
		773	});
		774	});
		775	};
		776
504	=item ($can_read, $can_write) = $fcp->test_dda_sync ($local_directory, $remote_directory, $want_read, $want_write))	777	=item ($can_read, $can_write) = $fcp->test_dda ($local_directory, $remote_directory, $want_read, $want_write))
505		778
506	The DDA test in FCP is probably the single most broken protocol - only	779	The DDA test in FCP is probably the single most broken protocol - only
507	one directory test can be outstanding at any time, and some guessing and	780	one directory test can be outstanding at any time, and some guessing and
508	heuristics are involved in mangling the paths.	781	heuristics are involved in mangling the paths.
509		782
510	This function combines C<TestDDARequest> and C<TestDDAResponse> in one	783	This function combines C<TestDDARequest> and C<TestDDAResponse> in one
511	request, handling file reading and writing as well.	784	request, handling file reading and writing as well, and tries very hard to
		785	do the right thing.
		786
		787	Both C<$local_directory> and C<$remote_directory> must specify the same
		788	directory - C<$local_directory> is the directory path on the client (where
		789	L<AnyEvent::FCP> runs) and C<$remote_directory> is the directory path on
		790	the server (where the freenet node runs). When both are running on the
		791	same node, the paths are generally identical.
		792
		793	C<$want_read> and C<$want_write> should be set to a true value when you
		794	want to read (get) files or write (put) files, respectively.
		795
		796	On error, an exception is thrown. Otherwise, C<$can_read> and
		797	C<$can_write> indicate whether you can read or write to freenet via the
		798	directory.
512		799
513	=cut	800	=cut
514		801
515	_txn test_dda => sub {	802	_txn test_dda => sub {
516	my ($self, $cv, $local, $remote, $want_read, $want_write) = @_;	803	my ($self, $ok, $err, $local, $remote, $want_read, $want_write) = @_;
517		804
518	$self->serialise (test_dda => sub {	805	$self->serialise (test_dda => sub {
519	my ($self, $guard) = @_;	806	my ($self, $guard) = @_;
520		807
521	$self->send_msg (test_dda_request =>	808	$self->send_msg (test_dda_request =>
…		…
542	}	829	}
543		830
544	my %response = (directory => $remote);	831	my %response = (directory => $remote);
545		832
546	if (length $kv->{read_filename}) {	833	if (length $kv->{read_filename}) {
547	warn "$local/$kv->{read_filename}";#d#
548	if (open my $fh, "<:raw", "$local/$kv->{read_filename}") {	834	if (open my $fh, "<:raw", "$local/$kv->{read_filename}") {
549	sysread $fh, my $buf, -s $fh;	835	sysread $fh, my $buf, -s $fh;
550	$response{read_content} = $buf;	836	$response{read_content} = $buf;
551	}	837	}
552	}	838	}
…		…
563	my ($self, $type, $kv) = @_;	849	my ($self, $type, $kv) = @_;
564		850
565	$guard if 0; # reference	851	$guard if 0; # reference
566		852
567	if ($type eq "test_dda_complete") {	853	if ($type eq "test_dda_complete") {
568	$cv->(	854	$ok->(
569	$kv->{read_directory_allowed} eq "true",	855	$kv->{read_directory_allowed} eq "true",
570	$kv->{write_directory_allowed} eq "true",	856	$kv->{write_directory_allowed} eq "true",
571	);	857	);
572	} elsif ($type eq "protocol_error" && $kv->{identifier} eq $remote) {	858	} elsif ($type eq "protocol_error" && $kv->{identifier} eq $remote) {
573	$cv->croak ($kv->{extra_description});	859	$err->($kv->{extra_description});
574	return;	860	return;
575	}	861	}
576		862
577	1	863	1
578	});	864	});
579		865
580	return;	866	return;
581	} elsif ($type eq "protocol_error" && $kv->{identifier} eq $remote) {	867	} elsif ($type eq "protocol_error" && $kv->{identifier} eq $remote) {
582	$cv->croak ($kv->{extra_description});	868	$err->($kv);
583	return;	869	return;
584	}	870	}
585		871
586	1	872	1
587	});	873	});
588	});	874	});
589	};	875	};
590		876
591	=back	877	=back
592		878
		879	=head2 REQUEST CACHE
		880
		881	The C<AnyEvent::FCP> class keeps a request cache, where it caches all
		882	information from requests.
		883
		884	For these messages, it will store a copy of the key-value pairs, together with a C<type> slot,
		885	in C<< $fcp->{req}{$identifier} >>:
		886
		887	persistent_get
		888	persistent_put
		889	persistent_put_dir
		890
		891	This message updates the stored data:
		892
		893	persistent_request_modified
		894
		895	This message will remove this entry:
		896
		897	persistent_request_removed
		898
		899	These messages get merged into the cache entry, under their
		900	type, i.e. a C<simple_progress> message will be stored in C<<
		901	$fcp->{req}{$identifier}{simple_progress} >>:
		902
		903	simple_progress # get/put
		904
		905	uri_generated # put
		906	generated_metadata # put
		907	started_compression # put
		908	finished_compression # put
		909	put_failed # put
		910	put_fetchable # put
		911	put_successful # put
		912
		913	sending_to_network # get
		914	compatibility_mode # get
		915	expected_hashes # get
		916	expected_mime # get
		917	expected_data_length # get
		918	get_failed # get
		919	data_found # get
		920	enter_finite_cooldown # get
		921
		922	In addition, an event (basically a fake message) of type C<request_changed> is generated
		923	on every change, which will be called as C<< $cb->($fcp, $kv, $type) >>, where C<$type>
		924	is the type of the original message triggering the change,
		925
		926	To fill this cache with the global queue and keep it updated,
		927	call C<watch_global> to subscribe to updates, followed by
		928	C<list_persistent_requests>.
		929
		930	$fcp->watch_global_; # do not wait
		931	$fcp->list_persistent_requests; # wait
		932
		933	To get a better idea of what is stored in the cache, here is an example of
		934	what might be stored in C<< $fcp->{req}{"Frost-gpl.txt"} >>:
		935
		936	{
		937	identifier => "Frost-gpl.txt",
		938	uri => 'CHK@Fnx5kzdrfE,EImdzaVyEWl,AAIC--8/gpl.txt',
		939	binary_blob => "false",
		940	global => "true",
		941	max_retries => -1,
		942	max_size => 9223372036854775807,
		943	persistence => "forever",
		944	priority_class => 3,
		945	real_time => "false",
		946	return_type => "direct",
		947	started => "true",
		948	type => "persistent_get",
		949	verbosity => 2147483647,
		950	sending_to_network => {
		951	identifier => "Frost-gpl.txt",
		952	global => "true",
		953	},
		954	compatibility_mode => {
		955	identifier => "Frost-gpl.txt",
		956	definitive => "true",
		957	dont_compress => "false",
		958	global => "true",
		959	max => "COMPAT_1255",
		960	min => "COMPAT_1255",
		961	},
		962	expected_hashes => {
		963	identifier => "Frost-gpl.txt",
		964	global => "true",
		965	hashes => {
		966	ed2k => "d83596f5ee3b7...",
		967	md5 => "e0894e4a2a6...",
		968	sha1 => "...",
		969	sha256 => "...",
		970	sha512 => "...",
		971	tth => "...",
		972	},
		973	},
		974	expected_mime => {
		975	identifier => "Frost-gpl.txt",
		976	global => "true",
		977	metadata => { content_type => "application/rar" },
		978	},
		979	expected_data_length => {
		980	identifier => "Frost-gpl.txt",
		981	data_length => 37576,
		982	global => "true",
		983	},
		984	simple_progress => {
		985	identifier => "Frost-gpl.txt",
		986	failed => 0,
		987	fatally_failed => 0,
		988	finalized_total => "true",
		989	global => "true",
		990	last_progress => 1438639282628,
		991	required => 372,
		992	succeeded => 102,
		993	total => 747,
		994	},
		995	data_found => {
		996	identifier => "Frost-gpl.txt",
		997	completion_time => 1438663354026,
		998	data_length => 37576,
		999	global => "true",
		1000	metadata => { content_type => "image/jpeg" },
		1001	startup_time => 1438657196167,
		1002	},
		1003	}
		1004
593	=head1 EXAMPLE PROGRAM	1005	=head1 EXAMPLE PROGRAM
594		1006
595	use AnyEvent::FCP;	1007	use AnyEvent::FCP;
596		1008
597	my $fcp = new AnyEvent::FCP;	1009	my $fcp = new AnyEvent::FCP;
598		1010
599	# let us look at the global request list	1011	# let us look at the global request list
600	$fcp->watch_global (1, 0);	1012	$fcp->watch_global_ (1);
601		1013
602	# list them, synchronously	1014	# list them, synchronously
603	my $req = $fcp->list_persistent_requests_sync;	1015	my $req = $fcp->list_persistent_requests;
604		1016
605	# go through all requests	1017	# go through all requests
		1018	TODO
606	for my $req (values %$req) {	1019	for my $req (values %$req) {
607	# skip jobs not directly-to-disk	1020	# skip jobs not directly-to-disk
608	next unless $req->{return_type} eq "disk";	1021	next unless $req->{return_type} eq "disk";
609	# skip jobs not issued by FProxy	1022	# skip jobs not issued by FProxy
610	next unless $req->{identifier} =~ /^FProxy:/;	1023	next unless $req->{identifier} =~ /^FProxy:/;
…		…
631	if 0.1 > rand;	1044	if 0.1 > rand;
632	}	1045	}
633	}	1046	}
634		1047
635	# see if the dummy plugin is loaded, to ensure all previous requests have finished.	1048	# see if the dummy plugin is loaded, to ensure all previous requests have finished.
636	$fcp->get_plugin_info_sync ("dummy");	1049	$fcp->get_plugin_info ("dummy");
637		1050
638	=head1 SEE ALSO	1051	=head1 SEE ALSO
639		1052
640	L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0>, L<Net::FCP>.	1053	L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0>, L<Net::FCP>.
641		1054

Diff Legend

-–
+Removed lines
-+
+Added lines
-<
+Changed lines
->
+Changed lines

Comparing AnyEvent-FCP/FCP.pm (file contents): Revision 1.10 by root, Tue Aug 4 00:50:25 2015 UTC vs. Revision 1.27 by root, Wed Jun 15 11:18:25 2016 UTC

Diff Legend

Comparing AnyEvent-FCP/FCP.pm (file contents):
Revision 1.10 by root, Tue Aug 4 00:50:25 2015 UTC vs.
Revision 1.27 by root, Wed Jun 15 11:18:25 2016 UTC