Manifest-driven SPARQL Protocol Test Driver

sparql-protocol-manifest-driven-test-driver.pl

#!/usr/bin/env perl

use 5.020;
use strict;
use warnings;
use Attean;
use URI;
use Attean::RDF qw(iri blank literal quad);
use LWP::UserAgent;
use HTTP::Request;
use Test::More;
use Data::Dumper;
use Encode qw(encode);

my $rdf_type		= iri('http://www.w3.org/1999/02/22-rdf-syntax-ns#type');
my $Manifest		= iri('http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#Manifest');
my $entries			= iri('http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#entries');
my $requests		= iri('http://www.w3.org/2011/http#requests');
my $mf_action		= iri('http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#action');
my $absolutePath	= iri('http://www.w3.org/2011/http#absolutePath');
my $methodName		= iri('http://www.w3.org/2011/http#methodName');
my $ht_body			= iri('http://www.w3.org/2011/http#body');
my $ht_headers		= iri('http://www.w3.org/2011/http#headers');
my $cnt_encoding	= iri('http://www.w3.org/2011/content#characterEncoding');
my $cnt_chars		= iri('http://www.w3.org/2011/content#chars');
my $ht_fieldName	= iri('http://www.w3.org/2011/http#fieldName');
my $ht_fieldValue	= iri('http://www.w3.org/2011/http#fieldValue');
my $ht_resp			= iri('http://www.w3.org/2011/http#resp');
my $expectedBoolean	= iri('http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#expectedBoolean');
my $expectedFormat	= iri('http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#expectedFormat');
my $expectedStatus	= iri('http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#expectedStatus');
my $mf_expectation	= iri('http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#expectation');
my $ut_graphData	= iri('http://www.w3.org/2009/sparql/tests/test-update#graphData');
my $ut_graph		= iri('http://www.w3.org/2009/sparql/tests/test-update#graph');
my $rdfs_label		= iri('http://www.w3.org/2000/01/rdf-schema#label');

if (scalar(@ARGV) == 0) {
	print <<"END";

Usage: $0 http://endpoint/sparql [test-pattern] [-v]

Run the SPARQL Protocol tests against the specified endpoint.
If [test-pattern] is given, only runs tests whose IRI match the given regex pattern.

END

	exit(1);
}

my $endpoint	= shift;
my $pattern		= shift // '';
my $flags		= shift // '';
my $verbose		= ($flags =~ /-v/);
my $euri		= URI->new($endpoint);
$euri->fragment(undef);
$euri->query(undef);
$endpoint		= $euri->as_string;

my $manifest	= shift // 'manifest.ttl';
my $graph		= iri('http://graph-name/');
my $store = Attean->get_store('Memory')->new();
my $parser = Attean->get_parser('Turtle')->new();
{
	open(my $fh, '<:utf8', $manifest) or die $!;
	my $iter = $parser->parse_iter_from_io($fh);
	my $quads = $iter->as_quads($graph);
	$store->add_iter($quads);
}

my $ua		= LWP::UserAgent->new();

# clear dataset
my $resp	= $ua->post($endpoint, {update => 'DROP ALL'});
die $resp->status_line unless ($resp->is_success);

my $model	= Attean::QuadModel->new( store => $store );
my ($m)		= $model->subjects($rdf_type, $Manifest)->elements;
my ($obj)	= $model->objects($m, $entries)->elements;
my @tests	= $model->get_list($graph, $obj)->elements;
foreach my $test (@tests) {
	next unless ($test->value =~ /$pattern/);
	subtest $test->value => sub {
		run_test($ua, $endpoint, $model, $test);
	};
}
done_testing();

sub make_request {
	my $endpoint	= shift;
	my $model		= shift;
	my $req			= shift;
	my ($path)		= $model->objects($req, $absolutePath)->elements;
	my $pathuri		= new URI($path->value);
	my ($method)	= $model->objects($req, $methodName)->elements;
	my ($body)		= $model->objects($req, $ht_body)->elements;
	my ($headers)	= $model->objects($req, $ht_headers)->elements;

	my $m			= HTTP::Request->new();
	$m->method($method->value);
	my $uri	= new URI($endpoint);
	$uri->query($pathuri->query);
	$m->uri($uri);
	if ($body) {
		my ($content)		= $model->objects($body, $cnt_chars)->elements;
		my ($encoding)		= $model->objects($body, $cnt_encoding)->elements;
		my $bytes			= encode($encoding->value, $content->value);
		$m->content($bytes);
	}
	
	my @headers	= $model->get_list($graph, $headers)->elements;
	foreach my $h (@headers) {
		my ($key)		= $model->objects($h, $ht_fieldName)->elements;
		my ($value)		= $model->objects($h, $ht_fieldValue)->elements;
		$m->header($key->value => $value->value);
	}
	return $m;
}

