[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.11 by root, Fri Aug 7 01:54:00 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;
103	my $self = bless { @_ }, $class;	101	my $self = bless {
104		102	host => $ENV{FREDHOST} \|\| "127.0.0.1",
105	$self->{host} \|\|= $ENV{FREDHOST} \|\| "127.0.0.1";	103	port => $ENV{FREDPORT} \|\| 9481,
106	$self->{port} \|\|= $ENV{FREDPORT} \|\| 9481;	104	timeout => 3600 * 2,
107	$self->{name} \|\|= time.rand.rand.rand; # lame	105	name => time.rand.rand.rand, # lame
108	$self->{timeout} \|\|= 600;	106	@_,
109		107	queue => [],
110	$self->{id} = "a0";	108	req => {},
		109	id => "a0",
		110	}, $class;
111		111
112	{	112	{
113	Scalar::Util::weaken (my $self = $self);	113	Scalar::Util::weaken (my $self = $self);
114		114
115	$self->{hdl} = new AnyEvent::Handle	115	$self->{hdl} = new AnyEvent::Handle
116	connect => [$self->{host} => $self->{port}],	116	connect => [$self->{host} => $self->{port}],
117	timeout => $self->{timeout},	117	timeout => $self->{timeout},
118	on_error => sub {	118	on_error => sub {
119	warn "<@_>\n";	119	warn "@_\n";#d#
120	exit 1;	120	exit 1;
121	},	121	},
122	on_read => sub { $self->on_read (@_) },	122	on_read => sub { $self->on_read (@_) },
123	on_eof => $self->{on_eof} \|\| sub { };	123	on_eof => $self->{on_eof} \|\| sub { };
124		124
125	Scalar::Util::weaken ($self->{hdl}{fcp} = $self);	125	Scalar::Util::weaken ($self->{hdl}{fcp} = $self);
126	}	126	}
127		127
128	$self->send_msg (	128	$self->send_msg (client_hello =>
129	client_hello =>
130	name => $self->{name},	129	name => $self->{name},
131	expected_version => "2.0",	130	expected_version => "2.0",
132	);	131	);
133		132
134	$self	133	$self
135	}	134	}
136		135
137	sub progress {
138	my ($self, $txn, $type, $attr) = @_;
139
140	$self->{progress}->($self, $txn, $type, $attr)
141	if $self->{progress};
142	}
143
144	sub send_msg {	136	sub send_msg {
145	my ($self, $type, %kv) = @_;	137	my ($self, $type, %kv) = @_;
146		138
147	my $data = delete $kv{data};	139	my $data = delete $kv{data};
148		140
149	if (exists $kv{id_cb}) {	141	if (exists $kv{id_cb}) {
150	my $id = $kv{identifier} \|\| ++$self->{id};	142	my $id = $kv{identifier} \|\|= ++$self->{id};
151	$self->{id}{$id} = delete $kv{id_cb};	143	$self->{id}{$id} = delete $kv{id_cb};
152	$kv{identifier} = $id;
153	}	144	}
154		145
155	my $msg = (touc $type) . "\012"	146	my $msg = (touc $type) . "\012"
156	. join "", map +(touc $_) . "=$kv{$_}\012", keys %kv;	147	. join "", map +(touc $_) . "=$kv{$_}\012", keys %kv;
157		148
…		…
169	}	160	}
170		161
171	$self->{hdl}->push_write ($msg);	162	$self->{hdl}->push_write ($msg);
172	}	163	}
173		164
		165	sub on {
		166	my ($self, $cb) = @_;
		167
		168	# cb return undef - message eaten, remove cb
		169	# cb return 0 - message eaten
		170	# cb return 1 - pass to next
		171
		172	push @{ $self->{on} }, $cb;
		173	}
		174
		175	sub _push_queue {
		176	my ($self, $queue) = @_;
		177
		178	shift @$queue;
		179	$queue->[0]($self, AnyEvent::Util::guard { $self->_push_queue ($queue) })
		180	if @$queue;
		181	}
		182
		183	# lock so only one $type (arbitrary string) is in flight,
		184	# to work around horribly misdesigned protocol.
		185	sub serialise {
		186	my ($self, $type, $cb) = @_;
		187
		188	my $queue = $self->{serialise}{$type} \|\|= [];
		189	push @$queue, $cb;
		190	$cb->($self, AnyEvent::Util::guard { $self->_push_queue ($queue) })
		191	unless $#$queue;
		192	}
		193
		194	# how to merge these types into $self->{persistent}
		195	our %PERSISTENT_TYPE = (
		196	persistent_get => sub { %{ $_[1] } = (type => "persistent_get" , %{ $_[2] }) },
		197	persistent_put => sub { %{ $_[1] } = (type => "persistent_put" , %{ $_[2] }) },
		198	persistent_put_dir => sub { %{ $_[1] } = (type => "persistent_put_dir", %{ $_[2] }) },
		199	persistent_request_modified => sub { %{ $_[1] } = (%{ $_[1] }, %{ $_[2] }) },
		200	persistent_request_removed => sub { delete $_[0]{req}{$_[2]{identifier}} },
		201
		202	simple_progress => sub { $_[1]{simple_progress} = $_[2] }, # get/put
		203
		204	uri_generated => sub { $_[1]{uri_generated} = $_[2] }, # put
		205	generated_metadata => sub { $_[1]{generated_metadata} = $_[2] }, # put
		206	started_compression => sub { $_[1]{started_compression} = $_[2] }, # put
		207	finished_compression => sub { $_[1]{finished_compression} = $_[2] }, # put
		208	put_fetchable => sub { $_[1]{put_fetchable} = $_[2] }, # put
		209	put_failed => sub { $_[1]{put_failed} = $_[2] }, # put
		210	put_successful => sub { $_[1]{put_successful} = $_[2] }, # put
		211
		212	sending_to_network => sub { $_[1]{sending_to_network} = $_[2] }, # get
		213	compatibility_mode => sub { $_[1]{compatibility_mode} = $_[2] }, # get
		214	expected_hashes => sub { $_[1]{expected_hashes} = $_[2] }, # get
		215	expected_mime => sub { $_[1]{expected_mime} = $_[2] }, # get
		216	expected_data_length => sub { $_[1]{expected_data_length} = $_[2] }, # get
		217	get_failed => sub { $_[1]{get_failed} = $_[2] }, # get
		218	data_found => sub { $_[1]{data_found} = $_[2] }, # get
		219	enter_finite_cooldown => sub { $_[1]{enter_finite_cooldown} = $_[2] }, # get
		220	);
		221
		222	sub recv {
		223	my ($self, $type, $kv, @extra) = @_;
		224
		225	if (my $cb = $PERSISTENT_TYPE{$type}) {
		226	my $id = $kv->{identifier};
		227	my $req = $_[0]{req}{$id} \|\|= {};
		228	$cb->($self, $req, $kv);
		229	$self->recv (request_change => $kv, $type, @extra);
		230	}
		231
		232	my $on = $self->{on};
		233	for (0 .. $#$on) {
		234	unless (my $res = $on->[$_]($self, $type, $kv, @extra)) {
		235	splice @$on, $_, 1 unless defined $res;
		236	return;
		237	}
		238	}
		239
		240	if (my $cb = $self->{queue}[0]) {
		241	$cb->($self, $type, $kv, @extra)
		242	and shift @{ $self->{queue} };
		243	} else {
		244	$self->default_recv ($type, $kv, @extra);
		245	}
		246	}
		247
