ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent-FCP/FCP.pm
Revision: 1.13
Committed: Sat Aug 8 04:07:28 2015 UTC (8 years, 9 months ago) by root
Branch: MAIN
Changes since 1.12: +30 -6 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.11 my $self = bless {
102     host => $ENV{FREDHOST} || "127.0.0.1",
103     port => $ENV{FREDPORT} || 9481,
104     timeout => 3600 * 2,
105     name => time.rand.rand.rand, # lame
106     @_,
107     queue => [],
108     req => {},
109     id => "a0",
110     }, $class;
111 root 1.2
112     {
113     Scalar::Util::weaken (my $self = $self);
114    
115     $self->{hdl} = new AnyEvent::Handle
116     connect => [$self->{host} => $self->{port}],
117     timeout => $self->{timeout},
118     on_error => sub {
119 root 1.8 warn "@_\n";#d#
120 root 1.2 exit 1;
121     },
122     on_read => sub { $self->on_read (@_) },
123     on_eof => $self->{on_eof} || sub { };
124    
125     Scalar::Util::weaken ($self->{hdl}{fcp} = $self);
126     }
127    
128 root 1.11 $self->send_msg (client_hello =>
129     name => $self->{name},
130 root 1.2 expected_version => "2.0",
131     );
132 root 1.1
133     $self
134     }
135    
136 root 1.2 sub send_msg {
137     my ($self, $type, %kv) = @_;
138 root 1.1
139 root 1.2 my $data = delete $kv{data};
140 root 1.1
141 root 1.2 if (exists $kv{id_cb}) {
142 root 1.9 my $id = $kv{identifier} ||= ++$self->{id};
143 root 1.2 $self->{id}{$id} = delete $kv{id_cb};
144 root 1.1 }
145    
146 root 1.2 my $msg = (touc $type) . "\012"
147     . join "", map +(touc $_) . "=$kv{$_}\012", keys %kv;
148 root 1.1
149 root 1.2 sub id {
150     my ($self) = @_;
151 root 1.1
152    
153 root 1.2 }
154 root 1.1
155     if (defined $data) {
156 root 1.2 $msg .= "DataLength=" . (length $data) . "\012"
157     . "Data\012$data";
158 root 1.1 } else {
159 root 1.2 $msg .= "EndMessage\012";
160 root 1.1 }
161    
162 root 1.2 $self->{hdl}->push_write ($msg);
163 root 1.1 }
164    
165 root 1.9 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 root 1.11 # 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    
248 root 1.2 sub on_read {
249 root 1.1 my ($self) = @_;
250    
251 root 1.2 my $type;
252     my %kv;
253     my $rdata;
254    
255     my $hdr_cb; $hdr_cb = sub {
256     if ($_[1] =~ /^([^=]+)=(.*)$/) {
257     my ($k, $v) = ($1, $2);
258     my @k = split /\./, tolc $k;
259     my $ro = \\%kv;
260    
261     while (@k) {
262     my $k = shift @k;
263     if ($k =~ /^\d+$/) {
264     $ro = \$$ro->[$k];
265 root 1.1 } else {
266 root 1.2 $ro = \$$ro->{$k};
267 root 1.1 }
268     }
269    
270 root 1.2 $$ro = $v;
271 root 1.1
272 root 1.2 $_[0]->push_read (line => $hdr_cb);
273     } elsif ($_[1] eq "Data") {
274     $_[0]->push_read (chunk => delete $kv{data_length}, sub {
275     $rdata = \$_[1];
276 root 1.11 $self->recv ($type, \%kv, $rdata);
277 root 1.2 });
278     } elsif ($_[1] eq "EndMessage") {
279 root 1.11 $self->recv ($type, \%kv);
280 root 1.2 } else {
281     die "protocol error, expected message end, got $_[1]\n";#d#
282     }
283     };
284 root 1.1
285 root 1.2 $self->{hdl}->push_read (line => sub {
286     $type = tolc $_[1];
287     $_[0]->push_read (line => $hdr_cb);
288     });
289     }
290 root 1.1
291 root 1.2 sub default_recv {
292     my ($self, $type, $kv, $rdata) = @_;
293    
294     if ($type eq "node_hello") {
295     $self->{node_hello} = $kv;
296     } elsif (exists $self->{id}{$kv->{identifier}}) {
297     $self->{id}{$kv->{identifier}}($self, $type, $kv, $rdata)
298     and delete $self->{id}{$kv->{identifier}};
299 root 1.1 }
300     }
301    
302 root 1.12 =back
303    
304     =head2 FCP REQUESTS
305    
306     The following methods implement various requests. Most of them map
307     directory to the FCP message of the same name. The added benefit of
308     these over sending requests yourself is that they handle the necessary
309     serialisation, protocol quirks, and replies.
310    
311     All of them exist in two versions, the variant shown in this manpage, and
312     a variant with an extra C<_> at the end, and an extra C<$cb> argument. The
313     version as shown is I<synchronous> - it will wait for any replies, and
314     either return the reply, or croak with an error. The underscore variant
315     returns immediately and invokes one or more callbacks or condvars later.
316    
317     For example, the call
318    
319     $info = $fcp->get_plugin_info ($name, $detailed);
320    
321     Also comes in this underscore variant:
322    
323     $fcp->get_plugin_info_ ($name, $detailed, $cb);
324    
325     You can thinbk of the underscore as a kind of continuation indicator - the
326     normal function waits and returns with the data, the C<_> indicates that
327     you pass the continuation yourself, and the continuation will be invoked
328     with the results.
329    
330     This callback/continuation argument (C<$cb>) can come in three forms itself:
331    
332     =over 4
333    
334     =item A code reference (or rather anything not matching some other alternative)
335    
336     This code reference will be invoked with the result on success. On an
337     error, it will die (in the event loop) with a backtrace of the call site.
338    
339     This is a popular choice, but it makes handling errors hard - make sure
340     you never generate protocol errors!
341    
342     =item A condvar (as returned by e.g. C<< AnyEvent->condvar >>)
343    
344     When a condvar is passed, it is sent (C<< $cv->send ($results) >>) the
345     results when the request has finished. Should an error occur, the error
346     will instead result in C<< $cv->croak ($error) >>.
347    
348     This is also a popular choice.
349    
350     =item An array with two callbacks C<[$success, $failure]>
351    
352     The C<$success> callback will be invoked with the results, while the
353     C<$failure> callback will be invoked on any errors.
354    
355     =item C<undef>
356    
357     This is the same thing as specifying C<sub { }> as callback, i.e. on
358     success, the results are ignored, while on failure, you the module dies
359     with a backtrace.
360    
361     This is good for quick scripts, or when you really aren't interested in
362     the results.
363    
364     =back
365    
366     =cut
367    
368 root 1.11 our $NOP_CB = sub { };
369    
370 root 1.2 sub _txn {
371     my ($name, $sub) = @_;
372 root 1.1
373 root 1.2 *{$name} = sub {
374 root 1.12 my $cv = AE::cv;
375    
376     splice @_, 1, 0, $cv, sub { $cv->throw ($_[0]{extra_description}) };
377 root 1.2 &$sub;
378 root 1.11 $cv->recv
379 root 1.2 };
380 root 1.1
381 root 1.11 *{"$name\_"} = sub {
382 root 1.12 my ($ok, $err) = pop;
383    
384     if (ARRAY:: eq ref $ok) {
385     ($ok, $err) = @$ok;
386     } elsif (UNIVERSAL::isa $ok, AnyEvent::CondVar::) {
387     $err = sub { $ok->throw ($_[0]{extra_description}) };
388     } else {
389     my $bt = Carp::longmess "";
390     $err = sub {
391     die "$_[0]{extra_description}$bt";
392     };
393     }
394    
395     $ok ||= $NOP_CB;
396    
397     splice @_, 1, 0, $ok, $err;
398 root 1.2 &$sub;
399     };
400 root 1.1 }
401    
402 root 1.12 =over 4
403    
404 root 1.11 =item $peers = $fcp->list_peers ([$with_metdata[, $with_volatile]])
405 root 1.3
406     =cut
407    
408 root 1.2 _txn list_peers => sub {
409 root 1.12 my ($self, $ok, undef, $with_metadata, $with_volatile) = @_;
410 root 1.1
411 root 1.2 my @res;
412 root 1.1
413 root 1.2 $self->send_msg (list_peers =>
414     with_metadata => $with_metadata ? "true" : "false",
415     with_volatile => $with_volatile ? "true" : "false",
416     id_cb => sub {
417     my ($self, $type, $kv, $rdata) = @_;
418    
419     if ($type eq "end_list_peers") {
420 root 1.12 $ok->(\@res);
421 root 1.2 1
422     } else {
423     push @res, $kv;
424     0
425     }
426     },
427     );
428     };
429 root 1.1
430 root 1.11 =item $notes = $fcp->list_peer_notes ($node_identifier)
431 root 1.3
432     =cut
433    
434 root 1.2 _txn list_peer_notes => sub {
435 root 1.12 my ($self, $ok, undef, $node_identifier) = @_;
436 root 1.1
437 root 1.2 $self->send_msg (list_peer_notes =>
438     node_identifier => $node_identifier,
439     id_cb => sub {
440     my ($self, $type, $kv, $rdata) = @_;
441    
442 root 1.12 $ok->($kv);
443 root 1.2 1
444     },
445     );
446     };
447 root 1.1
448 root 1.11 =item $fcp->watch_global ($enabled[, $verbosity_mask])
449 root 1.3
450     =cut
451    
452 root 1.2 _txn watch_global => sub {
453 root 1.12 my ($self, $ok, $err, $enabled, $verbosity_mask) = @_;
454 root 1.1
455 root 1.2 $self->send_msg (watch_global =>
456     enabled => $enabled ? "true" : "false",
457     defined $verbosity_mask ? (verbosity_mask => $verbosity_mask+0) : (),
458     );
459 root 1.1
460 root 1.12 $ok->();
461 root 1.2 };
462 root 1.1
463 root 1.11 =item $reqs = $fcp->list_persistent_requests
464 root 1.3
465     =cut
466    
467 root 1.2 _txn list_persistent_requests => sub {
468 root 1.12 my ($self, $ok, $err) = @_;
469 root 1.1
470 root 1.10 $self->serialise (list_persistent_requests => sub {
471     my ($self, $guard) = @_;
472    
473 root 1.11 my @res;
474 root 1.1
475 root 1.10 $self->send_msg ("list_persistent_requests");
476 root 1.1
477 root 1.10 $self->on (sub {
478     my ($self, $type, $kv, $rdata) = @_;
479 root 1.2
480 root 1.10 $guard if 0;
481 root 1.2
482 root 1.10 if ($type eq "end_list_persistent_requests") {
483 root 1.12 $ok->(\@res);
484 root 1.10 return;
485 root 1.2 } else {
486 root 1.10 my $id = $kv->{identifier};
487    
488     if ($type =~ /^persistent_(get|put|put_dir)$/) {
489 root 1.11 push @res, [$type, $kv];
490 root 1.10 }
491 root 1.2 }
492 root 1.10
493     1
494     });
495     });
496 root 1.2 };
497 root 1.1
498 root 1.12 =item $sync = $fcp->modify_persistent_request ($global, $identifier[, $client_token[, $priority_class]])
499    
500     Update either the C<client_token> or C<priority_class> of a request
501     identified by C<$global> and C<$identifier>, depending on which of
502     C<$client_token> and C<$priority_class> are not C<undef>.
503 root 1.3
504     =cut
505    
506 root 1.12 _txn modify_persistent_request => sub {
507     my ($self, $ok, $err, $global, $identifier, $client_token, $priority_class) = @_;
508 root 1.1
509 root 1.12 $self->serialise ($identifier => sub {
510     my ($self, $guard) = @_;
511 root 1.2
512 root 1.12 $self->send_msg (modify_persistent_request =>
513     global => $global ? "true" : "false",
514     identifier => $identifier,
515     defined $client_token ? (client_token => $client_token ) : (),
516     defined $priority_class ? (priority_class => $priority_class) : (),
517     );
518 root 1.1
519 root 1.12 $self->on (sub {
520     my ($self, $type, $kv, @extra) = @_;
521 root 1.3
522 root 1.13 $guard if 0;
523    
524 root 1.12 if ($kv->{identifier} eq $identifier) {
525     if ($type eq "persistent_request_modified") {
526     $ok->($kv);
527     return;
528     } elsif ($type eq "protocol_error") {
529     $err->($kv);
530     return;
531     }
532     }
533 root 1.1
534 root 1.2 1
535 root 1.12 });
536     });
537 root 1.2 };
538 root 1.1
539 root 1.11 =item $info = $fcp->get_plugin_info ($name, $detailed)
540 root 1.3
541     =cut
542    
543 root 1.2 _txn get_plugin_info => sub {
544 root 1.12 my ($self, $ok, $err, $name, $detailed) = @_;
545 root 1.1
546 root 1.2 $self->send_msg (get_plugin_info =>
547     plugin_name => $name,
548     detailed => $detailed ? "true" : "false",
549     id_cb => sub {
550     my ($self, $type, $kv, $rdata) = @_;
551    
552 root 1.12 $ok->($kv);
553 root 1.2 1
554     },
555     );
556 root 1.4 };
557    
558 root 1.11 =item $status = $fcp->client_get ($uri, $identifier, %kv)
559 root 1.1
560 root 1.4 %kv can contain (L<http://wiki.freenetproject.org/FCP2p0ClientGet>).
561    
562     ignore_ds, ds_only, verbosity, max_size, max_temp_size, max_retries,
563     priority_class, persistence, client_token, global, return_type,
564     binary_blob, allowed_mime_types, filename, temp_filename
565    
566     =cut
567    
568     _txn client_get => sub {
569 root 1.12 my ($self, $ok, $err, $uri, $identifier, %kv) = @_;
570 root 1.4
571 root 1.13 $self->serialise ($identifier => sub {
572     my ($self, $guard) = @_;
573    
574     $self->send_msg (client_get =>
575     %kv,
576     uri => $uri,
577     identifier => $identifier,
578     );
579    
580     $self->on (sub {
581     my ($self, $type, $kv, @extra) = @_;
582    
583     $guard if 0;
584    
585     if ($kv->{identifier} eq $identifier) {
586     if ($type eq "persistent_get") {
587     $ok->($kv);
588     return;
589     } elsif ($type eq "protocol_error") {
590     $err->($kv);
591     return;
592     }
593     }
594 root 1.12
595 root 1.13 1
596     });
597     });
598 root 1.11 };
599    
600     =item $status = $fcp->remove_request ($identifier[, $global])
601    
602     Remove the request with the given isdentifier. Returns true if successful,
603     false on error.
604    
605     =cut
606    
607     _txn remove_request => sub {
608 root 1.12 my ($self, $ok, $err, $identifier, $global) = @_;
609 root 1.11
610     $self->serialise ($identifier => sub {
611     my ($self, $guard) = @_;
612    
613     $self->send_msg (remove_request =>
614     identifier => $identifier,
615     global => $global ? "true" : "false",
616     );
617     $self->on (sub {
618     my ($self, $type, $kv, @extra) = @_;
619    
620 root 1.13 $guard if 0;
621    
622 root 1.11 if ($kv->{identifier} eq $identifier) {
623     if ($type eq "persistent_request_removed") {
624 root 1.12 $ok->(1);
625 root 1.11 return;
626     } elsif ($type eq "protocol_error") {
627 root 1.12 $err->($kv);
628 root 1.11 return;
629     }
630     }
631 root 1.4
632     1
633 root 1.11 });
634     });
635 root 1.2 };
636 root 1.1
637 root 1.11 =item ($can_read, $can_write) = $fcp->test_dda ($local_directory, $remote_directory, $want_read, $want_write))
638 root 1.9
639     The DDA test in FCP is probably the single most broken protocol - only
640     one directory test can be outstanding at any time, and some guessing and
641     heuristics are involved in mangling the paths.
642    
643     This function combines C<TestDDARequest> and C<TestDDAResponse> in one
644 root 1.11 request, handling file reading and writing as well, and tries very hard to
645     do the right thing.
646    
647     Both C<$local_directory> and C<$remote_directory> must specify the same
648     directory - C<$local_directory> is the directory path on the client (where
649     L<AnyEvent::FCP> runs) and C<$remote_directory> is the directory path on
650     the server (where the freenet node runs). When both are running on the
651     same node, the paths are generally identical.
652    
653     C<$want_read> and C<$want_write> should be set to a true value when you
654     want to read (get) files or write (put) files, respectively.
655    
656     On error, an exception is thrown. Otherwise, C<$can_read> and
657     C<$can_write> indicate whether you can reaqd or write to freenet via the
658     directory.
659 root 1.9
660     =cut
661    
662     _txn test_dda => sub {
663 root 1.12 my ($self, $ok, $err, $local, $remote, $want_read, $want_write) = @_;
664 root 1.9
665     $self->serialise (test_dda => sub {
666     my ($self, $guard) = @_;
667    
668     $self->send_msg (test_dda_request =>
669     directory => $remote,
670     want_read_directory => $want_read ? "true" : "false",
671     want_write_directory => $want_write ? "true" : "false",
672     );
673     $self->on (sub {
674 root 1.10 my ($self, $type, $kv) = @_;
675 root 1.9
676     if ($type eq "test_dda_reply") {
677     # the filenames are all relative to the server-side directory,
678     # which might or might not match $remote anymore, so we
679     # need to rewrite the paths to be relative to $local
680     for my $k (qw(read_filename write_filename)) {
681     my $f = $kv->{$k};
682     for my $dir ($kv->{directory}, $remote) {
683     if ($dir eq substr $f, 0, length $dir) {
684     substr $f, 0, 1 + length $dir, "";
685     $kv->{$k} = $f;
686     last;
687     }
688     }
689     }
690    
691     my %response = (directory => $remote);
692    
693     if (length $kv->{read_filename}) {
694     if (open my $fh, "<:raw", "$local/$kv->{read_filename}") {
695     sysread $fh, my $buf, -s $fh;
696     $response{read_content} = $buf;
697     }
698     }
699    
700     if (length $kv->{write_filename}) {
701     if (open my $fh, ">:raw", "$local/$kv->{write_filename}") {
702     syswrite $fh, $kv->{content_to_write};
703     }
704     }
705    
706     $self->send_msg (test_dda_response => %response);
707    
708     $self->on (sub {
709 root 1.10 my ($self, $type, $kv) = @_;
710 root 1.9
711     $guard if 0; # reference
712    
713     if ($type eq "test_dda_complete") {
714 root 1.12 $ok->(
715 root 1.9 $kv->{read_directory_allowed} eq "true",
716     $kv->{write_directory_allowed} eq "true",
717     );
718     } elsif ($type eq "protocol_error" && $kv->{identifier} eq $remote) {
719 root 1.12 $err->($kv->{extra_description});
720 root 1.9 return;
721     }
722    
723     1
724     });
725    
726     return;
727     } elsif ($type eq "protocol_error" && $kv->{identifier} eq $remote) {
728 root 1.12 $err->($kv);
729 root 1.9 return;
730     }
731    
732     1
733     });
734     });
735     };
736    
737 root 1.1 =back
738    
739 root 1.11 =head2 REQUEST CACHE
740    
741     The C<AnyEvent::FCP> class keeps a request cache, where it caches all
742     information from requests.
743    
744     For these messages, it will store a copy of the key-value pairs, together with a C<type> slot,
745     in C<< $fcp->{req}{$identifier} >>:
746    
747     persistent_get
748     persistent_put
749     persistent_put_dir
750    
751     This message updates the stored data:
752    
753     persistent_request_modified
754    
755     This message will remove this entry:
756    
757     persistent_request_removed
758    
759     These messages get merged into the cache entry, under their
760     type, i.e. a C<simple_progress> message will be stored in C<<
761     $fcp->{req}{$identifier}{simple_progress} >>:
762    
763     simple_progress # get/put
764    
765     uri_generated # put
766     generated_metadata # put
767     started_compression # put
768     finished_compression # put
769     put_failed # put
770     put_fetchable # put
771     put_successful # put
772    
773     sending_to_network # get
774     compatibility_mode # get
775     expected_hashes # get
776     expected_mime # get
777     expected_data_length # get
778     get_failed # get
779     data_found # get
780     enter_finite_cooldown # get
781    
782     In addition, an event (basically a fake message) of type C<request_changed> is generated
783     on every change, which will be called as C<< $cb->($fcp, $kv, $type) >>, where C<$type>
784     is the type of the original message triggering the change,
785    
786     To fill this cache with the global queue and keep it updated,
787     call C<watch_global> to subscribe to updates, followed by
788     C<list_persistent_requests_sync>.
789    
790     $fcp->watch_global_sync_; # do not wait
791     $fcp->list_persistent_requests; # wait
792    
793     To get a better idea of what is stored in the cache, here is an example of
794     what might be stored in C<< $fcp->{req}{"Frost-gpl.txt"} >>:
795    
796     {
797     identifier => "Frost-gpl.txt",
798     uri => 'CHK@Fnx5kzdrfE,EImdzaVyEWl,AAIC--8/gpl.txt',
799     binary_blob => "false",
800     global => "true",
801     max_retries => -1,
802     max_size => 9223372036854775807,
803     persistence => "forever",
804     priority_class => 3,
805     real_time => "false",
806     return_type => "direct",
807     started => "true",
808     type => "persistent_get",
809     verbosity => 2147483647,
810     sending_to_network => {
811     identifier => "Frost-gpl.txt",
812     global => "true",
813     },
814     compatibility_mode => {
815     identifier => "Frost-gpl.txt",
816     definitive => "true",
817     dont_compress => "false",
818     global => "true",
819     max => "COMPAT_1255",
820     min => "COMPAT_1255",
821     },
822     expected_hashes => {
823     identifier => "Frost-gpl.txt",
824     global => "true",
825     hashes => {
826     ed2k => "d83596f5ee3b7...",
827     md5 => "e0894e4a2a6...",
828     sha1 => "...",
829     sha256 => "...",
830     sha512 => "...",
831     tth => "...",
832     },
833     },
834     expected_mime => {
835     identifier => "Frost-gpl.txt",
836     global => "true",
837     metadata => { content_type => "application/rar" },
838     },
839     expected_data_length => {
840     identifier => "Frost-gpl.txt",
841     data_length => 37576,
842     global => "true",
843     },
844     simple_progress => {
845     identifier => "Frost-gpl.txt",
846     failed => 0,
847     fatally_failed => 0,
848     finalized_total => "true",
849     global => "true",
850     last_progress => 1438639282628,
851     required => 372,
852     succeeded => 102,
853     total => 747,
854     },
855     data_found => {
856     identifier => "Frost-gpl.txt",
857     completion_time => 1438663354026,
858     data_length => 37576,
859     global => "true",
860     metadata => { content_type => "image/jpeg" },
861     startup_time => 1438657196167,
862     },
863     }
864    
865 root 1.3 =head1 EXAMPLE PROGRAM
866    
867     use AnyEvent::FCP;
868    
869     my $fcp = new AnyEvent::FCP;
870    
871     # let us look at the global request list
872 root 1.11 $fcp->watch_global_ (1);
873 root 1.3
874     # list them, synchronously
875 root 1.11 my $req = $fcp->list_persistent_requests;
876 root 1.3
877     # go through all requests
878 root 1.11 TODO
879 root 1.3 for my $req (values %$req) {
880     # skip jobs not directly-to-disk
881     next unless $req->{return_type} eq "disk";
882     # skip jobs not issued by FProxy
883     next unless $req->{identifier} =~ /^FProxy:/;
884    
885     if ($req->{data_found}) {
886     # file has been successfully downloaded
887    
888     ... move the file away
889     (left as exercise)
890    
891     # remove the request
892    
893     $fcp->remove_request (1, $req->{identifier});
894     } elsif ($req->{get_failed}) {
895     # request has failed
896     if ($req->{get_failed}{code} == 11) {
897     # too many path components, should restart
898     } else {
899     # other failure
900     }
901     } else {
902     # modify priorities randomly, to improve download rates
903     $fcp->modify_persistent_request (1, $req->{identifier}, undef, int 6 - 5 * (rand) ** 1.7)
904     if 0.1 > rand;
905     }
906     }
907    
908     # see if the dummy plugin is loaded, to ensure all previous requests have finished.
909     $fcp->get_plugin_info_sync ("dummy");
910    
911 root 1.1 =head1 SEE ALSO
912    
913 root 1.2 L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0>, L<Net::FCP>.
914 root 1.1
915     =head1 BUGS
916    
917     =head1 AUTHOR
918    
919     Marc Lehmann <schmorp@schmorp.de>
920     http://home.schmorp.de/
921    
922     =cut
923    
924     1
925