#!/usr/bin/perl

=head1 NAME

HTTP::LRDD - link-based resource descriptor discovery

=head1 SYNOPSIS

 use HTTP::LRDD;
 
 my $lrdd        = HTTP::LRDD->new;
 my @descriptors = $lrdd->discover($resource);
 foreach my $descriptor (@descriptors)
 {
   my $description = $lrdd->parse($descriptor);
   # $description is an RDF::Trine::Model
 }

=cut

package HTTP::LRDD;

use strict;
use 5.008;

use HTML::HTML5::Parser;
use HTML::HTML5::Sanity;
use HTTP::Link::Parser qw(:all);
use HTTP::Status qw(:constants);
use RDF::RDFa::Parser;
use RDF::TrineShortcuts;
use Scalar::Util qw(blessed);
use URI;
use URI::Escape;
use XML::Atom::OWL;
use XRD::Parser '0.101';

=head1 VERSION

0.102

=cut

our $VERSION = '0.102';
my (@Predicates, @MediaTypes);

BEGIN
{
	@Predicates = qw(describedby lrdd http://www.w3.org/1999/xhtml/vocab#meta http://www.w3.org/2000/01/rdf-schema#seeAlso);
	@MediaTypes = qw(application/xrd+xml application/rdf+xml text/turtle application/atom+xml;q=0.9 application/xhtml+xml;q=0.9 text/html;q=0.9 */*;q=0.1)
}

=head1 DESCRIPTION

Note: the LRDD specification has ceased to be, with some parts being merged into
the host-meta Internet Draft. This CPAN module will go in its own direction,
bundling up best-practice techniques for discovering links and descriptors for a
given URI.

=head2 Import Routine

=over 4

=item C<< use HTTP::LRDD (@predicates); >>

When importing HTTP::LRDD, you can optionally provide a list of
predicate URIs (i.e. the URIs which rel values expand to). This
may also include IANA-registered link types, which are short tokens
rather than full URIs.

If you do not provide a list of predicate URIs, then a sensible
default set is used.

=back

=cut

sub import
{
	my $class   = shift;
	@Predicates = @_ if @_;
}

=head2 Constructors

=over 4

=item C<< HTTP::LRDD->new(@predicates) >>

Create a new LRDD discovery object using the given predicate URIs.
If @predicates is omitted, then the predicates passed to the import
routine are used instead.

=cut

sub new
{
	my $class   = shift;
	my $self    = bless { }, $class;
	
	$self->{'predicates'} = @_ ? \@_ : \@Predicates;
	
	return $self;
}

=item C<< HTTP::LRDD->new_strict >>

Create a new LRDD discovery object using the 'describedby' and
'lrdd' IANA-registered predicates.

=cut

sub new_strict
{
	my $class   = shift;
	return $class->new(qw(describedby lrdd));
}

=item C<< HTTP::LRDD->new_default >>

Create a new LRDD discovery object using the default set of
predicates ('describedby', 'lrdd', 'xhv:meta' and 'rdfs:seeAlso').

=back

=cut

sub new_default
{
	my $class   = shift;
	return $class->new(qw(describedby lrdd http://www.w3.org/1999/xhtml/vocab#meta http://www.w3.org/2000/01/rdf-schema#seeAlso));
}

=head2 Public Methods

=over 4

=item C<< $lrdd->discover($resource_uri) >>

Discovers a descriptor for the given resource; or if called in a list
context, a list of descriptors.

A descriptor is a resource that provides a description for something.
So, if the given resource URI was the web address for an image, then
the descriptor might be the web address for a metadata file about the
image. If the given URI was an e-mail address, then the descriptor
might be a profile document for the person to whom the address belongs.

The following sources are checked (in order) to find links to
descriptors.

=over 4

=item * HTTP response headers ("Link" header; "303 See Other" status)

=item * HTTP response message (RDF or RDFa)

=item * https://HOSTNAME/.well-known/host-meta

=item * http://HOSTNAME/.well-known/host-meta

=back

If none of the above is able to yield a link to a descriptor, then
the resource URI itself may be returned if it is in a self-describing
format (e.g. RDF).

There is no guaranteed file format for the descriptor, but it is
usually RDF, POWDER XML or XRD.

This method can also be called without an object (as a class method)
in which case, a temporary object is created automatically using
C<< new >>.

=cut

sub discover
{
	my $self = shift;
	my $uri  = shift;
	my $list = wantarray;
	
	$self = $self->new
		unless blessed($self) && $self->isa(__PACKAGE__);

	my (@results, $rdfa, $rdfx, $response);

	# STEP 1: check the HTTP headers for a descriptor link
	if ($uri =~ /^https?:/i)
	{
		$response = $self->_ua->head($uri);
		my $model    = rdf_parse();
		
		# Parse HTTP 'Link' headers.
		parse_links_into_model($response, $model);
		
		if ($response->code eq HTTP_SEE_OTHER) # 303 Redirect
		{
			my $seeother = URI->new_abs(
				$response->header('Location'),
				URI->new($uri));
			
			$model->add_hashref({
				$uri => {
					'http://www.w3.org/2000/01/rdf-schema#seeAlso' => [
							{ 'value' => "$seeother" , 'type' => 'uri' },
						],
					},
				});
		}

		my $iterator = rdf_query($self->_make_sparql($uri, $list), $model);
		while (my $row = $iterator->next)
		{
			push @results, $row->{'descriptor'}->uri
				if defined $row->{'descriptor'}
				&& $row->{'descriptor'}->is_resource;
		}
		
		# Bypass further processing if we've got a result and we only wanted one!
		return $results[0] if @results && !$list;
	}

	# STEP 2: check the HTTP body (RDF) for a descriptor link
	if ($uri =~ /^https?:/i)
	{
		my $model = rdf_parse();
		
		# Parse as RDFa, if the response is RDFa.
		($response, $rdfa) = $self->_cond_parse_rdfa($response, $model, $uri);
		
		# If the response was not RDFa, try parsing as RDF.
		($response, $rdfx) = $self->_cond_parse_rdf($response, $model, $uri)
			unless defined $rdfa;

		my $iterator = rdf_query($self->_make_sparql($uri, $list), $model);
		while (my $row = $iterator->next)
		{
			push @results, $row->{'descriptor'}->uri
				if defined $row->{'descriptor'}
				&& $row->{'descriptor'}->is_resource;
		}
		
		# Bypass further processing if we've got a result and we only wanted one!
		return $results[0] if @results && !$list;		
	}

	# STEP 2a: AtomOWL doesn't use <id> as a subject URI.
	if (defined $rdfa && $rdfa->{'atom_parser'} && blessed($self->{'cache'}->{$uri}))
	{
		my $iterator = rdf_query($self->_make_sparql_atomowl($uri, $list), $self->{'cache'}->{$uri});
		while (my $row = $iterator->next)
		{
			push @results, $row->{'descriptor'}->uri
				if defined $row->{'descriptor'}
				&& $row->{'descriptor'}->is_resource;
		}
		
		# Bypass further processing if we've got a result and we only wanted one!
		return $results[0] if @results && !$list;
	}
	
	# STEP 3: try host-meta.
	my $hostmeta_location = XRD::Parser::hostmeta_location($uri);
	unless (blessed($self->{'cache'}->{$hostmeta_location}))
	{
		eval
		{
			my $hm = XRD::Parser->hostmeta($uri);
			$hm->consume;
			$self->{'cache'}->{$hostmeta_location} = $hm->graph;
		};
	}
	if (blessed( $self->{'cache'}->{$hostmeta_location} ))
	{
		my $hm_graph = $self->{'cache'}->{$hostmeta_location};
		
		# First try original query.
		my $iterator = rdf_query($self->_make_sparql($uri, $list), $hm_graph);
		while (my $row = $iterator->next)
		{
			push @results, $row->{'descriptor'}->uri
				if defined $row->{'descriptor'}
				&& $row->{'descriptor'}->is_resource;
		}
		
		# Then try using host-meta URI templates.
		$iterator = rdf_query($self->_make_sparql_template($uri, $list), $hm_graph);
		while (my $row = $iterator->next)
		{
			if (defined $row->{'descriptor'}
			&&  $row->{'descriptor'}->is_literal
			&&  $row->{'descriptor'}->literal_datatype eq (XRD::Parser->URI_XRD.'URITemplate'))
			{
				my $u = $row->{'descriptor'}->literal_value;
				$u =~ s/\{uri\}/uri_escape($uri)/ie;
				push @results, $u;
			}
		}
	}
	
	# STEP 4: the resource may be self-describing
	if ($rdfa || $rdfx)
	{
		my $data = $self->parse($uri);
		
		# only add $uri to @results
		#    if we're completely desparate,
		#    or it seems to provide something useful.
		push @results, $uri
			if !@results
			|| $data->count_statements(RDF::Trine::Node::Resource->new($uri), undef, undef);
	}
	
	if (@results)
	{
		return $list ? @results : $results[0];
	}

	return undef;
}

=item C<< $lrdd->parse($descriptor_uri) >>

Parses a descriptor in XRD or RDF (RDF/XML, RDFa, Turtle, etc).

Returns an RDF::Trine::Model or undef if unable to process.

This method can also be called without an object (as a class method)
in which case, a temporary object is created automatically using
C<< new >>.

=cut

sub parse
{
	my $self = shift;
	my $uri  = shift or return undef;

	$self = $self->new
		unless blessed($self) && $self->isa(__PACKAGE__);
	
	unless (blessed($self->{'cache'}->{$uri})
	&& $self->{'cache'}->{$uri}->isa('RDF::Trine::Model'))
	{
		my $response = $self->_ua->get($uri);
		my $model    = rdf_parse();
		
		# Parse as RDFa, if the response is RDFa.
		($response, my $rdfa) = $self->_cond_parse_rdfa($response, $model, $uri);
		
		# If the response was not RDFa, try parsing as RDF.
		($response, my $rdfx) = $self->_cond_parse_rdf($response, $model, $uri)
			unless defined $rdfa;
			
		# If the response was not RDFa, try parsing as RDF.
		($response, my $xrd) = $self->_cond_parse_xrd($response, $model, $uri)
			unless defined $rdfa || defined $rdfx;
	}
	
	return $self->{'cache'}->{$uri};
}

=item C<< $lrdd->process($resource_uri) >>

Performs the equivalent of C<discover> and C<parse> in one easy step.

Calls C<discover> in a non-list context, so only the first descriptor
is used.

=cut

sub process
{
	my $self = shift;
	my $uri  = shift;

	$self = $self->new
		unless blessed($self) && $self->isa(__PACKAGE__);
		
	my $descriptor = $self->discover($uri);
	return $self->parse($descriptor);
}

=item C<< $lrdd->process_all($resource_uri) >>

Performs the equivalent of C<discover> and C<parse> in one easy step.

Calls C<discover> in a list context, so multiple descriptors are
combined into the resulting graph.

=cut

sub process_all
{
	my $self = shift;
	my $uri  = shift;

	$self = $self->new
		unless blessed($self) && $self->isa(__PACKAGE__);
		
	my @descriptors = $self->discover($uri);
	my $model       = $self->parse($uri);
	
	foreach my $descriptor (@descriptors)
	{
		my $description = $self->parse($descriptor);
		rdf_parse($description, model=>$model); # merge
	}
	
	return $model;
}

sub _make_sparql
{
	my ($self, $uri, $list) = @_;

	my @p;
	foreach my $p (@{ $self->{'predicates'} })
	{
		push @p, sprintf('{ <%s> <%s> ?descriptor . }',
			$uri, HTTP::Link::Parser::relationship_uri($p));
	}
	return $list ?
		'SELECT DISTINCT ?descriptor WHERE { '.(join ' UNION ', @p).' }' :
		'SELECT DISTINCT ?descriptor WHERE { OPTIONAL '.(join ' OPTIONAL ', @p).' }';
}

sub _make_sparql_atomowl
{
	my ($self, $uri, $list) = @_;

	my @p;
	foreach my $p (@{ $self->{'predicates'} })
	{
		push @p, sprintf('{ ?feed <%s> ?descriptor . }',
			HTTP::Link::Parser::relationship_uri($p));
	}
	
	# this can be ambiguous in the face of atom:source.
	return $list ?
		'SELECT DISTINCT ?descriptor WHERE { ?feed a <http://bblfish.net/work/atom-owl/2006-06-06/#Feed> . { '.(join ' UNION ', @p).'} }' :
		'SELECT DISTINCT ?descriptor WHERE { ?feed a <http://bblfish.net/work/atom-owl/2006-06-06/#Feed> . OPTIONAL '.(join ' OPTIONAL ', @p).' }';
}

sub _make_sparql_template
{
	my ($self, $uri, $list) = @_;
	my $hosturi = XRD::Parser::host_uri( $uri );
	my @p;
	foreach my $p (@{ $self->{'predicates'} })
	{
		push @p, sprintf('{ <%s> <%s> ?descriptor . }',
			$hosturi, XRD::Parser::template_uri(HTTP::Link::Parser::relationship_uri($p)));
	}
	return $list ?
		'SELECT DISTINCT ?descriptor WHERE { '.(join ' UNION ', @p).' }' :
		'SELECT DISTINCT ?descriptor WHERE { OPTIONAL '.(join ' OPTIONAL ', @p).' }';
}

sub _cond_parse_rdfa
{
	my ($self, $response, $model, $uri) = @_;
	
	my $rdfa_options;
	my $rdfa_input;
	
	if ($response->content_type =~ m'^(application/atom\+xml|image/svg\+xml|application/xhtml\+xml|text/html)'i)
	{
		if (uc $response->request->method ne 'GET')
		{
			$self->_ua->max_redirect(3);
			$response = $self->_ua->get($uri);
			$self->_ua->max_redirect(0);
		}
	}
	else
	{
		return ($response, undef);
	}

	$response->is_success or return ($response, undef);

	if ($RDF::RDFa::Parser::VERSION >= '1.09_10')
	{
		my $hostlang = RDF::RDFa::Parser::Config->host_from_media_type($response->content_type);
		$rdfa_options = RDF::RDFa::Parser::Config->new($hostlang, RDF::RDFa::Parser::Config->RDFA_GUESS, 
			atom_parser => ($response->content_type =~ m'^application/atom\+xml'i ? 1 : 0),
			);
	}
	elsif ($response->content_type =~ m'^application/atom\+xml'i)
	{
		$rdfa_options = RDF::RDFa::Parser::OPTS_ATOM;
		$rdfa_options->{'atom_parser'} = 1;
	}
	elsif ($response->content_type =~ m'^image/svg\+xml'i)
	{
		$rdfa_options = RDF::RDFa::Parser::OPTS_SVG;
	}
	elsif ($response->content_type =~ m'^application/xhtml\+xml'i)
	{
		$rdfa_options = RDF::RDFa::Parser::OPTS_XHTML;
	}
	elsif ($response->content_type =~ m'^text/html'i)
	{
		$rdfa_options = RDF::RDFa::Parser::OPTS_HTML5;
		$rdfa_options = RDF::RDFa::Parser::OPTS_HTML4
			if $response->decoded_content =~ m'<!doctype\s+html\s+public\s+.-//W3C//DTD HTML 4'i;
		
		my $parser  = HTML::HTML5::Parser->new;
		$rdfa_input = $parser->parse_string($response->decoded_content);
	}
	
	if (defined $rdfa_options)
	{
		# Make sure any predicate keywords are recognised in @rel/@rev.
		# This can override some normal RDFa keywords in some cases.
		foreach my $attr (qw(rel rev))
		{
			foreach my $p (@{ $self->{'predicates'} })
			{
				$rdfa_options->{'keywords'}->{$attr}->{$p}
					= HTTP::Link::Parser::relationship_uri($p)
					unless $p =~ /:/;
				$rdfa_options->{'keywords'}->{'insensitive'}->{$attr}->{$p}
					= HTTP::Link::Parser::relationship_uri($p)
					unless $p =~ /:/;
			}
		}
		
		$rdfa_input = $response->decoded_content
			unless defined $rdfa_input;
		
		my $parser = RDF::RDFa::Parser->new($rdfa_input, $response->base, $rdfa_options, $model->_store);
		$parser->consume;
		$self->{'cache'}->{$uri} = $model;
		return ($response, $rdfa_options);
	}
	
	return ($response, undef);
}

sub _cond_parse_rdf
{
	my ($self, $response, $model, $uri) = @_;
	my $type;
	
	if ($response->content_type =~ m'^(application/rdf\+xml|(application|text)/(x-)?(rdf\+)?(turtle|n3|json))'i)
	{
		if (uc $response->request->method ne 'GET')
		{
			$self->_ua->max_redirect(3);
			$response = $self->_ua->get($uri);
			$self->_ua->max_redirect(0);
		}
		
		$type = 'Turtle';
		$type = 'RDFXML'  if $response->content_type =~ /rdf.xml/;
		$type = 'RDFJSON' if $response->content_type =~ /json/;
	}
	else
	{
		return ($response, undef);
	}

	$response->is_success or return ($response, undef);

	rdf_parse($response->decoded_content, type=>$type, model=>$model, base=>$response->base);
	$self->{'cache'}->{$uri} = $model;
	return ($response, 1);
}

sub _cond_parse_xrd
{
	my ($self, $response, $model, $uri) = @_;
	my $type;
	
	if ($response->content_type =~ m'^(text/plain|application/octet-stream|application/xrd\+xml|(application|text)/xml)'i)
	{
		if (uc $response->request->method ne 'GET')
		{
			$self->_ua->max_redirect(3);
			$response = $self->_ua->get($uri);
			$self->_ua->max_redirect(0);
		}
	}
	else
	{
		return ($response, undef);
	}

	$response->is_success or return ($response, undef);
	
	my $xrd = XRD::Parser->new($response->decoded_content, $response->base, {loose_mime=>1}, $model->_store);
	$xrd->consume;
	$self->{'cache'}->{$uri} = $model;
	return ($response, $xrd);
}

sub _ua
{
	my $self = shift;
	
	unless (defined $self->{'ua'})
	{
		$self->{'ua'} = LWP::UserAgent->new;
		$self->_ua->agent(sprintf('%s/%s ', __PACKAGE__, $VERSION));
		$self->_ua->default_header('Accept' => (join ', ', @MediaTypes));
		$self->_ua->max_redirect(0);
	}
	
	return $self->{'ua'};
}

1;

=back

=head1 EXAMPLES

Discover the hub address (PubSubHubub) for a feed:

 my $lrdd = HTTP::LRDD->new('hub');
 my $hub  = $lrdd->discover('http://example.net/feed.atom');

Discover an author link (rel="author") from an HTML page:

 my $lrdd   = HTTP::LRDD->new('author');
 my $author = $lrdd->discover('http://example.com/page.html');

(For RDF people, you should note that rel="author" is not semantically
equivalent to the "foaf:maker" property but closer to the 
"foaf:maker/foaf:homepage" SPARQL 1.1 property path - i.e. the rel="author"
link destination is not a URI for the author themselves, but a page about
the author.)

If that author resource is in a machine-readable format (e.g. RDF), then
parse the data:

 my $author_data = $lrdd->parse($author);
 
Or, you can combine C<discover> and C<parse>:

 my $lrdd        = HTTP::LRDD->new('author');
 my $author_data = $lrdd->process('http://example.com/page.html');

Get metadata for an image:

 my $lrdd = HTTP::LRDD->new;
 my $data = $lrdd->process_all('http://example.org/flower.jpeg');

As we're not passing any arguments to the constructor, we can use a shortcut:

 my $data = HTTP::LRDD->process_all('http://example.org/flower.jpeg');
 
Find the title of the image:

 use RDF::TrineShortcuts qw':default :flatten';
 
 my @results = flatten_iterator(rdf_query(
  "SELECT ?t WHERE { <http://example.org/flower.jpeg> dc:title ?t }"));
 if (@results) {
   printf("The title is: %s\n", $results[0]->{'title'});
 } else {
   warn "Could not find title for image.";
 }

=head1 BUGS

Please report any bugs to L<http://rt.cpan.org/>.

=head1 SEE ALSO

L<HTTP::Link::Parser>, L<XRD::Parser>, L<XML::Atom::OWL>
L<WWW::Finger>, L<RDF::TrineShortcuts>.

L<http://www.perlrdf.org/>.

=head1 AUTHOR

Toby Inkster E<lt>tobyink@cpan.orgE<gt>.

=head1 COPYRIGHT

Copyright 2010 Toby Inkster

This library is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut
