ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent-FCP/FCP.pm
Revision: 1.12
Committed: Sat Aug 8 04:02:48 2015 UTC (8 years, 9 months ago) by root
Branch: MAIN
Changes since 1.11: +135 -49 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.12 if ($kv->{identifier} eq $identifier) {
523     if ($type eq "persistent_request_modified") {
524     $ok->($kv);
525     return;
526     } elsif ($type eq "protocol_error") {
527     $err->($kv);
528     return;
529     }
530     }
531 root 1.1
532 root 1.2 1
533 root 1.12 });
534     });
535 root 1.2 };
536 root 1.1
537 root 1.11 =item $info = $fcp->get_plugin_info ($name, $detailed)
538 root 1.3
539     =cut
540    
541 root 1.2 _txn get_plugin_info => sub {
542 root 1.12 my ($self, $ok, $err, $name, $detailed) = @_;
543 root 1.1
544 root 1.2 $self->send_msg (get_plugin_info =>
545     plugin_name => $name,
546     detailed => $detailed ? "true" : "false",
547     id_cb => sub {
548     my ($self, $type, $kv, $rdata) = @_;
549    
550 root 1.12 $ok->($kv);
551 root 1.2 1
552     },
553     );
554 root 1.4 };
555    
556 root 1.11 =item $status = $fcp->client_get ($uri, $identifier, %kv)
557 root 1.1
558 root 1.4 %kv can contain (L<http://wiki.freenetproject.org/FCP2p0ClientGet>).
559    
560     ignore_ds, ds_only, verbosity, max_size, max_temp_size, max_retries,
561     priority_class, persistence, client_token, global, return_type,
562     binary_blob, allowed_mime_types, filename, temp_filename
563    
564     =cut
565    
566     _txn client_get => sub {
567 root 1.12 my ($self, $ok, $err, $uri, $identifier, %kv) = @_;
568 root 1.4
569     $self->send_msg (client_get =>
570     %kv,
571     uri => $uri,
572     identifier => $identifier,
573 root 1.11 );
574 root 1.12
575     $ok->();
576 root 1.11 };
577    
578     =item $status = $fcp->remove_request ($identifier[, $global])
579    
580     Remove the request with the given isdentifier. Returns true if successful,
581     false on error.
582    
583     =cut
584    
585     _txn remove_request => sub {
586 root 1.12 my ($self, $ok, $err, $identifier, $global) = @_;
587 root 1.11
588     $self->serialise ($identifier => sub {
589     my ($self, $guard) = @_;
590    
591     $self->send_msg (remove_request =>
592     identifier => $identifier,
593     global => $global ? "true" : "false",
594     );
595     $self->on (sub {
596     my ($self, $type, $kv, @extra) = @_;
597    
598     if ($kv->{identifier} eq $identifier) {
599     if ($type eq "persistent_request_removed") {
600 root 1.12 $ok->(1);
601 root 1.11 return;
602     } elsif ($type eq "protocol_error") {
603 root 1.12 $err->($kv);
604 root 1.11 return;
605     }
606     }
607 root 1.4
608     1
609 root 1.11 });
610     });
611 root 1.2 };
612 root 1.1
613 root 1.11 =item ($can_read, $can_write) = $fcp->test_dda ($local_directory, $remote_directory, $want_read, $want_write))
614 root 1.9
615     The DDA test in FCP is probably the single most broken protocol - only
616     one directory test can be outstanding at any time, and some guessing and
617     heuristics are involved in mangling the paths.
618    
619     This function combines C<TestDDARequest> and C<TestDDAResponse> in one
620 root 1.11 request, handling file reading and writing as well, and tries very hard to
621     do the right thing.
622    
623     Both C<$local_directory> and C<$remote_directory> must specify the same
624     directory - C<$local_directory> is the directory path on the client (where
625     L<AnyEvent::FCP> runs) and C<$remote_directory> is the directory path on
626     the server (where the freenet node runs). When both are running on the
627     same node, the paths are generally identical.
628    
629     C<$want_read> and C<$want_write> should be set to a true value when you
630     want to read (get) files or write (put) files, respectively.
631    
632     On error, an exception is thrown. Otherwise, C<$can_read> and
633     C<$can_write> indicate whether you can reaqd or write to freenet via the
634     directory.
635 root 1.9
636     =cut
637    
638     _txn test_dda => sub {
639 root 1.12 my ($self, $ok, $err, $local, $remote, $want_read, $want_write) = @_;
640 root 1.9
641     $self->serialise (test_dda => sub {
642     my ($self, $guard) = @_;
643    
644     $self->send_msg (test_dda_request =>
645     directory => $remote,
646     want_read_directory => $want_read ? "true" : "false",
647     want_write_directory => $want_write ? "true" : "false",
648     );
649     $self->on (sub {
650 root 1.10 my ($self, $type, $kv) = @_;
651 root 1.9
652     if ($type eq "test_dda_reply") {
653     # the filenames are all relative to the server-side directory,
654     # which might or might not match $remote anymore, so we
655     # need to rewrite the paths to be relative to $local
656     for my $k (qw(read_filename write_filename)) {
657     my $f = $kv->{$k};
658     for my $dir ($kv->{directory}, $remote) {
659     if ($dir eq substr $f, 0, length $dir) {
660     substr $f, 0, 1 + length $dir, "";
661     $kv->{$k} = $f;
662     last;
663     }
664     }
665     }
666    
667     my %response = (directory => $remote);
668    
669     if (length $kv->{read_filename}) {
670     if (open my $fh, "<:raw", "$local/$kv->{read_filename}") {
671     sysread $fh, my $buf, -s $fh;
672     $response{read_content} = $buf;
673     }
674     }
675    
676     if (length $kv->{write_filename}) {
677     if (open my $fh, ">:raw", "$local/$kv->{write_filename}") {
678     syswrite $fh, $kv->{content_to_write};
679     }
680     }
681    
682     $self->send_msg (test_dda_response => %response);
683    
684     $self->on (sub {
685 root 1.10 my ($self, $type, $kv) = @_;
686 root 1.9
687     $guard if 0; # reference
688    
689     if ($type eq "test_dda_complete") {
690 root 1.12 $ok->(
691 root 1.9 $kv->{read_directory_allowed} eq "true",
692     $kv->{write_directory_allowed} eq "true",
693     );
694     } elsif ($type eq "protocol_error" && $kv->{identifier} eq $remote) {
695 root 1.12 $err->($kv->{extra_description});
696 root 1.9 return;
697     }
698    
699     1
700     });
701    
702     return;
703     } elsif ($type eq "protocol_error" && $kv->{identifier} eq $remote) {
704 root 1.12 $err->($kv);
705 root 1.9 return;
706     }
707    
708     1
709     });
710     });
711     };
712    
713 root 1.1 =back
714    
715 root 1.11 =head2 REQUEST CACHE
716    
717     The C<AnyEvent::FCP> class keeps a request cache, where it caches all
718     information from requests.
719    
720     For these messages, it will store a copy of the key-value pairs, together with a C<type> slot,
721     in C<< $fcp->{req}{$identifier} >>:
722    
723     persistent_get
724     persistent_put
725     persistent_put_dir
726    
727     This message updates the stored data:
728    
729     persistent_request_modified
730    
731     This message will remove this entry:
732    
733     persistent_request_removed
734    
735     These messages get merged into the cache entry, under their
736     type, i.e. a C<simple_progress> message will be stored in C<<
737     $fcp->{req}{$identifier}{simple_progress} >>:
738    
739     simple_progress # get/put
740    
741     uri_generated # put
742     generated_metadata # put
743     started_compression # put
744     finished_compression # put
745     put_failed # put
746     put_fetchable # put
747     put_successful # put
748    
749     sending_to_network # get
750     compatibility_mode # get
751     expected_hashes # get
752     expected_mime # get
753     expected_data_length # get
754     get_failed # get
755     data_found # get
756     enter_finite_cooldown # get
757    
758     In addition, an event (basically a fake message) of type C<request_changed> is generated
759     on every change, which will be called as C<< $cb->($fcp, $kv, $type) >>, where C<$type>
760     is the type of the original message triggering the change,
761    
762     To fill this cache with the global queue and keep it updated,
763     call C<watch_global> to subscribe to updates, followed by
764     C<list_persistent_requests_sync>.
765    
766     $fcp->watch_global_sync_; # do not wait
767     $fcp->list_persistent_requests; # wait
768    
769     To get a better idea of what is stored in the cache, here is an example of
770     what might be stored in C<< $fcp->{req}{"Frost-gpl.txt"} >>:
771    
772     {
773     identifier => "Frost-gpl.txt",
774     uri => 'CHK@Fnx5kzdrfE,EImdzaVyEWl,AAIC--8/gpl.txt',
775     binary_blob => "false",
776     global => "true",
777     max_retries => -1,
778     max_size => 9223372036854775807,
779     persistence => "forever",
780     priority_class => 3,
781     real_time => "false",
782     return_type => "direct",
783     started => "true",
784     type => "persistent_get",
785     verbosity => 2147483647,
786     sending_to_network => {
787     identifier => "Frost-gpl.txt",
788     global => "true",
789     },
790     compatibility_mode => {
791     identifier => "Frost-gpl.txt",
792     definitive => "true",
793     dont_compress => "false",
794     global => "true",
795     max => "COMPAT_1255",
796     min => "COMPAT_1255",
797     },
798     expected_hashes => {
799     identifier => "Frost-gpl.txt",
800     global => "true",
801     hashes => {
802     ed2k => "d83596f5ee3b7...",
803     md5 => "e0894e4a2a6...",
804     sha1 => "...",
805     sha256 => "...",
806     sha512 => "...",
807     tth => "...",
808     },
809     },
810     expected_mime => {
811     identifier => "Frost-gpl.txt",
812     global => "true",
813     metadata => { content_type => "application/rar" },
814     },
815     expected_data_length => {
816     identifier => "Frost-gpl.txt",
817     data_length => 37576,
818     global => "true",
819     },
820     simple_progress => {
821     identifier => "Frost-gpl.txt",
822     failed => 0,
823     fatally_failed => 0,
824     finalized_total => "true",
825     global => "true",
826     last_progress => 1438639282628,
827     required => 372,
828     succeeded => 102,
829     total => 747,
830     },
831     data_found => {
832     identifier => "Frost-gpl.txt",
833     completion_time => 1438663354026,
834     data_length => 37576,
835     global => "true",
836     metadata => { content_type => "image/jpeg" },
837     startup_time => 1438657196167,
838     },
839     }
840    
841 root 1.3 =head1 EXAMPLE PROGRAM
842    
843     use AnyEvent::FCP;
844    
845     my $fcp = new AnyEvent::FCP;
846    
847     # let us look at the global request list
848 root 1.11 $fcp->watch_global_ (1);
849 root 1.3
850     # list them, synchronously
851 root 1.11 my $req = $fcp->list_persistent_requests;
852 root 1.3
853     # go through all requests
854 root 1.11 TODO
855 root 1.3 for my $req (values %$req) {
856     # skip jobs not directly-to-disk
857     next unless $req->{return_type} eq "disk";
858     # skip jobs not issued by FProxy
859     next unless $req->{identifier} =~ /^FProxy:/;
860    
861     if ($req->{data_found}) {
862     # file has been successfully downloaded
863    
864     ... move the file away
865     (left as exercise)
866    
867     # remove the request
868    
869     $fcp->remove_request (1, $req->{identifier});
870     } elsif ($req->{get_failed}) {
871     # request has failed
872     if ($req->{get_failed}{code} == 11) {
873     # too many path components, should restart
874     } else {
875     # other failure
876     }
877     } else {
878     # modify priorities randomly, to improve download rates
879     $fcp->modify_persistent_request (1, $req->{identifier}, undef, int 6 - 5 * (rand) ** 1.7)
880     if 0.1 > rand;
881     }
882     }
883    
884     # see if the dummy plugin is loaded, to ensure all previous requests have finished.
885     $fcp->get_plugin_info_sync ("dummy");
886    
887 root 1.1 =head1 SEE ALSO
888    
889 root 1.2 L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0>, L<Net::FCP>.
890 root 1.1
891     =head1 BUGS
892    
893     =head1 AUTHOR
894    
895     Marc Lehmann <schmorp@schmorp.de>
896     http://home.schmorp.de/
897    
898     =cut
899    
900     1
901