AnyEvent-FCP/FCP.pm

=head1 NAME

AnyEvent::FCP - freenet client protocol 2.0

=head1 SYNOPSIS

 use AnyEvent::FCP;

 my $fcp = new AnyEvent::FCP;

 my $ni = $fcp->txn_node_info->result;
 my $ni = $fcp->node_info;

=head1 DESCRIPTION

This module implements the freenet client protocol version 2.0, as used by
freenet 0.7. See L<Net::FCP> for the earlier freenet 0.5 version.

See L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0> for a description
of what the messages do.

The module uses L<AnyEvent> to find a suitable event module.

=head2 IMPORT TAGS

Nothing much can be "imported" from this module right now.

=head2 FREENET BASICS

Ok, this section will not explain any freenet basics to you, just some
problems I found that you might want to avoid:

=over 4

=item freenet URIs are _NOT_ URIs

Whenever a "uri" is required by the protocol, freenet expects a kind of
URI prefixed with the "freenet:" scheme, e.g. "freenet:CHK...". However,
these are not URIs, as freeent fails to parse them correctly, that is, you
must unescape an escaped characters ("%2c" => ",") yourself. Maybe in the
future this library will do it for you, so watch out for this incompatible
change.

=back

=head2 THE AnyEvent::FCP CLASS

=over 4

=cut

package AnyEvent::FCP;

use common::sense;

use Carp;

our $VERSION = '0.1';

use Scalar::Util ();

use AnyEvent;
use AnyEvent::Handle;

sub touc($) {
   local $_ = shift;
   1 while s/((?:^|_)(?:svk|chk|uri|fcp)(?:_|$))/\U$1/;
   s/(?:^|_)(.)/\U$1/g;
   $_
}

sub tolc($) {
   local $_ = shift;
   1 while s/(SVK|CHK|URI|FCP)([^_])/$1\_$2/i;
   1 while s/([^_])(SVK|CHK|URI|FCP)/$1\_$2/i;
   s/(?<=[a-z])(?=[A-Z])/_/g;
   lc
}

=item $fcp = new AnyEvent::FCP [host => $host][, port => $port][, progress => \&cb][, name => $name]

Create a new FCP connection to the given host and port (default
127.0.0.1:9481, or the environment variables C<FREDHOST> and C<FREDPORT>).

If no C<name> was specified, then AnyEvent::FCP will generate a (hopefully)
unique client name for you.

#TODO
#You can install a progress callback that is being called with the AnyEvent::FCP
#object, a txn object, the type of the transaction and the attributes. Use
#it like this:
#
#   sub progress_cb {
#      my ($self, $txn, $type, $attr) = @_;
#
#      warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
#   }

=cut

sub new {
   my $class = shift;
   my $self = bless { @_ }, $class;

   $self->{host}    ||= $ENV{FREDHOST} || "127.0.0.1";
   $self->{port}    ||= $ENV{FREDPORT} || 9481;
   $self->{name}    ||= time.rand.rand.rand; # lame
   $self->{timeout} ||= 600;

   $self->{id} = "a0";

   {
      Scalar::Util::weaken (my $self = $self);

      $self->{hdl} = new AnyEvent::Handle
         connect  => [$self->{host} => $self->{port}],
         timeout  => $self->{timeout},
         on_error => sub {
            warn "<@_>\n";
            exit 1;
         },
         on_read  => sub { $self->on_read (@_) },
         on_eof   => $self->{on_eof} || sub { };

      Scalar::Util::weaken ($self->{hdl}{fcp} = $self);
   }

   $self->send_msg (
      client_hello =>
      name => $self->{name},
      expected_version => "2.0",
   );

   $self
}

sub progress {
   my ($self, $txn, $type, $attr) = @_;

   $self->{progress}->($self, $txn, $type, $attr)
      if $self->{progress};
}