sub validate_response {
	my $model	= shift;
	my $test	= shift;
	my $name	= $test->value;
	my $req		= shift;
	my $m		= shift;
	
	my ($resp)	= $model->objects($req, $ht_resp)->elements;

	my (@expected_status)	= $model->objects($resp, $expectedStatus)->elements;
	if (scalar(@expected_status)) {
		my %ok				= map { $_ => 1 } map { $_->value } @expected_status;
		my $code			= $m->code;
		my $digit			= int($code / 100);
		my $actual_iri		= "http://www.w3.org/2011/http#StatusCode${digit}xx";
		ok(exists $ok{$actual_iri}, "Unexpected status code: " . $m->status_line);
	}
	my ($expected_format)	= $model->objects($resp, $expectedFormat)->elements;
	if ($expected_format) {
		my $ct	= $m->header('Content-Type');
		my $expected	= $expected_format->value;
		if ($expected eq 'tabular') {
			like($ct, qr#^application/sparql-results[+](json|xml)|text/csv|text/tab-separated-values#, "expected tabular result but got $ct");
		} elsif ($expected eq 'boolean') {
			like($ct, qr#^application/sparql-results[+](json|xml)|text/plain#, "expected boolean result but got $ct");
		} elsif ($expected eq 'RDF') {
			like($ct, qr#^(application/rdf-xml)|text/((n-(triples|quads))|turtle)|application/ld[+]json#, "expected RDF result but got $ct")
		} else {
			die("Unexpected format value '$expected'");
		}
	}
	my ($expected_bool)		= $model->objects($resp, $expectedBoolean)->elements;
	if ($expected_bool) {
		my $ct	= $m->header('Content-Type');
		my $body	= $m->decoded_content;
		my $expected	= $expected_bool->value;
		if ($ct eq 'application/sparql-results+json') {
			like($body, qr#"boolean"\s*:\s*${expected}#sm, "expected boolean $expected");
		} elsif ($ct eq 'application/sparql-results+xml') {
			like($body, qr#<boolean>${expected}</boolean>#sm, "expected boolean $expected");
		} elsif ($ct eq 'text/plain') {
			like($body, qr#${expected}#sm, "expected boolean $expected");
		} else {
			die("validate expected boolean: " . $expected_bool->value);
		}
	}

	my ($expectation)		= $model->objects($resp, $mf_expectation)->elements;
	if ($expectation) {
		fail("validate expectation: " . $expectation->value);
	}
}

sub setup_dataset {
	my $ua			= shift;
	my $endpoint	= shift;
	my $model		= shift;
	my $test		= shift;
	my (@graphs)	= $model->objects($test, $ut_graphData)->elements;
	if (scalar(@graphs)) {
		warn "Clearing dataset ...\n";
		my $resp	= $ua->post($endpoint, {update => 'DROP ALL'});
		die $resp->status_line unless ($resp->is_success);
		foreach my $graph (@graphs) {
			# loading contents of $uri into graph named $name
			my ($name)	= map { $_->value } $model->objects($graph, $rdfs_label)->elements;
			my ($uri)	= map { $_->value } $model->objects($graph, $ut_graph)->elements;
			my $content	= do { local($/); open(my $fh, '<:utf8', $uri) or die $!; <$fh> };
			my $update	= "INSERT DATA { GRAPH <$name> { $content } }";
			warn "Loading data <$name> ...\n";
			my $resp	= $ua->post($endpoint, {update => $update});
			die $resp->status_line unless ($resp->is_success);
		}
	}
}

sub run_test {
	my $ua			= shift;
	my $endpoint	= shift;
	my $model		= shift;
	my $test		= shift;
	say '# ' . $test->value if ($verbose);
	my ($action)	= $model->objects($test, $mf_action)->elements;
	my ($reqs)		= $model->objects($action, $requests)->elements;
	my @reqs		= $model->get_list($graph, $reqs)->elements;
	
	setup_dataset($ua, $endpoint, $model, $test);
	
	foreach my $req (@reqs) {
		say "---------------------------------" if ($verbose);
		my $m	= make_request($endpoint, $model, $req);
# 		next unless ($m->method eq 'GET');
		say "REQUEST:\n" . $m->as_string if ($verbose);
		my $resp	= $ua->request($m);
		say "RESPONSE:\n" . $resp->as_string if ($verbose);
		validate_response($model, $test, $req, $resp);
	}
}