mod_perl service providing JSON and XML flattened, fleshed pcrud search results

Signed-off-by: Mike Rylander <mrylander@gmail.com>

diff --git a/Open-ILS/src/perlmods/lib/OpenILS/WWW/FlatFielder.pm b/Open-ILS/src/perlmods/lib/OpenILS/WWW/FlatFielder.pm
new file mode 100644 (file)
index 0000000..6151bb7
--- /dev/null
+++ b/Open-ILS/src/perlmods/lib/OpenILS/WWW/FlatFielder.pm
@@ -0,0 +1,144 @@
+package OpenILS::WWW::FlatFielder;
+
+use strict;
+use warnings;
+
+use Apache2::Log;
+use Apache2::Const -compile => qw(
+    OK HTTP_NOT_ACCEPTABLE HTTP_INTERNAL_SERVER_ERROR :log
+);
+use XML::LibXML;
+use Text::Glob;
+use CGI qw(:all -utf8);
+
+use OpenSRF::Utils::JSON;
+use OpenSRF::AppSession;
+
+# BEGIN package globals
+
+# We'll probably never need this fanciness for autosuggest, but
+# you can add handlers for different requested content-types here, and
+# you can weight them to control what matches requests for things like
+# 'application/*'
+
+my $_output_handler_dispatch = {
+    "application/xml" => {
+        "prio" => 0,
+        "code" => sub {
+            my ($r, $data) = @_;
+            $r->content_type("application/xml; charset=utf-8");
+            print data_to_xml($data);
+            return Apache2::Const::OK;
+        }
+    },
+    "application/json" => {
+        "prio" => 1,
+        "code" => sub {
+            my ($r, $data) = @_;
+            $r->content_type("application/json; charset=utf-8");
+            print data_to_json($data);
+            return Apache2::Const::OK;
+        }
+    }
+};
+
+my @_output_handler_types = sort {
+    $_output_handler_dispatch->{$a}->{prio} <=>
+        $_output_handler_dispatch->{$b}->{prio}
+} keys %$_output_handler_dispatch;
+
+# END package globals
+
+sub data_to_xml {
+    my ($data) = @_;
+
+    my $dom = new XML::LibXML::Document("1.0", "UTF-8");
+    my $fs = $dom->createElement("FlatSearch");
+    $fs->setAttribute("hint", $args->{hint}) if $args->{hint};
+    $fs->setAttribute("identifier", $args->{id_field}) if $args->{id_field};
+    $fs->setAttribute("label", $args->{label_field}) if $args->{label_field};
+    $fs->setAttribute("FS_key", $args->{key}) if $args->{key};
+    $dom->setDocumentElement($fs);
+
+    for my $i (@{$$args{data}}) {
+        my $item = $dom->createElement("item");
+        for my $k (keys %$i) {
+            my $val = $dom->createElement($k);
+            $val->appendText($i->{$k});
+            $item->addChild($val);
+        }
+        $fs->addChild($item);
+    }
+
+    # XML::LibXML::Document::toString() returns an encoded byte string, which
+    # is why we don't need to binmode STDOUT, ':utf8'.
+    return $dom->toString();
+}
+
+sub data_to_json {
+    my ($args) = @_;
+
+    return OpenSRF::Utils::JSON->perl2JSON({
+        ($$args{hint} ? (hint => $$args{hint}) : ())
+        ($$args{identifier_field} ? (identifier => $$args{identifier_field}) : ())
+        ($$args{label_field} ? (label => $$args{label_field}) : ())
+        ($$args{key} ? (FS_key => $$args{key}) : ())
+        items => $$args{data}
+    });
+}
+
+# Given data and the Apache request object, this sub picks a sub from a
+# dispatch table based on the list of content-type encodings that the client
+# has indicated it will accept, and calls that sub, which will deliver
+# a response of appropriately encoded data.
+sub output_handler {
+    my ($r, $args) = @_;
+
+    my @types = split /,/, $r->headers_in->{Accept};
+
+    if ($$args{format}) {
+        unshift @types, $$args{format};
+    }
+
+    foreach my $media_range (@types) {
+        $media_range =~ s/;.+$//; # keep type, subtype. lose parameters.
+
+        my ($match) = grep {
+            Text::Glob::match_glob($media_range, $_)
+        } @_output_handler_types;
+
+        if ($match) {
+            return $_output_handler_dispatch->{$match}{code}->($r, $args);
+        }
+    }
+
+    return Apache2::Const::HTTP_NOT_ACCEPTABLE;
+}
+
+sub handler {
+    my $r = shift;
+    my $cgi = new CGI;
+
+    my %args;
+    my $args{format} = $cgi->param('format');
+    my $args{auth} = $cgi->param('ses');
+    my $args{hint} = $cgi->param('hint');
+    my $args{map} = OpenSRF::Utils::JSON->JSON2perl($cgi->param('map'));
+    my $args{where} = OpenSRF::Utils::JSON->JSON2perl($cgi->param('where'));
+    my $args{slo} = OpenSRF::Utils::JSON->JSON2perl($cgi->param('slo'));
+    my $args{key} = $cgi->param('key');
+    my $args{id_field} = $cgi->param('identifier');
+    my $args{label_field} = $cgi->param('label');
+
+    my $fielder = OpenSRF::AppSession->create('open-ils.fielder');
+    if ($map) {
+        $args{data} = $fielder->request('open-ils.fielder.flattened_search.atomic', $auth, $hint, $map, $where, $slo )->gather(1);
+    } else {
+        $args{data} = $fielder->request('open-ils.fielder.flattened_search.execute.atomic', $auth, $key, $where, $slo )->gather(1);
+    }
+
+    return output_handler( $r, \%args );
+
+}
+
+1;