WebPAC/Output/Estraier.pm

package WebPAC::Output::Estraier;

use warnings;
use strict;

use base qw/WebPAC::Common/;

use Search::Estraier;
use Text::Iconv;
use Data::Dumper;
use LWP;
use URI::Escape;

=head1 NAME

WebPAC::Output::Estraier - Create Hyper Estraier full text index

=head1 VERSION

Version 0.09

=cut

our $VERSION = '0.09';

=head1 SYNOPSIS

Create full text index using Hyper Estraier index from data with
type C<search>.

=head1 FUNCTIONS

=head2 new

Connect to Hyper Estraier index using HTTP

 my $est = new WebPAC::Output::Estraier(
        masterurl => 'http://localhost:1978/',
        user => 'admin',
        passwd => 'admin',
        database => 'demo',
        encoding => 'iso-8859-2',
        clean => 1,
 );

Options are:

=over 4

=item masterurl

URI to C<estmaster> node

=item user

C<estmaster> user with sufficient rights

=item passwd

password for user

=item database

name of database from which data comes

=item encoding

character encoding of C<data_structure> if it's differenet than C<ISO-8859-2>
(and it probably is). This encoding will be converted to C<UTF-8> for
Hyper Estraier.

=back

Name of database will be used to form URI of documents in index.

=cut

sub new {
        my $class = shift;
        my $self = {@_};
        bless($self, $class);

        my $log = $self->_get_logger;

        #$log->debug("self: ", sub { Dumper($self) });

        foreach my $p (qw/masterurl user passwd database/) {
                $log->logdie("need $p") unless ($self->{$p});
        }

        my $url = $self->{masterurl} . '/node/' . $self->{database};
        $self->{url} = $url;

        if ($self->{clean}) {
                $log->debug("nodedel $self->{database}");
                $self->master( action => 'nodedel', name => $self->{database} );
        } else {
                $log->debug("opening index $self->{url}");
        }

        my $nodes = $self->master( action => 'nodelist' );

        $log->debug("nodes found: $nodes");

        if ($nodes !~ m/^$self->{database}\t/sm) {
                $log->warn("creating index $url");
                $self->master(
                        action => 'nodeadd',
                        name => $self->{database},
                        label => "WebPAC $self->{database}",
                ) || $log->logdie("can't create Hyper Estraier node $self->{database}");
        }

        $self->{db} = Search::Estraier::Node->new( debug => 1 );
        $self->{db}->set_url($self->{url});
        $self->{db}->set_auth($self->{user}, $self->{passwd});

        my $encoding = $self->{encoding} || 'ISO-8859-2';
        $log->info("using index $self->{url} with encoding $encoding");

        $self->{iconv} = new Text::Iconv($encoding, 'UTF-8') or
                $log->logdie("can't create conversion from $encoding to UTF-8");

        $self ? return $self : return undef;
}


=head2 add

Adds one entry to database.

  $est->add(
        id => 42,
        ds => $ds,
        type => 'display',
        text => 'optional text from which snippet is created',
  );

This function will create  entries in index using following URI format:

  C<file:///type/database%20name/000>

Each tag in C<data_structure> with specified C<type> will create one
attribute and corresponding hidden text (used for search).

=cut

