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