sub send_msg {
   my ($self, $type, %kv) = @_;

   my $data  = delete $kv{data};

   if (exists $kv{id_cb}) {
      my $id = $kv{identifier} || ++$self->{id};
      $self->{id}{$id} = delete $kv{id_cb};
      $kv{identifier} = $id;
   }

   my $msg = (touc $type) . "\012"
             . join "", map +(touc $_) . "=$kv{$_}\012", keys %kv;

      sub id {
         my ($self) = @_;


      }

   if (defined $data) {
      $msg .= "DataLength=" . (length $data) . "\012"
            . "Data\012$data";
   } else {
      $msg .= "EndMessage\012";
   }

   $self->{hdl}->push_write ($msg);
}

sub on_read {
   my ($self) = @_;

   my $type;
   my %kv;
   my $rdata;

   my $done_cb = sub {
      $kv{pkt_type} = $type;

      if (my $cb = $self->{queue}[0]) {
         $cb->($self, $type, \%kv, $rdata)
            and shift @{ $self->{queue} };
      } else {
         $self->default_recv ($type, \%kv, $rdata);
      }
   };

   my $hdr_cb; $hdr_cb = sub {
      if ($_[1] =~ /^([^=]+)=(.*)$/) {
         my ($k, $v) = ($1, $2);
         my @k = split /\./, tolc $k;
         my $ro = \\%kv;

         while (@k) {
            my $k = shift @k;
            if ($k =~ /^\d+$/) {
               $ro = \$$ro->[$k];
            } else {
               $ro = \$$ro->{$k};
            }
         }

         $$ro = $v;

         $_[0]->push_read (line => $hdr_cb);
      } elsif ($_[1] eq "Data") {
         $_[0]->push_read (chunk => delete $kv{data_length}, sub {
            $rdata = \$_[1];
            $done_cb->();
         });
      } elsif ($_[1] eq "EndMessage") {
         $done_cb->();
      } else {
         die "protocol error, expected message end, got $_[1]\n";#d#
      }
   };

   $self->{hdl}->push_read (line => sub {
      $type = tolc $_[1];
      $_[0]->push_read (line => $hdr_cb);
   });
}

sub default_recv {
   my ($self, $type, $kv, $rdata) = @_;

   if ($type eq "node_hello") {
      $self->{node_hello} = $kv;
   } elsif (exists $self->{id}{$kv->{identifier}}) {
      $self->{id}{$kv->{identifier}}($self, $type, $kv, $rdata)
         and delete $self->{id}{$kv->{identifier}};
   } else {
      # on_warn
      #warn "protocol warning (unexpected $type message)\n";
   }
}

sub _txn {
   my ($name, $sub) = @_;

   *{$name} = sub {
      splice @_, 1, 0, (my $cv = AnyEvent->condvar);
      &$sub;
      $cv
   };

   *{"$name\_sync"} = sub {
      splice @_, 1, 0, (my $cv = AnyEvent->condvar);
      &$sub;
      $cv->recv
   };
}

_txn list_peers => sub {
   my ($self, $cv, $with_metadata, $with_volatile) = @_;

   my @res;

   $self->send_msg (list_peers =>
      with_metadata => $with_metadata ? "true" : "false",
      with_volatile => $with_volatile ? "true" : "false",
      id_cb         => sub {
         my ($self, $type, $kv, $rdata) = @_;

         if ($type eq "end_list_peers") {
            $cv->(\@res);
            1
         } else {
            push @res, $kv;
            0
         }
      },
   );
};

_txn list_peer_notes => sub {
   my ($self, $cv, $node_identifier) = @_;

   $self->send_msg (list_peer_notes =>
      node_identifier => $node_identifier,
      id_cb           => sub {
         my ($self, $type, $kv, $rdata) = @_;

         $cv->($kv);
         1
      },
   );
};

_txn watch_global => sub {
   my ($self, $cv, $enabled, $verbosity_mask) = @_;

   $self->send_msg (watch_global =>
      enabled        => $enabled ? "true" : "false",
      defined $verbosity_mask ? (verbosity_mask => $verbosity_mask+0) : (),
   );

   $cv->();
};

