… | |
… | |
31 | package Net::FCP; |
31 | package Net::FCP; |
32 | |
32 | |
33 | use Carp; |
33 | use Carp; |
34 | use IO::Socket::INET; |
34 | use IO::Socket::INET; |
35 | |
35 | |
36 | $VERSION = 0.02; |
36 | $VERSION = 0.04; |
37 | |
37 | |
38 | sub event_reg_cb { |
38 | sub event_reg_cb { |
39 | my ($obj) = @_; |
39 | my ($obj) = @_; |
40 | require Event; |
40 | require Event; |
41 | |
41 | |
… | |
… | |
72 | local $_ = shift; |
72 | local $_ = shift; |
73 | s/(?<=[a-z])(?=[A-Z])/_/g; |
73 | s/(?<=[a-z])(?=[A-Z])/_/g; |
74 | lc $_; |
74 | lc $_; |
75 | } |
75 | } |
76 | |
76 | |
|
|
77 | =item $meta = Net::FCP::parse_metadata $string |
|
|
78 | |
|
|
79 | Parse a metadata string and return it. |
|
|
80 | |
|
|
81 | The metadata will be a hashref with key C<version> (containing |
|
|
82 | the mandatory version header entries). |
|
|
83 | |
|
|
84 | All other headers are represented by arrayrefs (they can be repeated). |
|
|
85 | |
|
|
86 | Since this is confusing, here is a rather verbose example of a parsed |
|
|
87 | manifest: |
|
|
88 | |
|
|
89 | ( |
|
|
90 | version => { revision => 1 }, |
|
|
91 | document => [ |
|
|
92 | { |
|
|
93 | "info.format" => "image/jpeg", |
|
|
94 | name => "background.jpg", |
|
|
95 | "redirect.target" => "freenet:CHK\@ZcagI,ra726bSw" |
|
|
96 | }, |
|
|
97 | { |
|
|
98 | "info.format" => "text/html", |
|
|
99 | name => ".next", |
|
|
100 | "redirect.target" => "freenet:SSK\@ilUPAgM/TFEE/3" |
|
|
101 | }, |
|
|
102 | { |
|
|
103 | "info.format" => "text/html", |
|
|
104 | "redirect.target" => "freenet:CHK\@8M8Po8ucwI,8xA" |
|
|
105 | } |
|
|
106 | ] |
|
|
107 | ) |
|
|
108 | |
|
|
109 | =cut |
|
|
110 | |
|
|
111 | sub parse_metadata { |
|
|
112 | my $meta; |
|
|
113 | |
|
|
114 | my $data = shift; |
|
|
115 | if ($data =~ /^Version\015?\012/gc) { |
|
|
116 | my $hdr = $meta->{version} = {}; |
|
|
117 | |
|
|
118 | for (;;) { |
|
|
119 | while ($data =~ /\G([^=\015\012]+)=([^\015\012]*)\015?\012/gc) { |
|
|
120 | my ($k, $v) = ($1, $2); |
|
|
121 | $hdr->{tolc $k} = $v; |
|
|
122 | } |
|
|
123 | |
|
|
124 | if ($data =~ /\GEndPart\015?\012/gc) { |
|
|
125 | } elsif ($data =~ /\GEnd\015?\012/gc) { |
|
|
126 | last; |
|
|
127 | } elsif ($data =~ /\G([A-Za-z0-9.\-]+)\015?\012/gcs) { |
|
|
128 | push @{$meta->{tolc $1}}, $hdr = {}; |
|
|
129 | } elsif ($data =~ /\G(.*)/gcs) { |
|
|
130 | die "metadata format error ($1)"; |
|
|
131 | } |
|
|
132 | } |
|
|
133 | } |
|
|
134 | |
|
|
135 | #$meta->{tail} = substr $data, pos $data; |
|
|
136 | |
|
|
137 | $meta; |
|
|
138 | } |
|
|
139 | |
77 | =item $fcp = new Net::FCP [host => $host][, port => $port] |
140 | =item $fcp = new Net::FCP [host => $host][, port => $port] |
78 | |
141 | |
79 | Create a new virtual FCP connection to the given host and port (default |
142 | Create a new virtual FCP connection to the given host and port (default |
80 | 127.0.0.1:8481). |
143 | 127.0.0.1:8481, or the environment variables C<FREDHOST> and C<FREDPORT>). |
81 | |
144 | |
82 | Connections are virtual because no persistent physical connection is |
145 | Connections are virtual because no persistent physical connection is |
83 | established. However, the existance of the node is checked by executing a |
146 | established. However, the existance of the node is checked by executing a |
84 | C<ClientHello> transaction. |
147 | C<ClientHello> transaction. |
85 | |
148 | |
… | |
… | |
87 | |
150 | |
88 | sub new { |
151 | sub new { |
89 | my $class = shift; |
152 | my $class = shift; |
90 | my $self = bless { @_ }, $class; |
153 | my $self = bless { @_ }, $class; |
91 | |
154 | |
92 | $self->{host} ||= "127.0.0.1"; |
155 | $self->{host} ||= $ENV{FREDHOST} || "127.0.0.1"; |
93 | $self->{port} ||= 8481; |
156 | $self->{port} ||= $ENV{FREDPORt} || 8481; |
94 | |
157 | |
95 | $self->{nodehello} = $self->txn("ClientHello")->result |
158 | $self->{nodehello} = $self->client_hello |
96 | or croak "unable to get nodehello from node\n"; |
159 | or croak "unable to get nodehello from node\n"; |
97 | |
160 | |
98 | $self; |
161 | $self; |
99 | } |
162 | } |
100 | |
163 | |
… | |
… | |
187 | =cut |
250 | =cut |
188 | |
251 | |
189 | _txn generate_chk => sub { |
252 | _txn generate_chk => sub { |
190 | my ($self, $metadata, $data) = @_; |
253 | my ($self, $metadata, $data) = @_; |
191 | |
254 | |
192 | $self->txn (generate_chk => data => "$data$metadata", meta_data_length => length $metadata); |
255 | $self->txn (generate_chk => data => "$data$metadata", metadata_length => length $metadata); |
193 | }; |
256 | }; |
194 | |
257 | |
195 | =item $txn = $fcp->txn_generate_svk_pair |
258 | =item $txn = $fcp->txn_generate_svk_pair |
196 | |
259 | |
197 | =item ($public, $private) = @{ $fcp->generate_svk_pair } |
260 | =item ($public, $private) = @{ $fcp->generate_svk_pair } |
… | |
… | |
246 | my ($self, $uri) = @_; |
309 | my ($self, $uri) = @_; |
247 | |
310 | |
248 | $self->txn (get_size => URI => $uri); |
311 | $self->txn (get_size => URI => $uri); |
249 | }; |
312 | }; |
250 | |
313 | |
|
|
314 | =item $txn = $fcp->txn_client_get ($uri [, $htl = 15 [, $removelocal = 0]]) |
|
|
315 | |
|
|
316 | =item ($metadata, $data) = @{ $fcp->client_get ($uri, $htl, $removelocal) |
|
|
317 | |
|
|
318 | Fetches a (small, as it should fit into memory) file from |
|
|
319 | freenet. C<$meta> is the metadata (as returned by C<parse_metadata> or |
|
|
320 | C<undef>). |
|
|
321 | |
|
|
322 | Due to the overhead, a better method to download big files should be used. |
|
|
323 | |
|
|
324 | my ($meta, $data) = @{ |
|
|
325 | $fcp->client_get ( |
|
|
326 | "freenet:CHK@hdXaxkwZ9rA8-SidT0AN-bniQlgPAwI,XdCDmBuGsd-ulqbLnZ8v~w" |
|
|
327 | ) |
|
|
328 | }; |
|
|
329 | |
|
|
330 | =cut |
|
|
331 | |
|
|
332 | _txn client_get => sub { |
|
|
333 | my ($self, $uri, $htl, $removelocal) = @_; |
|
|
334 | |
|
|
335 | $self->txn (client_get => URI => $uri, hops_to_live => ($htl || 15), remove_local => $removelocal*1); |
|
|
336 | }; |
|
|
337 | |
251 | =item MISSING: ClientGet, ClientPut |
338 | =item MISSING: ClientPut |
252 | |
339 | |
253 | =back |
340 | =back |
254 | |
341 | |
255 | =head2 THE Net::FCP::Txn CLASS |
342 | =head2 THE Net::FCP::Txn CLASS |
256 | |
343 | |
… | |
… | |
327 | |
414 | |
328 | if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) { |
415 | if (sysread $self->{fh}, $self->{buf}, 65536, length $self->{buf}) { |
329 | for (;;) { |
416 | for (;;) { |
330 | if ($self->{datalen}) { |
417 | if ($self->{datalen}) { |
331 | if (length $self->{buf} >= $self->{datalen}) { |
418 | if (length $self->{buf} >= $self->{datalen}) { |
332 | $self->recv_data (substr $self->{buf}, 0, $self->{datalen}, ""); |
419 | $self->rcv_data (substr $self->{buf}, 0, $self->{datalen}, ""); |
333 | } else { |
420 | } else { |
334 | last; |
421 | last; |
335 | } |
422 | } |
336 | } elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=(\d+)\015?\012Data\015?\012//) { |
423 | } elsif ($self->{buf} =~ s/^DataChunk\015?\012Length=([0-9a-fA-F]+)\015?\012Data\015?\012//) { |
337 | $self->{datalen} = $1; |
424 | $self->{datalen} = hex $1; |
338 | } elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(.*?)\015?\012EndMessage\015?\012//s) { |
425 | } elsif ($self->{buf} =~ s/^([a-zA-Z]+)\015?\012(?:(.+?)\015?\012)?EndMessage\015?\012//s) { |
339 | $self->rcv ($1, { |
426 | $self->rcv ($1, { |
340 | map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) } |
427 | map { my ($a, $b) = split /=/, $_, 2; ((Net::FCP::tolc $a), $b) } |
341 | split /\015?\012/, $2 |
428 | split /\015?\012/, $2 |
342 | }); |
429 | }); |
343 | } else { |
430 | } else { |
… | |
… | |
351 | } |
438 | } |
352 | } |
439 | } |
353 | |
440 | |
354 | sub rcv_data { |
441 | sub rcv_data { |
355 | my ($self, $chunk) = @_; |
442 | my ($self, $chunk) = @_; |
|
|
443 | |
|
|
444 | $self->{data} .= $chunk; |
356 | } |
445 | } |
357 | |
446 | |
358 | sub rcv { |
447 | sub rcv { |
359 | my ($self, $type, $attr) = @_; |
448 | my ($self, $type, $attr) = @_; |
360 | |
449 | |
361 | $type = Net::FCP::tolc $type; |
450 | $type = Net::FCP::tolc $type; |
|
|
451 | |
|
|
452 | #use PApp::Util; warn PApp::Util::dumpval [$type, $attr]; |
362 | |
453 | |
363 | if (my $method = $self->can("rcv_$type")) { |
454 | if (my $method = $self->can("rcv_$type")) { |
364 | $method->($self, $attr, $type); |
455 | $method->($self, $attr, $type); |
365 | } else { |
456 | } else { |
366 | warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n"; |
457 | warn "received unexpected reply type '$type' for '$self->{type}', ignoring\n"; |
367 | $self->eof; |
|
|
368 | } |
458 | } |
|
|
459 | } |
|
|
460 | |
|
|
461 | sub set_result { |
|
|
462 | my ($self, $result) = @_; |
|
|
463 | |
|
|
464 | $self->{result} = $result unless exists $self->{result}; |
369 | } |
465 | } |
370 | |
466 | |
371 | sub eof { |
467 | sub eof { |
372 | my ($self, $result) = @_; |
468 | my ($self) = @_; |
373 | |
469 | $self->set_result; |
374 | $self->{result} = $result unless exists $self->{result}; |
|
|
375 | } |
470 | } |
376 | |
471 | |
377 | =item $result = $txn->result |
472 | =item $result = $txn->result |
378 | |
473 | |
379 | Waits until a result is available and then returns it. |
474 | Waits until a result is available and then returns it. |
380 | |
475 | |
381 | This waiting is (depending on your event modul) not very efficient, as it |
476 | This waiting is (depending on your event model) not very efficient, as it |
382 | is done outside the "mainloop". |
477 | is done outside the "mainloop". |
383 | |
478 | |
384 | =cut |
479 | =cut |
385 | |
480 | |
386 | sub result { |
481 | sub result { |
… | |
… | |
400 | use base Net::FCP::Txn; |
495 | use base Net::FCP::Txn; |
401 | |
496 | |
402 | sub rcv_node_hello { |
497 | sub rcv_node_hello { |
403 | my ($self, $attr) = @_; |
498 | my ($self, $attr) = @_; |
404 | |
499 | |
405 | $self->eof ($attr); |
500 | $self->set_result ($attr); |
406 | } |
501 | } |
407 | |
502 | |
408 | package Net::FCP::Txn::ClientInfo; |
503 | package Net::FCP::Txn::ClientInfo; |
409 | |
504 | |
410 | use base Net::FCP::Txn; |
505 | use base Net::FCP::Txn; |
411 | |
506 | |
412 | sub rcv_node_info { |
507 | sub rcv_node_info { |
413 | my ($self, $attr) = @_; |
508 | my ($self, $attr) = @_; |
414 | |
509 | |
415 | $self->eof ($attr); |
510 | $self->set_result ($attr); |
416 | } |
511 | } |
417 | |
512 | |
418 | package Net::FCP::Txn::GenerateCHK; |
513 | package Net::FCP::Txn::GenerateCHK; |
419 | |
514 | |
420 | use base Net::FCP::Txn; |
515 | use base Net::FCP::Txn; |
421 | |
516 | |
422 | sub rcv_success { |
517 | sub rcv_success { |
423 | my ($self, $attr) = @_; |
518 | my ($self, $attr) = @_; |
424 | |
519 | |
425 | $self->eof ($attr); |
520 | $self->set_result ($attr); |
426 | } |
521 | } |
427 | |
522 | |
428 | package Net::FCP::Txn::GenerateSVKPair; |
523 | package Net::FCP::Txn::GenerateSVKPair; |
429 | |
524 | |
430 | use base Net::FCP::Txn; |
525 | use base Net::FCP::Txn; |
431 | |
526 | |
432 | sub rcv_success { |
527 | sub rcv_success { |
433 | my ($self, $attr) = @_; |
528 | my ($self, $attr) = @_; |
434 | |
529 | |
435 | $self->eof ([$attr->{PublicKey}, $attr->{PrivateKey}]); |
530 | $self->set_result ([$attr->{PublicKey}, $attr->{PrivateKey}]); |
436 | } |
531 | } |
437 | |
532 | |
438 | package Net::FCP::Txn::InvertPrivateKey; |
533 | package Net::FCP::Txn::InvertPrivateKey; |
439 | |
534 | |
440 | use base Net::FCP::Txn; |
535 | use base Net::FCP::Txn; |
441 | |
536 | |
442 | sub rcv_success { |
537 | sub rcv_success { |
443 | my ($self, $attr) = @_; |
538 | my ($self, $attr) = @_; |
444 | |
539 | |
445 | $self->eof ($attr->{PublicKey}); |
540 | $self->set_result ($attr->{PublicKey}); |
446 | } |
541 | } |
447 | |
542 | |
448 | package Net::FCP::Txn::GetSize; |
543 | package Net::FCP::Txn::GetSize; |
449 | |
544 | |
450 | use base Net::FCP::Txn; |
545 | use base Net::FCP::Txn; |
451 | |
546 | |
452 | sub rcv_success { |
547 | sub rcv_success { |
453 | my ($self, $attr) = @_; |
548 | my ($self, $attr) = @_; |
454 | |
549 | |
455 | $self->eof ($attr->{Length}); |
550 | $self->set_result ($attr->{Length}); |
|
|
551 | } |
|
|
552 | |
|
|
553 | package Net::FCP::Txn::ClientGet; |
|
|
554 | |
|
|
555 | use base Net::FCP::Txn; |
|
|
556 | |
|
|
557 | sub rcv_data_found { |
|
|
558 | my ($self, $attr) = @_; |
|
|
559 | |
|
|
560 | $self->{datalength} = hex $attr->{data_length}; |
|
|
561 | $self->{metalength} = hex $attr->{metadata_length}; |
|
|
562 | } |
|
|
563 | |
|
|
564 | sub rcv_restarted { |
|
|
565 | # nop, maybe feedback |
|
|
566 | } |
|
|
567 | |
|
|
568 | sub eof { |
|
|
569 | my ($self) = @_; |
|
|
570 | |
|
|
571 | my $data = delete $self->{data}; |
|
|
572 | my $meta = Net::FCP::parse_metadata substr $data, 0, $self->{metalength}, ""; |
|
|
573 | |
|
|
574 | $self->set_result ([$meta, $data]); |
456 | } |
575 | } |
457 | |
576 | |
458 | =back |
577 | =back |
459 | |
578 | |
460 | =head1 SEE ALSO |
579 | =head1 SEE ALSO |