File Coverage

blib/lib/Search/OpenSearch/Federated.pm

Criterion	Covered	Total	%
statement	31	33	93.9
branch			n/a
condition			n/a
subroutine	11	11	100.0
pod			n/a
total	42	44	95.4

package Search::OpenSearch::Federated;
use Moo;

our $VERSION = '0.007';

has 'debug' => ( is => 'rw' );
has 'fields' => (
    is      => 'rw',
    default => sub { [qw( title id author link summary tags modified )] }
);
has 'urls'             => ( is => 'rw' );
has 'total'            => ( is => 'rw' );
has 'facets'           => ( is => 'rw' );
has 'subtotals'        => ( is => 'rw' );
has 'timeout'          => ( is => 'rw' );
has 'normalize_scores' => ( is => 'rw' );
has 'version'          => ( is => 'rw', default => sub {$VERSION} );

use Carp;
use Data::Dump qw( dump );
use Parallel::Iterator qw( iterate_as_array );
use JSON;
use LWP::UserAgent;
use Scalar::Util qw( blessed );
use Search::Tools::XML;
use Data::Transformer;
use Normalize;

# we do not use WWW::OpenSearch because we need to pull out
# some non-standard data from the XML.
# we do use XML::Feed to parse XML responses.
use XML::Simple;
use XML::Feed;

my $OS_NS = 'http://a9.com/-/spec/opensearch/1.1/';

my $XMLer = Search::Tools::XML->new();

my $XML_ESCAPER = Data::Transformer->new(
    normal => sub { local ($_) = shift; $$_ = $XMLer->escape($$_); } );

sub search {
    my $self = shift;

    my $urls     = $self->{urls} or croak "no urls defined";
    my $num_urls = scalar @$urls;
    my @done     = iterate_as_array(
        sub {
            $self->_fetch( $_[1] );
        },
        $urls,
    );

    return $self->_aggregate( \@done );
}

sub _aggregate {
    my $self      = shift;
    my $responses = shift;
    my $results   = [];
    my $fields    = $self->fields;
    my $total     = 0;
    my %subtotals = ();
    my %facets    = ();

RESP: for my $resp (@$responses) {

        my $req_uri     = $resp->request->uri;
        my $resp_status = $resp->code;
        $self->debug
            and warn
            sprintf( "response for %s = %s\n", $req_uri, $resp_status );
        next RESP unless $resp_status =~ m/^2/;

        # temporary buffer to allow for normalizing scores
        my @resp_results  = ();
        my $highest_score = 0;

        if ( $resp->content_type eq 'application/json' ) {
            my $r = decode_json( $resp->content );
            if ( $r->{results} ) {
                @resp_results = @{ $r->{results} };
            }

            # must turn facets inside out in order
            # to aggregate counts correctly
            if ( $r->{facets} ) {
                for my $name ( keys %{ $r->{facets} } ) {
                    for my $facet ( @{ $r->{facets}->{$name} } ) {
                        $facets{$name}->{ $facet->{term} } += $facet->{count};
                    }
                }
            }
            $total += $r->{total} || 0;
            $subtotals{$req_uri} = $r->{total};
        }
        elsif ( $resp->content_type eq 'application/xml' ) {
            my $xml = $resp->content;

            #warn $xml;
            my $feed = XML::Feed->parse( \$xml );

            if ( !$feed ) {
                warn XML::Feed->errstr;
                next RESP;
            }

            #dump $feed;

            #
            # we must re-escape the XML content since the feed parser
            # and XML::Simple will escape values automatically
            #
            my @entries;
            for my $item ( $feed->entries ) {
                my $e = {};
                for my $f (@$fields) {
                    $e->{$f} = $item->$f;
                    if ( blessed( $e->{$f} ) ) {

                        #dump( $e->{$f} );
                        if ( $e->{$f}->isa('XML::Feed::Content') ) {
                            $e->{$f} = $XMLer->escape( $e->{$f}->body );
                        }
                        elsif ( $e->{$f}->isa('DateTime') ) {
                            $e->{$f} = $e->{$f}->epoch;
                        }
                    }
                    else {
                        $e->{$f} = $XMLer->escape( $e->{$f} );
                    }
                }

                #dump $e;
                my $content = $item->content;
                my $fields = XMLin( $content->body, NoAttr => 1 );

                #dump $fields;

                for my $f ( keys %$fields ) {
                    $e->{$f} = $fields->{$f};
                    if ( ref $e->{$f} ) {
                        $XML_ESCAPER->traverse( $e->{$f} );
                    }
                    else {
                        $e->{$f} = $XMLer->escape( $e->{$f} );
                    }
                }

                # massage some field names
                $e->{mtime} = delete $e->{modified};
                $e->{uri}   = delete $e->{id};

                #dump $content;
                #dump $e;
                push @entries, $e;

            }

            # facets require digging into the raw xml
            my $xml_feed = XMLin( $feed->as_xml, NoAttr => 1 );

            #dump($xml_feed);

            # must turn facets inside out in order
            # to aggregate counts correctly
            if ( $xml_feed->{category}->{sos}->{facets} ) {
                my $facet_feed = $xml_feed->{category}->{sos}->{facets};
                for my $name ( keys %$facet_feed ) {
                    if ( ref $facet_feed->{$name}->{$name} eq 'ARRAY' ) {
                        for my $facet ( @{ $facet_feed->{$name}->{$name} } ) {
                            $facets{$name}->{ $facet->{term} }
                                += $facet->{count};
                        }
                    }
                    elsif ( ref $facet_feed->{$name}->{$name} eq 'HASH' ) {
                        my $facet = $facet_feed->{$name}->{$name};
                        $facets{$name}->{ $facet->{term} } = $facet->{count};
                    }

                }
            }

            my $atom = $feed->{atom};
            my $this_total = $atom->get( $OS_NS, 'totalResults' );
            $total += $this_total;
            $subtotals{$req_uri} = $this_total;
            push @resp_results, @entries;
        }
        else {
            croak sprintf( "Unsupported response type '%s' for %s\n",
                scalar $resp->content_type, $req_uri );
        }

        # normalize scores
        if ( $self->normalize_scores ) {
            my $normalizer = Normalize->new( 'round_to' => 0.001 );
            my %normalized = ();
            my $i          = 0;

            # compute
            for my $r (@resp_results) {
                $normalized{ $i++ } = $r->{score};
            }
            $normalizer->normalize_to_max( \%normalized );

            # apply
            for my $idx ( keys %normalized ) {
                $resp_results[$idx]->{score} = ( $normalized{$idx} * 1000 );
            }
        }

        # aggregate
        push @$results, @resp_results;

    }

    # transform facets back into arrays of count/term pairs
    my %facets_norm;
    for my $name ( keys %facets ) {
        my @diads = ();
        for my $term ( keys %{ $facets{$name} } ) {
            push @diads, { term => $term, count => $facets{$name}->{$term} };
        }
        $facets_norm{$name} = [@diads];
    }
    $self->{facets}    = \%facets_norm;
    $self->{total}     = $total;
    $self->{subtotals} = \%subtotals;
    return [ sort { $b->{score} <=> $a->{score} } @$results ];
}

sub _fetch {
    my $self = shift;
    my $url  = shift or croak "url required";
    my $ua   = LWP::UserAgent->new();
    $ua->agent( 'sos-fedsearch ' . $VERSION );
    $ua->timeout( $self->{timeout} ) if $self->{timeout};

    my $response = $ua->get($url);

    $self->debug and warn "got response for $url: " . $response->status_line;
    return $response;
}

1;

__END__