File Coverage

blib/lib/Plack/App/unAPI.pm

Criterion	Covered	Total	%
statement	97	98	98.9
branch	25	28	89.2
condition	16	21	76.1
subroutine	19	19	100.0
pod	4	6	66.6
total	161	172	93.6

use strict;
package Plack::App::unAPI;
#ABSTRACT: Serve via unAPI
our $VERSION = '0.61'; #VERSION

use v5.10.1;

use parent 'Plack::Component';
use Plack::Util::Accessor qw(formats);

use Plack::Request;
use Carp;

sub prepare_app {
    my ($self) = @_;
    $self->_trigger_formats( $self->formats );
}

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

    my $req    = Plack::Request->new($env);
    my $format = $req->param('format') // '';
    my $id     = $req->param('id') // '';

    # TODO: here we could first lookup the resource at the server
    # and sent 404 if no known format was specified
    # return 404 unless $self->available_formats($id);

    return $self->formats_as_psgi($id)
        if $format eq '' or $format eq '_';

    my $route = $self->formats->{$format};
    if ( !$route || !$route->{app} ) {
        my $res = $self->formats_as_psgi($id);
        $res->[0] = 406; # Not Acceptable
        return $res;
    }

    return $self->formats_as_psgi('')
        if $id eq '' and !($route->{always} // $self->formats->{_}->{always});

    my $res = eval { $route->{app}->($env) };
    my $error = $@;

    if ($error) {
        $error = "Internal crash with format=$format and id=$id: $error";
    } elsif (!_is_psgi_response($res)) {
        # we may also check response type...
        $error = "No PSGI response for format=$format and id=$id";
    }

    if ($error) { # TODO: catch only on request
        return [ 500, [ 'Content-Type' => 'text/plain' ], [ $error ] ];
    }

    $res;
}

# can return a subset of formats for some identifiers in a subclass
sub available_formats {
    my ($self, $id) = @_;
    return keys %{$self->formats};
}

sub formats_as_psgi {
    my ($self, $id) = @_;

    my $formats = $self->formats;

    my $status = 300; # Multiple Choices
    my $type   = 'application/xml; charset: utf-8';
    my @xml    = '';

    push @xml, _xmltag(' ($id eq '' ? undef : $id ) ).">";

    foreach my $name (sort $self->available_formats($id)) {
        next if $name eq '_';
        push @xml, _xmltag('
                name => $name,
                type => $formats->{$name}->{type},
                docs => $formats->{$name}->{docs})." />";
    }

    push @xml, '';

    return [ $status, [ 'Content-Type' => $type ], [ join "\n", @xml] ];
}

# TODO: better force lookup functions to return full/partial PSGI???
sub _lookup2psgi {
    my ($method, $type) = @_;
    # TODO: error response in corresponding content type and more headers
    sub {
        my ($env) = @_;
        my $id      = Plack::Request->new($env)->param('id') // '';
        my $content = $method->( $id, $env );
        return defined $content
            ? [ 200, [ 'Content-Type' => $type ], [ $content ] ]
            : [ 404, [ 'Content-Type' => 'text/plain' ], [ 'not found' ] ];
    };
}

# convert [  $app => $type, %about ] to { type => $type, %about }
# convert         [  $type, %about ] to { type => $type, %about }
sub _trigger_formats { # TODO: make Plack::App::unAPI::Format
    my ($self, $formats) = @_;

    $self->{formats} = { };

    foreach my $name (grep { $_ ne '_' } keys %$formats) {
        my $spec = $formats->{$name};
        if (ref $spec eq 'ARRAY') {

            my ($app, $type, %about) = @$spec % 2 ? (undef,@$spec) : @$spec;
            croak "unAPI format required MIME type" unless $type;

            if (!$app) {
                my $lookup = do {
                    my $method = "format_$name";
                    if (!$self->can($method)) {
                        croak __PACKAGE__." must implement method $method";
                    }
                    sub { $self->$method(@_); };
                };

                $app = _lookup2psgi( $lookup, $type );
            }

            $self->{formats}->{$name} = { type => $type, %about, app => $app };
        } # TODO: keep { ... }
    }

    $self->{formats}->{_} = $formats->{_};
}


###### FUNCTIONS

use parent 'Exporter';
our @EXPORT = qw(unAPI wrAPI);

## no critic
sub unAPI(@) {
    Plack::App::unAPI->new( formats => { @_ } )->to_app;
}
## use critic

sub wrAPI {
    my ($code, $type, %about) = @_;

    my $app = _lookup2psgi( $code, $type );

    return [ $app => $type, %about ];
}

###### Utility

# checks whether PSGI conforms to PSGI specification
sub _is_psgi_response {
    my $res = shift;
    return (ref($res) and ref($res) eq 'ARRAY' and
        (@$res == 3 or @$res == 2) and
        $res->[0] =~ /^\d+$/ and $res->[0] >= 100 and
        ref $res->[1] and ref $res->[1] eq 'ARRAY');
}

sub _xmltag {
    my $name = shift;
    my %attr = @_;

    return $name . join '', map {
        my $val = $attr{$_};
        $val =~ s/\&/\&\;/g;
        $val =~ s/\
        $val =~ s/"/\"\;/g;
        " $_=\"$val\"";
    } grep { defined $attr{$_} }
      grep { state $n=0; ++$n % 2; } @_;
}

1;

__END__