1. Toby Inkster
  2. p5-www-finger

Commits

Toby Inkster  committed 2b344ab

Beginnings of WWW::Finger module.

  • Participants
  • Branches WWW-Finger

Comments (0)

Files changed (11)

File Changes

View file
  • Ignore whitespace
+Revision history for Perl extension WWW::Finger::Fingerpoint.
+
+0.01  Tue Dec  8 15:38:56 2009
+	- original version; created by h2xs 1.23 with options
+		--skip-warnings --skip-exporter --skip-autoloader -X -b 5.8.1 WWW::Finger::Fingerpoint
+

File MANIFEST

View file
  • Ignore whitespace
+Changes
+Makefile.PL
+MANIFEST
+README
+t/WWW-Finger-Fingerpoint.t
+lib/WWW/Finger/Fingerpoint.pm

File Makefile.PL

View file
  • Ignore whitespace
+use 5.008001;
+use ExtUtils::MakeMaker;
+# See lib/ExtUtils/MakeMaker.pm for details of how to influence
+# the contents of the Makefile that is written.
+WriteMakefile(
+    NAME              => 'WWW::Finger::Fingerpoint',
+    VERSION_FROM      => 'lib/WWW/Finger/Fingerpoint.pm', # finds $VERSION
+    PREREQ_PM         => {}, # e.g., Module::Name => 1.1
+    ($] >= 5.005 ?     ## Add these new keywords supported since 5.005
+      (ABSTRACT_FROM  => 'lib/WWW/Finger/Fingerpoint.pm', # retrieve abstract from module
+       AUTHOR         => 'Toby Inkster <tai@localdomain>') : ()),
+);

File README

View file
  • Ignore whitespace
+WWW-Finger-Fingerpoint version 0.01
+===================================
+
+The README is used to introduce the module and provide instructions on
+how to install the module, any machine dependencies it may have (for
+example C compilers and installed libraries) and any other information
+that should be provided before the module is installed.
+
+A README file is required for CPAN modules since CPAN extracts the
+README file from a module distribution so that people browsing the
+archive can use it get an idea of the modules uses. It is usually a
+good idea to provide version information here so that people can
+decide whether fixes for the module are worth downloading.
+
+INSTALLATION
+
+To install this module type the following:
+
+   perl Makefile.PL
+   make
+   make test
+   make install
+
+DEPENDENCIES
+
+This module requires these other modules and libraries:
+
+  blah blah blah
+
+COPYRIGHT AND LICENCE
+
+Put the correct copyright and licence information here.
+
+Copyright (C) 2009 by Toby Inkster
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.10.1 or,
+at your option, any later version of Perl 5 you may have available.
+
+

File example.pl

View file
  • Ignore whitespace
+#!/usr/bin/perl
+
+use lib "lib";
+use WWW::Finger;
+
+my $finger = WWW::Finger->new('mailto:tobyink@cpan.org');
+
+print $finger->name . "\n";
+print $finger->homepage . "\n";
+print $finger->image . "\n";
+print $finger->mbox . "\n";

File example2.pl

View file
  • Ignore whitespace
+use lib "lib";
+use WWW::Finger;
+
+my $finger = WWW::Finger->new('mail@tobyinkster.co.uk');
+foreach my $pgp_key_uri ($finger->key)
+{
+	print "$pgp_key_uri\n";
+}

File lib/WWW/Finger.pm

View file
  • Ignore whitespace
+package WWW::Finger;
+
+use WWW::Finger::CPAN;
+use WWW::Finger::Fingerpoint;
+use WWW::Finger::Webfinger;
+
+BEGIN
+{
+	my @Modules = ();
+}
+
+sub new
+{
+	my $class      = shift;
+	my $identifier = shift;
+	
+	foreach my $module (@Modules)
+	{
+		my $rv = $module->new($identifier);
+		return $rv
+			if defined $rv;
+	}
+	
+	return undef;
+}
+
+sub name     { return undef; }
+sub mbox     { return undef; }
+sub key      { return undef; }
+sub image    { return undef; }
+sub homepage { return undef; }
+sub weblog   { return undef; }
+sub endpoint { return undef; }
+sub webid    { return undef; }
+sub graph    { return undef; }
+
+1;

File lib/WWW/Finger/CPAN.pm

View file
  • Ignore whitespace
+package WWW::Finger::CPAN;
+
+use 5.008001;
+use strict;
+
+use Digest::MD5 qw(md5_hex);
+use LWP::Simple;
+use WWW::Finger;
+
+our @ISA = qw(WWW::Finger);
+our $VERSION = '0.01';
+
+BEGIN
+{
+	push @WWW::Finger::Modules, __PACKAGE__;
+}
+
+sub new
+{
+	my $class = shift;
+	my $ident = shift;
+	my $self = bless {}, $class;
+
+	$ident = "mailto:$ident"
+		unless $ident =~ /^[a-z0-9\.\-\+]+:/i;
+	$ident = URI->new($ident);
+	
+	return undef
+		unless $ident;
+		
+	$self->{'ident'} = $ident;
+	
+	my ($user, $host) = split /\@/, $self->{'ident'}->to;
+	return undef
+		unless lc $host eq 'cpan.org';
+	
+	return $self;
+}
+
+sub name
+{
+	my $self = shift;
+	$self->{'pagedata'} = &get( $self->cpanpage )
+		unless $self->{'pagedata'};
+	my $name = '';
+	
+	if ($self->{'pagedata'} =~ /<title>(.+) - search.cpan.org/)
+	{
+		$name = $1;
+	}
+	else
+	{
+		my ($user, $host) = split /\@/, $self->{'ident'}->to;
+		$name = uc $user;
+	}
+	if (wantarray)
+	{
+		return @{ [$name] };
+	}
+	else
+	{
+		return $name;
+	}
+	
+}
+
+sub mbox
+{
+	my $self = shift;
+	
+	$self->{'pagedata'} = &get( $self->cpanpage )
+		unless $self->{'pagedata'};
+	my @e;
+
+	if ($self->{'pagedata'} =~ m`<td class=cell><a href="(mailto:[^"]+)">`)
+	{
+		push @e, $1;
+	}
+	my ($user, $host) = split /\@/, $self->{'ident'}->to;
+	push @e, 'mailto:' . $user . '@cpan.org';
+	
+	if (wantarray)
+	{
+		return @e;
+	}
+	else
+	{
+		return $e[0];
+	}
+}
+
+sub cpanpage
+{
+	my $self = shift;
+	my ($user, $host) = split /\@/, $self->{'ident'}->to;
+	my $cpanpage = 'http://search.cpan.org/~' . $user . '/';
+	
+	if (wantarray)
+	{
+		return @{[$cpanpage]};
+	}
+	else
+	{
+		return $cpanpage;
+	}
+}
+
+sub homepage
+{
+	my $self = shift;
+	
+	$self->{'pagedata'} = &get( $self->cpanpage )
+		unless $self->{'pagedata'};
+	my @hp;
+
+	if ($self->{'pagedata'} =~ m`<a href="([^"]+)" rel="me">`)
+	{
+		push @hp, $1;
+	}
+	push @hp, $self->cpanpage;
+	
+	if (wantarray)
+	{
+		return @hp;
+	}
+	else
+	{
+		return $hp[0];
+	}
+}
+
+sub image
+{
+	my $self = shift;
+	my $md5 = lc md5_hex(lc $self->{'ident'}->to);
+	if (wantarray)
+	{
+		return @{ ["http://www.gravatar.com/avatar/$md5.jpg"] };
+	}
+	else
+	{
+		return "http://www.gravatar.com/avatar/$md5.jpg";
+	}
+}
+
+1;
+__END__
+# Below is stub documentation for your module. You'd better edit it!
+
+=head1 NAME
+
+WWW::Finger::CPAN - WWW::Finger implementation for CPAN authors
+
+=head1 AUTHOR
+
+Toby Inkster, E<lt>tobyink@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2009 by Toby Inkster
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8.1 or,
+at your option, any later version of Perl 5 you may have available.
+
+
+=cut