_txn list_persistent_requests => sub {
   my ($self, $cv) = @_;

   my %res;

   $self->send_msg ("list_persistent_requests");

   push @{ $self->{queue} }, sub {
      my ($self, $type, $kv, $rdata) = @_;

      if ($type eq "end_list_persistent_requests") {
         $cv->(\%res);
         1
      } else {
         my $id = $kv->{identifier};

         if ($type =~ /^persistent_(get|put|put_dir)$/) {
            $res{$id} = {
               type => $1,
               %{ $res{$id} },
               %$kv,
            };
         } elsif ($type eq "simple_progress") {
            delete $kv->{pkt_type}; # save memory
            push @{ $res{delete $kv->{identifier}}{simple_progress} }, $kv;
         } else {
            $res{delete $kv->{identifier}}{delete $kv->{pkt_type}} = $kv;
         }
         0
      }
   };
};

_txn remove_request => sub {
   my ($self, $cv, $global, $identifier) = @_;

   $self->send_msg (remove_request =>
      global     => $global ? "true" : "false",
      identifier => $identifier,
      id_cb      => sub {
         my ($self, $type, $kv, $rdata) = @_;

         $cv->($kv);
         1
      },
   );

   $cv->();
};

_txn modify_persistent_request => sub {
   my ($self, $cv, $global, $identifier, $client_token, $priority_class) = @_;

   $self->send_msg (modify_persistent_request =>
      global     => $global ? "true" : "false",
      identifier => $identifier,
      defined $client_token   ? (client_token   => $client_token  ) : (),
      defined $priority_class ? (priority_class => $priority_class) : (),
      id_cb      => sub {
         my ($self, $type, $kv, $rdata) = @_;

         $cv->($kv);
         1
      },
   );

   $cv->();
};

_txn get_plugin_info => sub {
   my ($self, $cv, $name, $detailed) = @_;

   $self->send_msg (get_plugin_info =>
      plugin_name => $name,
      detailed    => $detailed ? "true" : "false",
      id_cb       => sub {
         my ($self, $type, $kv, $rdata) = @_;

         $cv->($kv);
         1
      },
   );

   $cv->();
};

=back

=head1 SEE ALSO

L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0>, L<Net::FCP>.

=head1 BUGS

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut

1