174	sub on_read {	248	sub on_read {
175	my ($self) = @_;	249	my ($self) = @_;
176		250
177	my $type;	251	my $type;
178	my %kv;	252	my %kv;
179	my $rdata;	253	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		254
192	my $hdr_cb; $hdr_cb = sub {	255	my $hdr_cb; $hdr_cb = sub {
193	if ($_[1] =~ /^([^=]+)=(.*)$/) {	256	if ($_[1] =~ /^([^=]+)=(.*)$/) {
194	my ($k, $v) = ($1, $2);	257	my ($k, $v) = ($1, $2);
195	my @k = split /\./, tolc $k;	258	my @k = split /\./, tolc $k;
…		…
208		271
209	$_[0]->push_read (line => $hdr_cb);	272	$_[0]->push_read (line => $hdr_cb);
210	} elsif ($_[1] eq "Data") {	273	} elsif ($_[1] eq "Data") {
211	$_[0]->push_read (chunk => delete $kv{data_length}, sub {	274	$_[0]->push_read (chunk => delete $kv{data_length}, sub {
212	$rdata = \$_[1];	275	$rdata = \$_[1];
213	$done_cb->();	276	$self->recv ($type, \%kv, $rdata);
214	});	277	});
215	} elsif ($_[1] eq "EndMessage") {	278	} elsif ($_[1] eq "EndMessage") {
216	$done_cb->();	279	$self->recv ($type, \%kv);
217	} else {	280	} else {
218	die "protocol error, expected message end, got $_[1]\n";#d#	281	die "protocol error, expected message end, got $_[1]\n";#d#
219	}	282	}
220	};	283	};
221		284
…		…
231	if ($type eq "node_hello") {	294	if ($type eq "node_hello") {
232	$self->{node_hello} = $kv;	295	$self->{node_hello} = $kv;
233	} elsif (exists $self->{id}{$kv->{identifier}}) {	296	} elsif (exists $self->{id}{$kv->{identifier}}) {
234	$self->{id}{$kv->{identifier}}($self, $type, $kv, $rdata)	297	$self->{id}{$kv->{identifier}}($self, $type, $kv, $rdata)
235	and delete $self->{id}{$kv->{identifier}};	298	and delete $self->{id}{$kv->{identifier}};
236	} else {
237	# on_warn
238	#warn "protocol warning (unexpected $type message)\n";
239	}	299	}
240	}	300	}
		301
		302	our $NOP_CB = sub { };
