File Coverage

blib/lib/AtteanX/Endpoint.pm
Criterion Covered Total %
statement 83 101 82.1
branch 0 4 0.0
condition n/a
subroutine 29 32 90.6
pod n/a
total 112 137 81.7


line stmt bran cond sub pod time code
1             # TODO: If the model supports caching roles, add headers and check for http 304
2             # TODO: Implement and support Accept-Language models (port from RDF::Trine::Store::LanguagePreference)
3             # TODO: Add next/prev link headers if query is paged
4             # TODO: Add configuration and link headers to indicate LDF/SPARQL mirrors
5              
6 2     2   907925 use v5.14;
  2         4  
7 2     2   6 use warnings;
  2         2  
  2         60  
8              
9             package AtteanX::Error {
10 2     2   453 use Moo;
  2         9005  
  2         8  
11 2     2   1836 use Types::Standard qw(Str HashRef);
  2         46688  
  2         14  
12 2     2   1515 use namespace::clean;
  2         7738  
  2         8  
13              
14             has 'message' => (is => 'ro', isa => Str, required => 1);
15             has 'details' => (is => 'ro', isa => HashRef, default => sub { +{} });
16             has 'uri' => (is => 'ro', isa => Str);
17             }
18              
19             package AtteanX::Endpoint::Error {
20 2     2   734 use Moo;
  2         2  
  2         8  
21             extends 'AtteanX::Error';
22 2     2   425 use Types::Standard qw(Int);
  2         4  
  2         9  
23 2     2   597 use namespace::clean;
  2         2  
  2         7  
24             has 'code' => (is => 'ro', isa => Int, required => 1);
25             }
26              
27             package AtteanX::Endpoint::ClientError {
28 2     2   536 use Moo;
  2         3  
  2         6  
29             extends 'AtteanX::Endpoint::Error';
30 2     2   393 use Types::Standard qw(Int);
  2         2  
  2         8  
31 2     2   537 use namespace::clean;
  2         3  
  2         7  
32              
33             has 'code' => (is => 'ro', isa => Int, default => 400);
34             }
35              
36             package AtteanX::Endpoint::ServerError {
37 2     2   825 use Moo;
  2         2  
  2         14  
38             extends 'AtteanX::Endpoint::Error';
39 2     2   368 use Types::Standard qw(Int);
  2         3  
  2         7  
40 2     2   541 use namespace::clean;
  2         2  
  2         7  
41              
42             has 'code' => (is => 'ro', isa => Int, default => 500);
43             }
44              
45             package Plack::App::AtteanX::Endpoint 0.001 {
46 2     2   1001 use parent qw(Plack::Component);
  2         232  
  2         11  
47 2     2   12208 use Plack::Request;
  2         68944  
  2         351  
48            
49             sub configure {
50 0     0     my $self = shift;
51 0           $self->{config} = shift;
52 0           return $self;
53             }
54            
55             sub prepare_app {
56 0     0     my $self = shift;
57 0           my $config = $self->{config};
58 0           $self->{endpoint} = eval { AtteanX::Endpoint->new( $config ) };
  0            
59 0 0         if ($@) {
60 0           warn $@;
61             }
62             }
63              
64             sub call {
65 0     0     my($self, $env) = @_;
66 0           my $req = Plack::Request->new($env);
67 0 0         unless ($req->method =~ /^(GET|HEAD|POST)$/) {
68 0           return [ 405, [ 'Content-type', 'text/plain' ], [ 'Method not allowed' ] ];
69             }
70              
71 0           my $ep = $self->{endpoint};
72 0           my $resp = $ep->run( $req );
73 0           return $resp->finalize;
74             }
75             }
76              
77             =head1 NAME
78              
79             AtteanX::Endpoint - SPARQL 1.1 Protocol Endpoint
80              
81             =head1 VERSION
82              
83             This document describes AtteanX::Endpoint version 0.001
84              
85             =head1 SYNOPSIS
86              
87             use v5.14;
88             use Attean;
89              
90             =head1 DESCRIPTION
91              
92             The AtteanX::Endpoint class implements a PSGI SPARQL Protocol endpoint.
93              
94             =head1 ATTRIBUTES
95              
96             =over 4
97              
98             =item C<< planner >>
99              
100             =item C<< model >>
101              
102             =item C<< conf >>
103              
104             A hash reference containing configuration data for the endpoint. For example:
105              
106             {
107             endpoint => {
108             service_description => {
109             named_graphs => 1,
110             default => 1,
111             },
112             html => {
113             embed_images => 1,
114             image_width => 200,
115             resource_links => 1,
116             },
117             load_data => 0,
118             update => 0,
119             }
120             }
121              
122             =item C<< graph >>
123              
124             The L<Attean::API::IRI> of the graph in the model that represents the default graph.
125              
126             =back
127              
128             =head1 METHODS
129              
130             =over 4
131              
132             =cut
133              
134             package AtteanX::Endpoint {
135 2     2   2 use Moo;
  2         16  
136 2     2   967 use Attean;
  2         755417  
  2         12  
137 2     2   861 use TryCatch;
  2         1678119  
  2         9  
138 2     2   1655 use JSON;
  2         13707  
  2         7  
139 2     2   207 use Encode;
  2         2  
  2         162  
140 2     2   9 use Plack::Request;
  2         2  
  2         35  
141 2     2   737 use Plack::Response;
  2         5022  
  2         49  
142 2     2   11 use Scalar::Util qw(blessed refaddr);
  2         2  
  2         92  
143 2     2   9 use List::MoreUtils qw(any);
  2         2  
  2         21  
144 2     2   1511 use File::ShareDir qw(dist_dir);
  2         7861  
  2         165  
145 2     2   12 use HTTP::Negotiate qw(choose);
  2         2  
  2         83  
146 2     2   1050 use IO::Compress::Gzip qw(gzip);
  2         45337  
  2         122  
147 2     2   905 use HTML::HTML5::Parser;
  0            
  0            
148             use HTML::HTML5::Writer qw(DOCTYPE_XHTML_RDFA);
149             use Carp qw(croak);
150             use Types::Standard qw(ConsumerOf CodeRef HashRef ArrayRef Str Int);
151             # use IO::Handle;
152             # use Digest::MD5 qw(md5_base64);
153             # use XML::LibXML 1.70;
154             # use RDF::RDFa::Generator 0.102;
155             # use Hash::Merge::Simple qw/ merge /;
156             # use Fcntl qw(:flock SEEK_END);
157             use namespace::clean;
158              
159             our $VERSION = 0.001;
160              
161             with 'MooX::Log::Any';
162              
163             has 'planner' => (
164             is => 'ro',
165             isa => ConsumerOf['Attean::API::QueryPlanner'],
166             required => 1,
167             default => sub {
168             Attean::IDPQueryPlanner->new();
169             }
170             );
171             has 'model' => (is => 'ro', isa => ConsumerOf['Attean::API::Model'], required => 1);
172             has 'conf' => (is => 'ro', isa => HashRef, required => 1);
173             has 'graph' => (is => 'ro', isa => ConsumerOf['Attean::API::IRI'], required => 1);
174            
175             sub BUILDARGS {
176             my $class = shift;
177             my @params = @_;
178             my %args;
179             if (blessed($params[0]) and $params[0]->does('Attean::API::Model')) {
180             # ->new( $model, \%conf )
181             $args{ model } = shift @params;
182             $args{ conf } = shift @params;
183             $args{ graph } = Attean::IRI->new('http://example.org/graph');
184             } elsif (any { blessed($_) && $_->does('Attean::API::Model') } @params) {
185             # Assume the buildargs can be taken directly
186             return $class->SUPER::BUILDARGS(@params);
187             } else {
188             # ->new( \%conf )
189             my $conf = shift @params;
190             my $store_conf = $conf->{store};
191             my ($name, $file) = split(';', $store_conf, 2);
192             my $sclass = Attean->get_store($name)->new();
193             my $store = $sclass->new();
194             my $model = Attean::MutableQuadModel->new( store => $store );
195            
196             my $graph = Attean::IRI->new('http://example.org/graph');
197             if (defined($file) and length($file)) {
198             $graph = Attean::IRI->new('file://' . File::Spec->rel2abs($file));
199             open(my $fh, '<:encoding(UTF-8)', $file) or die $!;
200             #$self->log->debug("Parsing data from $file...");
201             my $pclass = Attean->get_parser( filename => $file ) // 'AtteanX::Parser::Turtle';
202             my $parser = $pclass->new(base => $graph);
203             my $iter = $parser->parse_iter_from_io($fh);
204             my $quads = $iter->as_quads($graph);
205             $model->add_iter($quads);
206             }
207            
208             $args{ model } = $model;
209             $args{ conf } = $conf;
210             $args{ graph } = $graph;
211             }
212            
213             return $class->SUPER::BUILDARGS(%args);
214             }
215              
216             =item C<< run ( $request ) >>
217              
218             Run the SPARQL request contained in the given C<< $request >> object and return
219             a response object.
220              
221             =cut
222            
223             sub run {
224             my $self = shift;
225             my $req = shift;
226             try {
227             return $self->_run($req, @_);
228             }
229             catch (AtteanX::Endpoint::Error $e) {
230             my $resp = Plack::Response->new;
231             my $code = $e->code;
232             my $status = $e->message;
233             my $error = {
234             title => $status,
235             describedby => $e->uri,
236             };
237             if (my $d = $e->details) {
238             $error->{details} = $d;
239             }
240             my @variants = (
241             ['text/plain', 0.98, 'text/plain'],
242             ['application/json-problem', 0.99, 'application/json-problem'],
243             );
244             my $headers = $req->headers;
245             my $stype = choose( \@variants, $headers ) || 'text/plain';
246             if ($stype eq 'application/json-problem') {
247             $resp->headers->content_type( 'application/json-problem' );
248             $resp->status($code);
249             my $content = encode_json($error);
250             $resp->body($content);
251             } else {
252             $resp->headers->content_type( 'text/plain' );
253             $resp->status($code);
254             my @messages = grep { defined($_) } @{ $error }{ qw(title detail) };
255             my $content = join("\n\n", $status, @messages);
256             $resp->body($content);
257             }
258             return $resp;
259             }
260             }
261            
262             sub _run {
263             my $self = shift;
264             my $req = shift;
265            
266             my $config = $self->{conf};
267             my $endpoint_path = $config->{endpoint}{endpoint_path} || '/sparql';
268             my $model = $self->{model};
269            
270             my $response = Plack::Response->new;
271              
272             our $VERSION;
273             my $server = "AtteanX::Endpoint/$VERSION";
274             $server .= " " . $response->headers->header('Server') if defined($response->headers->header('Server'));
275             $response->headers->header('Server' => $server);
276              
277             unless ($req->path eq $endpoint_path) {
278             my $content;
279             my $path = $req->path_info;
280             $path =~ s#^/##;
281             my $dir = $ENV{ATTEAN_ENDPOINT_SHAREDIR} || File::Spec->catdir((eval { dist_dir('AtteanX-Endpoint') } || 'share'), 'endpoint');
282             my $abs = File::Spec->rel2abs($dir);
283             my $file = File::Spec->catfile($abs, 'www', $path);
284             if (-r $file) {
285             open( my $fh, '<', $file ) or croak $!;
286             $response->status(200);
287             $content = $fh;
288             } else {
289             my $path = $req->path;
290             $response->status(404);
291             $content = <<"END";
292             <!DOCTYPE HTML PUBLIC "-//IETF//DTD HTML 2.0//EN">\n<html><head>\n<title>404 Not Found</title>\n</head><body>\n
293             <h1>Not Found</h1>\n<p>The requested URL $path was not found on this server.</p>\n</body></html>
294             END
295             }
296             $response->body($content);
297             return $response;
298             }
299            
300             my $headers = $req->headers;
301             my $type = $headers->header('Accept') || 'application/sparql-results+xml';
302             if (my $t = $req->param('media-type')) {
303             $type = $t;
304             $headers->header('Accept' => $type);
305             }
306            
307             my $ae = $req->headers->header('Accept-Encoding') || '';
308            
309             my $sparql;
310             my $content;
311             my $ct = $req->header('Content-type');
312             if ($req->method !~ /^(GET|POST)$/i) {
313             my $method = uc($req->method);
314             $content = "Unexpected method $method (expecting GET or POST)";
315             $self->log_error( $req, $content );
316             $response->header('Allow' => 'GET, POST');
317             die AtteanX::Endpoint::ClientError->new(code => 405, message => 'Method not allowed', uri => 'http://id.kasei.us/rdf-endpoint/error/bad_http_method');
318             } elsif (defined($ct) and $ct eq 'application/sparql-query') {
319             $sparql = $req->content;
320             } elsif (defined($ct) and $ct eq 'application/sparql-update') {
321             if ($config->{endpoint}{update} and $req->method eq 'POST') {
322             $sparql = $req->content;
323             }
324             } elsif ($req->param('query')) {
325             my @sparql = $req->param('query');
326             if (scalar(@sparql) > 1) {
327             $content = "More than one query string submitted";
328             $self->log_error( $req, $content );
329             die AtteanX::Endpoint::ClientError->new(code => 400, message => 'Multiple query strings not allowed', uri => 'http://id.kasei.us/rdf-endpoint/error/multiple_queries');
330             } else {
331             $sparql = $sparql[0];
332             }
333             } elsif ($req->param('update')) {
334             my @sparql = $req->param('update');
335             if (scalar(@sparql) > 1) {
336             $content = "More than one update string submitted";
337             $self->log_error( $req, $content );
338             die AtteanX::Endpoint::ClientError->new(code => 400, message => 'Multiple update strings not allowed', uri => 'http://id.kasei.us/rdf-endpoint/error/multiple_updates');
339             }
340            
341             if ($config->{endpoint}{update} and $req->method eq 'POST') {
342             $sparql = $sparql[0];
343             } elsif ($req->method ne 'POST') {
344             my $method = $req->method;
345             $content = "Update operations must use POST";
346             $self->log_error( $req, $content );
347             $response->header('Allow' => 'POST');
348             die AtteanX::Endpoint::ClientError->new(code => 405, message => "$method Not Allowed for Update Operation", uri => 'http://id.kasei.us/rdf-endpoint/error/bad_http_method_update');
349             }
350             }
351            
352             if ($sparql) {
353             my %args;
354             $args{ update } = 1 if ($config->{endpoint}{update} and $req->method eq 'POST');
355             $args{ load_data } = 1 if ($config->{endpoint}{load_data});
356            
357             my $protocol_specifies_update_dataset = 0;
358             {
359             my @default = $req->param('default-graph-uri');
360             my @named = $req->param('named-graph-uri');
361             if (scalar(@default) or scalar(@named)) {
362             delete $args{ load_data };
363             # TODO: handle custom-dataset
364             $self->log->warn('custom query datasets not supported yet');
365             # $model = Attean::MutableQuadModel->new( store => Attean->get_store('Memory')->new() );
366             # foreach my $url (@named) {
367             # RDF::Trine::Parser->parse_url_into_model( $url, $model, context => iri($url) );
368             # }
369             # foreach my $url (@default) {
370             # RDF::Trine::Parser->parse_url_into_model( $url, $model );
371             # }
372             }
373             }
374            
375             {
376             my @default = $req->param('using-graph-uri');
377             my @named = $req->param('using-named-graph-uri');
378             if (scalar(@named) or scalar(@default)) {
379             $protocol_specifies_update_dataset = 1;
380             # TODO: handle custom-dataset
381             $self->log->warn('custom update datasets not supported yet');
382             # $model = RDF::Trine::Model::Dataset->new( $model );
383             # $model->push_dataset( default => \@default, named => \@named );
384             }
385             }
386            
387             # my $match = $headers->header('if-none-match') || '';
388             # my $etag = md5_base64( join('#', $self->run_tag, $model->etag, $type, $ae, $sparql) );
389             # if (length($match)) {
390             # if (defined($etag) and ($etag eq $match)) {
391             # $response->status(304);
392             # return $response;
393             # }
394             # }
395            
396             my $base = $req->base;
397             my $parser = Attean->get_parser('SPARQL')->new(base => $base);
398             $parser->update(1) if ($args{update});
399             my ($algebra) = eval { $args{update} ? $parser->parse_update($sparql, base => $base) : $parser->parse($sparql, base => $base) };
400             if ($@ or not($algebra)) {
401             my $error = $@ || 'Internal error';
402             $self->log_error( $req, $error );
403             my $eclass = ($error =~ /Syntax/) ? 'AtteanX::Endpoint::ClientError' : 'AtteanX::Endpoint::ServerError';
404             if ($req->method ne 'POST' and $error =~ /read-only queries/sm) {
405             $error = 'Updates must use a HTTP POST request.';
406             die $eclass->new(message => 'Updates must use a HTTP POST request', uri => 'http://id.kasei.us/rdf-endpoint/error/bad_http_method_update');
407             } else {
408             die $eclass->new(message => 'SPARQL query/update parse error', uri => 'http://id.kasei.us/rdf-endpoint/error/parse_error', details => { error => $error, sparql => $sparql });
409             }
410             } else {
411             $self->log_query( $req, $sparql );
412             # TODO: handle case where query specifies update dataset
413             # if ($protocol_specifies_update_dataset and $query->specifies_update_dataset) {
414             # my $method = $req->method;
415             # $content = "Update operations cannot specify a dataset in both the query and with protocol parameters";
416             # $self->log_error( $req, $content );
417             # die AtteanX::Endpoint::ClientError->new(code => 400, message => 'Multiple datasets specified for update', uri => 'http://id.kasei.us/rdf-endpoint/error/update_specifies_multiple_datasets');
418             # }
419             if ($self->log->is_trace) {
420             $self->log->trace("Algebra:\n" . $algebra->as_string);
421             }
422             my $graph = $self->graph;
423             my $default_graphs = [$graph];
424             my $planner = $self->planner;
425             if ($self->log->is_trace) {
426             $self->log->debug('Planning with default graphs:');
427             foreach my $g (@$default_graphs) {
428             $self->log->trace($g->as_string);
429             }
430             }
431             my $plan = $planner->plan_for_algebra($algebra, $model, $default_graphs);
432             if ($self->log->is_debug) {
433             $self->log->debug("Plan:\n" . $plan->as_string);
434             }
435             eval {
436             my $iter = $plan->evaluate($model);
437             $response->status(200);
438             my $sclass = Attean->negotiate_serializer(request_headers => $headers) // Attean->get_serializer('sparqlxml');
439             $self->log->debug("Serializer class: $sclass");
440             my $s = $sclass->new();
441             $content = $s->serialize_iter_to_bytes($iter);
442             my $stype = $s->canonical_media_type;
443             $response->headers->content_type($stype);
444             };
445             if ($@) {
446             my $error = $@;
447             $self->log->fatal($error);
448             die AtteanX::Endpoint::ServerError->new(code => 500, message => 'SPARQL query/update execution error', uri => 'http://id.kasei.us/rdf-endpoint/error/execution_error', details => { error => $@, sparql => $sparql });
449             }
450             }
451             } elsif ($req->method eq 'POST') {
452             $content = "POST without recognized query or update";
453             $self->log_error( $req, $content );
454             die AtteanX::Endpoint::ClientError->new(message => 'Missing SPARQL Query/Update String', uri => 'http://id.kasei.us/rdf-endpoint/error/missing_sparql_string');
455             } else {
456             my $stype = 'text/html';
457             my $dir = $ENV{ATTEAN_ENDPOINT_SHAREDIR} || File::Spec->catdir((eval { dist_dir('AtteanX-Endpoint') } || 'share'), 'endpoint');
458             my $template = File::Spec->catfile($dir, 'index.html');
459             my $parser = HTML::HTML5::Parser->new;
460             my $doc = $parser->parse_file( $template );
461             # my $gen = RDF::RDFa::Generator->new( style => 'HTML::Head');
462             # $gen->inject_document($doc, $sdmodel);
463            
464             my $writer = HTML::HTML5::Writer->new( markup => 'xhtml', doctype => DOCTYPE_XHTML_RDFA );
465             $content = encode_utf8( $writer->document($doc) );
466             $response->status(200);
467             $response->headers->content_type('text/html');
468             }
469            
470             $content = $response->body || $content;
471             my $length = 0;
472             my %ae = map { $_ => 1 } split(/\s*,\s*/, $ae);
473             if ($ae{'gzip'}) {
474             my $orig = length($content);
475             my ($rh, $wh);
476             pipe($rh, $wh);
477             if (ref($content)) {
478             gzip $content => $wh;
479             } else {
480             gzip \$content => $wh;
481             }
482             close($wh);
483             my $body = do { local($/) = undef; <$rh> };
484             $self->log->info("Compressed $orig bytes to " . length($body) . " bytes");
485             $length = bytes::length($body);
486             $response->headers->header('Content-Encoding' => 'gzip');
487             $response->headers->header('Content-Length' => $length);
488             $response->body( $body ) unless ($req->method eq 'HEAD');
489             } else {
490             local($/) = undef;
491             my $body = ref($content) ? <$content> : $content;
492             $length = bytes::length($body);
493             $response->headers->header('Content-Length' => $length);
494             $response->body( $body ) unless ($req->method eq 'HEAD');
495             }
496             return $response;
497             }
498            
499             =item C<< log_query ( $request, $sparql ) >>
500              
501             Log the C<< $sparql >> query string after having been parsed from the
502             C<< $request >> but before evaluation.
503              
504             =cut
505              
506             sub log_query {
507             my $self = shift;
508             my $req = shift;
509             my $message = shift;
510             $self->log->info("SPARQL query:\n" . $message);
511             $self->_log( $req, { level => 'info', message => $message } );
512             }
513              
514             =item C<< log_error ( $message ) >>
515              
516             =cut
517              
518             sub log_error {
519             my $self = shift;
520             my $req = shift;
521             my $message = shift;
522             $self->log->error($message);
523             $self->_log( $req, { level => 'error', message => $message } );
524             }
525              
526             sub _log {
527             my $self = shift;
528             my $req = shift;
529             my $data = shift;
530             my $logger = $req->logger || sub {};
531            
532             $logger->($data);
533             }
534              
535             sub _set_response_error {
536             my $self = shift;
537             my $req = shift;
538             my $resp = shift;
539             my $code = shift;
540             my $error = shift;
541             my @variants = (
542             ['text/plain', 1.0, 'text/plain'],
543             ['application/json-problem', 0.99, 'application/json-problem'],
544             );
545             my $headers = $req->headers;
546             my $stype = choose( \@variants, $headers ) || 'text/plain';
547             if ($stype eq 'application/json-problem') {
548             $resp->headers->content_type( 'application/json-problem' );
549             $resp->status($code);
550             my $content = encode_json($error);
551             $resp->body($content);
552             } else {
553             $resp->headers->content_type( 'text/plain' );
554             $resp->status($code);
555             my @messages = grep { defined($_) } @{ $error }{ qw(title detail) };
556             my $content = join("\n\n", @messages);
557             $resp->body($content);
558             }
559             return;
560             }
561             }
562              
563             1;
564              
565             __END__
566              
567             =back
568              
569             =head1 BUGS
570              
571             Please report any bugs or feature requests to through the GitHub web interface
572             at L<https://github.com/kasei/attean/issues>.
573              
574             =head1 SEE ALSO
575              
576             L<http://www.perlrdf.org/>
577              
578             =head1 AUTHOR
579              
580             Gregory Todd Williams C<< <gwilliams@cpan.org> >>
581              
582             =head1 COPYRIGHT
583              
584             Copyright (c) 2014 Gregory Todd Williams.
585             This program is free software; you can redistribute it and/or modify it under
586             the same terms as Perl itself.
587              
588             =cut