Open-ILS/src/perlmods/lib/OpenILS/WWW/FlatFielder.pm

   1 package OpenILS::WWW::FlatFielder;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Apache2::Log;
   7 use Apache2::Const -compile => qw(
   8     OK HTTP_NOT_ACCEPTABLE HTTP_PAYMENT_REQUIRED HTTP_INTERNAL_SERVER_ERROR :log
   9 );
  10 use XML::LibXML;
  11 use XML::LibXSLT;
  12 use Text::Glob;
  13 use CGI qw(:all -utf8);
  14
  15 use OpenSRF::Utils::JSON;
  16 use OpenSRF::AppSession;
  17 use OpenSRF::Utils::SettingsClient;
  18
  19 use OpenILS::Application::AppUtils;
  20 my $U = 'OpenILS::Application::AppUtils';
  21
  22
  23 my $_parser = new XML::LibXML;
  24 my $_xslt = new XML::LibXSLT;
  25
  26 # BEGIN package globals
  27
  28 # We'll probably never need this fanciness for autosuggest, but
  29 # you can add handlers for different requested content-types here, and
  30 # you can weight them to control what matches requests for things like
  31 # 'application/*'
  32
  33
  34 sub html_ish_output {
  35     my ($r, $args, $xslt) = @_;
  36     $args->{'stylesheet'} =
  37         OpenSRF::Utils::SettingsClient->new->config_value(dirs => 'xsl') . '/' . $xslt;
  38     print data_to_xml($args);
  39     return Apache2::Const::OK;
  40 }
  41
  42 my $_output_handler_dispatch = {
  43     "text/csv" => {
  44         "prio" => 0,
  45         "code" => sub {
  46             my ($r, $args) = @_;
  47             $r->headers_out->set("Content-Disposition" => "attachment; filename=FlatSearch.csv");
  48             # Anecdotally, IE 8 needs name= here to provoke downloads, where
  49             # other browswers respect filename= in Content-Disposition.  Also,
  50             # we might want to make the filename choosable by CGI param later?
  51             # Or vary it by timestamp?
  52             $r->content_type('text/csv; name=FlatSearch.csv; charset=utf-8');
  53             print_data_as_csv($args, \*STDOUT);
  54             return Apache2::Const::OK;
  55         }
  56     },
  57     "text/html" => {
  58         "prio" => 0,
  59         "code" => sub {
  60             $_[0]->content_type("text/html; charset=utf-8");
  61             return html_ish_output( @_, 'FlatFielder2HTML.xsl' );
  62         }
  63     },
  64     "application/xml" => {
  65         "prio" => 0,
  66         "code" => sub {
  67             my ($r, $args) = @_;
  68             $r->content_type("application/xml; charset=utf-8");
  69             print data_to_xml($args);
  70             return Apache2::Const::OK;
  71         }
  72     },
  73     "application/json" => {
  74         "prio" => 1,
  75         "code" => sub {
  76             my ($r, $args) = @_;
  77             $r->content_type("application/json; charset=utf-8");
  78             print data_to_json($args);
  79             return Apache2::Const::OK;
  80         }
  81     }
  82 };
  83
  84 my @_output_handler_types = sort {
  85     $_output_handler_dispatch->{$a}->{prio} <=>
  86         $_output_handler_dispatch->{$b}->{prio}
  87 } keys %$_output_handler_dispatch;
  88
  89 # END package globals
  90
  91 =comment
  92
  93 <FlatSearch hint='foo' identifier='bar' label='Foo Bar' FS_key='ad1awe43a3a2a3ra32a23ra32ra23rar23a23r'>
  94   <row ordinal='1'>
  95     <column name='fiz'>YAY!</column>
  96     <column name='faz'>boooo</column>
  97   </row>
  98   <row ordinal='2'>
  99     <column name='fiz'>WHEEE!</column>
 100     <column name='faz'>noooo</column>
 101   </row>
 102 </FlatSearch>
 103
 104 =cut
 105
 106 sub data_to_xml {
 107     my ($args) = @_;
 108
 109     my $dom = new XML::LibXML::Document("1.0", "UTF-8");
 110     my $fs = $dom->createElement("FlatSearch");
 111     $fs->setAttribute("hint", $args->{hint}) if $args->{hint};
 112     $fs->setAttribute("identifier", $args->{id_field}) if $args->{id_field};
 113     $fs->setAttribute("label", $args->{label_field}) if $args->{label_field};
 114     $fs->setAttribute("FS_key", $args->{key}) if $args->{key};
 115     $dom->setDocumentElement($fs);
 116
 117     my @columns;
 118     my %column_labels;
 119     if (@{$args->{columns}}) {
 120         @columns = @{$args->{columns}};
 121         if (@{$args->{labels}}) {
 122             my @labels = @{$args->{labels}};
 123             $column_labels{$columns[$_]} = $labels[$_] for (0..$#labels);
 124         }
 125     }
 126
 127     my $rownum = 1;
 128     for my $i (@{$$args{data}}) {
 129         my $item = $dom->createElement("row");
 130         $item->setAttribute('ordinal', $rownum);
 131         $rownum++;
 132         @columns = keys %$i unless @columns;
 133         for my $k (@columns) {
 134             my $val = $dom->createElement('column');
 135             my $datum = $i->{$k};
 136             $datum = join(" ", @$datum) if ref $datum eq 'ARRAY';
 137
 138             $val->setAttribute('name', $column_labels{$k} || $k);
 139             $val->appendText($datum);
 140             $item->addChild($val);
 141         }
 142         $fs->addChild($item);
 143     }
 144
 145     # XML::LibXML::Document::toString() returns an encoded byte string, which
 146     # is why we don't need to binmode STDOUT, ':utf8'.
 147
 148     return $_xslt->parse_stylesheet(
 149         $_parser->parse_file( $$args{stylesheet} )
 150     )->transform(
 151         $dom
 152     )->toString if ($$args{stylesheet}); # configured transform, early return
 153
 154     return $dom->toString();
 155 }
 156
 157 sub print_data_as_csv {
 158     my ($args, $fh) = @_;
 159
 160     my @keys = sort keys %{ $$args{data}[0] };
 161     return unless @keys;
 162
 163     my $csv = new Text::CSV({ always_quote => 1, eol => "\r\n" });
 164
 165     $csv->print($fh, \@keys);
 166
 167     for my $row (@{$$args{data}}) {
 168         $csv->print($fh, [map { $row->{$_} } @keys]);
 169     }
 170 }
 171
 172 sub data_to_json {
 173     my ($args) = @_;
 174
 175     # Turns out we don't want the data structure you'd use to initialize an
 176     # itemfilereadstore or similar. We just want rows.
 177
 178 #    return OpenSRF::Utils::JSON->perl2JSON({
 179 #        ($$args{hint} ? (hint => $$args{hint}) : ()),
 180 #        ($$args{id_field} ? (identifier => $$args{id_field}) : ()),
 181 #        ($$args{label_field} ? (label => $$args{label_field}) : ()),
 182 #        ($$args{key} ? (FS_key => $$args{key}) : ()),
 183 #        items => $$args{data}
 184 #    });
 185     return OpenSRF::Utils::JSON->perl2JSON($args->{data});
 186 }
 187
 188 # Given data and the Apache request object, this sub picks a sub from a
 189 # dispatch table based on the list of content-type encodings that the client
 190 # has indicated it will accept, and calls that sub, which will deliver
 191 # a response of appropriately encoded data.
 192 sub output_handler {
 193     my ($r, $args) = @_;
 194
 195     my @types = split /,/, $r->headers_in->{Accept};
 196
 197     if ($$args{format}) {
 198         unshift @types, $$args{format};
 199     }
 200
 201     foreach my $media_range (@types) {
 202         $media_range =~ s/;.+$//; # keep type, subtype. lose parameters.
 203
 204         my ($match) = grep {
 205             Text::Glob::match_glob($media_range, $_)
 206         } @_output_handler_types;
 207
 208         if ($match) {
 209             return $_output_handler_dispatch->{$match}{code}->($r, $args);
 210         }
 211     }
 212
 213     return Apache2::Const::HTTP_NOT_ACCEPTABLE;
 214 }
 215
 216 sub handler {
 217     my $r = shift;
 218     my $cgi = new CGI;
 219
 220     my %args;
 221     $args{format} = $cgi->param('format');
 222     $args{auth} = $cgi->param('ses');
 223     $args{hint} = $cgi->param('hint');
 224     $args{map} = OpenSRF::Utils::JSON->JSON2perl($cgi->param('map'));
 225     $args{where} = OpenSRF::Utils::JSON->JSON2perl($cgi->param('where'));
 226     $args{slo} = OpenSRF::Utils::JSON->JSON2perl($cgi->param('slo'));
 227     $args{key} = $cgi->param('key');
 228     $args{id_field} = $cgi->param('identifier');
 229     $args{label_field} = $cgi->param('label');
 230     $args{columns} = [ $cgi->param('columns') ];
 231     $args{labels} = [ $cgi->param('labels') ];
 232
 233     my $fielder = OpenSRF::AppSession->create('open-ils.fielder');
 234     if ($args{map}) {
 235         $args{data} = $fielder->request(
 236             'open-ils.fielder.flattened_search.atomic',
 237             @args{qw/auth hint map where slo/}
 238         )->gather(1);
 239     } else {
 240         $args{data} = $fielder->request(
 241             'open-ils.fielder.flattened_search.execute.atomic',
 242             @args{qw/auth key where slo/}
 243         )->gather(1);
 244
 245         if (ref $args{data} and $args{data}[0] and
 246             $U->event_equals($args{data}[0], 'CACHE_MISS')) {
 247
 248             # You have to pay the cache! I kill me.
 249             return Apache2::Const::HTTP_PAYMENT_REQUIRED;
 250         }
 251     }
 252
 253     return output_handler( $r, \%args );
 254
 255 }
 256
 257 1;