credentials results from the CPAN

credentials

Geo-OGC-Service-WFS

view release on metacpan or search on metacpan

lib/Geo/OGC/Service/WFS.pm view on Meta::CPAN

    $writer->close_element;
}

=pod

=head3 DescribeFeatureType

Service the DescribeFeatureType request.

=cut

sub DescribeFeatureType {
    my ($self) = @_;

    my @typenames;
    for my $query (@{$self->{request}{queries}}) {
        push @typenames, split(/\s*,\s*/, $query->{typename});
    }

    unless (@typenames) {
        $self->error({ exceptionCode => 'MissingParameterValue',
                       locator => 'typeName' },
                     [$self->CORS]);
        return;
    }
    
    my %types;

    for my $name (@typenames) {
        eval {
            $types{$name} = $self->get_feature_type($name);
        };
        unless ($types{$name}) {
            $@ =~ s/ at \/.*//;
            $self->error({ exceptionCode => 'InvalidParameterValue',
                           locator => 'typeName',
                           ExceptionText => $@ },
                         [$self->CORS]);
            return;
        }
    }

    my $writer = Geo::OGC::Service::XMLWriter::Caching->new();
    
    $writer->open_element(schema => { 
        targetNamespace => $self->{config}{targetNamespace},
        xmlns => "http://www.w3.org/2001/XMLSchema",
        'xmlns:gml' => "http://schemas.opengis.net/gml",
        elementFormDefault => "qualified",
        attributeFormDefault => "unqualified" });
    
    $writer->element(import => { 
        namespace => "http://www.opengis.net/gml",
        schemaLocation => "http://schemas.opengis.net/gml/2.1.2/feature.xsd" });

    for my $name (sort keys %types) {
        my $type = $types{$name};

        # to do: geometry and primary key

        my ($pseudo_credentials) = pseudo_credentials($type);
        my @elements;
        for my $property (keys %{$type->{columns}}) {

            next if $pseudo_credentials->{$property};

            my $minOccurs = 0;
            push @elements, ['element', { 
                name => $type->{columns}{$property}{out_name},
                type => $type->{columns}{$property}{out_type},
                minOccurs => "$minOccurs",
                maxOccurs => "1" 
            }];
            
        }
        $writer->element(
            'complexType', 
            {name => $type->{Name}.'Type'},
            ['complexContent', 
                ['extension', { base => 'gml:AbstractFeatureType' },
                    ['sequence', \@elements
                    ]]]
            );
        $writer->element(
            'element', { name => $type->{Name},
                         type => 'ogr:'.$type->{Name}.'Type',
                         substitutionGroup => 'gml:_Feature' } );
    }
    
    $writer->close_element();
    $writer->stream($self->{responder});
}

=pod

=head3 GetPropertyValue

Not yet implemented.

=cut

sub GetPropertyValue {
}

=pod

=head3 GetFeature

Service the GetFeature request. The response is generated with the GML
driver of GDAL using options TARGET_NAMESPACE, PREFIX, and
FORMAT. They are from the root of the configuration (TARGET_NAMESPACE
from FeatureType falling back to root) falling back to default ones
"http://www.opengis.net/wfs", "wfs", and "GML3.2". The content type of
the reponse is from configuration (root key 'Content-Type') falling
back to default "text/xml".

The "gml:id" attribute of the features is GDAL generated or from a
field defined by the key "gml:id" in the configuration (in the hash
with layer name falling back to FeatureType).

=cut

sub GetFeature {
    my ($self) = @_;

    my $query = $self->{request}{queries}[0]; # actually we should loop through all queries?
    my ($typename) = split(/\s*,\s*/, $query->{typename});
    
    unless ($typename) {
        $self->error({ exceptionCode => 'MissingParameterValue',
                       locator => 'typeName' },
                     [$self->CORS]);
        return;
    }

    my $type;
    eval {
        $type = $self->get_feature_type($typename);
    };
    unless ($type) {
        $@ =~ s/ at \/.*//;
        $self->error({ exceptionCode => 'InvalidParameterValue',
                       locator => 'typeName',
                       ExceptionText => $@ },
                     [$self->CORS]);
        return;
    }

    my $ds = Geo::OGR::Open($type->{DataSource});
    my $layer;
    my $epsg = $query->{EPSG} // $type->{SRID};

    my @bbox;
    my $bbox_crs;
    if ($query->{BBOX}) {
        @bbox = @{$query->{BBOX}};
        $bbox_crs = 4326; # WFS 1.1.0 14.3.3
        if (@bbox == 5) {
            $bbox_crs = epsg_number(pop @bbox);
        }
    }

    my $filter = filter2sql($query->{filter}, $type) // '';

    # pseudo_credentials: these fields are required to be in the filter and they are not included as attributes
    my ($pseudo_credentials, @pseudo_credentials) = pseudo_credentials($type);
    if (@pseudo_credentials) {
        # test for pseudo credentials in filter
        my $pat1 = "\\(\\(\"$pseudo_credentials[0]\" = '.+?'\\) AND \\(\"$pseudo_credentials[1]\" = '.+?'\\)\\)";
        my $pat2 = "\\(\\(\"$pseudo_credentials[1]\" = '.+?'\\) AND \\(\"$pseudo_credentials[0]\" = '.+?'\\)\\)";
        my $n = join(' and ', @pseudo_credentials);
        unless ($filter and ($filter =~ /$pat1/ or $filter =~ /$pat2/)) {
            $self->error({ exceptionCode => 'InvalidParameterValue',
                           locator => 'filter',
                           ExceptionText => "Not authorized. Please provide '$n' in filter." });
            return;
        }
    }

    my @columns = ("$type->{'gml:id'} as gml_id");
    # reverse the field names
    for my $column (keys %{$type->{columns}}) {
        next if $pseudo_credentials->{$column};
        my $name = $type->{columns}{$column}{out_name};
        next if $query->{properties} && not $query->{properties}{$name};
        
        $filter =~ s/$name/$column/g if $filter;
        push @columns, "\"$column\" as \"$name\"";
    }
    my $Geometry = $type->{GeometryColumn};
    push @columns, "ST_Transform($Geometry,$epsg) as geometryProperty";
    
    my $sql = "SELECT ".join(',',@columns)." FROM $type->{Table} WHERE ST_IsValid($Geometry)";
    
    if ($filter) {
        $filter =~ s/GeometryColumn/$Geometry/g;
        $sql .= " AND $filter";
    }
    
    if (@bbox) {
        my $bbox = join(",", @bbox);
        $sql .= " AND (ST_Transform($Geometry,$epsg) && ST_Transform(ST_MakeEnvelope($bbox,$bbox_crs),$epsg))";
    }
    
    print STDERR "$sql\n" if $self->{debug};
    eval {
        $layer = $ds->ExecuteSQL($sql);
    };
    unless ($layer) {
        say STDERR $sql,"\n",$@;
        $self->error({ exceptionCode => 'Error',
                       ExceptionText => 'Internal error' });
        return;
    }

    my $i = 0;
    my $count = min($query->{count}, $self->{config}{max_count}, 1000000);
    my $result_type = $query->{resulttype} // 'results'; # real data instead of number of features
    my ($content_type, $driver);

    # for GML creation options see http://www.gdal.org/drv_gml.html
    # for GeoJSON creation options see http://www.gdal.org/drv_geojson.html

    # the FORMAT, TARGET_NAMESPACE, and PREFIX need to be set for OpenLayers
    # the following has worked
    # OpenLayers 2: FORMAT (not set), TARGET_NAMESPACE (http://ogr.maptools.org/), and PREFIX (ogr)
    # OpenLayers 4: FORMAT (GML3), TARGET_NAMESPACE (http://www.opengis.net/gml), and PREFIX (ogr)

    # tweaked GML is for getting transactions to work with OpenLayers v4

    my %creation_options;
    $creation_options{FORMAT} = $self->{request}{outputformat} // $self->{config}{FORMAT} // $type->{FORMAT} // 'GML2';
    for my $format ($creation_options{FORMAT}) {
        # convert some known values to those understood by GDAL
        $format = $OutputFormats{$format} if $format && $OutputFormats{$format};
        if ($format =~ /GML/) {
            for my $key (@GDAL_GML_Creation_options) {
                next if $key eq 'FORMAT';
                next unless exists $type->{$key} || exists $self->{config}{$key};
                $creation_options{$key} = $type->{$key} // $self->{config}{$key};
            }
            $content_type = $self->{config}{'Content-Type'} // 'text/xml; charset=utf-8';
            $driver = Geo::OGR::Driver('GML');

lib/Geo/OGC/Service/WFS.pm view on Meta::CPAN

                }
            }
            unless ($pk_exists) {
                if ($self->{debug} > 3) {
                    say STDERR "$table->[3]: 'gml:id ($pk[0]) does not exist in the table";
                }
                %geometries = ();
            }
        } elsif ($self->{debug} > 3) {
            say STDERR "$table->[3] does not have single PK, maybe use gml:id in config?";
        }
        for my $geom (keys %geometries) {
            my $ok;
            my $sql = "select auth_name,auth_srid from $table->[2] ".
                "join spatial_ref_sys on spatial_ref_sys.srid=st_srid(\"$geom\") ".
                "limit 1";
            $sth = $dbh->prepare($sql);
            if ($sth) {
                my $rv = $sth->execute;
                if ($rv) {
                    my ($auth_name, $auth_srid) = $sth->fetchrow_array;
                    $auth_name //= 'undef';
                    $auth_srid //= 'undef';
                    $geometries{$geom} = [$auth_name, $auth_srid];
                    if ($auth_name eq 'EPSG' && $auth_srid) {
                        $ok = 1;
                    } elsif ($self->{debug} > 3) {
                        say STDERR "$table->[3]: auth of $geom is $auth_name:$auth_srid (is it empty?)";
                    }
                } elsif ($self->{debug} > 3) {
                    say STDERR "$table->[3]: no permission";
                }
            }
            delete $geometries{$geom} unless $ok;
        }
        unless (%geometries) {
            if ($self->{debug} > 2) {
                say STDERR "$table->[3]: is not readable with single integer pk and geometry column(s) with EPSG SRS";
            }
            next;
        }

        for my $geom (keys %geometries) {
            
            my $name = $table->[3].'.'.$geom;
            $name =~ s/ /_/g; # XML layer names can't have spaces

            my $feature_type = {
                Name => $name,
                Title => $name,
                Abstract => "Layer from $table->[1] in $table->[0] using column $geom.",
                DefaultSRS => $geometries{$geom}[0].":".$geometries{$geom}[1],
                SRID => $geometries{$geom}[1],
                DataSource => $ds,
                Table => $table->[2], # full quoted name with schema
                GeometryColumn => '"'.$geom.'"',
                columns => \%columns,
                'gml:id' => $pk[0],
                Operations => $type->{Operations}, # $self->{config}{Operations} is the default
                require_user => $type->{require_user} // $self->{config}{require_user}, # operation dependent?
                pseudo_credentials => $type->{pseudo_credentials},
                # to do: these in ows:WGS84BoundingBox, GetCapabilities
                #LowerCorner 
                #UpperCorner
            };
            for my $o (@GDAL_GML_Creation_options) {
                $feature_type->{$o} = $type->{$o} if exists $type->{$o};
            }

            my ($h, @c) = pseudo_credentials($feature_type);
            my $ok = 1;
            for my $c (@c) {
                unless ($feature_type->{columns}{$c}) {
                    carp "pseudo credential column '$c' not in table.\n";
                    $ok = 0;
                    next;
                }
            }
            next unless $ok;
            push @types, $feature_type;
        }
    }
    #print STDERR Dumper \@types;
    return \@types;
}

# return WFS request in a hash
# this function is written according to WFS 1.1.0 / 2.0.0
sub ogc_request {
    my ($node) = @_;
    my ($ns, $name) = parse_tag($node);
    if ($name eq 'GetCapabilities') {
        return { service => $node->getAttribute('service'), 
                 request => $name,
                 version => $node->getAttribute('version') };

    } elsif ($name eq 'DescribeFeatureType') {
        my $request = { service => $node->getAttribute('service'), 
                        request => $name,
                        version => $node->getAttribute('version') };
        $request->{queries} = [];
        for ($node = $node->firstChild; $node; $node = $node->nextSibling) {
            my ($ns, $name) = parse_tag($node);
            if ($name eq 'TypeName') {
                push @{$request->{queries}}, { typename => $node->textContent };
            }
        }
        return $request;

    } elsif ($name eq 'GetFeature') {
        my $request = { request => 'GetFeature' };
        for my $a (qw/service version resultType outputFormat count maxFeatures/) {
            my %map = (maxFeatures => 'count');
            my $key = $map{$a} // $a;
            my $b = $node->getAttribute($a);
            $request->{lc($key)} = $b if $b;
        }
        $request->{queries} = [];
        for ($node = $node->firstChild; $node; $node = $node->nextSibling) {
            push @{$request->{queries}}, ogc_request($node);
        }
        return $request;

    } elsif ($name eq 'Transaction') {
        my $request = { request => 'Transaction' };
        for my $a (qw/service version/) {
            my $b = $node->getAttribute($a);
            $request->{$a} = $b if $b;
        }
        for ($node = $node->firstChild; $node; $node = $node->nextSibling) {

lib/Geo/OGC/Service/WFS.pm view on Meta::CPAN

            }
            unless ($col) {
                say STDERR "Can't find column name for property '$name'.";
                next;
            }
            $set .= "$col = $val, ";
        }
        $set =~ s/, $//;
        my $where = $get_filter->($node, $type);
        say STDERR "Update: SET $set WHERE $where" if $self->{debug} > 1;
        push @{$dbisql{$dbi}{Update}{SQL}}, "UPDATE $type->{Table} SET $set WHERE $where";
        push @{$dbisql{$dbi}{Update}{type}}, $type;
    }
    for my $node (@{$self->{request}{Delete}}) {
        my ($type_name, $type, $dbi) = $get_type->($node->getAttribute('typeName'));
        next unless $type_name;
        my $where = $get_filter->($node, $type);
        say STDERR "Delete: $where" if $self->{debug} > 1;
        push @{$dbisql{$dbi}{Delete}{SQL}}, "DELETE FROM $type->{Table} WHERE $where";
        push @{$dbisql{$dbi}{Delete}{type}}, $type;
    }
    return \%dbisql;
}

