WebService::Solr - Module to interface with the Solr (Lucene) webservice

    my $solr = WebService::Solr->new;
    $solr->add( @docs );

    my $response = $solr->search( $query );
    for my $doc ( $response->docs ) {
        print $doc->value_for( $id );
    }

    my $solr = WebService::Solr->new( $url,
        { agent => LWP::UserAgent->new( keep_alive => 1 ) }
    );

    # delete documents matching "title:bar" or uniqueId 13 or 42
    $solr->delete( {
        query => 'title:bar',
        id    => [ 13, 42 ],
    } );

    my $solr = WebService::Solr->new( undef, { autocommit => 0 } );
    $solr->add( $doc ); # will not automatically call commit()
    $solr->commit;

package WebService::Solr;

use Moose;

use Encode qw(encode);
use URI;
use LWP::UserAgent;
use WebService::Solr::Response;
use HTTP::Request;
use HTTP::Headers;
use XML::Easy::Element;
use XML::Easy::Content;
use XML::Easy::Text ();

has 'url' => (
    is      => 'ro',
    isa     => 'URI',
    default => sub { URI->new( 'http://localhost:8983/solr' ) }
);

has 'agent' =>
    ( is => 'ro', isa => 'Object', default => sub { LWP::UserAgent->new } );

has 'autocommit' => ( is => 'ro', isa => 'Bool', default => 1 );

has 'default_params' => (
    is         => 'ro',
    isa        => 'HashRef',
    auto_deref => 1,
    default    => sub { { wt => 'json' } }
);

our $VERSION = '0.14';

sub BUILDARGS {
    my ( $self, $url, $options ) = @_;
    $options ||= {};

    if ( $url ) {
        $options->{ url } = ref $url ? $url : URI->new( $url );
    }

    if ( exists $options->{ default_params } ) {
        $options->{ default_params }
            = { %{ $options->{ default_params } }, wt => 'json', };
    }

    return $options;
}

sub add {
    my ( $self, $doc, $params ) = @_;
    my @docs = ref $doc eq 'ARRAY' ? @$doc : ( $doc );

    my @elements = map {
        (   '',
            blessed $_
            ? $_->to_element
            : WebService::Solr::Document->new(
                ref $_ eq 'HASH' ? %$_ : @$_
                )->to_element
            )
    } @docs;

    $params ||= {};
    my $e
        = XML::Easy::Element->new( 'add', $params,
        XML::Easy::Content->new( [ @elements, '' ] ),
        );
    my $xml = XML::Easy::Text::xml10_write_element( $e );

    my $response = $self->_send_update( $xml );
    return $response->ok;
}

sub update {
    return shift->add( @_ );
}

sub commit {
    my ( $self, $params ) = @_;
    $params ||= {};
    my $e        = XML::Easy::Element->new( 'commit', $params, [ '' ] );
    my $xml      = XML::Easy::Text::xml10_write_element( $e );
    my $response = $self->_send_update( $xml, {}, 0 );
    return $response->ok;
}

sub rollback {
    my ( $self ) = @_;
    my $response = $self->_send_update( '<rollback/>', {}, 0 );
    return $response->ok;
}

sub optimize {
    my ( $self, $params ) = @_;
    $params ||= {};
    my $e        = XML::Easy::Element->new( 'optimize', $params, [ '' ] );
    my $xml      = XML::Easy::Text::xml10_write_element( $e );
    my $response = $self->_send_update( $xml, {}, 0 );
    return $response->ok;
}

sub delete {
    my ( $self, $options ) = @_;

    my $xml = '';
    for my $k ( keys %$options ) {
        my $v = $options->{ $k };
        $xml .= join(
            '',
            map {
                XML::Easy::Text::xml10_write_element(
                    XML::Easy::Element->new( $k, {}, [ $_ ] ) )
                } ref $v ? @$v : $v
        );
    }

    my $response = $self->_send_update( "<delete>${xml}</delete>" );
    return $response->ok;
}

sub delete_by_id {
    my ( $self, $id ) = @_;
    return $self->delete( { id => $id } );
}

sub delete_by_query {
    my ( $self, $query ) = @_;
    return $self->delete( { query => $query } );
}

sub ping {
    my ( $self ) = @_;
    my $response = WebService::Solr::Response->new(
        $self->agent->get( $self->_gen_url( 'admin/ping' ) ) );
    return $response->is_success;
}

sub search {
    my ( $self, $query, $params ) = @_;
    $params ||= {};
    $params->{ 'q' } = $query;
    return $self->generic_solr_request( 'select', $params );
}

sub auto_suggest {
    shift->generic_solr_request( 'autoSuggest', @_ );
}

sub generic_solr_request {
    my ( $self, $path, $params ) = @_;
    $params ||= {};
    my $response = WebService::Solr::Response->new(
        $self->agent->get( $self->_gen_url( $path, $params ) ) );
    return $response;
}

sub _gen_url {
    my ( $self, $handler, $params ) = @_;
    $params ||= {};

    my $url = $self->url->clone;
    $url->path( $url->path . "/$handler" );
    $url->query_form( { $self->default_params, %$params } );
    return $url;
}

sub _send_update {
    my ( $self, $xml, $params, $autocommit ) = @_;
    $autocommit = $self->autocommit unless defined $autocommit;

    my $url = $self->_gen_url( 'update', $params );
    my $req = HTTP::Request->new(
        POST => $url,
        HTTP::Headers->new( Content_Type => 'text/xml; charset=utf-8' ),
        '<?xml version="1.0" encoding="UTF-8"?>' . encode( 'utf8', "$xml" )
    );

    my $http_response = $self->agent->request( $req );
    if ( $http_response->is_error ) {
        confess $http_response->status_line . ': ' . $http_response->content;
    }

    my $res = WebService::Solr::Response->new( $http_response );

    $self->commit if $autocommit;

    return $res;
}

no Moose;

__PACKAGE__->meta->make_immutable;

1;

__END__