Geo-OGC-Service
view release on metacpan or search on metacpan
lib/Geo/OGC/Service.pm view on Meta::CPAN
Common: {
"CORS": {
"Allow-Origin" : "*",
"Allow-Headers" : "Content-Type, X-Requested-With"
},
"Content-Type": "text/xml; charset=utf-8",
"TARGET_NAMESPACE": "http://ogr.maptools.org/"
},
WFS: {
"resource": "http://$HTTP_HOST/WFS",
"version": "1.1.0",
"TARGET_NAMESPACE": "http://ogr.maptools.org/",
"PREFIX": "ogr",
"Transaction": "Insert,Update,Delete",
"FeatureTypeList": [
{
}
]
},
"WMS": {
"resource": "http://$HTTP_HOST/WMS"
},
"TMS": {
"resource": "http://$HTTP_HOST/TMS"
},
"WMTS": {
"resource": "http://$HTTP_HOST/WMTS"
},
"TileSets": [
],
"BoundingBox3857": {
"SRS": "EPSG:3857",
"minx": 2399767,
"miny": 8645741,
"maxx": 2473612,
"maxy": 8688005
}
}
The keys and structure of this file depend on the type of the
service(s) you are setting up. "CORS" is the only one that is
recognized by this module. "CORS" is either a string denoting the
allowed origin or a hash of "Allow-Origin", "Allow-Methods",
"Allow-Headers", and "Max-Age".
$HTTP_HOST and $SCRIPT_NAME are replaced in runtime to the HTTP_HOST
and SCRIPT_NAME values respectively in the environment given by Plack.
=head2 EXPORT
None by default.
=head2 METHODS
=cut
package Geo::OGC::Service;
use 5.010000; # say // and //=
use Carp;
use Modern::Perl;
use Encode qw(decode encode);
use Plack::Request;
use Plack::Builder;
use JSON;
use XML::LibXML;
use Clone 'clone';
use XML::LibXML::PrettyPrint;
use parent qw/Plack::Component/;
binmode STDERR, ":utf8";
our $VERSION = '0.14';
=pod
=head3 new
This creates a new Geo::OGC::Service app. You need to call it in the
psgi file as a class method with a named parameter hash reference. The
parameters are
config, services
config is required and it is a path to a file or a reference to an
anonymous hash containing the configuration for the services. The top
level keys are service names. If it is a file, it is expected to be
JSON. A configuration in a file may use top level Common hash and
references. A reference is a key,value pair, where the value begins
with 'ref:/' followed by a top level key name. The Common block is
cloned and references are solved and cloned into each service
configuration.
services is a reference to a hash of service names associated with
names of classes, which will process service requests. The key of the
hash is the requested service.
=cut
sub new {
my ($class, $parameters) = @_;
my $self = Plack::Component->new($parameters);
if (not ref $self->{config}) {
open my $fh, '<', $self->{config} or croak "Can't open file '$self->{config}': $!\n";
my @json = <$fh>;
close $fh;
$self->{config} = decode_json "@json";
expand_config($self->{config});
$self->{config}{debug} //= 0;
}
croak "A configuration file is needed." unless $self->{config};
croak "No services are defined." unless $self->{services};
return bless $self, $class;
}
sub expand_config {
my $config = shift;
my $had_ref;
do {
$had_ref = 0;
lib/Geo/OGC/Service.pm view on Meta::CPAN
return $config->{$service};
}
if (ref $config->{$config->{$service}}) {
return $config->{$config->{$service}};
}
return undef;
}
return $config;
}
=pod
=head3 error($responder, $msg)
Stream an error report as an XML message of type
<?xml version="1.0" encoding="UTF-8"?>
<ExceptionReport>
<Exception exceptionCode="$msg->{exceptionCode}" locator="$msg->{locator}">
<ExceptionText>$msg->{ExceptionText}<ExceptionText>
<Exception>
</ExceptionReport>
=cut
sub error {
my ($responder, $msg, $headers) = @_;
my $writer = Geo::OGC::Service::XMLWriter::Caching->new($headers);
$writer->open_element('ExceptionReport', { version => "1.0" });
my $attributes = { exceptionCode => $msg->{exceptionCode} };
my $content;
$content = [ ExceptionText => $msg->{ExceptionText} ] if exists $msg->{ExceptionText};
if (exists $msg->{locator}) {
$attributes->{locator} = $msg->{locator};
}
$writer->element('Exception', $attributes, $content);
$writer->close_element;
$writer->stream($responder);
}
=pod
=head1 Geo::OGC::Service::Common
A base type for all OGC services.
=head2 SYNOPSIS
$service->DescribeService($writer);
$service->Operation($writer, $operation, $protocols, $parameters);
=head2 DESCRIPTION
The class contains methods for common tasks for all services.
=head2 METHODS
=cut
package Geo::OGC::Service::Common;
use Modern::Perl;
=pod
=head3 CORS
Return the CORS headers as a list according to the configuration. CORS
may be in the configuration as a scalar or as a hash. A scalar value
is taken as a value for Access-Control-Allow-Origin. A hash may have
the following keys. (Note the missing prefix Access-Control-.)
key default value
----------------- ----------------------------------
Allow-Origin
Allow-Credentials
Expose-Headers
Max-Age 60*60*24
Allow-Methods GET,POST
Allow-Headers origin,x-requested-with,content-type
=cut
sub CORS {
my $self = shift;
# default CORS response headers:
my %default = (
'Allow-Origin' => '',
'Allow-Credentials' => '',
'Expose-Headers' => '',
'Max-Age' => 60*60*24,
'Allow-Methods' => 'GET,POST',
'Allow-Headers' => 'origin,x-requested-with,content-type'
);
# where CORS is in the configuration
my $config = $self->{config}{Common}{CORS} // $self->{config}{CORS};
my @cors;
if (ref $config eq 'HASH') {
for my $key (keys %default) {
my $val = $config->{$key} // $default{$key};
push @cors, ('Access-Control-'.$key => $val);
}
} else {
$default{'Allow-Origin'} = $config;
for my $key (keys %default) {
my $val = $default{$key};
push @cors, ('Access-Control-'.$key => $val);
}
}
return @cors;
}
=pod
=head3 DescribeService($writer)
Create ows:ServiceIdentification and ows:ServiceProvider elements.
=cut
sub DescribeService {
my ($self, $writer) = @_;
lib/Geo/OGC/Service.pm view on Meta::CPAN
=head1 Geo::OGC::Service::XMLWriter
A helper class for writing XML.
=head2 SYNOPSIS
my $writer = Geo::OGC::Service::XMLWriter::Caching->new();
$writer->open_element(
'wfs:WFS_Capabilities',
{ 'xmlns:gml' => "http://www.opengis.net/gml" });
$writer->element('ows:ServiceProvider',
[['ows:ProviderName'],
['ows:ProviderSite', {'xlink:type'=>"simple", 'xlink:href'=>""}],
['ows:ServiceContact']]);
$writer->close_element;
$writer->stream($responder);
or
my $writer = Geo::OGC::Service::XMLWriter::Streaming->new($responder);
$writer->prolog;
$writer->open_element('MyXML');
while (a long time) {
$writer->element('MyElement');
}
$writer->close_element;
# $writer is closed when it goes out of scope
=head2 DESCRIPTION
The classes Geo::OGC::Service::XMLWriter (abstract),
Geo::OGC::Service::XMLWriter::Streaming (concrete), and
Geo::OGC::Service::XMLWriter::Caching (concrete) are provided as a
convenience for writing XML to the client.
The element method has the syntax
$writer->element($tag[, $attributes][, $content])
or
$writer->element($element)
where $element is a reference to an array [$tag[, $attributes][,
$content]].
$attributes is a reference to a hash
$content is nothing, undef, '/>', plain content (string), an element
(as above), a list of elements, or a reference to a list of
elements. If there is no $content or $content is undef, a self-closing
tag is written. If $content is '/>' a closing tag is written.
Setting $tag to 0 or 1, allows writing plain content.
If $attribute{$key} is undefined the attribute is not written at all.
=cut
package Geo::OGC::Service::XMLWriter;
use Modern::Perl;
use Encode qw(decode encode is_utf8);
use Carp;
sub element {
my $self = shift;
my $tag = shift;
return unless defined $tag;
if (ref($tag) eq 'ARRAY') {
for my $element ($tag, @_) {
$self->element(@$element);
}
return;
}
my $attributes;
$attributes = shift if @_ and ref($_[0]) eq 'HASH';
if (@_ && defined($_[0]) && $_[0] eq '/>') {
$self->write("</$tag>");
return;
}
if ($tag =~ /^\d/) {
$self->write($_[0]);
return;
}
$self->write("<$tag");
if ($attributes) {
for my $a (keys %$attributes) {
my $attr = $attributes->{$a};
if (defined $attr) {
$attr = decode utf8 => $attr unless is_utf8($attr);
$self->write(" $a=\"$attr\"");
}
}
}
if (@_ == 0 || !defined($_[0])) {
$self->write(" />");
} else {
$self->write(">");
for my $element (@_) {
next unless defined($element);
if (ref $element eq 'ARRAY') {
$self->element(@$element);
} elsif (ref $element) {
croak ref($element)." can't be used as an XML element.";
} elsif ($element eq '>') {
} else {
if (is_utf8($element)) {
$self->write($element);
} else {
$self->write(decode utf8 => $element);
}
}
}
$self->write("</$tag>");
}
}
sub open_element {
my $self = shift;
my $element = shift;
my $attributes;
for my $x (@_) {
$attributes = $x, next if ref($x) eq 'HASH';
}
$self->write("<$element");
if ($attributes) {
for my $a (keys %$attributes) {
my $attr = $attributes->{$a};
if (defined $attr) {
$attr = decode utf8 => $attr unless is_utf8($attr);
$self->write(" $a=\"$attr\"");
}
}
}
$self->write(">");
$self->{open_element} = [] unless $self->{open_element};
push @{$self->{open_element}}, $element;
}
sub close_element {
my $self = shift;
my $element = pop @{$self->{open_element}};
$self->write("</$element>");
}
=pod
=head1 Geo::OGC::Service::XMLWriter::Streaming
A helper class for writing XML into a stream.
=head2 SYNOPSIS
my $w = Geo::OGC::Service::XMLWriter::Streaming($responder, $headers, $declaration);
Using $w as XMLWriter sets writer, which is obtained from $responder,
to write XML. The writer is closed when $w is destroyed.
$headers and $declaration are optional. The defaults are
'Content-Type' => 'text/xml; charset=utf-8' and '<?xml version="1.0"
encoding="UTF-8"?>'.
=cut
package Geo::OGC::Service::XMLWriter::Streaming;
use Modern::Perl;
our @ISA = qw(Geo::OGC::Service::XMLWriter Plack::Util::Prototype); # can't use parent since Plack is not yet
sub new {
my ($class, $responder, $headers, $declaration) = @_;
my %headers;
if (ref $headers) {
%headers = @$headers;
} else {
$headers{'Content-Type'} = $headers;
}
$headers{'Content-Type'} //= 'text/xml; charset=utf-8';
my $self = $responder->([200, [%headers]]);
$self->{declaration} = $declaration //= '<?xml version="1.0" encoding="UTF-8"?>';
return bless $self, $class;
}
sub prolog {
my $self = shift;
$self->write($self->{declaration});
}
sub DESTROY {
my $self = shift;
$self->close;
}
=pod
=head1 Geo::OGC::Service::XMLWriter::Caching
A helper class for writing XML into a cache.
=head2 SYNOPSIS
my $w = Geo::OGC::Service::XMLWriter::Caching($headers, $declaration);
$w->stream($responder);
Using $w to produce XML caches the XML. The cached XML can be
written by a writer obtained from a $responder.
$headers and $declaration are optional. The defaults are as in
Geo::OGC::Service::XMLWriter::Streaming.
=cut
package Geo::OGC::Service::XMLWriter::Caching;
use Modern::Perl;
use Encode qw(decode encode is_utf8);
our @ISA = qw(Geo::OGC::Service::XMLWriter);
sub new {
my ($class, $headers, $declaration) = @_;
my %headers;
if (ref $headers) {
%headers = @$headers;
} else {
$headers{'Content-Type'} = $headers;
}
$headers{'Content-Type'} //= 'text/xml; charset=utf-8';
my $self = {
cache => [],
headers => \%headers,
declaration => $declaration //= '<?xml version="1.0" encoding="UTF-8"?>'
};
$self->{cache} = [];
return bless $self, $class;
}
sub write {
my $self = shift;
my $line = shift;
push @{$self->{cache}}, $line;
}
sub to_string {
my $self = shift;
my $xml = $self->{declaration};
for my $line (@{$self->{cache}}) {
$xml .= $line;
}
return $xml;
}
sub stream {
my $self = shift;
my $responder = shift;
my $debug = shift;
my $writer = $responder->([200, [ %{$self->{headers}} ]]);
$writer->write($self->{declaration});
my $xml = '';
for my $line (@{$self->{cache}}) {
$writer->write(encode utf8 => $line);
$xml .= $line if $debug;
}
$writer->close;
if ($debug) {
my $parser = XML::LibXML->new(no_blanks => 1);
my $pp = XML::LibXML::PrettyPrint->new(indent_string => " ");
my $dom = $parser->load_xml(string => $xml);
$pp->pretty_print($dom);
say STDERR $dom->toString;
}
}
1;
__END__
( run in 2.286 seconds using v1.01-cache-2.11-cpan-99c4e6809bf )