File Coverage

blib/lib/Store/CouchDB.pm

Criterion	Covered	Total	%
statement	49	446	10.9
branch	10	220	4.5
condition	3	75	4.0
subroutine	9	37	24.3
pod	23	23	100.0
total	94	801	11.7

package Store::CouchDB;

use Any::Moose;

# ABSTRACT: Store::CouchDB - a simple CouchDB driver

our $VERSION = '3.8'; # VERSION

use JSON;
use LWP::UserAgent;
use URI::Escape;
use Carp;
use Data::Dump 'dump';
use Types::Serialiser;


has 'debug' => (
    is      => 'rw',
    isa     => 'Bool',
    default => sub { 0 },
    lazy    => 1,
);


has 'host' => (
    is       => 'rw',
    isa      => 'Str',
    required => 1,
    default  => sub { 'localhost' },
);


has 'port' => (
    is       => 'rw',
    isa      => 'Int',
    required => 1,
    default  => sub { 5984 },
);


has 'ssl' => (
    is      => 'rw',
    isa     => 'Bool',
    default => sub { 0 },
    lazy    => 1,
);


has 'db' => (
    is        => 'rw',
    isa       => 'Str',
    predicate => 'has_db',
);


has 'user' => (
    is  => 'rw',
    isa => 'Str',
);


has 'pass' => (
    is  => 'rw',
    isa => 'Str',
);


has 'method' => (
    is       => 'rw',
    required => 1,
    default  => sub { 'GET' },
);


has 'error' => (
    is        => 'rw',
    predicate => 'has_error',
    clearer   => 'clear_error',
);


has 'purge_limit' => (
    is      => 'rw',
    default => sub { 5000 },
);


has 'timeout' => (
    is      => 'rw',
    isa     => 'Int',
    default => sub { 30 },
);


has 'json' => (
    is      => 'rw',
    isa     => 'JSON',
    default => sub {
        JSON->new->utf8->allow_nonref->allow_blessed->convert_blessed;
    },
);


sub get_doc {
    my ($self, $data) = @_;

    unless (ref $data eq 'HASH') {
        $data = { id => $data };
    }

    $self->_check_db($data);

    unless ($data->{id}) {
        carp 'Document ID not defined';
        return;
    }

    my $path = $self->db . '/' . $data->{id};
    my $rev;
    $rev = 'rev=' . $data->{rev} if (exists $data->{rev} and $data->{rev});
    my $params = $self->_uri_encode($data->{opts});
    if ($rev or $params) {
        $path .= '?';
        $path .= $rev . '&' if $rev;
        $path .= $params . '&' if $params;
        chop $path;
    }

    $self->method('GET');

    return $self->_call($path);
}


sub head_doc {
    my ($self, $data) = @_;

    unless (ref $data eq 'HASH') {
        $data = { id => $data };
    }

    $self->_check_db($data);

    unless ($data->{id}) {
        carp 'Document ID not defined';
        return;
    }

    my $path = $self->db . '/' . $data->{id};

    $self->method('HEAD');
    my $rev = $self->_call($path);

    $rev =~ s/"//g if $rev;

    return $rev;
}


sub all_docs {
    my ($self, $data) = @_;

    $self->_check_db($data);

    my $path   = $self->db . '/_all_docs';
    my $params = $self->_uri_encode($data);
    $path .= '?' . $params if $params;

    $self->method('GET');
    my $res = $self->_call($path);

    return unless $res->{rows}->[0];
    return $res->{rows};
}


sub get_design_docs {
    my ($self, $data) = @_;

    $self->_check_db($data);

    my $path = $self->db
        . '/_all_docs?descending=true&startkey="_design0"&endkey="_design"';
    my $params = $self->_uri_encode($data);
    $path .= $params if $params;

    $self->method('GET');
    my $res = $self->_call($path);

    return unless $res->{rows}->[0];
    return $res->{rows}
        if (ref $data eq 'HASH' and $data->{include_docs});

    my @design;
    foreach my $design (@{ $res->{rows} }) {
        my (undef, $name) = split(/\//, $design->{key}, 2);
        push(@design, $name);
    }

    return \@design;
}


sub put_doc {
    my ($self, $data) = @_;

    unless (exists $data->{doc} and ref $data->{doc} eq 'HASH') {
        carp "Document not defined";
        return;
    }

    $self->_check_db($data);

    my $path;
    if (exists $data->{doc}->{_id} and defined $data->{doc}->{_id}) {
        $self->method('PUT');
        $path = $self->db . '/' . $data->{doc}->{_id};
    }
    else {
        $self->method('POST');
        $path = $self->db;
    }

    my $params = $self->_uri_encode($data->{opts});
    $path .= '?' . $params if $params;
    my $res = $self->_call($path, $data->{doc});

    # update revision in original doc for convenience
    $data->{doc}->{_rev} = $res->{rev} if exists $res->{rev};

    return ($res->{id}, $res->{rev}) if wantarray;
    return $res->{id};
}


sub del_doc {
    my ($self, $data) = @_;

    unless (ref $data eq 'HASH') {
        $data = { id => $data };
    }

    my $id  = $data->{id}  || $data->{_id};
    my $rev = $data->{rev} || $data->{_rev};

    unless ($id) {
        carp 'Document ID not defined';
        return;
    }

    $self->_check_db($data);

    # get doc revision if missing
    unless ($rev) {
        $rev = $self->head_doc($id);
    }

    # stop if doc doesn't exist
    unless ($rev) {
        carp "Document does not exist";
        return;
    }

    my $path   = $self->db . '/' . $id . '?rev=' . $rev;
    my $params = $self->_uri_encode($data->{opts});
    $path .= $params if $params;

    $self->method('DELETE');
    my $res = $self->_call($path);

    return ($res->{id}, $res->{rev}) if wantarray;
    return $res->{rev};
}


sub update_doc {
    my ($self, $data) = @_;

    unless (ref $data eq 'HASH'
        and exists $data->{doc}
        and ref $data->{doc} eq 'HASH')
    {
        carp "Document not defined";
        return;
    }

    if ($data->{name}) {
        $data->{doc}->{_id} = $data->{name};
    }

    unless (exists $data->{doc}->{_id} and defined $data->{doc}->{_id}) {
        carp "Document ID not defined";
        return;
    }

    $self->_check_db($data);

    my $rev = $self->head_doc($data->{doc}->{_id});
    unless ($rev) {
        carp "Document does not exist";
        return;
    }

    # store revision in original doc to be able to put_doc
    $data->{doc}->{_rev} = $rev;

    return $self->put_doc($data);
}


sub copy_doc {
    my ($self, $data) = @_;

    unless (ref $data eq 'HASH') {
        $data = { id => $data };
    }

    unless ($data->{id}) {
        carp "Document ID not defined";
        return;
    }

    # as long as CouchDB does not support automatic document name creation
    # for the copy command we copy the ugly way ...
    my $doc = $self->get_doc($data);

    unless ($doc) {
        carp "Document does not exist";
        return;
    }

    delete $doc->{_id};
    delete $doc->{_rev};

    return $self->put_doc({ doc => $doc });
}


sub show_doc {
    my ($self, $data) = @_;

    $self->_check_db($data);

    unless ($data->{show}) {
        carp 'show not defined';
        return;
    }

    my $path = $self->_make_path($data);

    $self->method('GET');

    return $self->_call($path);
}


sub get_view {
    my ($self, $data) = @_;

    unless ($data->{view}) {
        carp "View not defined";
        return;
    }

    $self->_check_db($data);

    my $path = $self->_make_path($data);
    $self->method('GET');
    my $res = $self->_call($path);

    # fallback lookup for broken data consistency due to the way earlier
    # versions of this module where handling (or not) input data that had been
    # stringified by dumpers or otherwise internally
    # e.g. numbers were stored as strings which will be used as keys eventually
    unless ($res->{rows}->[0]) {
        $path = $self->_make_path($data, 1);
        $res = $self->_call($path);
    }

    return unless $res->{rows}->[0];

    my $c      = 0;
    my $result = {};
    foreach my $doc (@{ $res->{rows} }) {
        if ($doc->{doc}) {
            $result->{ $doc->{key} || $c } = $doc->{doc};
        }
        else {
            next unless exists $doc->{value};
            if (ref $doc->{key} eq 'ARRAY') {
                $self->_hash($result, $doc->{value}, @{ $doc->{key} });
            }
            else {
                # TODO debug why this crashes from time to time
                #$doc->{value}->{id} = $doc->{id};
                $result->{ $doc->{key} || $c } = $doc->{value};
            }
        }
        $c++;
    }

    return $result;
}


sub get_post_view {
    my ($self, $data) = @_;

    unless ($data->{view}) {
        carp 'View not defined';
        return;
    }
    unless ($data->{opts}) {
        carp 'No options defined - use "get_view" instead';
        return;
    }

    $self->_check_db($data);

    my $opts;
    if ($data->{opts}) {
        $opts = delete $data->{opts};
    }

    my $path = $self->_make_path($data);
    $self->method('POST');
    my $res = $self->_call($path, $opts);

    my $result;
    foreach my $doc (@{ $res->{rows} }) {
        next unless exists $doc->{value};
        $doc->{value}->{id} = $doc->{id};
        $result->{ $doc->{key} } = $doc->{value};
    }

    return $result;
}


sub get_view_array {
    my ($self, $data) = @_;

    unless ($data->{view}) {
        carp 'View not defined';
        return;
    }

    $self->_check_db($data);

    my $path = $self->_make_path($data);
    $self->method('GET');
    my $res = $self->_call($path);

    # fallback lookup for broken data consistency due to the way earlier
    # versions of this module where handling (or not) input data that had been
    # stringified by dumpers or otherwise internally
    # e.g. numbers were stored as strings which will be used as keys eventually
    unless ($res->{rows}->[0]) {
        $path = $self->_make_path($data, 1);
        $res = $self->_call($path);
    }

    my @result;
    foreach my $doc (@{ $res->{rows} }) {
        if ($doc->{doc}) {
            push(@result, $doc->{doc});
        }
        else {
            next unless exists $doc->{value};
            if (ref($doc->{value}) eq 'HASH') {
                $doc->{value}->{id} = $doc->{id};
                push(@result, $doc->{value});
            }
            else {
                push(@result, $doc);
            }
        }
    }

    return @result;
}


sub get_array_view {
    my ($self, $data) = @_;

    unless ($data->{view}) {
        carp "View not defined";
        return;
    }

    $self->_check_db($data);

    my $path = $self->_make_path($data);
    $self->method('GET');
    my $res = $self->_call($path);

    # fallback lookup for broken data consistency due to the way earlier
    # versions of this module where handling (or not) input data that had been
    # stringified by dumpers or otherwise internally
    # e.g. numbers were stored as strings which will be used as keys eventually
    unless ($res->{rows}->[0]) {
        $path = $self->_make_path($data, 1);
        $res = $self->_call($path);
    }

    my $result;
    foreach my $doc (@{ $res->{rows} }) {
        if ($doc->{doc}) {
            push(@{$result}, $doc->{doc});
        }
        else {
            next unless exists $doc->{value};
            if (ref($doc->{value}) eq 'HASH') {
                $doc->{value}->{id} = $doc->{id};
                push(@{$result}, $doc->{value});
            }
            else {
                push(@{$result}, $doc);
            }
        }
    }

    return $result;
}


sub list_view {
    my ($self, $data) = @_;

    unless ($data->{list}) {
        carp "List not defined";
        return;
    }

    unless ($data->{view}) {
        carp "View not defined";
        return;
    }

    $self->_check_db($data);

    my $path = $self->_make_path($data);

    $self->method('GET');

    return $self->_call($path);
}


sub changes {
    my ($self, $data) = @_;

    $self->_check_db($data);

    $self->method('GET');

    my $path   = $self->db . '/_changes';
    my $params = $self->_uri_encode($data);
    $path .= '?' . $params if $params;
    my $res = $self->_call($path);

    return $res;
}


sub purge {
    my ($self, $data) = @_;

    $self->_check_db($data);

    my $path = $self->db . '/_changes?limit=' . $self->purge_limit . '&since=0';
    $self->method('GET');
    my $res = $self->_call($path);

    return unless $res->{results}->[0];

    my @del;
    my $resp;

    $self->method('POST');
    foreach my $_del (@{ $res->{results} }) {
        next
            unless (exists $_del->{deleted}
            and ($_del->{deleted} eq 'true' or $_del->{deleted} == 1));

        my $opts = { $_del->{id} => [ $_del->{changes}->[0]->{rev} ], };
        $resp->{ $_del->{seq} } = $self->_call($self->db . '/_purge', $opts);
    }

    return $resp;
}


sub compact {
    my ($self, $data) = @_;

    $self->_check_db($data);

    my $res;
    if ($data->{purge}) {
        $res->{purge} = $self->purge();
    }

    if ($data->{view_compact}) {
        $self->method('POST');
        $res->{view_compact} = $self->_call($self->db . '/_view_cleanup');
        my $design = $self->get_design_docs();
        $self->method('POST');
        foreach my $doc (@{$design}) {
            $res->{ $doc . '_compact' } =
                $self->_call($self->db . '/_compact/' . $doc);
        }
    }

    $self->method('POST');
    $res->{compact} = $self->_call($self->db . '/_compact');

    return $res;
}


sub put_file {
    my ($self, $data) = @_;

    unless ($data->{file}) {
        carp 'File content not defined';
        return;
    }
    unless ($data->{filename}) {
        carp 'File name not defined';
        return;
    }

    $self->_check_db($data);

    my $id  = $data->{id}  || $data->{doc}->{_id};
    my $rev = $data->{rev} || $data->{doc}->{_rev};

    if (!$rev && $id) {
        $rev = $self->head_doc($id);
        $self->_log("put_file(): rev $rev") if $self->debug;
    }

    # create a new doc if required
    ($id, $rev) = $self->put_doc({ doc => {} }) unless $id;

    my $path = $self->db . '/' . $id . '/' . $data->{filename} . '?rev=' . $rev;

    $self->method('PUT');
    $data->{content_type} ||= 'text/plain';
    my $res = $self->_call($path, $data->{file}, $data->{content_type});

    return ($res->{id}, $res->{rev}) if wantarray;
    return $res->{id};
}


sub get_file {
    my ($self, $data) = @_;

    $self->_check_db($data);

    unless ($data->{id}) {
        carp "Document ID not defined";
        return;
    }
    unless ($data->{filename}) {
        carp "File name not defined";
        return;
    }

    my $path = join('/', $self->db, $data->{id}, $data->{filename});

    $self->method('GET');

    return $self->_call($path);
}


sub config {
    my ($self, $data) = @_;

    foreach my $key (keys %{$data}) {
        $self->$key($data->{$key}) or confess "$key not defined as property!";
    }
    return $self;
}


sub create_db {
    my ($self, $db) = @_;

    if ($db) {
        $self->db($db);
    }

    $self->method('PUT');
    my $res = $self->_call($self->db);

    return $res;
}


sub delete_db {
    my ($self, $db) = @_;

    if ($db) {
        $self->db($db);
    }

    $self->method('DELETE');
    my $res = $self->_call($self->db);

    return $res;
}


sub all_dbs {
    my ($self) = @_;

    $self->method('GET');
    my $res = $self->_call('_all_dbs');

    return @{ $res || [] };
}

sub _check_db {
    my ($self, $data) = @_;

    if (    ref $data eq 'HASH'
        and exists $data->{dbname}
        and defined $data->{dbname})
    {
        $self->db($data->{dbname});
        return;
    }

    unless ($self->has_db) {
        carp 'database not defined! you must set $sc->db("some_database")';
        return;
    }

    return;
}

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

    return unless (ref $options eq 'HASH');

    # make sure stringified keys and values return their original state
    # because otherwise JSON will encode numbers as strings
    my $opts = eval dump $options;    ## no critic

    my $path = '';
    foreach my $key (keys %$opts) {
        my $value = $opts->{$key};

        if ($key =~ m/key/) {

            # backwards compatibility with key, startkey, endkey as strings
            $value .= '' if ($compat && !ref($value));
        }
        else {
            unless (ref $value) {

                # copy $value to prevent stringifying
                my $cvalue = $value;

                # respect JSON booleans
                $value = Types::Serialiser::true  if $cvalue eq 'true';
                $value = Types::Serialiser::false if $cvalue eq 'false';
            }
        }

        $value = uri_escape($self->json->encode($value));
        $path .= $key . '=' . $value . '&';
    }

    # remove last '&'
    chop($path);

    return $path;
}

sub _make_path {
    my ($self, $data, $compat) = @_;

    my ($design, $view, $show, $list);

    if (exists $data->{view}) {
        $data->{view} =~ s/^\///;
        ($design, $view) = split(/\//, $data->{view}, 2);
    }

    if (exists $data->{show}) {
        $data->{show} =~ s/^\///;
        ($design, $show) = split(/\//, $data->{show}, 2);
    }

    $list = $data->{list} if exists $data->{list};

    my $path = $self->db . "/_design/${design}";
    if ($list) {
        $path .= "/_list/${list}/${view}";
    }
    elsif ($show) {
        $path .= "/_show/${show}";
        $path .= '/' . $data->{id} if defined $data->{id};
    }
    elsif ($view) {
        $path .= "/_view/${view}";
    }

    if (keys %{ $data->{opts} }) {
        my $params = $self->_uri_encode($data->{opts}, $compat);
        $path .= '?' . $params if $params;
    }

    return $path;
}

sub _call {
    my ($self, $path, $content, $ct) = @_;

    binmode(STDERR, ":encoding(UTF-8)") if $self->debug;

    # cleanup old error
    $self->clear_error if $self->has_error;

    my $uri = ($self->ssl) ? 'https://' : 'http://';
    $uri .= $self->user . ':' . $self->pass . '@'
        if ($self->user and $self->pass);
    $uri .= $self->host . ':' . $self->port . '/' . $path;

    $self->_log($self->method . ": $uri") if $self->debug;

    my $req = HTTP::Request->new();
    $req->method($self->method);
    $req->uri($uri);

    if ($content) {

        # make sure stringified keys and values return their original state
        # because otherwise JSON will encode numbers as strings for example
        my $c = eval dump $content;    ## no critic

        # ensure couchDB _id is a string as required
        # TODO: if support for _bulk_doc API is added we also need to make
        # sure every document ID is a string!
        if (ref $c eq 'HASH' && !defined $ct) {
            $c->{_id} .= '' if exists $c->{_id};
        }

        if ($self->debug) {
            $self->_log('Payload: ' . $self->_dump($content));
        }

        $req->content((
                  $ct
                ? $content
                : $self->json->encode($c)));
    }

    my $ua = LWP::UserAgent->new(timeout => $self->timeout);

    $ua->default_header('Content-Type' => $ct || "application/json");
    my $res = $ua->request($req);

    if ($self->method eq 'HEAD' and $res->header('ETag')) {
        $self->_log('Revision: ' . $res->header('ETag')) if $self->debug;
        return $res->header('ETag');
    }

    # try JSON decoding response content all the time
    my $result;
    eval { $result = $self->json->decode($res->content) };
    unless ($@) {
        $self->_log('Result: ' . $self->_dump($result)) if $self->debug;
    }

    if ($res->is_success) {
        return $result if $result;

        if ($self->debug) {
            my $dc = $res->decoded_content;
            chomp $dc;
            $self->_log('Result: ' . $self->_dump($dc));
        }

        return {
            file         => $res->decoded_content,
            content_type => [ $res->content_type ]->[0],
        };
    }
    else {
        $self->error($res->status_line . ': ' . $res->content);
    }

    return;
}

sub _hash {
    my ($self, $head, $val, @tail) = @_;

    if ($#tail == 0) {
        return $head->{ shift(@tail) } = $val;
    }
    else {
        return $self->_hash($head->{ shift(@tail) } //= {}, $val, @tail);
    }
}

sub _dump {
    my ($self, $obj) = @_;

    my %options;
    if ($self->debug) {
        $options{colored} = 1;
    }
    else {
        $options{colored}   = 0;
        $options{multiline} = 0;
    }

    require Data::Printer;
    Data::Printer->import(%options) unless __PACKAGE__->can('p');

    my $dump;
    if (ref $obj) {
        $dump = p($obj, %options);
    }
    else {
        $dump = p(\$obj, %options);
    }

    return $dump;
}

sub _log {
    my ($self, $msg) = @_;

    print STDERR __PACKAGE__ . ': ' . $msg . $/;

    return;
}


1;    # End of Store::CouchDB

__END__