FingerpointClient.pl

#!/usr/bin/perl

# Copyright (c) 2009 Toby A Inkster
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
# The above copyright notice and this permission notice shall be included in
# all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
# THE SOFTWARE.

use DateTime;
use Digest::SHA1 qw(sha1_hex);
use Getopt::Long;
use JSON;
use LWP::UserAgent;
use XML::Simple;
use URI;
use URI::Escape;
use strict;

my $vcard = 0;
&Getopt::Long::GetOptions(
'vcard' => \$vcard ,
);

# Hard-coded relation for finger SPARQL endpoint.
my $rel_fingerpoint = 'http://ontologi.es/sparql#fingerpoint';

# Get e-mail address supplied on command line, clean up.
my $ident = shift @ARGV || die "Need to supply an e-mail address\n";
$ident = "mailto:$ident" unless $ident =~ /^mailto:/i;
$ident = URI->new($ident);
my ($user, $host) = split /\@/, $ident->to;

# Instantiate an HTTP client
my $ua = LWP::UserAgent->new;
$ua->timeout(10);
$ua->env_proxy;

# Use HTTP Link header to find preferred finger SPARQL endpoint from address
my $httphost = "http://$host/";
my $response = $ua->head($httphost);
die "HTTP non-success when finding fingerpoint.\n"
unless $response->is_success;
my $linkdata = HTTP::Link::Parser::parse_response_to_rdf($response);
my $sparql   = $linkdata->{ $httphost }->{ $rel_fingerpoint }->[0]->{'value'};

