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.20 by root, Sun Jun 12 01:32:37 2016 UTC

… …
61 61
62use common::sense; 62use common::sense;
63 63
64use Carp; 64use Carp;
65 65
66our $VERSION = '0.3'; 66our $VERSION = 0.4;
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_error => $callback->($fcp, $message)
132
133Invoked on any (fatal) errors, such as unexpected connection close. The
134callback receives the FCP object and a textual error message.
135
136=item on_failure => $callback->($fcp, $backtrace, $args, $error)
137
138Invoked when an FCP request fails that didn't have a failure callback. See
139L<FCP REQUESTS> for details.
140
141=back
142
97=cut 143=cut
98 144
99sub new { 145sub new {
100 my $class = shift; 146 my $class = shift;
147
148 my $rand = join "", map chr 0x21 + rand 94, 1..40; # ~ 262 bits entropy
149
101 my $self = bless { 150 my $self = bless {
102 host => $ENV{FREDHOST} || "127.0.0.1", 151 host => $ENV{FREDHOST} || "127.0.0.1",
103 port => $ENV{FREDPORT} || 9481, 152 port => $ENV{FREDPORT} || 9481,
104 timeout => 3600 * 2, 153 timeout => 3600 * 2,
154 keepalive => 9 * 60,
105 name => time.rand.rand.rand, # lame 155 name => time.rand.rand.rand, # lame
106 @_, 156 @_,
107 queue => [], 157 queue => [],
108 req => {}, 158 req => {},
159 prefix => "..:aefcpid:$rand:",
109 id => "a0", 160 idseq => "a0",
110 }, $class; 161 }, $class;
111 162
112 { 163 {
113 Scalar::Util::weaken (my $self = $self); 164 Scalar::Util::weaken (my $self = $self);
165
166 $self->{kw} = AE::timer $self->{keepalive}, $self->{keepalive}, sub {
167 $self->{hdl}->push_write ("\n");
168 };
169
170 our $ENDMESSAGE = qr<\012(EndMessage|Data)\012>;
171
172 # these are declared here for performance reasons
173 my ($k, $v, $type);
174 my $rdata;
175
176 my $on_read = sub {
177 my ($hdl) = @_;
178
179 # we only carve out whole messages here
180 while ($hdl->{rbuf} =~ /\012(EndMessage|Data)\012/) {
181 # remember end marker
182 $rdata = $1 eq "Data"
183 or $1 eq "EndMessage"
184 or return $self->fatal ("protocol error, expected message end, got $1\n");
185
186 my @lines = split /\012/, substr $hdl->{rbuf}, 0, $-[0];
187
188 substr $hdl->{rbuf}, 0, $+[0], ""; # remove pkg
189
190 $type = shift @lines;
191 $type = ($TOLC{$type} ||= tolc $type);
192
193 my %kv;
194
195 for (@lines) {
196 ($k, $v) = split /=/, $_, 2;
197 $k = ($TOLC{$k} ||= tolc $k);
198
199 if ($k =~ /\./) {
200 # generic, slow case
201 my @k = split /\./, $k;
202 my $ro = \\%kv;
203
204 while (@k) {
205 $k = shift @k;
206 if ($k =~ /^\d+$/) {
207 $ro = \$$ro->[$k];
208 } else {
209 $ro = \$$ro->{$k};
210 }
211 }
212
213 $$ro = $v;
214
215 next;
216 }
217
218 # special comon case, for performance only
219 $kv{$k} = $v;
220 }
221
222 if ($rdata) {
223 $_[0]->push_read (chunk => delete $kv{data_length}, sub {
224 $rdata = \$_[1];
225 $self->recv ($type, \%kv, $rdata);
226 });
227
228 last; # do not tgry to parse more messages
229 } else {
230 $self->recv ($type, \%kv);
231 }
232 }
233 };
114 234
115 $self->{hdl} = new AnyEvent::Handle 235 $self->{hdl} = new AnyEvent::Handle
116 connect => [$self->{host} => $self->{port}], 236 connect => [$self->{host} => $self->{port}],
117 timeout => $self->{timeout}, 237 timeout => $self->{timeout},
238 on_read => $on_read,
239 on_eof => $self->{on_eof},
118 on_error => sub { 240 on_error => sub {
119 warn "@_\n";#d# 241 $self->fatal ($_[2]);
120 exit 1;
121 }, 242 },
122 on_read => sub { $self->on_read (@_) }, 243 ;
123 on_eof => $self->{on_eof} || sub { };
124 244
125 Scalar::Util::weaken ($self->{hdl}{fcp} = $self); 245 Scalar::Util::weaken ($self->{hdl}{fcp} = $self);
126 } 246 }
127 247
128 $self->send_msg (client_hello => 248 $self->send_msg (client_hello =>
… …
131 ); 251 );
132 252
133 $self 253 $self
134} 254}
135 255
256sub fatal {
257 my ($self, $msg) = @_;
258
259 $self->{hdl}->shutdown;
260 delete $self->{kw};
261
262 if ($self->{on_error}) {
263 $self->{on_error}->($self, $msg);
264 } else {
265 die $msg;
266 }
267}
268
269sub identifier {
270 $_[0]{prefix} . ++$_[0]{idseq}
271}
272
136sub send_msg { 273sub send_msg {
137 my ($self, $type, %kv) = @_; 274 my ($self, $type, %kv) = @_;
138 275
139 my $data = delete $kv{data}; 276 my $data = delete $kv{data};
140 277
141 if (exists $kv{id_cb}) { 278 if (exists $kv{id_cb}) {
142 my $id = $kv{identifier} ||= ++$self->{id}; 279 my $id = $kv{identifier} ||= $self->identifier;
143 $self->{id}{$id} = delete $kv{id_cb}; 280 $self->{id}{$id} = delete $kv{id_cb};
144 } 281 }
145 282
146 my $msg = (touc $type) . "\012" 283 my $msg = (touc $type) . "\012"
147 . join "", map +(touc $_) . "=$kv{$_}\012", keys %kv; 284 . join "", map +(touc $_) . "=$kv{$_}\012", keys %kv;
… …
224 361
225 if (my $cb = $PERSISTENT_TYPE{$type}) { 362 if (my $cb = $PERSISTENT_TYPE{$type}) {
226 my $id = $kv->{identifier}; 363 my $id = $kv->{identifier};
227 my $req = $_[0]{req}{$id} ||= {}; 364 my $req = $_[0]{req}{$id} ||= {};
228 $cb->($self, $req, $kv); 365 $cb->($self, $req, $kv);
229 $self->recv (request_change => $kv, $type, @extra); 366 $self->recv (request_changed => $kv, $type, @extra);
230 } 367 }
231 368
232 my $on = $self->{on}; 369 my $on = $self->{on};
233 for (0 .. $#$on) { 370 for (0 .. $#$on) {
234 unless (my $res = $on->[$_]($self, $type, $kv, @extra)) { 371 unless (my $res = $on->[$_]($self, $type, $kv, @extra)) {
… …
243 } else { 380 } else {
244 $self->default_recv ($type, $kv, @extra); 381 $self->default_recv ($type, $kv, @extra);
245 } 382 }
246} 383}
247 384
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 { 385sub default_recv {
292 my ($self, $type, $kv, $rdata) = @_; 386 my ($self, $type, $kv, $rdata) = @_;
293 387
294 if ($type eq "node_hello") { 388 if ($type eq "node_hello") {
295 $self->{node_hello} = $kv; 389 $self->{node_hello} = $kv;
… …
332=over 4 426=over 4
333 427
334=item A code reference (or rather anything not matching some other alternative) 428=item A code reference (or rather anything not matching some other alternative)
335 429
336This code reference will be invoked with the result on success. On an 430This code reference will be invoked with the result on success. On an
431error, 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. 432if none was defined, will die (in the event loop) with a backtrace of the
433call site.
338 434
339This is a popular choice, but it makes handling errors hard - make sure 435This is a popular choice, but it makes handling errors hard - make sure
340you never generate protocol errors! 436you never generate protocol errors!
437
438If an C<on_failure> hook exists, it will be invoked with the FCP object,
439a (textual) backtrace as generated by C<Carp::longmess>, and arrayref
440containing the arguments from the original request invocation and the
441error object from the server, in this order, e.g.:
442
443 on_failure => sub {
444 my ($fcp, $backtrace, $orig_args, $error_object) = @_;
445 ...
446 },
341 447
342=item A condvar (as returned by e.g. C<< AnyEvent->condvar >>) 448=item A condvar (as returned by e.g. C<< AnyEvent->condvar >>)
343 449
344When a condvar is passed, it is sent (C<< $cv->send ($results) >>) the 450When a condvar is passed, it is sent (C<< $cv->send ($results) >>) the
345results when the request has finished. Should an error occur, the error 451results when the request has finished. Should an error occur, the error
… …
350=item An array with two callbacks C<[$success, $failure]> 456=item An array with two callbacks C<[$success, $failure]>
351 457
352The C<$success> callback will be invoked with the results, while the 458The C<$success> callback will be invoked with the results, while the
353C<$failure> callback will be invoked on any errors. 459C<$failure> callback will be invoked on any errors.
354 460
461The C<$failure> callback will be invoked with the error object from the
462server.
463
355=item C<undef> 464=item C<undef>
356 465
357This is the same thing as specifying C<sub { }> as callback, i.e. on 466This 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 467success, the results are ignored, while on failure, the C<on_failure> hook
359with a backtrace. 468is invoked or the module dies with a backtrace.
360 469
361This is good for quick scripts, or when you really aren't interested in 470This is good for quick scripts, or when you really aren't interested in
362the results. 471the results.
363 472
364=back 473=back
… …
371 my ($name, $sub) = @_; 480 my ($name, $sub) = @_;
372 481
373 *{$name} = sub { 482 *{$name} = sub {
374 my $cv = AE::cv; 483 my $cv = AE::cv;
375 484
376 splice @_, 1, 0, $cv, sub { $cv->throw ($_[0]{extra_description}) }; 485 splice @_, 1, 0, $cv, sub { $cv->croak ($_[0]{extra_description}) };
377 &$sub; 486 &$sub;
378 $cv->recv 487 $cv->recv
379 }; 488 };
380 489
381 *{"$name\_"} = sub { 490 *{"$name\_"} = sub {
382 my ($ok, $err) = pop; 491 my ($ok, $err) = pop;
383 492
384 if (ARRAY:: eq ref $ok) { 493 if (ARRAY:: eq ref $ok) {
385 ($ok, $err) = @$ok; 494 ($ok, $err) = @$ok;
386 } elsif (UNIVERSAL::isa $ok, AnyEvent::CondVar::) { 495 } elsif (UNIVERSAL::isa $ok, AnyEvent::CondVar::) {
387 $err = sub { $ok->throw ($_[0]{extra_description}) }; 496 $err = sub { $ok->croak ($_[0]{extra_description}) };
388 } else { 497 } else {
389 my $bt = Carp::longmess ""; 498 my $bt = Carp::longmess "AnyEvent::FCP request $name";
499 Scalar::Util::weaken (my $self = $_[0]);
500 my $args = [@_]; shift @$args;
390 $err = sub { 501 $err = sub {
502 if ($self->{on_failure}) {
503 $self->{on_failure}($self, $args, $bt, $_[0]);
504 } else {
391 die "$_[0]{extra_description}$bt"; 505 die "$_[0]{code_description} ($_[0]{extra_description})$bt";
506 }
392 }; 507 };
393 } 508 }
394 509
395 $ok ||= $NOP_CB; 510 $ok ||= $NOP_CB;
396 511
… …
541=cut 656=cut
542 657
543_txn get_plugin_info => sub { 658_txn get_plugin_info => sub {
544 my ($self, $ok, $err, $name, $detailed) = @_; 659 my ($self, $ok, $err, $name, $detailed) = @_;
545 660
661 my $id = $self->identifier;
662
546 $self->send_msg (get_plugin_info => 663 $self->send_msg (get_plugin_info =>
664 identifier => $id,
547 plugin_name => $name, 665 plugin_name => $name,
548 detailed => $detailed ? "true" : "false", 666 detailed => $detailed ? "true" : "false",
549 id_cb => sub {
550 my ($self, $type, $kv, $rdata) = @_;
551
552 $ok->($kv);
553 1
554 },
555 ); 667 );
668 $self->on (sub {
669 my ($self, $type, $kv) = @_;
670
671 if ($kv->{identifier} eq $id) {
672 if ($type eq "get_plugin_info") {
673 $ok->($kv);
674 } else {
675 $err->($kv, $type);
676 }
677 return;
678 }
679
680 1
681 });
556}; 682};
557 683
558=item $status = $fcp->client_get ($uri, $identifier, %kv) 684=item $status = $fcp->client_get ($uri, $identifier, %kv)
559 685
560%kv can contain (L<http://wiki.freenetproject.org/FCP2p0ClientGet>). 686%kv can contain (L<http://wiki.freenetproject.org/FCP2p0ClientGet>).

Diff Legend

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