Replace LWP::UserAgent with WWW::Curl::Easy (faster http client)

lib/CouchDB/Client.pm

@@ -7,11 +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 {
@@ -29,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;
 }
@@ -70,30 +68,31 @@ 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 ---
 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;
 }

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 {

lib/CouchDB/Curl.pm

@@ -0,0 +1,209 @@
+################################################################################
+#	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) {
+		return $query;
+	} elsif ($ref eq 'HASH') {
+		my @params;
+		foreach my $key ( sort keys %$query ) {
+			my $v;
+			my $vref = ref $query->{$key};
+			if ( $vref ) {
+				$v = encodeURIComponent(encode_json($query->{$key}));
+			} else {
+				my $val = encode_json({value=>$query->{$key}});
+				($v) = ($val =~ m/{[^:]*:(.*)}/);
+				$v = encodeURIComponent($v);
+				$v = $query->{$key} if $key eq 'rev';
+			}
+			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, <jiri d.t sedlacek @t futu d.t cz>
+
+=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

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