241		303
242	sub _txn {	304	sub _txn {
243	my ($name, $sub) = @_;	305	my ($name, $sub) = @_;
244		306
245	*{$name} = sub {	307	*{$name} = sub {
246	splice @_, 1, 0, (my $cv = AnyEvent->condvar);
247	&$sub;
248	$cv
249	};
250
251	*{"$name\_sync"} = sub {
252	splice @_, 1, 0, (my $cv = AnyEvent->condvar);	308	splice @_, 1, 0, (my $cv = AnyEvent->condvar);
253	&$sub;	309	&$sub;
254	$cv->recv	310	$cv->recv
255	};	311	};
		312
		313	*{"$name\_"} = sub {
		314	splice @_, 1, 0, pop \|\| $NOP_CB;
		315	&$sub;
		316	};
256	}	317	}
		318
		319	=item $peers = $fcp->list_peers ([$with_metdata[, $with_volatile]])
		320
		321	=cut
257		322
258	_txn list_peers => sub {	323	_txn list_peers => sub {
259	my ($self, $cv, $with_metadata, $with_volatile) = @_;	324	my ($self, $cv, $with_metadata, $with_volatile) = @_;
260		325
261	my @res;	326	my @res;
…		…
275	}	340	}
276	},	341	},
277	);	342	);
278	};	343	};
279		344
		345	=item $notes = $fcp->list_peer_notes ($node_identifier)
		346
		347	=cut
		348
280	_txn list_peer_notes => sub {	349	_txn list_peer_notes => sub {
281	my ($self, $cv, $node_identifier) = @_;	350	my ($self, $cv, $node_identifier) = @_;
282		351
283	$self->send_msg (list_peer_notes =>	352	$self->send_msg (list_peer_notes =>
284	node_identifier => $node_identifier,	353	node_identifier => $node_identifier,
…		…
289	1	358	1
290	},	359	},
291	);	360	);
292	};	361	};
293		362
		363	=item $fcp->watch_global ($enabled[, $verbosity_mask])
		364
		365	=cut
		366
