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

   1 package OpenILS::WWW::AutoSuggest;
   2
   3 use strict;
   4 use warnings;
   5
   6 use Apache2::Log;
   7 use Apache2::Const -compile => qw(
   8     OK HTTP_NOT_ACCEPTABLE HTTP_INTERNAL_SERVER_ERROR :log
   9 );
  10 use XML::LibXML;
  11 use Text::Glob;
  12 use CGI qw(:all -utf8);
  13 use Digest::MD5 qw(md5_hex);
  14
  15 use OpenSRF::Utils::JSON;
  16 use OpenILS::Utils::CStoreEditor qw/:funcs/;
  17 use OpenSRF::Utils::Logger qw/:level/;
  18 use OpenSRF::Utils::SettingsClient;
  19 use OpenSRF::Utils::Cache;
  20
  21 my $log = 'OpenSRF::Utils::Logger';
  22
  23 my $init_done = 0;
  24 my $cache;
  25 my $cache_timeout;
  26
  27 sub initialize {
  28
  29     my $conf = OpenSRF::Utils::SettingsClient->new;
  30
  31     $cache_timeout = $conf->config_value(
  32             "apps", "open-ils.search", "app_settings", "cache_timeout" ) || 300;
  33
  34 }
  35 sub child_init {
  36     $cache = OpenSRF::Utils::Cache->new('global');
  37     $init_done = 1;
  38 }
  39
  40 # BEGIN package globals
  41
  42 # We'll probably never need this fanciness for autosuggest, but
  43 # you can add handlers for different requested content-types here, and
  44 # you can weight them to control what matches requests for things like
  45 # 'application/*'
  46
  47 my $_output_handler_dispatch = {
  48     "application/xml" => {
  49         "prio" => 0,
  50         "code" => sub {
  51             my ($r, $data) = @_;
  52             $r->content_type("application/xml; charset=utf-8");
  53             print suggestions_to_xml($data);
  54             return Apache2::Const::OK;
  55         }
  56     },
  57     "application/json" => {
  58         "prio" => 1,
  59         "code" => sub {
  60             my ($r, $data) = @_;
  61             $r->content_type("application/json; charset=utf-8");
  62             print suggestions_to_json($data);
  63             return Apache2::Const::OK;
  64         }
  65     }
  66 };
  67
  68 my @_output_handler_types = sort {
  69     $_output_handler_dispatch->{$a}->{prio} <=>
  70         $_output_handler_dispatch->{$b}->{prio}
  71 } keys %$_output_handler_dispatch;
  72
  73 # END package globals
  74
  75 # The third argument to our stored procedure, metabib.suggest_browse_entries(),
  76 # is passed through directly to ts_headline() as the 'options' arugment.
  77 sub prepare_headline_opts {
  78     my ($css_prefix, $highlight_min, $highlight_max, $short_word_length) = @_;
  79
  80     $css_prefix =~ s/[^\w]//g;
  81
  82     my @parts = (
  83         qq{StartSel="<span class='$css_prefix'>"},
  84         "StopSel=</span>"
  85     );
  86
  87     push @parts, "MinWords=$highlight_min" if $highlight_min > 0;
  88     push @parts, "MaxWords=$highlight_max" if $highlight_max > 0;
  89     push @parts, "ShortWord=$short_word_length" if defined $short_word_length;
  90
  91     return join(", ", @parts);
  92 }
  93
  94 # Get raw autosuggest data (rows returned from a stored procedure) from the DB.
  95 sub get_suggestions {
  96     my $editor = shift;
  97     my $query = shift;
  98     my $search_class = shift;
  99     my $org_unit = shift;
 100     my $css_prefix = shift || 'oils_AS';
 101     my $highlight_min = int(shift || 0);
 102     my $highlight_max = int(shift || 0);
 103     my $short_word_length = shift;
 104
 105     my $normalization = int(shift || 14);   # 14 is not totally arbitrary.
 106     # See http://www.postgresql.org/docs/9.0/static/textsearch-controls.html#TEXTSEARCH-RANKING
 107
 108     my $limit = int(shift || 10);
 109
 110     $limit = 10 unless $limit > 0;
 111
 112     my $headline_opts = prepare_headline_opts(
 113         $css_prefix, $highlight_min, $highlight_max,
 114         defined $short_word_length ? int($short_word_length) : undef
 115     );
 116
 117     my $key = 'oils_AS_' . md5_hex(
 118         $query .
 119         $search_class .
 120         $org_unit .
 121         $css_prefix .
 122         $highlight_min .
 123         $highlight_max .
 124         $normalization .
 125         $limit .
 126         $short_word_length
 127     );
 128
 129     my $res = $cache->get_cache( $key );
 130
 131     return $res if ($res);
 132
 133     $res = $editor->json_query({
 134         "from" => [
 135             "metabib.suggest_browse_entries",
 136             $query,
 137             $search_class,
 138             $headline_opts,
 139             $org_unit,
 140             $limit,
 141             $normalization
 142         ]
 143     });
 144
 145     $cache->put_cache( $key => $res => $cache_timeout );
 146
 147     return $res;
 148 }
 149
 150 sub suggestions_to_xml {
 151     my ($suggestions) = @_;
 152
 153     my $dom = new XML::LibXML::Document("1.0", "UTF-8");
 154     my $as = $dom->createElement("as");
 155     $dom->setDocumentElement($as);
 156
 157     foreach (@$suggestions) {
 158         my $val = $dom->createElement("val");
 159         $val->setAttribute("term", $_->{value});
 160         $val->setAttribute("field", $_->{field});
 161         $val->appendText($_->{match});
 162         $as->addChild($val);
 163     }
 164
 165     # XML::LibXML::Document::toString() returns an encoded byte string, which
 166     # is why we don't need to binmode STDOUT, ':utf8'.
 167     return $dom->toString();
 168 }
 169
 170 sub suggestions_to_json {
 171     my ($suggestions) = @_;
 172
 173     return OpenSRF::Utils::JSON->perl2JSON({
 174         "val" => [
 175             map {
 176                 +{ term => $_->{value}, field => $_->{field},
 177                     match => $_->{match} }
 178             } @$suggestions
 179         ]
 180     });
 181 }
 182
 183 # Given data and the Apache request object, this sub picks a sub from a
 184 # dispatch table based on the list of content-type encodings that the client
 185 # has indicated it will accept, and calls that sub, which will deliver
 186 # a response of appropriately encoded data.
 187 sub output_handler {
 188     my ($r, $data) = @_;
 189
 190     foreach my $media_range (split /,/, $r->headers_in->{Accept}) {
 191         $media_range =~ s/;.+$//; # keep type, subtype. lose parameters.
 192
 193         my ($match) = grep {
 194             Text::Glob::match_glob($media_range, $_)
 195         } @_output_handler_types;
 196
 197         if ($match) {
 198             return $_output_handler_dispatch->{$match}{code}->($r, $data);
 199         }
 200     }
 201
 202     return Apache2::Const::HTTP_NOT_ACCEPTABLE;
 203 }
 204
 205 sub handler {
 206     child_init() unless $init_done;
 207
 208     my $r = shift;
 209     my $cgi = new CGI;
 210
 211     my $editor = new_editor;
 212     my $suggestions = get_suggestions(
 213         $editor,
 214         map { scalar($cgi->param($_)) } qw(
 215             query
 216             search_class
 217             org_unit
 218             css_prefix
 219             highlight_min
 220             highlight_max
 221             short_word_length
 222             normalization
 223             limit
 224         )
 225     );
 226
 227     if (not $suggestions) {
 228         $r->log->error(
 229             "get_suggestions() failed: " . $editor->die_event->{textcode}
 230         );
 231         return Apache2::Const::HTTP_INTERNAL_SERVER_ERROR;
 232     }
 233
 234     $editor->disconnect;
 235
 236     return output_handler($r, $suggestions);
 237 }
 238
 239 1;