File Coverage

blib/lib/Store/CouchDB.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

package Store::CouchDB;

use Moo;

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

our $VERSION = '4.1'; # VERSION

use MooX::Types::MooseLike::Base qw(:all);
use experimental 'smartmatch';
use JSON;
use LWP::Protocol::Net::Curl;
use LWP::UserAgent;
use URI;
use URI::QueryParam;
use URI::Escape;
use Carp;
use Data::Dump 'dump';

# the following GET parameter keys have to be JSON encoded according to the
# couchDB API documentation. http://docs.couchdb.org/en/latest/api/
my @JSON_KEYS = qw(
    doc_ids
    key
    keys
    startkey
    start_key
    endkey
    end_key
);


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',
    isa     => Int,
    default => sub { 5000 },
);


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


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


has 'agent' => (
    is       => 'rw',
    lazy     => 1,
    required => 1,
    builder  => '_build_agent',
);

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

    return LWP::UserAgent->new(
        agent      => __PACKAGE__ . $Store::CouchDB::VERSION,
        timeout    => $self->timeout,
        keep_alive => 1,
    );
}


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 exists $res->{rows}
        and ref $res->{rows} eq 'ARRAY'
        and $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 exists $res->{rows}
        and ref $res->{rows} eq 'ARRAY'
        and $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, undef, $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;
    }

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

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

    $self->_check_db($data);

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

    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, 'accept_stale');

    # 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, 'compat');
        $res = $self->_call($path, 'accept_stale');
    }

    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, 'accept_stale', $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, 'accept_stale');

    # 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, 'compat');
        $res = $self->_call($path, 'accept_stale');
    }

    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, 'accept_stale');

    # 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, 'compat');
        $res = $self->_call($path, 'accept_stale');
    }

    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, 'accept_stale');
}


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', undef, $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, undef, $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 del_file {
    my ($self, $data) = @_;

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

    $self->_check_db($data);

    my $id  = $data->{id};
    my $rev = $data->{rev};

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

    my $path = $self->db . '/' . $id . '/' . $data->{filename} . '?rev=' . $rev;
    $self->method('DELETE');
    my $res = $self->_call($path);

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


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 ~~ @JSON_KEYS) {

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

            # only JSON encode URI parameter value if necessary and required by
            # documentation. see http://docs.couchdb.org/en/latest/api/
            $value = $self->json->encode($value);
        }

        $value = uri_escape($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 _build_uri {
    my ($self, $path) = @_;

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

    return $uri;
}

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

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

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

    my $uri = $self->_build_uri($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)));
    }

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

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

    # retry with stale=update_after in case of a timeout
    if ($accept_stale and $res->status_line eq '500 read timeout') {
        $uri->query_param_append(stale => 'update_after');
        $req->uri($uri);
        $res = $self->agent->request($req);
    }

    # 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('np');

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

    return $dump;
}

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

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

    return;
}


1;    # End of Store::CouchDB

__END__