ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent-FCP/FCP.pm
Revision: 1.14
Committed: Sat Aug 8 14:09:47 2015 UTC (8 years, 9 months ago) by root
Branch: MAIN
Changes since 1.13: +12 -4 lines
Log Message:
*** empty log message ***

File Contents

# User Rev Content
1 root 1.1 =head1 NAME
2    
3     AnyEvent::FCP - freenet client protocol 2.0
4    
5     =head1 SYNOPSIS
6    
7 root 1.3 use AnyEvent::FCP;
8 root 1.1
9 root 1.3 my $fcp = new AnyEvent::FCP;
10 root 1.1
11 root 1.7 # transactions return condvars
12 root 1.3 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;
17 root 1.1
18     =head1 DESCRIPTION
19    
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.
22    
23 root 1.3 See L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0> for a
24     description of what the messages do.
25 root 1.1
26     The module uses L<AnyEvent> to find a suitable event module.
27    
28 root 1.3 Only very little is implemented, ask if you need more, and look at the
29     example program later in this section.
30    
31 root 1.7 =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 root 1.11 $fcp->watch_global (1, 0);
41     my $req = $fcp->list_persistent_requests;
42 root 1.7
43 root 1.11 TODO
44 root 1.7 for my $req (values %$req) {
45     if ($req->{filename} =~ /a/) {
46 root 1.11 $fcp->modify_persistent_request (1, $req->{identifier}, undef, 0);
47 root 1.7 }
48     }
49    
50 root 1.1 =head2 IMPORT TAGS
51    
52     Nothing much can be "imported" from this module right now.
53    
54 root 1.11 =head1 THE AnyEvent::FCP CLASS
55 root 1.1
56     =over 4
57    
58     =cut
59    
60     package AnyEvent::FCP;
61    
62 root 1.2 use common::sense;
63    
64 root 1.1 use Carp;
65    
66 root 1.7 our $VERSION = '0.3';
67 root 1.1
68 root 1.2 use Scalar::Util ();
69 root 1.1
70     use AnyEvent;
71 root 1.2 use AnyEvent::Handle;
72 root 1.9 use AnyEvent::Util ();
73 root 1.1
74     sub touc($) {
75     local $_ = shift;
76 root 1.9 1 while s/((?:^|_)(?:svk|chk|uri|fcp|ds|mime|dda)(?:_|$))/\U$1/;
77 root 1.1 s/(?:^|_)(.)/\U$1/g;
78     $_
79     }
80    
81     sub tolc($) {
82     local $_ = shift;
83 root 1.11 1 while s/(SVK|CHK|URI|FCP|DS|MIME|DDA)([^_])/$1\_$2/;
84     1 while s/([^_])(SVK|CHK|URI|FCP|DS|MIME|DDA)/$1\_$2/;
85 root 1.1 s/(?<=[a-z])(?=[A-Z])/_/g;
86     lc
87     }
88    
89 root 1.11 =item $fcp = new AnyEvent::FCP [host => $host][, port => $port][, name => $name]
90 root 1.1
91     Create a new FCP connection to the given host and port (default
92 root 1.2 127.0.0.1:9481, or the environment variables C<FREDHOST> and C<FREDPORT>).
93 root 1.1
94 root 1.3 If no C<name> was specified, then AnyEvent::FCP will generate a
95     (hopefully) unique client name for you.
96    
97     =cut
98 root 1.1
99     sub new {
100     my $class = shift;
101 root 1.14
102     my $rand = join "", map chr 0x21 + rand 94, 1..40; # ~ 262 bits entropy
103    
104 root 1.11 my $self = bless {
105     host => $ENV{FREDHOST} || "127.0.0.1",
106     port => $ENV{FREDPORT} || 9481,
107     timeout => 3600 * 2,
108     name => time.rand.rand.rand, # lame
109     @_,
110     queue => [],
111     req => {},
112 root 1.14 prefix => "..:aefcpid-$rand:",
113     idseq => "a0",
114 root 1.11 }, $class;
115 root 1.2
116     {
117     Scalar::Util::weaken (my $self = $self);
118    
119     $self->{hdl} = new AnyEvent::Handle
120     connect => [$self->{host} => $self->{port}],
121     timeout => $self->{timeout},
122     on_error => sub {
123 root 1.8 warn "@_\n";#d#
124 root 1.2 exit 1;
125     },
126     on_read => sub { $self->on_read (@_) },
127     on_eof => $self->{on_eof} || sub { };
128    
129     Scalar::Util::weaken ($self->{hdl}{fcp} = $self);
130     }
131    
132 root 1.11 $self->send_msg (client_hello =>
133     name => $self->{name},
134 root 1.2 expected_version => "2.0",
135     );
136 root 1.1
137     $self
138     }
139    
140 root 1.14 sub identifier {
141     $_[0]{prefix} . ++$_[0]{idseq}
142     }
143    
144 root 1.2 sub send_msg {
145     my ($self, $type, %kv) = @_;
146 root 1.1
147 root 1.2 my $data = delete $kv{data};
148 root 1.1
149 root 1.2 if (exists $kv{id_cb}) {
150 root 1.14 my $id = $kv{identifier} ||= $self->identifier;
151 root 1.2 $self->{id}{$id} = delete $kv{id_cb};
152 root 1.1 }
153    
154 root 1.2 my $msg = (touc $type) . "\012"
155     . join "", map +(touc $_) . "=$kv{$_}\012", keys %kv;
156 root 1.1
157 root 1.2 sub id {
158     my ($self) = @_;
159 root 1.1
160    
161 root 1.2 }
162 root 1.1
163     if (defined $data) {
164 root 1.2 $msg .= "DataLength=" . (length $data) . "\012"
165     . "Data\012$data";
166 root 1.1 } else {
167 root 1.2 $msg .= "EndMessage\012";
168 root 1.1 }
169    
170 root 1.2 $self->{hdl}->push_write ($msg);
171 root 1.1 }
172    
173 root 1.9 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 root 1.11 # 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    
256 root 1.2 sub on_read {
257 root 1.1 my ($self) = @_;
258    
259 root 1.2 my $type;
260     my %kv;
261     my $rdata;
262    
263     my $hdr_cb; $hdr_cb = sub {
264     if ($_[1] =~ /^([^=]+)=(.*)$/) {
265     my ($k, $v) = ($1, $2);
266     my @k = split /\./, tolc $k;
267     my $ro = \\%kv;
268    
269     while (@k) {
270     my $k = shift @k;
271     if ($k =~ /^\d+$/) {
272     $ro = \$$ro->[$k];
273 root 1.1 } else {
274 root 1.2 $ro = \$$ro->{$k};
275 root 1.1 }
276     }
277    
278 root 1.2 $$ro = $v;
279 root 1.1
280 root 1.2 $_[0]->push_read (line => $hdr_cb);
281     } elsif ($_[1] eq "Data") {
282     $_[0]->push_read (chunk => delete $kv{data_length}, sub {
283     $rdata = \$_[1];
284 root 1.11 $self->recv ($type, \%kv, $rdata);
285 root 1.2 });
286     } elsif ($_[1] eq "EndMessage") {
287 root 1.11 $self->recv ($type, \%kv);
288 root 1.2 } else {
289     die "protocol error, expected message end, got $_[1]\n";#d#
290     }
291     };
292 root 1.1
293 root 1.2 $self->{hdl}->push_read (line => sub {
294     $type = tolc $_[1];
295     $_[0]->push_read (line => $hdr_cb);
296     });
297     }
298 root 1.1
299 root 1.2 sub default_recv {
300     my ($self, $type, $kv, $rdata) = @_;
301    
302     if ($type eq "node_hello") {
303     $self->{node_hello} = $kv;
304     } elsif (exists $self->{id}{$kv->{identifier}}) {
305     $self->{id}{$kv->{identifier}}($self, $type, $kv, $rdata)
306     and delete $self->{id}{$kv->{identifier}};
307 root 1.1 }
308     }
309    
310 root 1.12 =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 root 1.11 our $NOP_CB = sub { };
377    
378 root 1.2 sub _txn {
379     my ($name, $sub) = @_;
380 root 1.1
381 root 1.2 *{$name} = sub {
382 root 1.12 my $cv = AE::cv;
383    
384 root 1.14 splice @_, 1, 0, $cv, sub { $cv->croak ($_[0]{extra_description}) };
385 root 1.2 &$sub;
386 root 1.11 $cv->recv
387 root 1.2 };
388 root 1.1
389 root 1.11 *{"$name\_"} = sub {
390 root 1.12 my ($ok, $err) = pop;
391    
392     if (ARRAY:: eq ref $ok) {
393     ($ok, $err) = @$ok;
394     } elsif (UNIVERSAL::isa $ok, AnyEvent::CondVar::) {
395 root 1.14 $err = sub { $ok->croak ($_[0]{extra_description}) };
396 root 1.12 } 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 root 1.2 &$sub;
407     };
408 root 1.1 }
409    
410 root 1.12 =over 4
411    
412 root 1.11 =item $peers = $fcp->list_peers ([$with_metdata[, $with_volatile]])
413 root 1.3
414     =cut
415    
416 root 1.2 _txn list_peers => sub {
417 root 1.12 my ($self, $ok, undef, $with_metadata, $with_volatile) = @_;
418 root 1.1
419 root 1.2 my @res;
420 root 1.1
421 root 1.2 $self->send_msg (list_peers =>
422     with_metadata => $with_metadata ? "true" : "false",
423     with_volatile => $with_volatile ? "true" : "false",
424     id_cb => sub {
425     my ($self, $type, $kv, $rdata) = @_;
426    
427     if ($type eq "end_list_peers") {
428 root 1.12 $ok->(\@res);
429 root 1.2 1
430     } else {
431     push @res, $kv;
432     0
433     }
434     },
435     );
436     };
437 root 1.1
438 root 1.11 =item $notes = $fcp->list_peer_notes ($node_identifier)
439 root 1.3
440     =cut
441    
442 root 1.2 _txn list_peer_notes => sub {
443 root 1.12 my ($self, $ok, undef, $node_identifier) = @_;
444 root 1.1
445 root 1.2 $self->send_msg (list_peer_notes =>
446     node_identifier => $node_identifier,
447     id_cb => sub {
448     my ($self, $type, $kv, $rdata) = @_;
449    
450 root 1.12 $ok->($kv);
451 root 1.2 1
452     },
453     );
454     };
455 root 1.1
456 root 1.11 =item $fcp->watch_global ($enabled[, $verbosity_mask])
457 root 1.3
458     =cut
459    
460 root 1.2 _txn watch_global => sub {
461 root 1.12 my ($self, $ok, $err, $enabled, $verbosity_mask) = @_;
462 root 1.1
463 root 1.2 $self->send_msg (watch_global =>
464     enabled => $enabled ? "true" : "false",
465     defined $verbosity_mask ? (verbosity_mask => $verbosity_mask+0) : (),
466     );
467 root 1.1
468 root 1.12 $ok->();
469 root 1.2 };
470 root 1.1
471 root 1.11 =item $reqs = $fcp->list_persistent_requests
472 root 1.3
473     =cut
474    
475 root 1.2 _txn list_persistent_requests => sub {
476 root 1.12 my ($self, $ok, $err) = @_;
477 root 1.1
478 root 1.10 $self->serialise (list_persistent_requests => sub {
479     my ($self, $guard) = @_;
480    
481 root 1.11 my @res;
482 root 1.1
483 root 1.10 $self->send_msg ("list_persistent_requests");
484 root 1.1
485 root 1.10 $self->on (sub {
486     my ($self, $type, $kv, $rdata) = @_;
487 root 1.2
488 root 1.10 $guard if 0;
489 root 1.2
490 root 1.10 if ($type eq "end_list_persistent_requests") {
491 root 1.12 $ok->(\@res);
492 root 1.10 return;
493 root 1.2 } else {
494 root 1.10 my $id = $kv->{identifier};
495    
496     if ($type =~ /^persistent_(get|put|put_dir)$/) {
497 root 1.11 push @res, [$type, $kv];
498 root 1.10 }
499 root 1.2 }
500 root 1.10
501     1
502     });
503     });
504 root 1.2 };
505 root 1.1
506 root 1.12 =item $sync = $fcp->modify_persistent_request ($global, $identifier[, $client_token[, $priority_class]])
507    
508     Update either the C<client_token> or C<priority_class> of a request
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 root 1.3
512     =cut
513    
514 root 1.12 _txn modify_persistent_request => sub {
515     my ($self, $ok, $err, $global, $identifier, $client_token, $priority_class) = @_;
516 root 1.1
517 root 1.12 $self->serialise ($identifier => sub {
518     my ($self, $guard) = @_;
519 root 1.2
520 root 1.12 $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 root 1.1
527 root 1.12 $self->on (sub {
528     my ($self, $type, $kv, @extra) = @_;
529 root 1.3
530 root 1.13 $guard if 0;
531    
532 root 1.12 if ($kv->{identifier} eq $identifier) {
533     if ($type eq "persistent_request_modified") {
534     $ok->($kv);
535     return;
536     } elsif ($type eq "protocol_error") {
537     $err->($kv);
538     return;
539     }
540     }
541 root 1.1
542 root 1.2 1
543 root 1.12 });
544     });
545 root 1.2 };
546 root 1.1
547 root 1.11 =item $info = $fcp->get_plugin_info ($name, $detailed)
548 root 1.3
549     =cut
550    
551 root 1.2 _txn get_plugin_info => sub {
552 root 1.12 my ($self, $ok, $err, $name, $detailed) = @_;
553 root 1.1
554 root 1.2 $self->send_msg (get_plugin_info =>
555     plugin_name => $name,
556     detailed => $detailed ? "true" : "false",
557     id_cb => sub {
558     my ($self, $type, $kv, $rdata) = @_;
559    
560 root 1.12 $ok->($kv);
561 root 1.2 1
562     },
563     );
564 root 1.4 };
565    
566 root 1.11 =item $status = $fcp->client_get ($uri, $identifier, %kv)
567 root 1.1
568 root 1.4 %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 root 1.12 my ($self, $ok, $err, $uri, $identifier, %kv) = @_;
578 root 1.4
579 root 1.13 $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 root 1.12
603 root 1.13 1
604     });
605     });
606 root 1.11 };
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 root 1.12 my ($self, $ok, $err, $identifier, $global) = @_;
617 root 1.11
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 root 1.13 $guard if 0;
629    
630 root 1.11 if ($kv->{identifier} eq $identifier) {
631     if ($type eq "persistent_request_removed") {
632 root 1.12 $ok->(1);
633 root 1.11 return;
634     } elsif ($type eq "protocol_error") {
635 root 1.12 $err->($kv);
636 root 1.11 return;
637     }
638     }
639 root 1.4
640     1
641 root 1.11 });
642     });
643 root 1.2 };
644 root 1.1
645 root 1.11 =item ($can_read, $can_write) = $fcp->test_dda ($local_directory, $remote_directory, $want_read, $want_write))
646 root 1.9
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 root 1.11 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 root 1.9
668     =cut
669    
670     _txn test_dda => sub {
671 root 1.12 my ($self, $ok, $err, $local, $remote, $want_read, $want_write) = @_;
672 root 1.9
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 root 1.10 my ($self, $type, $kv) = @_;
683 root 1.9
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 root 1.10 my ($self, $type, $kv) = @_;
718 root 1.9
719     $guard if 0; # reference
720    
721     if ($type eq "test_dda_complete") {
722 root 1.12 $ok->(
723 root 1.9 $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 root 1.12 $err->($kv->{extra_description});
728 root 1.9 return;
729     }
730    
731     1
732     });
733    
734     return;
735     } elsif ($type eq "protocol_error" && $kv->{identifier} eq $remote) {
736 root 1.12 $err->($kv);
737 root 1.9 return;
738     }
739    
740     1
741     });
742     });
743     };
744    
745 root 1.1 =back
746    
747 root 1.11 =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 root 1.3 =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 root 1.11 $fcp->watch_global_ (1);
881 root 1.3
882     # list them, synchronously
883 root 1.11 my $req = $fcp->list_persistent_requests;
884 root 1.3
885     # go through all requests
886 root 1.11 TODO
887 root 1.3 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");
918    
919 root 1.1 =head1 SEE ALSO
920    
921 root 1.2 L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0>, L<Net::FCP>.
922 root 1.1
923     =head1 BUGS
924    
925     =head1 AUTHOR
926    
927     Marc Lehmann <schmorp@schmorp.de>
928     http://home.schmorp.de/
929    
930     =cut
931    
932     1
933