File Coverage

blib/lib/Plack/App/SeeAlso.pm

Criterion	Covered	Total	%
statement	135	138	97.8
branch	21	28	75.0
condition	12	27	44.4
subroutine	31	31	100.0
pod	5	6	83.3
total	204	230	88.7

use strict;
use warnings;
package Plack::App::SeeAlso;
#ABSTRACT: SeeAlso Server as PSGI application
$Plack::App::SeeAlso::VERSION = '0.14';
use feature ':5.10';

use Plack::Request;
use Plack::Middleware::JSONP;
use Plack::Middleware::Static;
use Plack::App::unAPI qw(0.3);
use File::ShareDir qw(dist_dir);
use Plack::Util;
use Carp qw(croak);
use Scalar::Util qw(blessed reftype);
use Try::Tiny;
use JSON;
use Encode;

use parent 'Plack::Component';
use parent 'Exporter';

use SeeAlso::Format;

our @EXPORT = qw(push_seealso);
our @EXPORT_OK = qw(valid_seealso);

# properties of the server form OpenSearch Description
our @PROPERTIES; BEGIN { @PROPERTIES = qw(Query Stylesheet Formats Examples
    ShortName LongName Attribution Tags Contact Description Source
    DateModified Developer); }

use Plack::Util::Accessor (@PROPERTIES, 'base');

# browsers will more likely complain otherwise
use Plack::MIME;
Plack::MIME->add_type( '.xsl' => 'text/xsl' );

sub prepare_app {
    my $self = shift;
    return if $self->{app}; # already initialized

    # get default configuration from module variables
    $self->{Stylesheet} = 'seealso.xsl' unless exists $self->{Stylesheet};
    foreach (@PROPERTIES) {
        no strict 'refs';
        unless (exists $self->{$_}) {
            $self->{$_} = ${ref($self)."::$_"} // '';
        }
    }

    # validate and normalize configuration
    $self->{ShortName}   = sprintf '%.16s',   $self->{ShortName} // '';
    $self->{LongName}    = sprintf '%.48s',   $self->{LongName} // '' ;
    $self->{Description} = sprintf '%.1024s', $self->{Description} // '';
    $self->{Tags}        = sprintf '%.256s',  $self->{Tags} // '';
    $self->{Attribution} = sprintf '%.256s',  $self->{Attribution} // '';

    my $examples = $self->{Examples};
    $examples = [] unless ref $examples and reftype $examples eq 'ARRAY';
    $self->{Examples}    = [
        grep { ref $_ and reftype($_) eq 'HASH' and $_->{id} } @$examples
    ];

    # TODO: validate
    #   Stylesheet
    #   Formats
    #   Contact
    #   Source
    #   DateModified

    my %formats = %{ $self->{Formats} || { } };
    delete $formats{$_} for (qw(opensearchdescription seealso _));

    # TODO: extend known formats: csv, redirect
    # my $f = SeeAlso::Format->new( $_ )
    # seealso => [ $f->app => $f->type ]
    my $f = SeeAlso::Format->new('seealso');
    #my $f = SeeAlso::Format::seealso->new;#('seealso');

    # never return format list if format parameter given
    $formats{_} = { always => 1 };
    $formats{opensearchdescription} = [
        sub { $self->openSearchDescription(@_); } => 'application/opensearchdescription+xml',
    ];
    $formats{seealso} = [ $f->app( sub { $self->query(@_) } ), $f->type ];

    my $app = unAPI( %formats );
    $app = Plack::Middleware::JSONP->wrap($app);

    if ($self->{Stylesheet}) {
        $app = Plack::Middleware::Static->wrap( $app,
            path => qw{seealso\.(js|xsl|css)$},
            root => dist_dir('Plack-App-SeeAlso')
        );
    }

    $self->{app} = $app;
}

sub query {
    my ($self, $id) = @_;
    return ( $self->{Query} ? $self->{Query}->( $id ) : [$id,[]] );
}

sub call {
    my ($self, $env) = @_;

    my $result = $self->{app}->( $env );

    Plack::Util::response_cb( $result, sub {
        my $res = shift;
        return unless $res->[0] == 300;
        my $base = $self->{base} || Plack::Request->new($env)->base;
        my $xsl = $self->{Stylesheet};
        $xsl = '';
        $xsl .= "\n\n";
        $res->[2]->[0] =~ s{\?>\s+\n$xsl
    } ) if $self->{Stylesheet};

    return $result;
}

sub openSearchDescription {
    my ($self, $env) = @_;
    my $base = Plack::Request->new($env)->base;

    my @xml = '

    xmlns:dc="http://purl.org/dc/elements/1.1/"
    xmlns:dcterms="http://purl.org/dc/terms/"
    xmlns:seealso="http://ws.gbv.de/seealso/schema/">';

    my @prop = (
        map { $_ => $_ } qw(ShortName LongName Description Tags Contact Developer Attribution),
        DateModified => 'dcterms:modified',
        Source       => 'dc:source',
    );
    while (@prop) {
        my $field = shift @prop;
        my $tag   = shift @prop;
        my $value = $self->{$field} or next;
        push @xml, "  <$tag>"._xmlescape($value)."";
    }

    foreach (@{ $self->{Examples} || [] }) {
        my $id = _xmlescape($_->{id});
        push @xml, "";
    }

    my $tpl = $base . ($base =~ /\?/ ? '&' : '?')
            . "id={searchTerms}&format=seealso&callback={callback}";
    push @xml, "  ";

    push @xml, '','';

    return [ 200, [ "Content-Type"
            => 'application/opensearchdescription+xml; charset: utf-8' ],
        [ encode('utf8', join "\n", @xml) ]
    ];
}

sub push_seealso ($$$$) {
    my $resp = shift;
    push @{$resp->[1]}, (shift // '');
    push @{$resp->[2]}, (shift // '');
    push @{$resp->[3]}, (shift // '');
    $resp;
}

sub valid_seealso ($) {
    return SeeAlso::Format::valid(@_);
}

# Replace &, <, >, " by XML entities.
sub _xmlescape {
    my $xml = shift;
    if ($xml =~ /[\&\<\>"]/) {
        $xml =~ s/\&/\&\;/g;
        $xml =~ s/\
        $xml =~ s/\>/\>\;/g;
        $xml =~ s/"/\"\;/g;
    }
    return $xml;
}

1;

__END__