File Coverage

blib/lib/Plack/App/DAIA.pm

Criterion	Covered	Total	%
statement	22	24	91.6
branch			n/a
condition			n/a
subroutine	8	8	100.0
pod			n/a
total	30	32	93.7

use strict;
use warnings;
package Plack::App::DAIA;
#ABSTRACT: DAIA Server as Plack application
our $VERSION = '0.55'; #VERSION
use v5.10.1;

use parent 'Plack::Component';
use LWP::Simple qw(get);
use Encode;
use JSON;
use DAIA;
use Scalar::Util qw(blessed);
use Try::Tiny;
use Plack::Util::Accessor qw(xslt root warnings errors code idformat initialized safe);
use Plack::Middleware::Static;
use File::ShareDir qw(dist_dir);

use Carp;
use Plack::Request;

our %FORMATS  = DAIA->formats;

sub prepare_app {
    my $self = shift;
    return if $self->initialized;

    $self->init;
    $self->errors(0) unless defined $self->errors;
    $self->warnings(1) if $self->errors or not defined $self->warnings;
    $self->idformat( qr{^.*$} ) unless defined $self->idformat;
    $self->safe(1) unless defined $self->safe;
    $self->xslt('daia.xsl') if ($self->xslt // 1) eq 1;

    $self->{client} = Plack::Middleware::Static->new(
        path => qr{daia\.(xsl|css|xsd)$|xmlverbatim\.xsl$|icons/[a-z0-9_-]+\.png$},
        root => ($self->root || dist_dir('Plack-App-DAIA'))
    ) if $self->xslt;

    $self->initialized(1);
}

sub init {
    # initialization hook
}

sub call_client {
    my ($self, $req) = @_;

    if ( $self->{client} and $req->path ne '/' and !keys %{$req->parameters} ) {
        return $self->{client}->_handle_static( $req->env );
    } else {
        return;
    }
}

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

    my $id     = $req->param('id') // '';
    my $format = lc($req->param('format') // '');

    # serve parts of the XSLT client
    my $res = $self->call_client($req);
    return $res if $res;

    # validate identifier
    my ($invalid_id, $error, %parts) = ('',undef);
    if ( $id ne '' and ref $self->idformat ) {
        if ( ref $self->idformat eq 'Regexp' ) {
            if ( $id =~ $self->idformat ) {
                %parts = %+; # named capturing groups
            } else {
                $invalid_id = $id;
                $id = "";
            }
        }
    }

    if ( $self->warnings ) {
        if ( $invalid_id ne '' ) {
            $error = 'unknown identifier format';
        } elsif ( $id eq ''  ) {
            $error = 'please provide a document identifier';
        }
    }

    # retrieve and construct response
    my ($status, $daia) = (200, undef);
    if ( $error and $self->errors ) {
        $daia = DAIA::Response->new;
    } else {
        if ($self->safe) {
            try {
                $daia = $self->retrieve( $id, %parts );
            } catch {
                chomp($error = "request method died: $_");
                $status = 500;
            }
        } else {
            $daia = $self->retrieve( $id, %parts );
        }
        if (!$daia or !blessed $daia or !$daia->isa('DAIA::Response')) {
            $daia = DAIA::Response->new;
            $error = 'request method did not return a DAIA response'
                unless $error;
            $status = 500;
        }
    }

    if ( $error and $self->warnings ) {
        $daia->addMessage( 'en' => $error, errno => 400 );
    }

    $self->as_psgi( $status, $daia, $format, $req->param('callback') );
}

sub retrieve {
    my $self = shift;
    return $self->code ? $self->code->(@_) : undef;
}

sub as_psgi {
    my ($self, $status, $daia, $format, $callback) = @_;
    my ($content, $type);

    $type = $FORMATS{$format} unless $format eq 'xml';
    $content = $daia->serialize($format) if $type;

    if (!$content) {
        $type = "application/xml; charset=utf-8";
        if ( $self->warnings ) {
            if ( not $format ) {
                $daia->addMessage( 'en' => 'please provide an explicit parameter format=xml', 300 );
            } elsif ( $format ne 'xml' ) {
                $daia->addMessage( 'en' => 'unknown or unsupported format', 300 );
            }
        }
        $content = $daia->xml( header => 1, xmlns => 1, ( $self->xslt ? (xslt => $self->xslt) : () )  );
    } elsif ( $type =~ qr{^application/javascript} and ($callback || '') =~ /^[\w\.\[\]]+$/ ) {
        $content = "$callback($content)";
    }

    return [ $status, [ "Content-Type" => $type ], [ encode('utf8',$content) ] ];
}

1;

__END__