ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent-FCP/FCP.pm
(Generate patch)

Comparing AnyEvent-FCP/FCP.pm (file contents):
Revision 1.13 by root, Sat Aug 8 04:07:28 2015 UTC vs.
Revision 1.28 by root, Thu Sep 9 00:49:06 2021 UTC

… …
18=head1 DESCRIPTION 18=head1 DESCRIPTION
19 19
20This module implements the freenet client protocol version 2.0, as used by 20This module implements the freenet client protocol version 2.0, as used by
21freenet 0.7. See L<Net::FCP> for the earlier freenet 0.5 version. 21freenet 0.7. See L<Net::FCP> for the earlier freenet 0.5 version.
22 22
23See L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0> for a 23See L<https://wiki.freenetproject.org/FCP> for a description of what the
24description of what the messages do. 24messages do.
25 25
26The module uses L<AnyEvent> to find a suitable event module. 26The module uses L<AnyEvent> to find a suitable event module.
27 27
28Only very little is implemented, ask if you need more, and look at the 28Only very little is implemented, ask if you need more, and look at the
29example program later in this section. 29example program later in this section.
… …
61 61
62use common::sense; 62use common::sense;
63 63
64use Carp; 64use Carp;
65 65
66our $VERSION = '0.3'; 66our $VERSION = 0.5;
67 67
68use Scalar::Util (); 68use Scalar::Util ();
69 69
70use AnyEvent; 70use AnyEvent;
71use AnyEvent::Handle; 71use AnyEvent::Handle;
72use AnyEvent::Util (); 72use AnyEvent::Util ();
73
74our %TOLC; # tolc cache
73 75
74sub touc($) { 76sub touc($) {
75 local $_ = shift; 77 local $_ = shift;
76 1 while s/((?:^|_)(?:svk|chk|uri|fcp|ds|mime|dda)(?:_|$))/\U$1/; 78 1 while s/((?:^|_)(?:svk|chk|uri|fcp|ds|mime|dda)(?:_|$))/\U$1/;
77 s/(?:^|_)(.)/\U$1/g; 79 s/(?:^|_)(.)/\U$1/g;
… …
84 1 while s/([^_])(SVK|CHK|URI|FCP|DS|MIME|DDA)/$1\_$2/; 86 1 while s/([^_])(SVK|CHK|URI|FCP|DS|MIME|DDA)/$1\_$2/;
85 s/(?<=[a-z])(?=[A-Z])/_/g; 87 s/(?<=[a-z])(?=[A-Z])/_/g;
86 lc 88 lc
87} 89}
88 90
89=item $fcp = new AnyEvent::FCP [host => $host][, port => $port][, name => $name] 91=item $fcp = new AnyEvent::FCP key => value...;
90 92
91Create a new FCP connection to the given host and port (default 93Create a new FCP connection to the given host and port (default
92127.0.0.1:9481, or the environment variables C<FREDHOST> and C<FREDPORT>). 94127.0.0.1:9481, or the environment variables C<FREDHOST> and C<FREDPORT>).
93 95
94If no C<name> was specified, then AnyEvent::FCP will generate a 96If no C<name> was specified, then AnyEvent::FCP will generate a
95(hopefully) unique client name for you. 97(hopefully) unique client name for you.
96 98
99The following keys can be specified (they are all optional):
100
101=over 4
102
103=item name => $string
104
105A unique name to identify this client. If none is specified, a randomly
106generated name will be used.
107
108=item host => $hostname
109
110The hostname or IP address of the freenet node. Default is C<$ENV{FREDHOST}>
111or C<127.0.0.1>.
112
113=item port => $portnumber
114
115The port number of the FCP port. Default is C<$ENV{FREDPORT}> or C<9481>.
116
117=item timeout => $seconds
118
119The timeout, in seconds, after which a connection error is assumed when
120there is no activity. Default is C<7200>, i.e. two hours.
121
122=item keepalive => $seconds
123
124The interval, in seconds, at which keepalive messages will be
125sent. Default is C<540>, i.e. nine minutes.
126
127These keepalive messages are useful both to detect that a connection is
128no longer working and to keep any (home) routers from expiring their
129masquerading entry.
130
131=item on_eof => $callback->($fcp)
132
133Invoked when the underlying L<AnyEvent::Handle> signals EOF, currently
134regardless of whether the EOF was expected or not.
135
136=item on_error => $callback->($fcp, $message)
137
138Invoked on any (fatal) errors, such as unexpected connection close. The
139callback receives the FCP object and a textual error message.
140
141=item on_failure => $callback->($fcp, $type, $args, $backtrace, $error)
142
143Invoked when an FCP request fails that didn't have a failure callback. See
144L<FCP REQUESTS> for details.
145
146=back
147
97=cut 148=cut
98 149
99sub new { 150sub new {
100 my $class = shift; 151 my $class = shift;
152
153 my $rand = join "", map chr 0x21 + rand 94, 1..40; # ~ 262 bits entropy
154
101 my $self = bless { 155 my $self = bless {
102 host => $ENV{FREDHOST} || "127.0.0.1", 156 host => $ENV{FREDHOST} || "127.0.0.1",
103 port => $ENV{FREDPORT} || 9481, 157 port => $ENV{FREDPORT} || 9481,
104 timeout => 3600 * 2, 158 timeout => 3600 * 2,
159 keepalive => 9 * 60,
105 name => time.rand.rand.rand, # lame 160 name => time.rand.rand.rand, # lame
106 @_, 161 @_,
107 queue => [], 162 queue => [],
108 req => {}, 163 req => {},
164 prefix => "..:aefcpid:$rand:",
109 id => "a0", 165 idseq => "a0",
110 }, $class; 166 }, $class;
111 167
112 { 168 {
113 Scalar::Util::weaken (my $self = $self); 169 Scalar::Util::weaken (my $self = $self);
170
171 $self->{kw} = AE::timer $self->{keepalive}, $self->{keepalive}, sub {
172 $self->{hdl}->push_write ("\n");
173 };
174
175 our $ENDMESSAGE = qr<\012(EndMessage|Data)\012>;
176
177 # these are declared here for performance reasons
178 my ($k, $v, $type);
179 my $rdata;
180
181 my $on_read = sub {
182 my ($hdl) = @_;
183
184 # we only carve out whole messages here
185 while ($hdl->{rbuf} =~ /\012(EndMessage|Data)\012/) {
186 # remember end marker
187 $rdata = $1 eq "Data"
188 or $1 eq "EndMessage"
189 or return $self->fatal ("protocol error, expected message end, got $1\n");
190
191 my @lines = split /\012/, substr $hdl->{rbuf}, 0, $-[0];
192
193 substr $hdl->{rbuf}, 0, $+[0], ""; # remove pkg
194
195 $type = shift @lines;
196 $type = ($TOLC{$type} ||= tolc $type);
197
198 my %kv;
199
200 for (@lines) {
201 ($k, $v) = split /=/, $_, 2;
202 $k = ($TOLC{$k} ||= tolc $k);
203
204 if ($k =~ /\./) {
205 # generic, slow case
206 my @k = split /\./, $k;
207 my $ro = \\%kv;
208
209 while (@k) {
210 $k = shift @k;
211 if ($k =~ /^\d+$/) {
212 $ro = \$$ro->[$k];
213 } else {
214 $ro = \$$ro->{$k};
215 }
216 }
217
218 $$ro = $v;
219
220 next;
221 }
222
223 # special comon case, for performance only
224 $kv{$k} = $v;
225 }
226
227 if ($rdata) {
228 $_[0]->push_read (chunk => delete $kv{data_length}, sub {
229 $rdata = \$_[1];
230 $self->recv ($type, \%kv, $rdata);
231 });
232
233 last; # do not tgry to parse more messages
234 } else {
235 $self->recv ($type, \%kv);
236 }
237 }
238 };
114 239
115 $self->{hdl} = new AnyEvent::Handle 240 $self->{hdl} = new AnyEvent::Handle
116 connect => [$self->{host} => $self->{port}], 241 connect => [$self->{host} => $self->{port}],
117 timeout => $self->{timeout}, 242 timeout => $self->{timeout},
243 on_read => $on_read,
244 on_eof => sub {
245 if ($self->{on_eof}) {
246 $self->{on_eof}($self);
247 } else {
248 $self->fatal ("EOF");
249 }
250 },
118 on_error => sub { 251 on_error => sub {
119 warn "@_\n";#d# 252 $self->fatal ($_[2]);
120 exit 1;
121 }, 253 },
122 on_read => sub { $self->on_read (@_) }, 254 ;
123 on_eof => $self->{on_eof} || sub { };
124 255
125 Scalar::Util::weaken ($self->{hdl}{fcp} = $self); 256 Scalar::Util::weaken ($self->{hdl}{fcp} = $self);
126 } 257 }
127 258
128 $self->send_msg (client_hello => 259 $self->send_msg (client_hello =>
… …
131 ); 262 );
132 263
133 $self 264 $self
134} 265}
135 266
267sub fatal {
268 my ($self, $msg) = @_;
269
270 $self->{hdl}->push_shutdown if $self->{hdl};
271 delete $self->{kw};
272
273 if ($self->{on_error}) {
274 $self->{on_error}->($self, $msg);
275 } else {
276 die "AnyEvent::FCP($self->{host}:$self->{port}): $msg";
277 }
278}
279
280sub identifier {
281 $_[0]{prefix} . ++$_[0]{idseq}
282}
283
136sub send_msg { 284sub send_msg {
137 my ($self, $type, %kv) = @_; 285 my ($self, $type, %kv) = @_;
138 286
139 my $data = delete $kv{data}; 287 my $data = delete $kv{data};
140 288
141 if (exists $kv{id_cb}) { 289 if (exists $kv{id_cb}) {
142 my $id = $kv{identifier} ||= ++$self->{id}; 290 my $id = $kv{identifier} ||= $self->identifier;
143 $self->{id}{$id} = delete $kv{id_cb}; 291 $self->{id}{$id} = delete $kv{id_cb};
144 } 292 }
145 293
146 my $msg = (touc $type) . "\012" 294 my $msg = (touc $type) . "\012"
147 . join "", map +(touc $_) . "=$kv{$_}\012", keys %kv; 295 . join "", map +(touc $_) . "=$kv{$_}\012", keys %kv;
148
149 sub id {
150 my ($self) = @_;
151
152
153 }
154 296
155 if (defined $data) { 297 if (defined $data) {
156 $msg .= "DataLength=" . (length $data) . "\012" 298 $msg .= "DataLength=" . (length $data) . "\012"
157 . "Data\012$data"; 299 . "Data\012$data";
158 } else { 300 } else {
… …
224 366
225 if (my $cb = $PERSISTENT_TYPE{$type}) { 367 if (my $cb = $PERSISTENT_TYPE{$type}) {
226 my $id = $kv->{identifier}; 368 my $id = $kv->{identifier};
227 my $req = $_[0]{req}{$id} ||= {}; 369 my $req = $_[0]{req}{$id} ||= {};
228 $cb->($self, $req, $kv); 370 $cb->($self, $req, $kv);
229 $self->recv (request_change => $kv, $type, @extra); 371 $self->recv (request_changed => $kv, $type, @extra);
230 } 372 }
231 373
232 my $on = $self->{on}; 374 my $on = $self->{on};
233 for (0 .. $#$on) { 375 for (0 .. $#$on) {
234 unless (my $res = $on->[$_]($self, $type, $kv, @extra)) { 376 unless (my $res = $on->[$_]($self, $type, $kv, @extra)) {
… …
243 } else { 385 } else {
244 $self->default_recv ($type, $kv, @extra); 386 $self->default_recv ($type, $kv, @extra);
245 } 387 }
246} 388}
247 389
248sub on_read {
249 my ($self) = @_;
250
251 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 } else {
266 $ro = \$$ro->{$k};
267 }
268 }
269
270 $$ro = $v;
271
272 $_[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 $self->recv ($type, \%kv, $rdata);
277 });
278 } elsif ($_[1] eq "EndMessage") {
279 $self->recv ($type, \%kv);
280 } else {
281 die "protocol error, expected message end, got $_[1]\n";#d#
282 }
283 };
284
285 $self->{hdl}->push_read (line => sub {
286 $type = tolc $_[1];
287 $_[0]->push_read (line => $hdr_cb);
288 });
289}
290
291sub default_recv { 390sub default_recv {
292 my ($self, $type, $kv, $rdata) = @_; 391 my ($self, $type, $kv, $rdata) = @_;
293 392
294 if ($type eq "node_hello") { 393 if ($type eq "node_hello") {
295 $self->{node_hello} = $kv; 394 $self->{node_hello} = $kv;
… …
320 419
321Also comes in this underscore variant: 420Also comes in this underscore variant:
322 421
323 $fcp->get_plugin_info_ ($name, $detailed, $cb); 422 $fcp->get_plugin_info_ ($name, $detailed, $cb);
324 423
325You can thinbk of the underscore as a kind of continuation indicator - the 424You can think of the underscore as a kind of continuation indicator - the
326normal function waits and returns with the data, the C<_> indicates that 425normal function waits and returns with the data, the C<_> indicates that
327you pass the continuation yourself, and the continuation will be invoked 426you pass the continuation yourself, and the continuation will be invoked
328with the results. 427with the results.
329 428
330This callback/continuation argument (C<$cb>) can come in three forms itself: 429This callback/continuation argument (C<$cb>) can come in three forms itself:
… …
332=over 4 431=over 4
333 432
334=item A code reference (or rather anything not matching some other alternative) 433=item A code reference (or rather anything not matching some other alternative)
335 434
336This code reference will be invoked with the result on success. On an 435This code reference will be invoked with the result on success. On an
436error, it will invoke the C<on_failure> callback of the FCP object, or,
337error, it will die (in the event loop) with a backtrace of the call site. 437if none was defined, will die (in the event loop) with a backtrace of the
438call site.
338 439
339This is a popular choice, but it makes handling errors hard - make sure 440This is a popular choice, but it makes handling errors hard - make sure
340you never generate protocol errors! 441you never generate protocol errors!
442
443In the failure case, if an C<on_failure> hook exists, it will be invoked
444with the FCP object, the request type (the name of the method, an arrayref
445containing the arguments from the original request invocation, a (textual)
446backtrace as generated by C<Carp::longmess>, and the error object from the
447server, in this order, e.g.:
448
449 on_failure => sub {
450 my ($fcp, $request_type, $orig_args, $backtrace, $error_object) = @_;
451
452 warn "FCP failure ($type @$args), $error_object->{code_description} ($error_object->{extra_description})$backtrace";
453 exit 1;
454 },
341 455
342=item A condvar (as returned by e.g. C<< AnyEvent->condvar >>) 456=item A condvar (as returned by e.g. C<< AnyEvent->condvar >>)
343 457
344When a condvar is passed, it is sent (C<< $cv->send ($results) >>) the 458When a condvar is passed, it is sent (C<< $cv->send ($results) >>) the
345results when the request has finished. Should an error occur, the error 459results when the request has finished. Should an error occur, the error
… …
350=item An array with two callbacks C<[$success, $failure]> 464=item An array with two callbacks C<[$success, $failure]>
351 465
352The C<$success> callback will be invoked with the results, while the 466The C<$success> callback will be invoked with the results, while the
353C<$failure> callback will be invoked on any errors. 467C<$failure> callback will be invoked on any errors.
354 468
469The C<$failure> callback will be invoked with the error object from the
470server.
471
355=item C<undef> 472=item C<undef>
356 473
357This is the same thing as specifying C<sub { }> as callback, i.e. on 474This is the same thing as specifying C<sub { }> as callback, i.e. on
358success, the results are ignored, while on failure, you the module dies 475success, the results are ignored, while on failure, the C<on_failure> hook
359with a backtrace. 476is invoked or the module dies with a backtrace.
360 477
361This is good for quick scripts, or when you really aren't interested in 478This is good for quick scripts, or when you really aren't interested in
362the results. 479the results.
363 480
364=back 481=back
… …
371 my ($name, $sub) = @_; 488 my ($name, $sub) = @_;
372 489
373 *{$name} = sub { 490 *{$name} = sub {
374 my $cv = AE::cv; 491 my $cv = AE::cv;
375 492
376 splice @_, 1, 0, $cv, sub { $cv->throw ($_[0]{extra_description}) }; 493 splice @_, 1, 0, $cv, sub { $cv->croak ($_[0]{extra_description}) };
377 &$sub; 494 &$sub;
378 $cv->recv 495 $cv->recv
379 }; 496 };
380 497
381 *{"$name\_"} = sub { 498 *{"$name\_"} = sub {
382 my ($ok, $err) = pop; 499 my ($ok, $err) = pop;
383 500
384 if (ARRAY:: eq ref $ok) { 501 if (ARRAY:: eq ref $ok) {
385 ($ok, $err) = @$ok; 502 ($ok, $err) = @$ok;
386 } elsif (UNIVERSAL::isa $ok, AnyEvent::CondVar::) { 503 } elsif (UNIVERSAL::isa $ok, AnyEvent::CondVar::) {
387 $err = sub { $ok->throw ($_[0]{extra_description}) }; 504 $err = sub { $ok->croak ($_[0]{extra_description}) };
388 } else { 505 } else {
389 my $bt = Carp::longmess ""; 506 my $bt = Carp::longmess "AnyEvent::FCP request $name";
507 Scalar::Util::weaken (my $self = $_[0]);
508 my $args = [@_]; shift @$args;
390 $err = sub { 509 $err = sub {
510 if ($self->{on_failure}) {
511 $self->{on_failure}($self, $name, $args, $bt, $_[0]);
512 } else {
391 die "$_[0]{extra_description}$bt"; 513 die "$_[0]{code_description} ($_[0]{extra_description})$bt";
514 }
392 }; 515 };
393 } 516 }
394 517
395 $ok ||= $NOP_CB; 518 $ok ||= $NOP_CB;
396 519
… …
541=cut 664=cut
542 665
543_txn get_plugin_info => sub { 666_txn get_plugin_info => sub {
544 my ($self, $ok, $err, $name, $detailed) = @_; 667 my ($self, $ok, $err, $name, $detailed) = @_;
545 668
669 my $id = $self->identifier;
670
546 $self->send_msg (get_plugin_info => 671 $self->send_msg (get_plugin_info =>
672 identifier => $id,
547 plugin_name => $name, 673 plugin_name => $name,
548 detailed => $detailed ? "true" : "false", 674 detailed => $detailed ? "true" : "false",
549 id_cb => sub {
550 my ($self, $type, $kv, $rdata) = @_;
551
552 $ok->($kv);
553 1
554 },
555 ); 675 );
676 $self->on (sub {
677 my ($self, $type, $kv) = @_;
678
679 if ($kv->{identifier} eq $id) {
680 if ($type eq "get_plugin_info") {
681 $ok->($kv);
682 } else {
683 $err->($kv, $type);
684 }
685 return;
686 }
687
688 1
689 });
556}; 690};
557 691
558=item $status = $fcp->client_get ($uri, $identifier, %kv) 692=item $status = $fcp->client_get ($uri, $identifier, %kv)
559 693
560%kv can contain (L<http://wiki.freenetproject.org/FCP2p0ClientGet>). 694%kv can contain (L<http://wiki.freenetproject.org/FCP2p0ClientGet>).
… …
597 }); 731 });
598}; 732};
599 733
600=item $status = $fcp->remove_request ($identifier[, $global]) 734=item $status = $fcp->remove_request ($identifier[, $global])
601 735
602Remove the request with the given isdentifier. Returns true if successful, 736Remove the request with the given identifier. Returns true if successful,
603false on error. 737false on error.
604 738
605=cut 739=cut
606 740
607_txn remove_request => sub { 741_txn remove_request => sub {
… …
652 786
653C<$want_read> and C<$want_write> should be set to a true value when you 787C<$want_read> and C<$want_write> should be set to a true value when you
654want to read (get) files or write (put) files, respectively. 788want to read (get) files or write (put) files, respectively.
655 789
656On error, an exception is thrown. Otherwise, C<$can_read> and 790On error, an exception is thrown. Otherwise, C<$can_read> and
657C<$can_write> indicate whether you can reaqd or write to freenet via the 791C<$can_write> indicate whether you can read or write to freenet via the
658directory. 792directory.
659 793
660=cut 794=cut
661 795
662_txn test_dda => sub { 796_txn test_dda => sub {
… …
783on every change, which will be called as C<< $cb->($fcp, $kv, $type) >>, where C<$type> 917on every change, which will be called as C<< $cb->($fcp, $kv, $type) >>, where C<$type>
784is the type of the original message triggering the change, 918is the type of the original message triggering the change,
785 919
786To fill this cache with the global queue and keep it updated, 920To fill this cache with the global queue and keep it updated,
787call C<watch_global> to subscribe to updates, followed by 921call C<watch_global> to subscribe to updates, followed by
788C<list_persistent_requests_sync>. 922C<list_persistent_requests>.
789 923
790 $fcp->watch_global_sync_; # do not wait 924 $fcp->watch_global_; # do not wait
791 $fcp->list_persistent_requests; # wait 925 $fcp->list_persistent_requests; # wait
792 926
793To get a better idea of what is stored in the cache, here is an example of 927To get a better idea of what is stored in the cache, here is an example of
794what might be stored in C<< $fcp->{req}{"Frost-gpl.txt"} >>: 928what might be stored in C<< $fcp->{req}{"Frost-gpl.txt"} >>:
795 929
… …
904 if 0.1 > rand; 1038 if 0.1 > rand;
905 } 1039 }
906 } 1040 }
907 1041
908 # see if the dummy plugin is loaded, to ensure all previous requests have finished. 1042 # see if the dummy plugin is loaded, to ensure all previous requests have finished.
909 $fcp->get_plugin_info_sync ("dummy"); 1043 $fcp->get_plugin_info ("dummy");
910 1044
911=head1 SEE ALSO 1045=head1 SEE ALSO
912 1046
913L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0>, L<Net::FCP>. 1047L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0>, L<Net::FCP>.
914 1048

Diff Legend

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