Initial release

Changes

@@ -0,0 +1,4 @@
+# Change file for Plack::App::unAPI
+
+0.1 2012-03-02
+    Initial release at CPAN

dist.ini

@@ -0,0 +1,21 @@
+name             = Plack-App-unAPI
+license          = Perl_5
+version          = 0.1
+copyright_year   = 2012
+author           = Jakob Voss
+copyright_holder = Jakob Voss
+
+[@Basic]
+[PkgVersion]
+[PodWeaver]
+[AutoPrereqs]
+[MinimumPerl]
+
+[PruneFiles]
+filename = dist.ini
+
+[AutoMetaResources]
+repository.github = user:nichtich
+bugtracker.github = user:nichtich
+
+[Test::Perl::Critic]

lib/Plack/App/unAPI.pm

@@ -0,0 +1,138 @@
+use strict;
+use warnings;
+package Plack::App::unAPI;
+#ABSTRACT: Serve via unAPI
+
+use 5.010;
+use parent qw(Plack::Component Exporter);
+use Plack::Request;
+
+our @EXPORT = qw(unAPI);
+
+## no critic
+sub unAPI(@) { __PACKAGE__->new(@_) }
+## use critic
+
+sub new {
+    my $proto = shift;
+    my $class = ref $proto || $proto;
+
+    my $self = bless {@_}, $class;
+
+    foreach (keys %$self) {
+        my ($app, $type, %about) = @{$self->{$_}};
+        $self->{$_} = { app => $app, type => $type, %about };
+    }
+
+    $self;
+}
+
+sub call {
+    my ($self, $env) = @_;
+    my $req    = Plack::Request->new($env);
+    my $format = $req->param('format') // '';
+    my $id     = $req->param('id') // '';
+
+    # here we could first lookup the resource at the server
+    # and sent 404 if no known format was specified
+
+    if ($format eq '' or $id eq '') {
+        return $self->formats($id);
+    }
+
+    my $app = $self->{$format}->{app};
+
+    if (!$app) {
+        my $res = $self->formats($id);
+        $res->[0] = 406; # Not Acceptable
+        return $res;
+    }
+
+    $app->( $env ); # we don't check response type and code by now
+}
+
+sub formats {
+    my ($self, $id) = @_;
+
+    my $status = 300; # Multiple Choices
+    my $type   = 'application/xml; charset: utf-8';
+    my @xml    = $id eq '' ?  '<formats>' 
+               : "<formats id=\"" . _xmlescape($id) . "\">";
+
+    while (my ($name, $format) = each %$self) {
+        my $line = "<format name=\"$name\" type=\"".$format->{type}."\"";
+        if ( $format->{docs} ) {
+            push @xml, "$line docs=\"" . _xmlescape($format->{docs}) . '" />';
+        } else {
+            push @xml, "$line />"
+        }
+    }
+
+    return [ $status, [ 'Content-Type' => $type ],
+        [ join "\n", '<?xml version="1.0" encoding="UTF-8"?>', @xml, '</formats>' ] ];
+}
+
+sub _xmlescape {
+    my $xml = shift;
+    if ($xml =~ /[\&\<\>"]/) {
+        $xml =~ s/\&/\&amp\;/g;
+        $xml =~ s/\</\&lt\;/g;
+        $xml =~ s/\>/\&gt\;/g;
+        $xml =~ s/"/\&quot\;/g;
+    }
+    return $xml;
+}
+
+1;
+
+=head1 DESCRIPTION
+
+This implements an unAPI server as PSGI application. unAPI is a tiny HTTP API
+to query discretely identified objects in different formats. See
+L<http://unapi.info> for details.
+
+=head1 SYNOPSIS
+
+    use Plack::App::unAPI;
+
+    my $app1 = sub { ... };
+    my $app2 = sub { ... };
+    my $app3 = sub { ... };
+
+    unAPI
+        json => [ $app1 => 'application/javascript' ],
+        xml  => [ $app2 => 'application/xml' ],
+        txt  => [ $app3 => 'text/plain', docs => 'http://example.com' ];
+
+To run this script you can simply call C<plackup yourscript.psgi>.
+
+=method new ( %formats )
+
+To create an new object you must provide a list of mappings between format
+names and PSGI applications to serve requests for the particular format. Each
+application is wrapped in an array reference, followed by its MIME type and
+optional information fields about the format. So the general form is: 
+
+    format => [ $app => $type, %about ]
+
+The following information fields are supported:
+
+=over
+
+=item docs
+
+An URL of a document that describes the format
+
+=back 
+
+=method unAPI ( %formats )
+
+The C<unAPI> keyword as constructor alias is exported by default. To prevent
+exporting, include this module via C<use Plack::App::unAPI ();>.
+
+=method formats ( [$id] )
+
+Returns a PSGI response with status 300 (Multiple Choices) and an XML document
+that lists all formats.
+
+=cut

t/basic.t

@@ -0,0 +1,65 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Test;
+use HTTP::Request::Common;
+use Plack::App::unAPI;
+use Plack::Request;
+
+my $app1 = sub { [ 404, [ 'Content-Type' => 'application/xml' ], [ '<xml/>' ] ] };
+
+{
+    package MyApp;
+    use parent 'Plack::Component';
+
+    sub call {
+        my $req = Plack::Request->new($_[1]);
+        my $id = $req->param('id');
+        return [ $id ? 200 : 404, 
+            [ 'Content-Type' => 'text/plain' ], [ "ID: $id" ] ];
+    }
+};
+
+my $app2 = MyApp->new;
+
+my @xml = ( 
+    '<?xml version="1.0" encoding="UTF-8"?>',
+    '<format name="xml" type="application/xml" />',
+    '<format name="txt" type="text/plain" docs="http://example.com" />',
+    '</formats>' );
+
+my $app = unAPI(
+    xml  => [ $app1 => 'application/xml' ],
+    txt  => [ $app2 => 'text/plain', docs => 'http://example.com' ]
+);
+
+test_psgi $app, sub {
+    my ($cb, $res) = @_;
+
+    foreach ('/','/?format=xml') {
+        $res = $cb->(GET $_);
+        is( $res->code, 300, "Multiple Choices for $_" );
+        is_deeply(
+            [sort (split "\n", $res->content)],
+            [sort ('<formats>',@xml)], 'list formats without id'
+        );
+    }
+
+    $res = $cb->(GET "/?id=abc");
+    is( $res->code, 300, 'Multiple Choices' );
+    is_deeply(
+        [sort (split "\n", $res->content)],
+        [sort ('<formats id="abc">',@xml)], 'list formats with id'
+    );
+
+    $res = $cb->(GET "/?id=0&format=xml");
+    is( $res->code, 404, 'Not found (via format=xml)' );
+    is( $res->content, "<xml/>", "format=xml" );
+
+    $res = $cb->(GET "/?id=abc&format=txt");
+    is( $res->code, 200, 'Found (via format=txt)' );
+    is( $res->content, "ID: abc", "format=txt" );
+
+};
+
+done_testing;