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.11 by root, Fri Aug 7 01:54:00 2015 UTC vs.
Revision 1.16 by root, Sat Sep 5 13:26:47 2015 UTC

… …
69 69
70use AnyEvent; 70use AnyEvent;
71use AnyEvent::Handle; 71use AnyEvent::Handle;
72use AnyEvent::Util (); 72use AnyEvent::Util ();
73 73
74our %TOLC; # tolc cache
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;
78 $_ 80 $_
… …
96 98
97=cut 99=cut
98 100
99sub new { 101sub new {
100 my $class = shift; 102 my $class = shift;
103
104 my $rand = join "", map chr 0x21 + rand 94, 1..40; # ~ 262 bits entropy
105
101 my $self = bless { 106 my $self = bless {
102 host => $ENV{FREDHOST} || "127.0.0.1", 107 host => $ENV{FREDHOST} || "127.0.0.1",
103 port => $ENV{FREDPORT} || 9481, 108 port => $ENV{FREDPORT} || 9481,
104 timeout => 3600 * 2, 109 timeout => 3600 * 2,
105 name => time.rand.rand.rand, # lame 110 name => time.rand.rand.rand, # lame
106 @_, 111 @_,
107 queue => [], 112 queue => [],
108 req => {}, 113 req => {},
114 prefix => "..:aefcpid:$rand:",
109 id => "a0", 115 idseq => "a0",
110 }, $class; 116 }, $class;
111 117
112 { 118 {
113 Scalar::Util::weaken (my $self = $self); 119 Scalar::Util::weaken (my $self = $self);
114 120
… …
131 ); 137 );
132 138
133 $self 139 $self
134} 140}
135 141
142sub identifier {
143 $_[0]{prefix} . ++$_[0]{idseq}
144}
145
136sub send_msg { 146sub send_msg {
137 my ($self, $type, %kv) = @_; 147 my ($self, $type, %kv) = @_;
138 148
139 my $data = delete $kv{data}; 149 my $data = delete $kv{data};
140 150
141 if (exists $kv{id_cb}) { 151 if (exists $kv{id_cb}) {
142 my $id = $kv{identifier} ||= ++$self->{id}; 152 my $id = $kv{identifier} ||= $self->identifier;
143 $self->{id}{$id} = delete $kv{id_cb}; 153 $self->{id}{$id} = delete $kv{id_cb};
144 } 154 }
145 155
146 my $msg = (touc $type) . "\012" 156 my $msg = (touc $type) . "\012"
147 . join "", map +(touc $_) . "=$kv{$_}\012", keys %kv; 157 . join "", map +(touc $_) . "=$kv{$_}\012", keys %kv;
… …
224 234
225 if (my $cb = $PERSISTENT_TYPE{$type}) { 235 if (my $cb = $PERSISTENT_TYPE{$type}) {
226 my $id = $kv->{identifier}; 236 my $id = $kv->{identifier};
227 my $req = $_[0]{req}{$id} ||= {}; 237 my $req = $_[0]{req}{$id} ||= {};
228 $cb->($self, $req, $kv); 238 $cb->($self, $req, $kv);
229 $self->recv (request_change => $kv, $type, @extra); 239 $self->recv (request_changed => $kv, $type, @extra);
230 } 240 }
231 241
232 my $on = $self->{on}; 242 my $on = $self->{on};
233 for (0 .. $#$on) { 243 for (0 .. $#$on) {
234 unless (my $res = $on->[$_]($self, $type, $kv, @extra)) { 244 unless (my $res = $on->[$_]($self, $type, $kv, @extra)) {
… …
246} 256}
247 257
248sub on_read { 258sub on_read {
249 my ($self) = @_; 259 my ($self) = @_;
250 260
251 my $type; 261 my ($k, $v, $type);
252 my %kv; 262 my %kv;
253 my $rdata; 263 my $rdata;
254 264
255 my $hdr_cb; $hdr_cb = sub { 265 my $hdr_cb; $hdr_cb = sub {
256 if ($_[1] =~ /^([^=]+)=(.*)$/) { 266 if (($v = index $_[1], "=") >= 0) {
257 my ($k, $v) = ($1, $2); 267 $k = substr $_[1], 0, $v;
268 $v = substr $_[1], $v + 1;
269 $k = ($TOLC{$k} ||= tolc $k);
270
271 if ($k !~ /\./) {
272 # special case common case, for performance only
273 $kv{$k} = $v;
274 } else {
258 my @k = split /\./, tolc $k; 275 my @k = split /\./, $k;
259 my $ro = \\%kv; 276 my $ro = \\%kv;
260 277
261 while (@k) { 278 while (@k) {
262 my $k = shift @k; 279 $k = shift @k;
263 if ($k =~ /^\d+$/) { 280 if ($k =~ /^\d+$/) {
264 $ro = \$$ro->[$k]; 281 $ro = \$$ro->[$k];
265 } else { 282 } else {
266 $ro = \$$ro->{$k}; 283 $ro = \$$ro->{$k};
284 }
267 } 285 }
286
287 $$ro = $v;
268 } 288 }
269
270 $$ro = $v;
271 289
272 $_[0]->push_read (line => $hdr_cb); 290 $_[0]->push_read (line => $hdr_cb);
273 } elsif ($_[1] eq "Data") { 291 } elsif ($_[1] eq "Data") {
274 $_[0]->push_read (chunk => delete $kv{data_length}, sub { 292 $_[0]->push_read (chunk => delete $kv{data_length}, sub {
275 $rdata = \$_[1]; 293 $rdata = \$_[1];
… …
281 die "protocol error, expected message end, got $_[1]\n";#d# 299 die "protocol error, expected message end, got $_[1]\n";#d#
282 } 300 }
283 }; 301 };
284 302
285 $self->{hdl}->push_read (line => sub { 303 $self->{hdl}->push_read (line => sub {
286 $type = tolc $_[1]; 304 $type = ($TOLC{$_[1]} ||= tolc $_[1]);
287 $_[0]->push_read (line => $hdr_cb); 305 $_[0]->push_read (line => $hdr_cb);
288 }); 306 });
289} 307}
290 308
291sub default_recv { 309sub default_recv {
… …
297 $self->{id}{$kv->{identifier}}($self, $type, $kv, $rdata) 315 $self->{id}{$kv->{identifier}}($self, $type, $kv, $rdata)
298 and delete $self->{id}{$kv->{identifier}}; 316 and delete $self->{id}{$kv->{identifier}};
299 } 317 }
300} 318}
301 319
320=back
321
322=head2 FCP REQUESTS
323
324The following methods implement various requests. Most of them map
325directory to the FCP message of the same name. The added benefit of
326these over sending requests yourself is that they handle the necessary
327serialisation, protocol quirks, and replies.
328
329All of them exist in two versions, the variant shown in this manpage, and
330a variant with an extra C<_> at the end, and an extra C<$cb> argument. The
331version as shown is I<synchronous> - it will wait for any replies, and
332either return the reply, or croak with an error. The underscore variant
333returns immediately and invokes one or more callbacks or condvars later.
334
335For example, the call
336
337 $info = $fcp->get_plugin_info ($name, $detailed);
338
339Also comes in this underscore variant:
340
341 $fcp->get_plugin_info_ ($name, $detailed, $cb);
342
343You can thinbk of the underscore as a kind of continuation indicator - the
344normal function waits and returns with the data, the C<_> indicates that
345you pass the continuation yourself, and the continuation will be invoked
346with the results.
347
348This callback/continuation argument (C<$cb>) can come in three forms itself:
349
350=over 4
351
352=item A code reference (or rather anything not matching some other alternative)
353
354This code reference will be invoked with the result on success. On an
355error, it will die (in the event loop) with a backtrace of the call site.
356
357This is a popular choice, but it makes handling errors hard - make sure
358you never generate protocol errors!
359
360=item A condvar (as returned by e.g. C<< AnyEvent->condvar >>)
361
362When a condvar is passed, it is sent (C<< $cv->send ($results) >>) the
363results when the request has finished. Should an error occur, the error
364will instead result in C<< $cv->croak ($error) >>.
365
366This is also a popular choice.
367
368=item An array with two callbacks C<[$success, $failure]>
369
370The C<$success> callback will be invoked with the results, while the
371C<$failure> callback will be invoked on any errors.
372
373=item C<undef>
374
375This is the same thing as specifying C<sub { }> as callback, i.e. on
376success, the results are ignored, while on failure, you the module dies
377with a backtrace.
378
379This is good for quick scripts, or when you really aren't interested in
380the results.
381
382=back
383
384=cut
385
302our $NOP_CB = sub { }; 386our $NOP_CB = sub { };
303 387
304sub _txn { 388sub _txn {
305 my ($name, $sub) = @_; 389 my ($name, $sub) = @_;
306 390
307 *{$name} = sub { 391 *{$name} = sub {
308 splice @_, 1, 0, (my $cv = AnyEvent->condvar); 392 my $cv = AE::cv;
393
394 splice @_, 1, 0, $cv, sub { $cv->croak ($_[0]{extra_description}) };
309 &$sub; 395 &$sub;
310 $cv->recv 396 $cv->recv
311 }; 397 };
312 398
313 *{"$name\_"} = sub { 399 *{"$name\_"} = sub {
400 my ($ok, $err) = pop;
401
402 if (ARRAY:: eq ref $ok) {
403 ($ok, $err) = @$ok;
404 } elsif (UNIVERSAL::isa $ok, AnyEvent::CondVar::) {
405 $err = sub { $ok->croak ($_[0]{extra_description}) };
406 } else {
407 my $bt = Carp::longmess "";
408 $err = sub {
409 die "$_[0]{code_description} ($_[0]{extra_description})$bt";
410 };
411 }
412
413 $ok ||= $NOP_CB;
414
314 splice @_, 1, 0, pop || $NOP_CB; 415 splice @_, 1, 0, $ok, $err;
315 &$sub; 416 &$sub;
316 }; 417 };
317} 418}
318 419
420=over 4
421
319=item $peers = $fcp->list_peers ([$with_metdata[, $with_volatile]]) 422=item $peers = $fcp->list_peers ([$with_metdata[, $with_volatile]])
320 423
321=cut 424=cut
322 425
323_txn list_peers => sub { 426_txn list_peers => sub {
324 my ($self, $cv, $with_metadata, $with_volatile) = @_; 427 my ($self, $ok, undef, $with_metadata, $with_volatile) = @_;
325 428
326 my @res; 429 my @res;
327 430
328 $self->send_msg (list_peers => 431 $self->send_msg (list_peers =>
329 with_metadata => $with_metadata ? "true" : "false", 432 with_metadata => $with_metadata ? "true" : "false",
330 with_volatile => $with_volatile ? "true" : "false", 433 with_volatile => $with_volatile ? "true" : "false",
331 id_cb => sub { 434 id_cb => sub {
332 my ($self, $type, $kv, $rdata) = @_; 435 my ($self, $type, $kv, $rdata) = @_;
333 436
334 if ($type eq "end_list_peers") { 437 if ($type eq "end_list_peers") {
335 $cv->(\@res); 438 $ok->(\@res);
336 1 439 1
337 } else { 440 } else {
338 push @res, $kv; 441 push @res, $kv;
339 0 442 0
340 } 443 }
… …
345=item $notes = $fcp->list_peer_notes ($node_identifier) 448=item $notes = $fcp->list_peer_notes ($node_identifier)
346 449
347=cut 450=cut
348 451
349_txn list_peer_notes => sub { 452_txn list_peer_notes => sub {
350 my ($self, $cv, $node_identifier) = @_; 453 my ($self, $ok, undef, $node_identifier) = @_;
351 454
352 $self->send_msg (list_peer_notes => 455 $self->send_msg (list_peer_notes =>
353 node_identifier => $node_identifier, 456 node_identifier => $node_identifier,
354 id_cb => sub { 457 id_cb => sub {
355 my ($self, $type, $kv, $rdata) = @_; 458 my ($self, $type, $kv, $rdata) = @_;
356 459
357 $cv->($kv); 460 $ok->($kv);
358 1 461 1
359 }, 462 },
360 ); 463 );
361}; 464};
362 465
363=item $fcp->watch_global ($enabled[, $verbosity_mask]) 466=item $fcp->watch_global ($enabled[, $verbosity_mask])
364 467
365=cut 468=cut
366 469
367_txn watch_global => sub { 470_txn watch_global => sub {
368 my ($self, $cv, $enabled, $verbosity_mask) = @_; 471 my ($self, $ok, $err, $enabled, $verbosity_mask) = @_;
369 472
370 $self->send_msg (watch_global => 473 $self->send_msg (watch_global =>
371 enabled => $enabled ? "true" : "false", 474 enabled => $enabled ? "true" : "false",
372 defined $verbosity_mask ? (verbosity_mask => $verbosity_mask+0) : (), 475 defined $verbosity_mask ? (verbosity_mask => $verbosity_mask+0) : (),
373 ); 476 );
374 477
375 $cv->(); 478 $ok->();
376}; 479};
377 480
378=item $reqs = $fcp->list_persistent_requests 481=item $reqs = $fcp->list_persistent_requests
379 482
380=cut 483=cut
381 484
382_txn list_persistent_requests => sub { 485_txn list_persistent_requests => sub {
383 my ($self, $cv) = @_; 486 my ($self, $ok, $err) = @_;
384 487
385 $self->serialise (list_persistent_requests => sub { 488 $self->serialise (list_persistent_requests => sub {
386 my ($self, $guard) = @_; 489 my ($self, $guard) = @_;
387 490
388 my @res; 491 my @res;
… …
393 my ($self, $type, $kv, $rdata) = @_; 496 my ($self, $type, $kv, $rdata) = @_;
394 497
395 $guard if 0; 498 $guard if 0;
396 499
397 if ($type eq "end_list_persistent_requests") { 500 if ($type eq "end_list_persistent_requests") {
398 $cv->(\@res); 501 $ok->(\@res);
399 return; 502 return;
400 } else { 503 } else {
401 my $id = $kv->{identifier}; 504 my $id = $kv->{identifier};
402 505
403 if ($type =~ /^persistent_(get|put|put_dir)$/) { 506 if ($type =~ /^persistent_(get|put|put_dir)$/) {
… …
408 1 511 1
409 }); 512 });
410 }); 513 });
411}; 514};
412 515
413=item $status = $fcp->remove_request ($global, $identifier) 516=item $sync = $fcp->modify_persistent_request ($global, $identifier[, $client_token[, $priority_class]])
414 517
415=cut 518Update either the C<client_token> or C<priority_class> of a request
519identified by C<$global> and C<$identifier>, depending on which of
520C<$client_token> and C<$priority_class> are not C<undef>.
416 521
417_txn remove_request => sub { 522=cut
418 my ($self, $cv, $global, $identifier) = @_;
419 523
524_txn modify_persistent_request => sub {
525 my ($self, $ok, $err, $global, $identifier, $client_token, $priority_class) = @_;
526
527 $self->serialise ($identifier => sub {
528 my ($self, $guard) = @_;
529
420 $self->send_msg (remove_request => 530 $self->send_msg (modify_persistent_request =>
421 global => $global ? "true" : "false", 531 global => $global ? "true" : "false",
422 identifier => $identifier, 532 identifier => $identifier,
423 id_cb => sub { 533 defined $client_token ? (client_token => $client_token ) : (),
534 defined $priority_class ? (priority_class => $priority_class) : (),
535 );
536
537 $self->on (sub {
424 my ($self, $type, $kv, $rdata) = @_; 538 my ($self, $type, $kv, @extra) = @_;
425 539
540 $guard if 0;
541
542 if ($kv->{identifier} eq $identifier) {
543 if ($type eq "persistent_request_modified") {
426 $cv->($kv); 544 $ok->($kv);
545 return;
546 } elsif ($type eq "protocol_error") {
547 $err->($kv);
548 return;
549 }
550 }
551
427 1 552 1
428 }, 553 });
429 ); 554 });
430}; 555};
431 556
432=item $sync = $fcp->modify_persistent_request ($global, $identifier[, $client_token[, $priority_class]])
433
434=cut
435
436_txn modify_persistent_request => sub {
437 my ($self, $cv, $global, $identifier, $client_token, $priority_class) = @_;
438
439 $self->send_msg (modify_persistent_request =>
440 global => $global ? "true" : "false",
441 defined $client_token ? (client_token => $client_token ) : (),
442 defined $priority_class ? (priority_class => $priority_class) : (),
443 identifier => $identifier,
444 id_cb => sub {
445 my ($self, $type, $kv, $rdata) = @_;
446
447 $cv->($kv);
448 1
449 },
450 );
451};
452
453=item $info = $fcp->get_plugin_info ($name, $detailed) 557=item $info = $fcp->get_plugin_info ($name, $detailed)
454 558
455=cut 559=cut
456 560
457_txn get_plugin_info => sub { 561_txn get_plugin_info => sub {
458 my ($self, $cv, $name, $detailed) = @_; 562 my ($self, $ok, $err, $name, $detailed) = @_;
563
564 my $id = $self->identifier;
459 565
460 $self->send_msg (get_plugin_info => 566 $self->send_msg (get_plugin_info =>
567 identifier => $id,
461 plugin_name => $name, 568 plugin_name => $name,
462 detailed => $detailed ? "true" : "false", 569 detailed => $detailed ? "true" : "false",
463 id_cb => sub {
464 my ($self, $type, $kv, $rdata) = @_;
465
466 $cv->($kv);
467 1
468 },
469 ); 570 );
571 $self->on (sub {
572 my ($self, $type, $kv) = @_;
573
574 if ($kv->{identifier} eq $id) {
575 if ($type eq "get_plugin_info") {
576 $ok->($kv);
577 } else {
578 $err->($kv, $type);
579 }
580 return;
581 }
582
583 1
584 });
470}; 585};
471 586
472=item $status = $fcp->client_get ($uri, $identifier, %kv) 587=item $status = $fcp->client_get ($uri, $identifier, %kv)
473 588
474%kv can contain (L<http://wiki.freenetproject.org/FCP2p0ClientGet>). 589%kv can contain (L<http://wiki.freenetproject.org/FCP2p0ClientGet>).
… …
478binary_blob, allowed_mime_types, filename, temp_filename 593binary_blob, allowed_mime_types, filename, temp_filename
479 594
480=cut 595=cut
481 596
482_txn client_get => sub { 597_txn client_get => sub {
483 my ($self, $cv, $uri, $identifier, %kv) = @_; 598 my ($self, $ok, $err, $uri, $identifier, %kv) = @_;
484 599
600 $self->serialise ($identifier => sub {
601 my ($self, $guard) = @_;
602
485 $self->send_msg (client_get => 603 $self->send_msg (client_get =>
486 %kv, 604 %kv,
487 uri => $uri, 605 uri => $uri,
488 identifier => $identifier, 606 identifier => $identifier,
607 );
608
609 $self->on (sub {
610 my ($self, $type, $kv, @extra) = @_;
611
612 $guard if 0;
613
614 if ($kv->{identifier} eq $identifier) {
615 if ($type eq "persistent_get") {
616 $ok->($kv);
617 return;
618 } elsif ($type eq "protocol_error") {
619 $err->($kv);
620 return;
621 }
622 }
623
624 1
625 });
489 ); 626 });
490}; 627};
491 628
492=item $status = $fcp->remove_request ($identifier[, $global]) 629=item $status = $fcp->remove_request ($identifier[, $global])
493 630
494Remove the request with the given isdentifier. Returns true if successful, 631Remove the request with the given isdentifier. Returns true if successful,
495false on error. 632false on error.
496 633
497=cut 634=cut
498 635
499_txn remove_request => sub { 636_txn remove_request => sub {
500 my ($self, $cv, $identifier, $global) = @_; 637 my ($self, $ok, $err, $identifier, $global) = @_;
501 638
502 $self->serialise ($identifier => sub { 639 $self->serialise ($identifier => sub {
503 my ($self, $guard) = @_; 640 my ($self, $guard) = @_;
504 641
505 $self->send_msg (remove_request => 642 $self->send_msg (remove_request =>
… …
507 global => $global ? "true" : "false", 644 global => $global ? "true" : "false",
508 ); 645 );
509 $self->on (sub { 646 $self->on (sub {
510 my ($self, $type, $kv, @extra) = @_; 647 my ($self, $type, $kv, @extra) = @_;
511 648
649 $guard if 0;
650
512 if ($kv->{identifier} eq $identifier) { 651 if ($kv->{identifier} eq $identifier) {
513 if ($type eq "persistent_request_removed") { 652 if ($type eq "persistent_request_removed") {
514 $cv->(1); 653 $ok->(1);
515 return; 654 return;
516 } elsif ($type eq "protocol_error") { 655 } elsif ($type eq "protocol_error") {
517 $cv->(undef); 656 $err->($kv);
518 return; 657 return;
519 } 658 }
520 } 659 }
521 660
522 1 661 1
… …
548directory. 687directory.
549 688
550=cut 689=cut
551 690
552_txn test_dda => sub { 691_txn test_dda => sub {
553 my ($self, $cv, $local, $remote, $want_read, $want_write) = @_; 692 my ($self, $ok, $err, $local, $remote, $want_read, $want_write) = @_;
554 693
555 $self->serialise (test_dda => sub { 694 $self->serialise (test_dda => sub {
556 my ($self, $guard) = @_; 695 my ($self, $guard) = @_;
557 696
558 $self->send_msg (test_dda_request => 697 $self->send_msg (test_dda_request =>
… …
599 my ($self, $type, $kv) = @_; 738 my ($self, $type, $kv) = @_;
600 739
601 $guard if 0; # reference 740 $guard if 0; # reference
602 741
603 if ($type eq "test_dda_complete") { 742 if ($type eq "test_dda_complete") {
604 $cv->( 743 $ok->(
605 $kv->{read_directory_allowed} eq "true", 744 $kv->{read_directory_allowed} eq "true",
606 $kv->{write_directory_allowed} eq "true", 745 $kv->{write_directory_allowed} eq "true",
607 ); 746 );
608 } elsif ($type eq "protocol_error" && $kv->{identifier} eq $remote) { 747 } elsif ($type eq "protocol_error" && $kv->{identifier} eq $remote) {
609 $cv->croak ($kv->{extra_description}); 748 $err->($kv->{extra_description});
610 return; 749 return;
611 } 750 }
612 751
613 1 752 1
614 }); 753 });
615 754
616 return; 755 return;
617 } elsif ($type eq "protocol_error" && $kv->{identifier} eq $remote) { 756 } elsif ($type eq "protocol_error" && $kv->{identifier} eq $remote) {
618 $cv->croak ($kv->{extra_description}); 757 $err->($kv);
619 return; 758 return;
620 } 759 }
621 760
622 1 761 1
623 }); 762 });

Diff Legend

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