From f0f0edf0130a32cb4f9a891b94d74e421cdf8d01 Mon Sep 17 00:00:00 2001 From: Jiri Sedlacek Date: Wed, 16 Mar 2011 00:03:15 +0100 Subject: [PATCH 1/4] CODE: speed up dbExists method --- lib/CouchDB/Client.pm | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/lib/CouchDB/Client.pm b/lib/CouchDB/Client.pm index 69f06b1..f51f0a5 100644 --- a/lib/CouchDB/Client.pm +++ b/lib/CouchDB/Client.pm @@ -11,6 +11,7 @@ use LWP::UserAgent qw(); use HTTP::Request qw(); use Encode qw(encode); use Carp qw(confess); +use URI::Escape qw(uri_escape_utf8); use CouchDB::Client::DB; @@ -70,7 +71,11 @@ sub dbExists { my $self = shift; my $name = shift; $name =~ s{/$}{}; - return (grep { $_ eq $name } @{$self->listDBNames}) ? 1 : 0; + return 0 if $name =~ m/[A-Z]/; # CouchDB does not allow upper case in DB names + my $res = $self->req('GET', uri_escape_utf8($name)); + return 1 if $res->{status} eq '200'; + return 0 if $res->{status} eq '404'; + confess("Connection error: $res->{msg}"); } # --- CONNECTION HANDLING --- From ca784fea8839bd9d8d4c28d9dcc63f36602624a1 Mon Sep 17 00:00:00 2001 From: Jiri Sedlacek Date: Mon, 21 Mar 2011 16:17:51 +0100 Subject: [PATCH 2/4] CODE: replace LWP::UserAgent with CouchDB::Curl (libcurl based HTTP client) --- lib/CouchDB/Client.pm | 32 +++--- lib/CouchDB/Client/Doc.pm | 17 +++- lib/CouchDB/Curl.pm | 206 ++++++++++++++++++++++++++++++++++++++ t/12-small-things.t | 2 +- 4 files changed, 232 insertions(+), 25 deletions(-) create mode 100644 lib/CouchDB/Curl.pm diff --git a/lib/CouchDB/Client.pm b/lib/CouchDB/Client.pm index f51f0a5..ece809e 100644 --- a/lib/CouchDB/Client.pm +++ b/lib/CouchDB/Client.pm @@ -7,12 +7,10 @@ use warnings; our $VERSION = '0.09'; use JSON::Any qw(XS JSON DWIW); -use LWP::UserAgent qw(); -use HTTP::Request qw(); -use Encode qw(encode); use Carp qw(confess); use URI::Escape qw(uri_escape_utf8); +use CouchDB::Curl qw(JSONCall); use CouchDB::Client::DB; sub new { @@ -30,7 +28,6 @@ sub new { ($opt{port} || '5984') . '/'; } $self{json} = ($opt{json} || JSON::Any->new(utf8 => 1, allow_blessed => 1)); - $self{ua} = ($opt{ua} || LWP::UserAgent->new(agent => "CouchDB::Client/$VERSION")); return bless \%self, $class; } @@ -81,24 +78,21 @@ sub dbExists { # --- CONNECTION HANDLING --- sub req { my $self = shift; - my $meth = shift; + my $method = shift; my $path = shift; my $content = shift; - my $headers = undef; - - if (ref $content) { - $content = encode('utf-8', $self->{json}->encode($content)); - $headers = HTTP::Headers->new('Content-Type' => 'application/json'); - } - my $res = $self->{ua}->request( HTTP::Request->new($meth, $self->uriForPath($path), $headers, $content) ); - my $ret = { - status => $res->code, - msg => $res->status_line, - success => 0, - }; - if ($res->is_success) { + my ($ret,$res); + eval {$res = JSONCall($method, $self->uriForPath($path), $content)}; + if (my $e = HTTP::Exception->caught) { + $ret->{success} = 0; + $ret->{status} = $e->code; + $ret->{msg} = $e->status_message; + } else { $ret->{success} = 1; - $ret->{json} = $self->{json}->decode($res->content); + $ret->{status} = 200; + } + if ($ret->{success}) { + $ret->{json} = $res } return $ret; } diff --git a/lib/CouchDB/Client/Doc.pm b/lib/CouchDB/Client/Doc.pm index 01671c8..3e75fe7 100644 --- a/lib/CouchDB/Client/Doc.pm +++ b/lib/CouchDB/Client/Doc.pm @@ -10,6 +10,7 @@ use HTTP::Request qw(); use URI::Escape qw(uri_escape_utf8); use MIME::Base64 qw(encode_base64); use Carp qw(confess); +use CouchDB::Curl qw(Curl); sub new { my $class = shift; @@ -161,11 +162,17 @@ sub fetchAttachment { my $attName = shift; confess("No such attachment: '$attName'") unless exists $self->{attachments}->{$attName}; - my $res = $self->{db}->{client}->{ua}->request( - HTTP::Request->new('GET', $self->{db}->{client}->uriForPath($self->uriName . '/' . uri_escape_utf8($attName))) - ); - return $res->content if $res->is_success; - confess("Object not found: $res->{msg}"); + my ( $method, $uri, $body, $headers, $query ) = @_; + + my ($ret, $res); + eval { $res = Curl('GET', $self->{db}->{client}->uriForPath($self->uriName . '/' . uri_escape_utf8($attName)))}; + if (my $e = HTTP::Exception->caught) { + $ret->{status} = $e->code; + $ret->{msg} = $e->status_message; + $ret->{success} = 0; + } + return $res unless $ret->{success}; + confess("Object not found: $ret->{msg}"); } sub addAttachment { diff --git a/lib/CouchDB/Curl.pm b/lib/CouchDB/Curl.pm new file mode 100644 index 0000000..621e2ae --- /dev/null +++ b/lib/CouchDB/Curl.pm @@ -0,0 +1,206 @@ +################################################################################ +# Curl +################################################################################ +# libcurl based HTTP client +# faster then LWP::UseAgent +# +#------------------------------------------------------------------------------- + +package CouchDB::Curl; + +use strict; +use WWW::Curl::Easy; +use JSON::XS; +use HTTP::Exception; +use Data::Dumper; +use URI; +use URI::Escape::XS 'encodeURIComponent'; +use MIME::Base64; + +use Exporter qw(import); +our @EXPORT_OK = qw(Curl JSONCall); + +#------------------------------------------------------------------------------- +# Function: JSONCall +# Call a resource using network stack, both sends and expects JSON. +# Can use Basic Authorisation. +# +# Parameters: +# $method - one of GET,HEAD,POST,PUT,DELETE +# $uri - something like "http://server/resource" +# $body - hashref +# $query - hashref with query parameters +# (will be transformed to ?key=value&...) +# $user - username +# $pwd - password +# +# Returns: +# $hashref or HTTP::Exception +#------------------------------------------------------------------------------- +sub JSONCall { + my ( $method, $uri, $body, $query, $user, $pwd ) = @_; + + my $auth = "Basic " . encode_base64("$user:$pwd", ''); + my $p = eval { encode_json($body) } if $body; + HTTP::Exception->throw('400', "Error encoding data to JSON: $@") if $@; + + my $data = Curl( + $method, $uri, $p, + [ + "Authorization: $auth", + "Accept: application/json", + "Content-Type: application/json" + ], + $query + ); + + my $r = eval { decode_json($data) } if $data; + HTTP::Exception->throw('500', "Error parsing JSON input: $@") if $@; + + return $r; +} + +#------------------------------------------------------------------------------- +# Function: Curl +# Make a HTTP call using libcurl library. +# +# See all available libcurl options here: +# http://curl.haxx.se/libcurl/c/curl_easy_setopt.html +# +# Parameters: +# $method - one of GET,HEAD,POST,PUT,DELETE +# $uri - something like "http://server/resource" +# $body - encoded body +# $headers - arrayref of headers (["Content-Type: text/yaml"]) +# $query - hashref with query parameters +# (will be transformed to ?key=value&...) +# +# Returns: +# $data or HTTP::Exception - response body +#------------------------------------------------------------------------------- +sub Curl { + my ( $method, $uri, $body, $headers, $query ) = @_; + + my $curl = WWW::Curl::Easy->new; + + my $q = _CompileQuery($query); + if ($q) { + if ($uri =~ m/\?/) { + $uri .= "&$q"; # in case some query is already present in uri + } else { + $uri .= "?$q"; + } + } + $curl->setopt( CURLOPT_URL, $uri ); + if ($body) { + $curl->setopt( CURLOPT_POSTFIELDS, $body ); + $curl->setopt( CURLOPT_POSTFIELDSIZE, length $body ); + } + $curl->setopt( CURLOPT_CUSTOMREQUEST, $method ); + $curl->setopt( CURLOPT_HTTPHEADER, $headers ) if $headers and @$headers > 0; + + my $response_body; + $curl->setopt( CURLOPT_WRITEDATA, \$response_body ); + my $retcode = $curl->perform; + if ( $retcode == 0 ) { + my $status = $curl->getinfo(CURLINFO_HTTP_CODE); + HTTP::Exception->throw($status, status_message => $response_body) if $status >= 300; + return $response_body; + } + else { + HTTP::Exception->throw(500, status_message => + "An error happened: " + . $curl->strerror($retcode) . " " + . $curl->errbuf) + } +} + +#------------------------------------------------------------------------------- +# Function: _CompileQuery +# Transform hash to URL query (behind "?") +# +# Parameters: +# hashref or scalar +# +# Returns: +# URL encoded string +# +#------------------------------------------------------------------------------- +sub _CompileQuery { + my ($query) = @_; + return undef unless $query; + my $ref = ref $query; + if ($ref eq 'SCALAR') { + return $query; + } elsif ($ref eq 'HASH') { + my @params; + foreach my $key ( sort keys %$query ) { + my $v; + my $vref = ref $query->{$key}; + if ( $vref and $vref ne 'SCALAR') { + $v = encodeURIComponent(encode_json($query->{$key})); + } else { + $v = $query->{$key}; + } + push @params,$key."=".$v; + } + return join( "&", @params ); + } else { + HTTP::Exception->throw('400', "Unsupported query param, use HASH or SCALAR"); + } +} + + +1; + +=pod + +=head1 NAME + +CouchDB::Curl - libcurl based HTTP client, faster then LWP::UserAgent + +=head1 SYNOPSIS + + my $hash = JSONCall('GET', 'http://localhost/resource'); + + JSONCall('POST','http://localhost/resource2', { hello => 'world' }); + if (my $e = HTTP::Exception->caught) { + die $e->code . $e->status_message; + } + + my $image = Curl('GET', 'http://localhost/image.png'); + + +=head1 DESCRIPTION + +This is a functional approach to HTTP client. It is based on libcurl which is faster then LWP::UserAgent. For example retrieving 1000 documents from CouchDB takes 6.3 seconds with LWP and just 3.3 with Curl. + + +=head1 METHODS + +=over 8 + +=item Curl + + +=item JSONCall + + +=back + +=head1 AUTHOR + +Jiri Sedlacek, + +=head1 BUGS + + +=head1 COPYRIGHT & LICENSE + +Copyright 2008 Jiri Sedlacek, all rights reserved. + +This library is free software; you can redistribute it and/or modify it under the same terms as +Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may +have available. + +=cut diff --git a/t/12-small-things.t b/t/12-small-things.t index 3a941fa..59b0255 100644 --- a/t/12-small-things.t +++ b/t/12-small-things.t @@ -89,7 +89,7 @@ my $DB = $C->newDB('blah'); $c = CouchDB::Client->new(scheme => 'https', host => 'example.org', port => '9000'); ok $c && $c->{uri} eq 'https://example.org:9000/', 'URI by fragments'; $c = CouchDB::Client->new(json => JSON::Any->new, ua => LWP::UserAgent->new); - ok $c && $c->{json} && $c->{ua}, 'helper objects'; + ok $c && $c->{json}, 'helper objects'; # bad address $c = CouchDB::Client->new(scheme => 'https'); From 7b7c08e45843ebe2530b7a1fb88be0b8d3218f5e Mon Sep 17 00:00:00 2001 From: Jiri Sedlacek Date: Fri, 8 Jul 2011 11:54:51 +0200 Subject: [PATCH 3/4] BUGFIX: correct encoding of different data types in URL - there IS a difference between $a = 3; and $a = "3"; even though undetectable by regexp - this patch has been used in production for months - as of now the original couchdb-client by maverick still has this wrong - encode_json is the fastest stable serialization method in Perl - example: now it's possible to query view with params ?key=[3,"3"] --- lib/CouchDB/Curl.pm | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/lib/CouchDB/Curl.pm b/lib/CouchDB/Curl.pm index 621e2ae..f113f07 100644 --- a/lib/CouchDB/Curl.pm +++ b/lib/CouchDB/Curl.pm @@ -140,7 +140,10 @@ sub _CompileQuery { if ( $vref and $vref ne 'SCALAR') { $v = encodeURIComponent(encode_json($query->{$key})); } else { - $v = $query->{$key}; + my $val = encode_json({value=>$query->{$key}}); + ($v) = ($val =~ m/{[^:]*:(.*)}/); + $v = encodeURIComponent($v); + $v = $query->{$key} if $key eq 'rev'; } push @params,$key."=".$v; } From 48584b0e17e0aceab6efa4f3b183572a38c5e508 Mon Sep 17 00:00:00 2001 From: Jiri Sedlacek Date: Thu, 18 Aug 2011 23:13:44 +0300 Subject: [PATCH 4/4] Edited lib/CouchDB/Curl.pm via GitHub --- lib/CouchDB/Curl.pm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/CouchDB/Curl.pm b/lib/CouchDB/Curl.pm index f113f07..a6fed24 100644 --- a/lib/CouchDB/Curl.pm +++ b/lib/CouchDB/Curl.pm @@ -130,14 +130,14 @@ sub _CompileQuery { my ($query) = @_; return undef unless $query; my $ref = ref $query; - if ($ref eq 'SCALAR') { + if (!$ref) { return $query; } elsif ($ref eq 'HASH') { my @params; foreach my $key ( sort keys %$query ) { my $v; my $vref = ref $query->{$key}; - if ( $vref and $vref ne 'SCALAR') { + if ( $vref ) { $v = encodeURIComponent(encode_json($query->{$key})); } else { my $val = encode_json({value=>$query->{$key}});