294	_txn watch_global => sub {	367	_txn watch_global => sub {
295	my ($self, $cv, $enabled, $verbosity_mask) = @_;	368	my ($self, $cv, $enabled, $verbosity_mask) = @_;
296		369
297	$self->send_msg (watch_global =>	370	$self->send_msg (watch_global =>
298	enabled => $enabled ? "true" : "false",	371	enabled => $enabled ? "true" : "false",
…		…
300	);	373	);
301		374
302	$cv->();	375	$cv->();
303	};	376	};
304		377
		378	=item $reqs = $fcp->list_persistent_requests
		379
		380	=cut
		381
305	_txn list_persistent_requests => sub {	382	_txn list_persistent_requests => sub {
306	my ($self, $cv) = @_;	383	my ($self, $cv) = @_;
307		384
		385	$self->serialise (list_persistent_requests => sub {
		386	my ($self, $guard) = @_;
		387
308	my %res;	388	my @res;
309		389
310	$self->send_msg ("list_persistent_requests");	390	$self->send_msg ("list_persistent_requests");
311		391
312	push @{ $self->{queue} }, sub {	392	$self->on (sub {
313	my ($self, $type, $kv, $rdata) = @_;	393	my ($self, $type, $kv, $rdata) = @_;
314		394
		395	$guard if 0;
		396
315	if ($type eq "end_list_persistent_requests") {	397	if ($type eq "end_list_persistent_requests") {
316	$cv->(\%res);	398	$cv->(\@res);
		399	return;
		400	} else {
		401	my $id = $kv->{identifier};
		402
		403	if ($type =~ /^persistent_(get\|put\|put_dir)$/) {
		404	push @res, [$type, $kv];
		405	}
		406	}
		407
317	1	408	1
318	} else {
319	my $id = $kv->{identifier};
320
321	if ($type =~ /^persistent_(get\|put\|put_dir)$/) {
322	$res{$id} = {
323	type => $1,
324	%{ $res{$id} },
325	%$kv,
326	};
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	}
333	0
334	}	409	});
335	};	410	});
336	};	411	};
		412
		413	=item $status = $fcp->remove_request ($global, $identifier)
		414
		415	=cut
337		416
338	_txn remove_request => sub {	417	_txn remove_request => sub {
339	my ($self, $cv, $global, $identifier) = @_;	418	my ($self, $cv, $global, $identifier) = @_;
340		419
341	$self->send_msg (remove_request =>	420	$self->send_msg (remove_request =>
…		…
346		425
347	$cv->($kv);	426	$cv->($kv);
348	1	427	1
349	},	428	},
350	);	429	);
351
352	$cv->();
353	};	430	};
		431
		432	=item $sync = $fcp->modify_persistent_request ($global, $identifier[, $client_token[, $priority_class]])
		433
		434	=cut
354		435
355	_txn modify_persistent_request => sub {	436	_txn modify_persistent_request => sub {
356	my ($self, $cv, $global, $identifier, $client_token, $priority_class) = @_;	437	my ($self, $cv, $global, $identifier, $client_token, $priority_class) = @_;
357		438
358	$self->send_msg (modify_persistent_request =>	439	$self->send_msg (modify_persistent_request =>
359	global => $global ? "true" : "false",	440	global => $global ? "true" : "false",
360	identifier => $identifier,
361	defined $client_token ? (client_token => $client_token ) : (),	441	defined $client_token ? (client_token => $client_token ) : (),
362	defined $priority_class ? (priority_class => $priority_class) : (),	442	defined $priority_class ? (priority_class => $priority_class) : (),
		443	identifier => $identifier,
363	id_cb => sub {	444	id_cb => sub {
364	my ($self, $type, $kv, $rdata) = @_;	445	my ($self, $type, $kv, $rdata) = @_;
365		446
366	$cv->($kv);	447	$cv->($kv);
367	1	448	1
368	},	449	},
369	);	450	);
370
371	$cv->();
372	};	451	};
		452
		453	=item $info = $fcp->get_plugin_info ($name, $detailed)
		454
		455	=cut