# determine the EPSG number
sub epsg_number {
    my $str = shift;
    return undef unless $str;
    my ($epsg) = $str =~ /^EPSG:(\d+)$/;
    return $epsg if $epsg;
}

sub DataSource2dbi {
    my $DataSource = shift;
    my $dbi = $DataSource;
    $dbi =~ s/^pg/Pg/i;
    $dbi =~ s/ host/;host/;
    $dbi =~ s/ port/;port/;
    $dbi =~ s/ options/;options/;
    $dbi =~ s/user=//;
    $dbi =~ s/password=//;
    return 'dbi:'.$dbi;
}

sub split_to_listref {
    my $s = shift;
    return undef unless $s;
    return [split /\s*,\s*/, $s];
}

sub list2element {
    my ($tag, $list) = @_;
    my @element;
    my @t = split /\s*,\s*/, $list;
    for my $t (@t) {
        push @element, [$tag, $t];
    }
    return @element;
}

sub pseudo_credentials {
    my $type = shift;
    my $c = $type->{pseudo_credentials};
    return ({}) unless $c;
    my($c1,$c2) = $c =~ /(\w+),(\w+)/;
    return ({$c1 => 1,$c2 => 1},$c1,$c2);
}

sub min {
    my $retval = shift;
    for my $x (@_) {
        next unless defined $x;
        $retval = $x unless defined $retval;
        $retval = $x if $x < $retval;
    }
    return $retval;
}

1;
__END__

=head1 SEE ALSO

Discuss this module on the Geo-perl email list.

L<https://list.hut.fi/mailman/listinfo/geo-perl>

For the WFS standard see 

L<http://www.opengeospatial.org/standards/wfs>

=head1 REPOSITORY

L<https://github.com/ajolma/Geo-OGC-Service-WFS>

=head1 AUTHOR

Ari Jolma, E<lt>ari.jolma at gmail.comE<gt>

=head1 COPYRIGHT AND LICENSE

Copyright (C) 2015- by Ari Jolma

This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.22.0 or,
at your option, any later version of Perl 5 you may have available.

=cut

( run in 0.543 second using v1.01-cache-2.11-cpan-cdf2f3d4e48 )