Revision:	1.2
Committed:	Sat Jul 25 06:28:49 2009 UTC (17 years, 1 month ago) by root
Branch:	MAIN
Changes since 1.1:	+231 -655 lines
Log Message:	* empty log message *
#	User	Rev	Content
1	root	1.1	=head1 NAME
2
3			AnyEvent::FCP - freenet client protocol 2.0
4
5			=head1 SYNOPSIS
6
7			use AnyEvent::FCP;
8
9			my $fcp = new AnyEvent::FCP;
10
11			my $ni = $fcp->txn_node_info->result;
12			my $ni = $fcp->node_info;
13
14			=head1 DESCRIPTION
15
16			This module implements the freenet client protocol version 2.0, as used by
17			freenet 0.7. See L<Net::FCP> for the earlier freenet 0.5 version.
18
19			See L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0> for a description
20			of what the messages do.
21
22			The module uses L<AnyEvent> to find a suitable event module.
23
24			=head2 IMPORT TAGS
25
26			Nothing much can be "imported" from this module right now.
27
28			=head2 FREENET BASICS
29
30			Ok, this section will not explain any freenet basics to you, just some
31			problems I found that you might want to avoid:
32
33			=over 4
34
35			=item freenet URIs are _NOT_ URIs
36
37			Whenever a "uri" is required by the protocol, freenet expects a kind of
38			URI prefixed with the "freenet:" scheme, e.g. "freenet:CHK...". However,
39			these are not URIs, as freeent fails to parse them correctly, that is, you
40			must unescape an escaped characters ("%2c" => ",") yourself. Maybe in the
41			future this library will do it for you, so watch out for this incompatible
42			change.
43
44			=back
45
46			=head2 THE AnyEvent::FCP CLASS
47
48			=over 4
49
50			=cut
51
52			package AnyEvent::FCP;
53
54	root	1.2	use common::sense;
55
56	root	1.1	use Carp;
57
58	root	1.2	our $VERSION = '0.1';
59	root	1.1
60	root	1.2	use Scalar::Util ();
61	root	1.1
62			use AnyEvent;
63	root	1.2	use AnyEvent::Handle;
64	root	1.1
65			sub touc($) {
66			local $_ = shift;
67	root	1.2	1 while s/((?:^\|_)(?:svk\|chk\|uri\|fcp)(?:_\|$))/\U$1/;
68	root	1.1	s/(?:^\|_)(.)/\U$1/g;
69			$_
70			}
71
72			sub tolc($) {
73			local $_ = shift;
74	root	1.2	1 while s/(SVK\|CHK\|URI\|FCP)([^_])/$1\_$2/i;
75			1 while s/([^_])(SVK\|CHK\|URI\|FCP)/$1\_$2/i;
76	root	1.1	s/(?<=[a-z])(?=[A-Z])/_/g;
77			lc
78			}
79
80			=item $fcp = new AnyEvent::FCP [host => $host][, port => $port][, progress => \&cb][, name => $name]
81
82			Create a new FCP connection to the given host and port (default
83	root	1.2	127.0.0.1:9481, or the environment variables C<FREDHOST> and C<FREDPORT>).
84	root	1.1
85			If no C<name> was specified, then AnyEvent::FCP will generate a (hopefully)
86			unique client name for you.
87
88			#TODO
89	root	1.2	#You can install a progress callback that is being called with the AnyEvent::FCP
90	root	1.1	#object, a txn object, the type of the transaction and the attributes. Use
91			#it like this:
92			#
93			# sub progress_cb {
94			# my ($self, $txn, $type, $attr) = @_;
95			#
96			# warn "progress<$txn,$type," . (join ":", %$attr) . ">\n";
97			# }
98
99			=cut
100
101			sub new {
102			my $class = shift;
103			my $self = bless { @_ }, $class;
104
105	root	1.2	$self->{host} \|\|= $ENV{FREDHOST} \|\| "127.0.0.1";
106			$self->{port} \|\|= $ENV{FREDPORT} \|\| 9481;
107			$self->{name} \|\|= time.rand.rand.rand; # lame
108			$self->{timeout} \|\|= 600;
109
110			$self->{id} = "a0";
111
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			warn "<@_>\n";
120			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			$self->send_msg (
129			client_hello =>
130			name => $self->{name},
131			expected_version => "2.0",
132			);
133	root	1.1
134			$self
135			}
136
137			sub progress {
138			my ($self, $txn, $type, $attr) = @_;
139
140			$self->{progress}->($self, $txn, $type, $attr)
141			if $self->{progress};
142			}
143
144	root	1.2	sub send_msg {
145			my ($self, $type, %kv) = @_;
146	root	1.1
147	root	1.2	my $data = delete $kv{data};
148	root	1.1
149	root	1.2	if (exists $kv{id_cb}) {
150			my $id = $kv{identifier} \|\| ++$self->{id};
151			$self->{id}{$id} = delete $kv{id_cb};
152			$kv{identifier} = $id;
153	root	1.1	}
154
155	root	1.2	my $msg = (touc $type) . "\012"
156			. join "", map +(touc $_) . "=$kv{$_}\012", keys %kv;
157	root	1.1
158	root	1.2	sub id {
159			my ($self) = @_;
160	root	1.1
161
162	root	1.2	}
163	root	1.1
164			if (defined $data) {
165	root	1.2	$msg .= "DataLength=" . (length $data) . "\012"
166			. "Data\012$data";
167	root	1.1	} else {
168	root	1.2	$msg .= "EndMessage\012";
169	root	1.1	}
170
171	root	1.2	$self->{hdl}->push_write ($msg);
172	root	1.1	}
173
174	root	1.2	sub on_read {
175	root	1.1	my ($self) = @_;
176
177	root	1.2	my $type;
178			my %kv;
179			my $rdata;
180
181			my $done_cb = sub {
182			$kv{pkt_type} = $type;
183
184			if (my $cb = $self->{queue}[0]) {
185			$cb->($self, $type, \%kv, $rdata)
186			and shift @{ $self->{queue} };
187			} else {
188			$self->default_recv ($type, \%kv, $rdata);
189	root	1.1	}
190	root	1.2	};
191	root	1.1
192	root	1.2	my $hdr_cb; $hdr_cb = sub {
193			if ($_[1] =~ /^([^=]+)=(.*)$/) {
194			my ($k, $v) = ($1, $2);
195			my @k = split /\./, tolc $k;
196			my $ro = \\%kv;
197
198			while (@k) {
199			my $k = shift @k;
200			if ($k =~ /^\d+$/) {
201			$ro = \$$ro->[$k];
202	root	1.1	} else {
203	root	1.2	$ro = \$$ro->{$k};
204	root	1.1	}
205			}
206
207	root	1.2	$$ro = $v;
208	root	1.1
209	root	1.2	$_[0]->push_read (line => $hdr_cb);
210			} elsif ($_[1] eq "Data") {
211			$_[0]->push_read (chunk => delete $kv{data_length}, sub {
212			$rdata = \$_[1];
213			$done_cb->();
214			});
215			} elsif ($_[1] eq "EndMessage") {
216			$done_cb->();
217			} else {
218			die "protocol error, expected message end, got $_[1]\n";#d#
219			}
220			};
221	root	1.1
222	root	1.2	$self->{hdl}->push_read (line => sub {
223			$type = tolc $_[1];
224			$_[0]->push_read (line => $hdr_cb);
225			});
226			}
227	root	1.1
228	root	1.2	sub default_recv {
229			my ($self, $type, $kv, $rdata) = @_;
230
231			if ($type eq "node_hello") {
232			$self->{node_hello} = $kv;
233			} elsif (exists $self->{id}{$kv->{identifier}}) {
234			$self->{id}{$kv->{identifier}}($self, $type, $kv, $rdata)
235			and delete $self->{id}{$kv->{identifier}};
236	root	1.1	} else {
237	root	1.2	# on_warn
238			#warn "protocol warning (unexpected $type message)\n";
239	root	1.1	}
240			}
241
242	root	1.2	sub _txn {
243			my ($name, $sub) = @_;
244	root	1.1
245	root	1.2	*{$name} = sub {
246			splice @_, 1, 0, (my $cv = AnyEvent->condvar);
247			&$sub;
248			$cv
249			};
250	root	1.1
251	root	1.2	*{"$name\_sync"} = sub {
252			splice @_, 1, 0, (my $cv = AnyEvent->condvar);
253			&$sub;
254			$cv->recv
255			};
256	root	1.1	}
257
258	root	1.2	_txn list_peers => sub {
259			my ($self, $cv, $with_metadata, $with_volatile) = @_;
260	root	1.1
261	root	1.2	my @res;
262	root	1.1
263	root	1.2	$self->send_msg (list_peers =>
264			with_metadata => $with_metadata ? "true" : "false",
265			with_volatile => $with_volatile ? "true" : "false",
266			id_cb => sub {
267			my ($self, $type, $kv, $rdata) = @_;
268
269			if ($type eq "end_list_peers") {
270			$cv->(\@res);
271			1
272			} else {
273			push @res, $kv;
274			0
275			}
276			},
277			);
278			};
279	root	1.1
280	root	1.2	_txn list_peer_notes => sub {
281			my ($self, $cv, $node_identifier) = @_;
282	root	1.1
283	root	1.2	$self->send_msg (list_peer_notes =>
284			node_identifier => $node_identifier,
285			id_cb => sub {
286			my ($self, $type, $kv, $rdata) = @_;
287
288			$cv->($kv);
289			1
290			},
291			);
292			};
293	root	1.1
294	root	1.2	_txn watch_global => sub {
295			my ($self, $cv, $enabled, $verbosity_mask) = @_;
296	root	1.1
297	root	1.2	$self->send_msg (watch_global =>
298			enabled => $enabled ? "true" : "false",
299			defined $verbosity_mask ? (verbosity_mask => $verbosity_mask+0) : (),
300			);
301	root	1.1
302	root	1.2	$cv->();
303			};
304	root	1.1
305	root	1.2	_txn list_persistent_requests => sub {
306			my ($self, $cv) = @_;
307	root	1.1
308	root	1.2	my %res;
309	root	1.1
310	root	1.2	$self->send_msg ("list_persistent_requests");
311	root	1.1
312	root	1.2	push @{ $self->{queue} }, sub {
313			my ($self, $type, $kv, $rdata) = @_;
314
315			if ($type eq "end_list_persistent_requests") {
316			$cv->(\%res);
317			1
318			} else {
319			my $id = $kv->{identifier};
320
321			if ($type =~ /^persistent_(get\|put\|put_dir)$/) {
322			$res{$id} = {
323			type => $1,
324			%{ $res{$id} },
325			%$kv,
326			};
327			} elsif ($type eq "simple_progress") {
328			delete $kv->{pkt_type}; # save memory
329			push @{ $res{delete $kv->{identifier}}{simple_progress} }, $kv;
330			} else {
331			$res{delete $kv->{identifier}}{delete $kv->{pkt_type}} = $kv;
332			}
333			0
334			}
335	root	1.1	};
336	root	1.2	};
337	root	1.1
338	root	1.2	_txn remove_request => sub {
339			my ($self, $cv, $global, $identifier) = @_;
340	root	1.1
341	root	1.2	$self->send_msg (remove_request =>
342			global => $global ? "true" : "false",
343			identifier => $identifier,
344			id_cb => sub {
345			my ($self, $type, $kv, $rdata) = @_;
346
347			$cv->($kv);
348			1
349			},
350			);
351	root	1.1
352	root	1.2	$cv->();
353			};
354	root	1.1
355	root	1.2	_txn modify_persistent_request => sub {
356			my ($self, $cv, $global, $identifier, $client_token, $priority_class) = @_;
357	root	1.1
358	root	1.2	$self->send_msg (modify_persistent_request =>
359			global => $global ? "true" : "false",
360			identifier => $identifier,
361			defined $client_token ? (client_token => $client_token ) : (),
362			defined $priority_class ? (priority_class => $priority_class) : (),
363			id_cb => sub {
364			my ($self, $type, $kv, $rdata) = @_;
365
366			$cv->($kv);
367			1
368			},
369			);
370	root	1.1
371	root	1.2	$cv->();
372			};
373	root	1.1
374	root	1.2	_txn get_plugin_info => sub {
375			my ($self, $cv, $name, $detailed) = @_;
376	root	1.1
377	root	1.2	$self->send_msg (get_plugin_info =>
378			plugin_name => $name,
379			detailed => $detailed ? "true" : "false",
380			id_cb => sub {
381			my ($self, $type, $kv, $rdata) = @_;
382
383			$cv->($kv);
384			1
385			},
386			);
387	root	1.1
388	root	1.2	$cv->();
389			};
390	root	1.1
391			=back
392
393			=head1 SEE ALSO
394
395	root	1.2	L<http://wiki.freenetproject.org/FreenetFCPSpec2Point0>, L<Net::FCP>.
396	root	1.1
397			=head1 BUGS
398
399			=head1 AUTHOR
400
401			Marc Lehmann <schmorp@schmorp.de>
402			http://home.schmorp.de/
403
404			=cut
405
406			1
407