File lib/WWW/Finger/Fingerpoint.pm

View file
  • Ignore whitespace
+package WWW::Finger::Fingerpoint;
+
+use 5.008001;
+use strict;
+
+use Carp;
+use Digest::SHA1 qw(sha1_hex);
+use HTTP::Link::Parser qw(:standard);
+use LWP::UserAgent;
+use RDF::Query::Client;
+use RDF::Trine;
+use WWW::Finger;
+use URI;
+
+our @ISA = qw(WWW::Finger);
+our $VERSION = '0.01';
+
+my $rel_fingerpoint = 'http://ontologi.es/sparql#fingerpoint';
+
+BEGIN
+{
+	push @WWW::Finger::Modules, __PACKAGE__;
+}
+
+sub new
+{
+	my $class = shift;
+	my $ident = shift or croak "Need to supply an e-mail address\n";
+	my $self  = bless {}, $class;
+		
+	$ident = "mailto:$ident"
+		unless $ident =~ /^[a-z0-9\.\-\+]+:/i;
+	$ident = URI->new($ident);
+	return undef
+		unless $ident->scheme eq 'mailto';
+	
+	$self->{'ident'} = $ident;
+	my ($user, $host) = split /\@/, $ident->to;
+	
+	my $ua = LWP::UserAgent->new;
+	$ua->timeout(10);
+	$ua->env_proxy;
+	
+	my $httphost = "http://$host/";
+	my $response = $ua->head($httphost);
+	return undef
+		unless $response->is_success;
+	
+	my $linkdata = HTTP::Link::Parser::parse_links_to_rdfjson($response);
+	my $sparql   = $linkdata->{ $httphost }->{ $rel_fingerpoint }->[0]->{'value'};
+
+	unless (defined $sparql)
+	{
+		$response = $ua->get($httphost,
+			'Accept' => 'application/xhtml+xml;q=1.0, text/html;q=0.9, */*;q=0.1');
+		return undef
+			unless $response->is_success;
+		if ($response->header('content-type') =~ m`^(text/html|application/xhtml+xml|application/xml|text/xml)`i)
+		{
+			$sparql = URI->new_abs($1, URI->new($httphost))
+				if $response->content =~ m`<[Ll][Ii][Nn][Kk]\s+[Rr][Ee][Ll]="[^"]*http://ontologi\.es/sparql#fingerpoint[^"]*"\s+[Hh][Rr][Ee][Ff]="([^"]+)"\s*/?>`;
+		}
+	}
+
+	return undef
+		unless length $sparql;
+	
+	$self->{'endpoint'} = $sparql;
+	
+	my $sha1 = sha1_hex($ident);
+	my $sparql_query = "PREFIX foaf: <http://xmlns.com/foaf/0.1/>
+	PREFIX wot: <http://xmlns.com/wot/0.1/>
+	SELECT DISTINCT *
+	WHERE {
+		{
+			{ ?person foaf:mbox <$ident> . }
+			UNION
+			{ ?person foaf:mbox_sha1sum \"$sha1\" . }
+		}
+		OPTIONAL { ?person foaf:name ?name . }
+		OPTIONAL { ?person foaf:homepage ?homepage . }
+		OPTIONAL { ?person foaf:mbox ?mbox . }
+		OPTIONAL { ?person foaf:weblog ?weblog . }
+		OPTIONAL { ?person foaf:img ?image . }
+		OPTIONAL { ?k wot:pubkeyAddress ?key ; wot:identity ?person . }
+	}";
+	my @fields = qw(name homepage mbox weblog image key);
+	
+	my $query  = RDF::Query::Client->new($sparql_query);
+	my $result = $query->execute($self->endpoint, {QueryMethod=>'POST'});
+	my $webid;
+
+	while (my $binding = $result->next)
+	{
+		$webid = $binding->{'person'}->uri
+			if  $binding->{'person'}
+			and $binding->{'person'}->is_resource
+			and !defined $webid;
+			
+		foreach my $field (@fields)
+		{
+			if ($binding->{$field}->is_resource)
+				{ $self->{'data'}->{$field}->{ $binding->{$field}->uri } = 1; }
+			elsif ($binding->{$field}->is_literal)
+				{ $self->{'data'}->{$field}->{ $binding->{$field}->literal_value } = 1; }
+		}
+	}
+	
+	foreach my $field (@fields)
+	{
+		$self->{'data'}->{$field} = [ keys %{ $self->{'data'}->{$field} } ];
+	}
+	
+	$self->{'webid'} = $webid;
+	
+	return $self;
+}
+
+sub graph
+{
+	my $self = shift;
+	
+	unless (defined $self->{'graph'})
+	{
+		my $ident = $self->{'ident'}.'';
+		my $sha1 = sha1_hex($ident);
+		my $model = RDF::Trine::Model->new( RDF::Trine::Store->temporary_store );
+		my $query  = RDF::Query::Client->new("
+			DESCRIBE ?person
+			WHERE
+			{
+				{ ?person foaf:mbox <$ident> . }
+				UNION
+				{ ?person foaf:mbox_sha1sum \"$sha1\" . }
+			}");
+		my $result = $query->execute($self->endpoint, {QueryMethod=>'POST'});
+		$model->add_statements( $result->as_stream );
+		
+		$self->{'graph'} = $model;
+	}
+	
+	return $self->{'graph'};
+}
+
+sub endpoint
+{
+	my $self = shift;
+	return $self->{'endpoint'};
+}
+
+sub webid
+{
+	my $self = shift;
+	return $self->{'webid'};
+}
+
+sub _data
+{
+	my $self = shift;
+	my $k    = shift;
+	if (wantarray)
+	{
+		return @{ $self->{'data'}->{$k} }
+			if defined $self->{'data'}->{$k};
+	}
+	else
+	{
+		return $self->{'data'}->{$k}->[0]
+			if defined $self->{'data'}->{$k}->[0];
+	}
+	return undef;
+}
+
+sub name
+{
+	my $self = shift;
+	return $self->_data('name');
+}
+
+sub mbox
+{
+	my $self = shift;
+	return $self->_data('mbox');
+}
+
+sub image
+{
+	my $self = shift;
+	return $self->_data('image');
+}
+
+sub homepage
+{
+	my $self = shift;
+	return $self->_data('homepage');
+}
+
+sub weblog
+{
+	my $self = shift;
+	return $self->_data('weblog');
+}
+
+sub key
+{
+	my $self = shift;
+	return $self->_data('key');
+}
+
+1;
+__END__
+# Below is stub documentation for your module. You'd better edit it!
+
+=head1 NAME
+
+WWW::Finger::Fingerpoint - Investigate E-mail Addresses using Fingerpoint
+
+=head1 VERSION
+
+0.01
+
+=head1 SYNOPSIS
+
+  use RDF::Query::Client;
+  use WWW::Finger::Fingerpoint;
+  
+  my $fingerpoint = WWW::Finger::Fingerpoint->new("joe@example.com");
+  
+  if ($fingerpoint->webid)
+  {
+    my $sparql  = sprintf(
+      "SELECT * WHERE {<%s> <http://xmlns.com/foaf/0.1/homepage> ?page.}",
+      $fingerpoint->webid);
+    my $query   = RDF::Query::Client->new($sparql);
+    my $results = $query->execute($fingerpoint->endpoint);
+	 while (my $row = $results->next)
+    {
+      print "Found page: " . $row->{'page'}->uri . "\n";
+    }
+  }
+
+=head1 DESCRIPTION
+
+Methods:
+
+  * new      - create new object from e-mail address
+  * name     - get person's name
+  * mbox     - get person's e-mail address
+  * homepage - get person's homepage URL
+  * weblog   - get person's blog URL
+  * image    - get person's photo or avatar URL
+  * key      - get a person's PGP/GPG key URL
+  * webid    - get person's identifying URI
+  * endpoint - get person's SPARQL endpoint for querying data
+  * graph    - get the results of a SPARQL DESCRIBE on the person
+
+I'll document this better one day!
+
+=head1 SEE ALSO
+
+L<WWW::Finger>.
+
+L<RDF::Query::Client>, L<RDF::Trine>.
+
+L<http://buzzword.org.uk/2009/fingerpoint/spec>.
+
+L<http://www.perlrdf.org/>.
+
+=head1 AUTHOR
+
+Toby Inkster, E<lt>tobyink@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2009 by Toby Inkster
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8.1 or,
+at your option, any later version of Perl 5 you may have available.
+
+
+=cut

File lib/WWW/Finger/Webfinger.pm

View file
  • Ignore whitespace
+package WWW::Finger::Webfinger;
+
+use 5.008001;
+use strict;
+
+use Carp;
+use LWP::Simple;
+use RDF::Query;
+use RDF::Trine;
+use WWW::Finger;
+use URI;
+use URI::Escape;
+use XRD::Parser 0.02;
+
+our @ISA = qw(WWW::Finger);
+our $VERSION = '0.01';
+
+sub new
+{
+	my $class = shift;
+	my $ident = shift or croak "Need to supply an e-mail address\n";
+	my $self  = bless {}, $class;
+		
+	$ident = "acct://$ident"
+		unless $ident =~ /^[a-z0-9\.\-\+]+:/i;
+	$ident = URI->new($ident);
+	return undef
+		unless $ident->scheme =~ /^(mailto|acct|xmpp)$/;
+
+	$self->{'ident'} = $ident;
+	my ($user, $host) = split /\@/, $ident->to;
+	
+	my $ua = LWP::UserAgent->new;
+	$ua->timeout(10);
+	$ua->env_proxy;
+
+	my $xrd_parser = XRD::Parser->new(undef,
+		sprintf("http://%s/.well-known/host-meta", $host));
+	$xrd_parser->consume;
+	$self->{'hostmeta'} = $xrd_parser->graph;
+	
+	my @descriptors;
+	my $sparql  = sprintf("SELECT ?template WHERE { <%s> <%s> ?template . }",
+		('http://ontologi.es/xrd#host:' . lc $host),
+		'x-xrd+template+for:http://lrdd.net/rel/descriptor');
+	my $query   = RDF::Query->new($sparql);
+	my $results = $query->execute( $self->{'hostmeta'} );
+	while (my $row = $results->next)
+	{
+		next
+			unless $row->{'template'}->is_literal;
+		next
+			unless $row->{'template'}->literal_datatype eq 'http://ontologi.es/xrd#URITemplate';
+			
+		my $template = $row->{'template'}->literal_value;
+		my $escaped  = uri_escape("$ident");
+		$template = s/\{uri\}/$escaped/;
+		
+		push @descriptors, $template;
+	}
+	
+	use Data::Dumper;
+	warn Dumper(\@descriptors);
+}
+
+1;
+__END__
+=head1 NAME
+
+WWW::Finger::Webfinger - WWW::Finger module for Webfinger
+
+=head1 AUTHOR
+
+Toby Inkster, E<lt>tobyink@cpan.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright (C) 2009 by Toby Inkster
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself, either Perl version 5.8.1 or,
+at your option, any later version of Perl 5 you may have available.
+
+
+=cut

File t/WWW-Finger-Fingerpoint.t

View file
  • Ignore whitespace
+# Before `make install' is performed this script should be runnable with
+# `make test'. After `make install' it should work as `perl WWW-Finger-Fingerpoint.t'
+
+#########################
+
+# change 'tests => 1' to 'tests => last_test_to_print';
+
+use Test::More tests => 1;
+BEGIN { use_ok('WWW::Finger::Fingerpoint') };
+
+#########################
+
+# Insert your test code below, the Test::More module is use()ed here so read
+# its man page ( perldoc Test::More ) for help writing this test script.
+