373		456
374	_txn get_plugin_info => sub {	457	_txn get_plugin_info => sub {
375	my ($self, $cv, $name, $detailed) = @_;	458	my ($self, $cv, $name, $detailed) = @_;
376		459
377	$self->send_msg (get_plugin_info =>	460	$self->send_msg (get_plugin_info =>
…		…
382		465
383	$cv->($kv);	466	$cv->($kv);
384	1	467	1
385	},	468	},
386	);	469	);
		470	};
387		471
388	$cv->();	472	=item $status = $fcp->client_get ($uri, $identifier, %kv)
		473
		474	%kv can contain (L<http://wiki.freenetproject.org/FCP2p0ClientGet>).
		475
		476	ignore_ds, ds_only, verbosity, max_size, max_temp_size, max_retries,
		477	priority_class, persistence, client_token, global, return_type,
		478	binary_blob, allowed_mime_types, filename, temp_filename
		479
		480	=cut
		481
		482	_txn client_get => sub {
		483	my ($self, $cv, $uri, $identifier, %kv) = @_;
		484
		485	$self->send_msg (client_get =>
		486	%kv,
		487	uri => $uri,
		488	identifier => $identifier,
		489	);
		490	};
		491
		492	=item $status = $fcp->remove_request ($identifier[, $global])
		493
		494	Remove the request with the given isdentifier. Returns true if successful,
		495	false on error.
		496
		497	=cut
		498
		499	_txn remove_request => sub {
		500	my ($self, $cv, $identifier, $global) = @_;
		501
		502	$self->serialise ($identifier => sub {
		503	my ($self, $guard) = @_;
		504
		505	$self->send_msg (remove_request =>
		506	identifier => $identifier,
		507	global => $global ? "true" : "false",
		508	);
		509	$self->on (sub {
		510	my ($self, $type, $kv, @extra) = @_;
		511
		512	if ($kv->{identifier} eq $identifier) {
		513	if ($type eq "persistent_request_removed") {
		514	$cv->(1);
		515	return;
		516	} elsif ($type eq "protocol_error") {
		517	$cv->(undef);
		518	return;
		519	}
		520	}
		521
		522	1
		523	});
		524	});
		525	};
		526
		527	=item ($can_read, $can_write) = $fcp->test_dda ($local_directory, $remote_directory, $want_read, $want_write))
		528
		529	The DDA test in FCP is probably the single most broken protocol - only
		530	one directory test can be outstanding at any time, and some guessing and
		531	heuristics are involved in mangling the paths.
		532
		533	This function combines C<TestDDARequest> and C<TestDDAResponse> in one
		534	request, handling file reading and writing as well, and tries very hard to
		535	do the right thing.
		536
		537	Both C<$local_directory> and C<$remote_directory> must specify the same
		538	directory - C<$local_directory> is the directory path on the client (where
		539	L<AnyEvent::FCP> runs) and C<$remote_directory> is the directory path on
		540	the server (where the freenet node runs). When both are running on the
		541	same node, the paths are generally identical.
		542
		543	C<$want_read> and C<$want_write> should be set to a true value when you
		544	want to read (get) files or write (put) files, respectively.
		545
		546	On error, an exception is thrown. Otherwise, C<$can_read> and
		547	C<$can_write> indicate whether you can reaqd or write to freenet via the
		548	directory.
		549
		550	=cut
		551
		552	_txn test_dda => sub {
		553	my ($self, $cv, $local, $remote, $want_read, $want_write) = @_;
		554
		555	$self->serialise (test_dda => sub {
		556	my ($self, $guard) = @_;
		557
		558	$self->send_msg (test_dda_request =>
		559	directory => $remote,
		560	want_read_directory => $want_read ? "true" : "false",
		561	want_write_directory => $want_write ? "true" : "false",
		562	);
		563	$self->on (sub {
		564	my ($self, $type, $kv) = @_;
		565
		566	if ($type eq "test_dda_reply") {
		567	# the filenames are all relative to the server-side directory,
		568	# which might or might not match $remote anymore, so we
		569	# need to rewrite the paths to be relative to $local
		570	for my $k (qw(read_filename write_filename)) {
		571	my $f = $kv->{$k};
		572	for my $dir ($kv->{directory}, $remote) {
		573	if ($dir eq substr $f, 0, length $dir) {
		574	substr $f, 0, 1 + length $dir, "";
		575	$kv->{$k} = $f;
		576	last;
		577	}
		578	}
		579	}
		580
		581	my %response = (directory => $remote);
		582
		583	if (length $kv->{read_filename}) {
		584	if (open my $fh, "<:raw", "$local/$kv->{read_filename}") {
		585	sysread $fh, my $buf, -s $fh;
		586	$response{read_content} = $buf;
		587	}
		588	}
		589
		590	if (length $kv->{write_filename}) {
		591	if (open my $fh, ">:raw", "$local/$kv->{write_filename}") {
		592	syswrite $fh, $kv->{content_to_write};
		593	}
		594	}
		595
		596	$self->send_msg (test_dda_response => %response);
		597
		598	$self->on (sub {
		599	my ($self, $type, $kv) = @_;
		600
		601	$guard if 0; # reference
		602
		603	if ($type eq "test_dda_complete") {
		604	$cv->(
		605	$kv->{read_directory_allowed} eq "true",
		606	$kv->{write_directory_allowed} eq "true",
		607	);
		608	} elsif ($type eq "protocol_error" && $kv->{identifier} eq $remote) {
		609	$cv->croak ($kv->{extra_description});
		610	return;
		611	}
		612
		613	1
		614	});
		615
		616	return;
		617	} elsif ($type eq "protocol_error" && $kv->{identifier} eq $remote) {
		618	$cv->croak ($kv->{extra_description});
		619	return;
		620	}
		621
		622	1
		623	});
		624	});
389	};	625	};
390		626
391	=back	627	=back
		628
		629	=head2 REQUEST CACHE
		630
		631	The C<AnyEvent::FCP> class keeps a request cache, where it caches all
		632	information from requests.
		633
		634	For these messages, it will store a copy of the key-value pairs, together with a C<type> slot,
		635	in C<< $fcp->{req}{$identifier} >>:
		636
		637	persistent_get
		638	persistent_put
		639	persistent_put_dir
		640
		641	This message updates the stored data:
		642
		643	persistent_request_modified
		644
		645	This message will remove this entry:
		646
		647	persistent_request_removed
		648
		649	These messages get merged into the cache entry, under their
		650	type, i.e. a C<simple_progress> message will be stored in C<<
		651	$fcp->{req}{$identifier}{simple_progress} >>:
		652
		653	simple_progress # get/put
		654
		655	uri_generated # put
		656	generated_metadata # put
		657	started_compression # put
		658	finished_compression # put
		659	put_failed # put
		660	put_fetchable # put
		661	put_successful # put
		662
		663	sending_to_network # get
		664	compatibility_mode # get
		665	expected_hashes # get
		666	expected_mime # get
		667	expected_data_length # get
		668	get_failed # get
		669	data_found # get
		670	enter_finite_cooldown # get
		671
		672	In addition, an event (basically a fake message) of type C<request_changed> is generated
		673	on every change, which will be called as C<< $cb->($fcp, $kv, $type) >>, where C<$type>
		674	is the type of the original message triggering the change,
		675
		676	To fill this cache with the global queue and keep it updated,
		677	call C<watch_global> to subscribe to updates, followed by
		678	C<list_persistent_requests_sync>.
		679
		680	$fcp->watch_global_sync_; # do not wait
		681	$fcp->list_persistent_requests; # wait
		682
		683	To get a better idea of what is stored in the cache, here is an example of
		684	what might be stored in C<< $fcp->{req}{"Frost-gpl.txt"} >>:
		685
		686	{
		687	identifier => "Frost-gpl.txt",
		688	uri => 'CHK@Fnx5kzdrfE,EImdzaVyEWl,AAIC--8/gpl.txt',
		689	binary_blob => "false",
		690	global => "true",
		691	max_retries => -1,
		692	max_size => 9223372036854775807,
		693	persistence => "forever",
		694	priority_class => 3,
		695	real_time => "false",
		696	return_type => "direct",
		697	started => "true",
		698	type => "persistent_get",
		699	verbosity => 2147483647,
		700	sending_to_network => {
		701	identifier => "Frost-gpl.txt",
		702	global => "true",
		703	},
		704	compatibility_mode => {
		705	identifier => "Frost-gpl.txt",
		706	definitive => "true",
		707	dont_compress => "false",
		708	global => "true",
		709	max => "COMPAT_1255",
		710	min => "COMPAT_1255",
		711	},
		712	expected_hashes => {
		713	identifier => "Frost-gpl.txt",
		714	global => "true",
		715	hashes => {
		716	ed2k => "d83596f5ee3b7...",
		717	md5 => "e0894e4a2a6...",
		718	sha1 => "...",
		719	sha256 => "...",
		720	sha512 => "...",
		721	tth => "...",
		722	},
		723	},
		724	expected_mime => {
		725	identifier => "Frost-gpl.txt",
		726	global => "true",
		727	metadata => { content_type => "application/rar" },
		728	},
		729	expected_data_length => {
		730	identifier => "Frost-gpl.txt",
		731	data_length => 37576,
		732	global => "true",
		733	},
		734	simple_progress => {
		735	identifier => "Frost-gpl.txt",
		736	failed => 0,
		737	fatally_failed => 0,
		738	finalized_total => "true",
		739	global => "true",
		740	last_progress => 1438639282628,
		741	required => 372,
		742	succeeded => 102,
		743	total => 747,
		744	},
		745	data_found => {
		746	identifier => "Frost-gpl.txt",
		747	completion_time => 1438663354026,
		748	data_length => 37576,
		749	global => "true",
		750	metadata => { content_type => "image/jpeg" },
		751	startup_time => 1438657196167,
		752	},
		753	}
		754
		755	=head1 EXAMPLE PROGRAM
		756
		757	use AnyEvent::FCP;
		758
		759	my $fcp = new AnyEvent::FCP;
		760
		761	# let us look at the global request list
		762	$fcp->watch_global_ (1);
		763
		764	# list them, synchronously
		765	my $req = $fcp->list_persistent_requests;
		766
		767	# go through all requests
		768	TODO
		769	for my $req (values %$req) {
		770	# skip jobs not directly-to-disk
		771	next unless $req->{return_type} eq "disk";
		772	# skip jobs not issued by FProxy
		773	next unless $req->{identifier} =~ /^FProxy:/;
		774
		775	if ($req->{data_found}) {
		776	# file has been successfully downloaded
		777
		778	... move the file away
		779	(left as exercise)
		780
		781	# remove the request
		782
		783	$fcp->remove_request (1, $req->{identifier});
		784	} elsif ($req->{get_failed}) {
		785	# request has failed
		786	if ($req->{get_failed}{code} == 11) {
		787	# too many path components, should restart
		788	} else {
		789	# other failure
		790	}
		791	} else {
		792	# modify priorities randomly, to improve download rates
		793	$fcp->modify_persistent_request (1, $req->{identifier}, undef, int 6 - 5 * (rand) ** 1.7)
		794	if 0.1 > rand;
		795	}
		796	}
		797
		798	# see if the dummy plugin is loaded, to ensure all previous requests have finished.
		799	$fcp->get_plugin_info_sync ("dummy");
392		800
393	=head1 SEE ALSO	801	=head1 SEE ALSO
394		802
395	L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0>, L<Net::FCP>.	803	L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0>, L<Net::FCP>.
396		804

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.11 by root, Fri Aug 7 01:54:00 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.11 by root, Fri Aug 7 01:54:00 2015 UTC