#!/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;