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

Comparing AnyEvent-FCP/FCP.pm (file contents):
Revision 1.2 by root, Sat Jul 25 06:28:49 2009 UTC vs.
Revision 1.14 by root, Sat Aug 8 14:09:47 2015 UTC

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

Diff Legend

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

Comparing AnyEvent-FCP/FCP.pm (file contents): Revision 1.2 by root, Sat Jul 25 06:28:49 2009 UTC vs. Revision 1.14 by root, Sat Aug 8 14:09:47 2015 UTC

Diff Legend

Comparing AnyEvent-FCP/FCP.pm (file contents):
Revision 1.2 by root, Sat Jul 25 06:28:49 2009 UTC vs.
Revision 1.14 by root, Sat Aug 8 14:09:47 2015 UTC