sub add {
        my $self = shift;

        my $args = {@_};

        my $log = $self->_get_logger;

        my $database = $self->{'database'} || $log->logconfess('no database in $self');
        $log->logconfess('need db in object') unless ($self->{'db'});

        foreach my $p (qw/id ds type/) {
                $log->logdie("need $p") unless ($args->{$p});
        }

        my $type = $args->{'type'};
        my $id = $args->{'id'};

        my $uri = "file:///$type/$database/$id";
        $log->debug("creating $uri");

        my $doc = Search::Estraier::Document->new;
        $doc->add_attr('@uri', $self->{'iconv'}->convert($uri) );

        $log->debug("ds = ", sub { Dumper($args->{'ds'}) } );

        # filter all tags which have type defined
        my @tags = grep {
                ref($args->{'ds'}->{$_}) eq 'HASH' && defined( $args->{'ds'}->{$_}->{$type} )
        } keys %{ $args->{'ds'} };

        $log->debug("tags = ", join(",", @tags));

        return unless (@tags);

        foreach my $tag (@tags) {

                my $vals = join(" ", @{ $args->{'ds'}->{$tag}->{$type} });

                $log->logconfess("no values for $tag/$type") unless ($vals);

                $vals = $self->{'iconv'}->convert( $vals ) or
                        $log->logdie("can't convert '$vals' to UTF-8");

                $doc->add_attr( $tag, $vals );
                $doc->add_hidden_text( $vals );
        }

        my $text = $args->{'text'};
        if ( $text ) {
                $text = $self->{'iconv'}->convert( $text ) or
                        $log->logdie("can't convert '$text' to UTF-8");
                $doc->add_text( $text );
        }

        $log->debug("adding ", sub { $doc->dump_draft } );
        $self->{'db'}->put_doc($doc) || $log->warn("can't add document $uri with draft " . $doc->dump_draft . " to node " . $self->{url} . " status: " . $self->{db}->status());

        return 1;
}

#
# REST parametars validation data
#

my $estraier_rest = {
        master => {
                userdel => [ qw/name/ ],
                nodelist => [],
                nodeadd => [ qw/name label/ ],
                nodedel => [ qw/name/ ],
        },
        node => {
                _set_link => [ qw/url label credit/ ],
        },
};

=head2 master

Issue administrative commands to C<estmaster> process and receive response
as array of lines

  my $nodelist = $est->master( action => 'nodelist' );

=cut

sub master {
        my $self = shift;

        my $args = {@_};
        my $log = $self->_get_logger;

        my $action = $args->{action} || $log->logconfess("no action specified");

        $log->logdie("action '$action' isn't supported") unless ($estraier_rest->{master}->{$action});

        $log->debug("master action: $action");

        return $self->estcall(
                validate => 'master',
                rest_url => $self->{masterurl} . '/master?action=' . $action ,
                action => $action,
                %{ $args },
        );
}

=head2 add_link

  $est->add_link(
        from => 'ps',
        to => 'webpac2',
        credit => 10000,
  );

=cut

sub add_link {
        my $self = shift;

        my $args = {@_};
        my $log = $self->_get_logger;

        my @labels = $self->master( action => 'nodelist' );

        $log->debug("got labels: ", join("|", @labels));

        @labels = grep(/^$args->{to}\t/, @labels);
        my $label = shift @labels;
        (undef,$label) = split(/\t/, $label) if ($label);

        if (! $label) {
                $log->warn("can't find label for $args->{to}, skipping link creaton");
                return;
        }

        $log->debug("using label $label for $args->{to}");

        return $self->estcall(
                validate => 'node',
                action => '_set_link',
                rest_url => $self->{masterurl} . '/node/' . $args->{from} . '/_set_link' ,
                url => $self->{masterurl} . '/node/' . $args->{to},
                label => $label,
                credit => $args->{credit},
        );
}

=head2 estcall

Workhourse which does actual calls to Hyper Estraier

  $self->estcall(
        rest_url => '/master?action=' . $action,
        validate => 'master',
        # ...
  );

C<rest_url> is relative URL to C<estmaster> and C<validate> is entry into
internal hash which will check if all parametars are available before
calling function.

=cut