# If HTTP Link header was not present, look for HTML <link/> tag.
unless (defined $sparql)
{
$response = $ua->get($httphost,
   'Accept' => 'application/xhtml+xml;q=1.0, text/html;q=0.9, */*;q=0.1');
die "HTTP non-success when finding fingerpoint HTML.\n"
   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*/?>`);
}
}

die "Could not discover Fingerpoint server.\n"
unless length $sparql;

# Figure out SPARQL query to run
my $sha1 = sha1_hex($ident);
my $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);

# Get the SPARQL Results
my ($base_part, $params_part) = split /\?/, $sparql;
$params_part .= '&query=' . uri_escape($query);
$params_part =~ s/^\&//;
my $results = $ua->post(
$base_part,
'Content' => $params_part,
'Accept' => 'application/sparql-results+json;q=1.0, application/sparql-results+xml;q=0.5');
die "HTTP non-success when performing SPARQL query at <$sparql>.\n"
unless $results->is_success;
my $data = {};

# Parse JSON response
if ($results->header('content-type') =~ /json/)
{
my $result_data = from_json($results->content);
foreach my $binding (@{ $result_data->{'results'}->{'bindings'} })
{
   foreach my $field (@fields)
   {
      if (defined $binding->{$field}->{'value'})
         { $data->{ $binding->{'person'}->{'value'} }->{$field}->{ $binding->{$field}->{'value'} }++; }
   }
}
}

# Parse XML response
else
{
my $result_data = XMLin($results->content);
foreach my $result (@{ $result_data->{'results'}->{'result'} })
{
   my $person = $result->{'binding'}->{'person'}->{'uri'};
   $person = '_:' . $result->{'binding'}->{'person'}->{'bnode'}
      if defined $result->{'binding'}->{'person'}->{'bnode'};
   foreach my $field (@fields)
   {
      if (defined $result->{'binding'}->{$field}->{'uri'})
         { $data->{ $person }->{$field}->{ $result->{'binding'}->{$field}->{'uri'} }++; }
      elsif (defined $result->{'binding'}->{$field}->{'literal'})
         { $data->{ $person }->{$field}->{ $result->{'binding'}->{$field}->{'literal'} }++; }
   }
}
}

# Output results - VCARD
if ($vcard)
{
foreach my $hit (sort keys %$data)
{
   print "BEGIN:VCARD\n";
   print "VERSION:3.0\n";
   printf("SOURCE;X-QUERY=SPARQL:%s\n", vcard_escape($base_part));
   printf("FN:%s\n", vcard_escape(sort keys %{$data->{$hit}->{'name'}}));
   printf("UID:%s\n", vcard_escape($hit));
   foreach my $email (sort keys %{$data->{$hit}->{'mbox'}})
   {
      $email =~ s/^mailto://i;
      printf("EMAIL;TYPE=INTERNET:%s\n", vcard_escape($email));
   }
   foreach my $u (sort keys %{$data->{$hit}->{'homepage'}})
   {
      printf("URL:%s\n", vcard_escape($u));
   }
   foreach my $u (sort keys %{$data->{$hit}->{'weblog'}})
   {
      printf("URL;TYPE=X-WEBLOG:%s\n", vcard_escape($u));
   }
   foreach my $u (sort keys %{$data->{$hit}->{'image'}})
   {
      printf("PHOTO;VALUE=URI:%s\n", vcard_escape($u));
   }
   foreach my $u (sort keys %{$data->{$hit}->{'key'}})
   {
      printf("KEY;VALUE=URI:%s\n", vcard_escape($u));
   }
   printf("REV:%s\n", DateTime->now->strftime('%Y%m%dT%H%M%S'));
   print "END:VCARD\n";
}
}

# Output results - plain text
else
{
foreach my $hit (sort keys %$data)
{
   print "<$hit>\n";
   foreach my $field (@fields)
   {
      print "\t$field:\n"
         if scalar keys %{$data->{$hit}->{$field}};
      foreach my $value (sort keys %{ $data->{$hit}->{$field} })
      {
         print "\t\t$value\n";
      }
   }
   print "\n";
}
}

sub vcard_escape
{
return $_[0];
}

# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #
# # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # #

package HTTP::Link::Parser;

use URI;
use strict;

sub relationship
{
my $str = shift;

if ($str =~ /^([a-z][a-z0-9\+\.\-]*)\:/i)
{
   # seems to be an absolute URI, so can safely return "as is".
   return $str;
}

return 'http://www.iana.org/assignments/relation/' . (lc $str);

my $url = url (lc $str), 'http://www.iana.org/assignments/relation/';
return $url->abs->as_string;

return undef;
}

sub parse_value_string
{
my $hdrv = shift;
my $base = shift;
my $rv   = {};

my $uri = undef;
if ($hdrv =~ /^(\s*<([^>]*)>\s*)/)
{
   $uri = $2;
   $hdrv = substr($hdrv, length($1));
}
else
{
   return $rv;
}

$rv->{'URI'} = URI->new_abs($uri, $base);

while ($hdrv =~ /^(\s*\;\s*(\/|[a-z0-9-]+)\s*\=\s*("[^"]*"|'[^']*'|[^\s\'\"\;\,]+)\s*)/i)
{
   $hdrv = substr($hdrv, length($1));
   my $key = lc $2;
   my $val = $3;

   $val =~ s/(^"|"$)//g if ($val =~ /^".*"$/);
   $val =~ s/(^'|'$)//g if ($val =~ /^'.*'$/ && $3 !~ /^".*"$/);

   if ($key eq 'rel')
   {
      $val =~ s/(^\s+)|(\s+$)//g;
      $val =~ s/\s+/ /g;

      my @rels = split / /, $val;
      foreach my $rel (@rels)
         { push @{ $rv->{'rel'} }, $rel; }
   }
   elsif ($key eq 'rev')
   {
      $val =~ s/(^\s+)|(\s+$)//g;
      $val =~ s/\s+/ /g;

      my @rels = split / /, $val;
      foreach my $rel (@rels)
         { push @{ $rv->{'rev'} }, $rel; }
   }
   elsif ($key eq 'anchor')
   {
      $rv->{'anchor'} = URI->new_abs($val, $base);
   }
   else
   {
      $rv->{ $key } = $val;
   }
}

return $rv;
}

sub parse_response
{
my $response = shift;
my $rv       = [];
my $base     = URI->new($response->base);

foreach my $header ($response->header('link'))
{
   push @$rv, parse_value_string($header, $base);
}

return $rv;
}

sub parse_response_to_rdf
{
my $response = shift;
my $base     = URI->new($response->base);
my $links    = parse_response($response);
my $rv       = {};

foreach my $link (@$links)
{
   my $subject = $base;

   $subject = $link->{'anchor'}
      if defined $link->{'anchor'};

   my $object = $link->{'URI'};

   foreach my $r (@{ $link->{'rel'} })
   {
      push @{ $rv->{ $subject }->{ $r } },
         {
            'value'    => "$object",
            'type'     => 'uri',
         };
   }

   foreach my $r (@{ $link->{'rev'} })
   {
      push @{ $rv->{ $object }->{ $r } },
         {
            'value'    => "$subject",
            'type'     => 'uri',
         };
   }

   if (defined $link->{'title'})
   {
      push @{ $rv->{ $object }->{ 'http://purl.org/dc/terms/title' } },
         {
            'value'    => $link->{'title'},
            'type'     => 'literal',
         };
   }
}

return $rv;
}

1;