sub estcall {
        my $self = shift;
        my $args = {@_};
        my $log = $self->_get_logger;

        $log->debug("estcall: ",Dumper($args));

        foreach my $p (qw/rest_url validate action/) {
                $log->die("ectcall needs $p parametar") unless ($args->{$p});
        }

        my $url = $args->{rest_url};
        my $del = '?';
        $del = '&' if ($url =~ m#\?#);

        my $url_args;

        foreach my $arg (@{ $estraier_rest->{ $args->{validate} }->{ $args->{action} } }) {
                $log->logdie("missing parametar $arg for action $args->{action}") unless ($args->{$arg});
                $url_args .= $del . $arg . '=' . uri_escape( $args->{$arg} );
                $del = '&';
        }

        $url .= $url_args if ($url_args);

        $log->debug("calling $url");

        my $res = $self->est_ua()->get($url);

        if ($res->is_success) {
                #$log->debug( $res->content );
                return split(/\n/, $res->content) if wantarray;
                return $res->content || 0E0;
        } else {
                $log->warn("unable to call $url: " . $res->status_line);
                return;
        }

}

=head2 est_ua

This is helper function to create C<LWP::UserAgent> object with Super User
priviledges

  my $ua = $self->est_ua( user => 'admin', passwd => 'admin' );

=cut

                                            
sub est_ua {
        my $self = shift;

        return $self->{_master_ua} if ($self->{_master_ua});

        {
                package AdminUserAgent;
                use base qw/LWP::UserAgent/;
                sub new {
                        my $self = LWP::UserAgent::new(@_);
                        $self->agent("webpac/$VERSION");
                        $self;
                }
                sub get_basic_credentials {
                        my($self, $realm, $uri) = @_;
                        return ($self->{user}, $self->{passwd});
                }
                sub set_basic_credentials {
                        my ($self, $user, $passwd) = @_;
                        $self->{user} = $user;
                        $self->{passwd} = $passwd;
                }
        };

        $self->{_master_ua} = AdminUserAgent->new( ) || sub {
                my $log = $self->_get_logger;
                $log->logdie("can't create LWP::UserAgent: $!");
        };

        $self->{_master_ua}->set_basic_credentials($self->{user}, $self->{passwd});

        return $self->{_master_ua};
}

=head1 AUTHOR

Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>

=head1 COPYRIGHT & LICENSE

Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1; # End of WebPAC::Output::Estraier
1	dpavlin	1	package WebPAC::Output::Estraier;
2
3			use warnings;
4			use strict;
5
6	dpavlin	74	use base qw/WebPAC::Common/;
7
8	dpavlin	343	use Search::Estraier;
9	dpavlin	74	use Text::Iconv;
10			use Data::Dumper;
11	dpavlin	211	use LWP;
12	dpavlin	210	use URI::Escape;
13	dpavlin	74
14	dpavlin	1	=head1 NAME
15
16	dpavlin	74	WebPAC::Output::Estraier - Create Hyper Estraier full text index
17	dpavlin	1
18			=head1 VERSION
19
20	dpavlin	343	Version 0.09
21	dpavlin	1
22			=cut
23
24	dpavlin	343	our $VERSION = '0.09';
25	dpavlin	1
26			=head1 SYNOPSIS
27
28	dpavlin	74	Create full text index using Hyper Estraier index from data with
29			type C<search>.
30	dpavlin	1
31	dpavlin	74	=head1 FUNCTIONS
32	dpavlin	1
33	dpavlin	74	=head2 new
34	dpavlin	1
35	dpavlin	74	Connect to Hyper Estraier index using HTTP
36	dpavlin	1
37	dpavlin	74	my $est = new WebPAC::Output::Estraier(
38	dpavlin	210	masterurl => 'http://localhost:1978/',
39	dpavlin	74	user => 'admin',
40			passwd => 'admin',
41			database => 'demo',
42			encoding => 'iso-8859-2',
43	dpavlin	307	clean => 1,
44	dpavlin	74	);
45	dpavlin	1
46	dpavlin	74	Options are:
47	dpavlin	1
48	dpavlin	74	=over 4
49	dpavlin	1
50	dpavlin	210	=item masterurl
51	dpavlin	1
52	dpavlin	74	URI to C<estmaster> node
53
54			=item user
55
56			C<estmaster> user with sufficient rights
57
58			=item passwd
59
60			password for user
61
62			=item database
63
64			name of database from which data comes
65
66			=item encoding
67
68			character encoding of C<data_structure> if it's differenet than C<ISO-8859-2>
69			(and it probably is). This encoding will be converted to C<UTF-8> for
70			Hyper Estraier.
71
72			=back
73
74			Name of database will be used to form URI of documents in index.
75
76	dpavlin	1	=cut
77
78	dpavlin	74	sub new {
79			my $class = shift;
80	dpavlin	343	my $self = {@_};
81			bless($self, $class);
82	dpavlin	74
83			my $log = $self->_get_logger;
84
85	dpavlin	211	#$log->debug("self: ", sub { Dumper($self) });
86	dpavlin	210
87			foreach my $p (qw/masterurl user passwd database/) {
88	dpavlin	74	$log->logdie("need $p") unless ($self->{$p});
89			}
90
91	dpavlin	210	my $url = $self->{masterurl} . '/node/' . $self->{database};
92			$self->{url} = $url;
93	dpavlin	74
94	dpavlin	307	if ($self->{clean}) {
95			$log->debug("nodedel $self->{database}");
96			$self->master( action => 'nodedel', name => $self->{database} );
97			} else {
98			$log->debug("opening index $self->{url}");
99			}
100	dpavlin	74
101	dpavlin	255	my $nodes = $self->master( action => 'nodelist' );
102	dpavlin	210
103	dpavlin	211	$log->debug("nodes found: $nodes");
104
105			if ($nodes !~ m/^$self->{database}\t/sm) {
106	dpavlin	301	$log->warn("creating index $url");
107	dpavlin	255	$self->master(
108	dpavlin	210	action => 'nodeadd',
109			name => $self->{database},
110			label => "WebPAC $self->{database}",
111			) \|\| $log->logdie("can't create Hyper Estraier node $self->{database}");
112			}
113
114	dpavlin	343	$self->{db} = Search::Estraier::Node->new( debug => 1 );
115			$self->{db}->set_url($self->{url});
116			$self->{db}->set_auth($self->{user}, $self->{passwd});
117	dpavlin	210
118	dpavlin	343	my $encoding = $self->{encoding} \|\| 'ISO-8859-2';
119	dpavlin	301	$log->info("using index $self->{url} with encoding $encoding");
120	dpavlin	74
121	dpavlin	343	$self->{iconv} = new Text::Iconv($encoding, 'UTF-8') or
122	dpavlin	85	$log->logdie("can't create conversion from $encoding to UTF-8");
123	dpavlin	74
124			$self ? return $self : return undef;
125	dpavlin	1	}
126
127	dpavlin	75
128	dpavlin	74	=head2 add
129	dpavlin	1
130	dpavlin	74	Adds one entry to database.
131
132			$est->add(
133			id => 42,
134			ds => $ds,
135			type => 'display',
136			text => 'optional text from which snippet is created',
137			);
138
139			This function will create entries in index using following URI format:
140
141	dpavlin	212	C<file:///type/database%20name/000>
142	dpavlin	74
143			Each tag in C<data_structure> with specified C<type> will create one
144			attribute and corresponding hidden text (used for search).
145
146	dpavlin	1	=cut
147
148	dpavlin	74	sub add {
149			my $self = shift;
150
151			my $args = {@_};
152
153			my $log = $self->_get_logger;
154
155			my $database = $self->{'database'} \|\| $log->logconfess('no database in $self');
156			$log->logconfess('need db in object') unless ($self->{'db'});
157
158			foreach my $p (qw/id ds type/) {
159			$log->logdie("need $p") unless ($args->{$p});
160			}
161
162			my $type = $args->{'type'};
163	dpavlin	213	my $id = $args->{'id'};
164	dpavlin	74
165	dpavlin	213	my $uri = "file:///$type/$database/$id";
166	dpavlin	74	$log->debug("creating $uri");
167
168	dpavlin	343	my $doc = Search::Estraier::Document->new;
169	dpavlin	75	$doc->add_attr('@uri', $self->{'iconv'}->convert($uri) );
170	dpavlin	74
171			$log->debug("ds = ", sub { Dumper($args->{'ds'}) } );
172
173			# filter all tags which have type defined
174			my @tags = grep {
175	dpavlin	113	ref($args->{'ds'}->{$_}) eq 'HASH' && defined( $args->{'ds'}->{$_}->{$type} )
176	dpavlin	74	} keys %{ $args->{'ds'} };
177
178			$log->debug("tags = ", join(",", @tags));
179
180			return unless (@tags);
181
182			foreach my $tag (@tags) {
183
184			my $vals = join(" ", @{ $args->{'ds'}->{$tag}->{$type} });
185
186			$log->logconfess("no values for $tag/$type") unless ($vals);
187
188	dpavlin	75	$vals = $self->{'iconv'}->convert( $vals ) or
189	dpavlin	85	$log->logdie("can't convert '$vals' to UTF-8");
190	dpavlin	75
191			$doc->add_attr( $tag, $vals );
192			$doc->add_hidden_text( $vals );
193	dpavlin	74	}
194
195			my $text = $args->{'text'};
196	dpavlin	75	if ( $text ) {
197			$text = $self->{'iconv'}->convert( $text ) or
198	dpavlin	85	$log->logdie("can't convert '$text' to UTF-8");
199	dpavlin	75	$doc->add_text( $text );
200			}
201	dpavlin	74
202			$log->debug("adding ", sub { $doc->dump_draft } );
203	dpavlin	319	$self->{'db'}->put_doc($doc) \|\| $log->warn("can't add document $uri with draft " . $doc->dump_draft . " to node " . $self->{url} . " status: " . $self->{db}->status());
204	dpavlin	74
205			return 1;
206	dpavlin	1	}
207
208	dpavlin	255	#
209			# REST parametars validation data
210			#
211	dpavlin	210
212	dpavlin	255	my $estraier_rest = {
213			master => {
214			userdel => [ qw/name/ ],
215			nodelist => [],
216			nodeadd => [ qw/name label/ ],
217			nodedel => [ qw/name/ ],
218			},
219			node => {
220			_set_link => [ qw/url label credit/ ],
221			},
222			};
223
224			=head2 master
225
226	dpavlin	210	Issue administrative commands to C<estmaster> process and receive response
227			as array of lines
228
229	dpavlin	255	my $nodelist = $est->master( action => 'nodelist' );
230	dpavlin	210
231			=cut
232
233	dpavlin	255	sub master {
234			my $self = shift;
235	dpavlin	210
236	dpavlin	255	my $args = {@_};
237			my $log = $self->_get_logger;
238	dpavlin	246
239	dpavlin	255	my $action = $args->{action} \|\| $log->logconfess("no action specified");
240	dpavlin	246
241	dpavlin	255	$log->logdie("action '$action' isn't supported") unless ($estraier_rest->{master}->{$action});
242	dpavlin	246
243	dpavlin	255	$log->debug("master action: $action");
244
245			return $self->estcall(
246			validate => 'master',
247			rest_url => $self->{masterurl} . '/master?action=' . $action ,
248			action => $action,
249	dpavlin	284	%{ $args },
250	dpavlin	255	);
251			}
252
253			=head2 add_link
254
255			$est->add_link(
256			from => 'ps',
257			to => 'webpac2',
258			credit => 10000,
259			);
260
261	dpavlin	246	=cut
262
263	dpavlin	255	sub add_link {
264	dpavlin	238	my $self = shift;
265
266	dpavlin	255	my $args = {@_};
267			my $log = $self->_get_logger;
268	dpavlin	238
269	dpavlin	255	my @labels = $self->master( action => 'nodelist' );
270	dpavlin	238
271	dpavlin	255	$log->debug("got labels: ", join("\|", @labels));
272	dpavlin	238
273	dpavlin	303	@labels = grep(/^$args->{to}\t/, @labels);
274			my $label = shift @labels;
275	dpavlin	307	(undef,$label) = split(/\t/, $label) if ($label);
276	dpavlin	255
277			if (! $label) {
278			$log->warn("can't find label for $args->{to}, skipping link creaton");
279			return;
280			}
281
282			$log->debug("using label $label for $args->{to}");
283
284			return $self->estcall(
285			validate => 'node',
286			action => '_set_link',
287			rest_url => $self->{masterurl} . '/node/' . $args->{from} . '/_set_link' ,
288			url => $self->{masterurl} . '/node/' . $args->{to},
289			label => $label,
290			credit => $args->{credit},
291			);
292	dpavlin	238	}
293
294	dpavlin	255	=head2 estcall
295
296			Workhourse which does actual calls to Hyper Estraier
297
298			$self->estcall(
299			rest_url => '/master?action=' . $action,
300			validate => 'master',
301			# ...
302			);
303
304			C<rest_url> is relative URL to C<estmaster> and C<validate> is entry into
305			internal hash which will check if all parametars are available before
306			calling function.
307
308			=cut
309
310			sub estcall {
311	dpavlin	210	my $self = shift;
312			my $args = {@_};
313			my $log = $self->_get_logger;
314
315	dpavlin	255	$log->debug("estcall: ",Dumper($args));
316	dpavlin	210
317	dpavlin	255	foreach my $p (qw/rest_url validate action/) {
318			$log->die("ectcall needs $p parametar") unless ($args->{$p});
319			}
320	dpavlin	210
321	dpavlin	255	my $url = $args->{rest_url};
322			my $del = '?';
323			$del = '&' if ($url =~ m#\?#);
324	dpavlin	210
325	dpavlin	255	my $url_args;
326	dpavlin	210
327	dpavlin	255	foreach my $arg (@{ $estraier_rest->{ $args->{validate} }->{ $args->{action} } }) {
328			$log->logdie("missing parametar $arg for action $args->{action}") unless ($args->{$arg});
329			$url_args .= $del . $arg . '=' . uri_escape( $args->{$arg} );
330			$del = '&';
331	dpavlin	210	}
332
333	dpavlin	284	$url .= $url_args if ($url_args);
334	dpavlin	255
335	dpavlin	210	$log->debug("calling $url");
336
337	dpavlin	238	my $res = $self->est_ua()->get($url);
338	dpavlin	210
339	dpavlin	211	if ($res->is_success) {
340			#$log->debug( $res->content );
341			return split(/\n/, $res->content) if wantarray;
342	dpavlin	255	return $res->content \|\| 0E0;
343	dpavlin	211	} else {
344			$log->warn("unable to call $url: " . $res->status_line);
345	dpavlin	210	return;
346			}
347
348			}
349
350	dpavlin	255	=head2 est_ua
351
352			This is helper function to create C<LWP::UserAgent> object with Super User
353			priviledges
354
355			my $ua = $self->est_ua( user => 'admin', passwd => 'admin' );
356
357			=cut
358
359	dpavlin	256
360
361	dpavlin	255	sub est_ua {
362			my $self = shift;
363
364			return $self->{_master_ua} if ($self->{_master_ua});
365
366	dpavlin	256	{
367			package AdminUserAgent;
368			use base qw/LWP::UserAgent/;
369			sub new {
370			my $self = LWP::UserAgent::new(@_);
371			$self->agent("webpac/$VERSION");
372			$self;
373			}
374			sub get_basic_credentials {
375			my($self, $realm, $uri) = @_;
376			return ($self->{user}, $self->{passwd});
377			}
378			sub set_basic_credentials {
379			my ($self, $user, $passwd) = @_;
380			$self->{user} = $user;
381			$self->{passwd} = $passwd;
382			}
383			};
384
385			$self->{_master_ua} = AdminUserAgent->new( ) \|\| sub {
386	dpavlin	255	my $log = $self->_get_logger;
387			$log->logdie("can't create LWP::UserAgent: $!");
388			};
389
390	dpavlin	256	$self->{_master_ua}->set_basic_credentials($self->{user}, $self->{passwd});
391	dpavlin	255
392			return $self->{_master_ua};
393			}
394
395	dpavlin	1	=head1 AUTHOR
396
397			Dobrica Pavlinusic, C<< <dpavlin@rot13.org> >>
398
399			=head1 COPYRIGHT & LICENSE
400
401			Copyright 2005 Dobrica Pavlinusic, All Rights Reserved.
402
403			This program is free software; you can redistribute it and/or modify it
404			under the same terms as Perl itself.
405
406			=cut
407
408			1; # End of WebPAC::Output::Estraier