Replace WWW::Curl::Simple with WWW::Curl::Easy

.github/workflows/test.yaml

@@ -7,12 +7,19 @@ jobs:
   test:
     name: ✅ Run Tests
     runs-on: ubuntu-latest
+    services:
+      httpbin:
+        image: mccutchen/go-httpbin
+        ports: [8080:8080]
     steps:
       - name: Checkout Repo
         uses: actions/checkout@v4
       - name: apt-get install
         run: sudo make deb-install-deps
       - run: make test
+        env:
+          HTTPBIN_URL: http://localhost:${{ job.services.httpbin.ports['8080'] }}
       - run: make coveralls
         env:
           GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+          HTTPBIN_URL: http://localhost:${{ job.services.httpbin.ports['8080'] }}

Makefile

@@ -37,7 +37,7 @@ deb-install-deps:
       libtest-mockmodule-perl \
       libtest-nowarnings-perl \
       liburi-perl \
-      libwww-curl-simple-perl \
+      libwww-curl-perl \
       libyaml-perl \
       make \
       postgresql-client

lib/Theory/Demo.pm

@@ -9,6 +9,9 @@ use Crypt::Misc qw(decode_b58b);
 use Encode qw(encode_utf8 decode_utf8);
 use File::Temp;
 use Getopt::Long;
+use HTTP::Headers;
+use HTTP::Request;
+use HTTP::Response;
 use HTTP::Status qw(HTTP_OK HTTP_CREATED HTTP_NO_CONTENT);
 use IO::Socket::SSL;
 use IPC::System::Simple 1.17 qw(capturex run runx capture);
@@ -18,7 +21,9 @@ use Net::SSLeay;
 use Term::ANSIColor ();
 use Term::TermKey;
 use URI;
-use WWW::Curl::Simple;
+use WWW::Curl::Easy;
+
+our $VERSION = v0.1.0;
 
 my $json = JSON::PP->new->utf8->allow_bignum;
 
@@ -67,16 +72,6 @@ C<['Location']>.
 
 sub new {
     my ($pkg, %params) = @_;
-    # Set up Curl.
-    if ($params{ca_bundle}) {
-        $params{curl} = WWW::Curl::Simple->new(
-            check_ssl_certs => 1,
-            ssl_cert_bundle => delete $params{ca_bundle},
-        );
-    } else {
-        $params{curl} = WWW::Curl::Simple->new;
-    }
-
     # Configure request headers.
     $params{head} = HTTP::Headers->new(
         #'Content-Type'  => 'application/json',
@@ -521,7 +516,7 @@ sub b58_int { Math::BigInt->from_bytes(decode_b58b $_[1]) }
 
 =cut
 
-sub _content_is_json {
+sub _content_is_json($) {
     my $ct = shift->content_type;
     return $ct eq "application/json" || $ct =~ /[+]json$/;
 }
@@ -578,21 +573,85 @@ sub handle {
         $self->emit($body);
         $self->nl_prompt;
     }
+
+    return
 }
 
 
 =head C<request>
 
-Creates and returns an L<HTTP::Request> for the given method, URL, and
-optional body. The body should be a Perl string which will be encoded as
+Makes a request for the given method, URL, and optional body and returns an
+L<HTTP::Response>. The body should be a Perl string which will be encoded as
 UTF-8. The request will contain the list of headers passed to C<new()>.
 
 =cut
 
 sub request {
     my ($self, $method, $url, $body) = @_;
-    my $req = HTTP::Request->new($method, $url, $self->{head}, $body);
-    $self->{curl}->request($req);
+    my ($curl, $head, $content) = $self->_curl($method, $url, $body);
+    if (my $code = $curl->perform) {
+        die "Request failed: " . $curl->strerror($code) . " ($code)\n";
+    }
+
+    # Create and return the response.
+    my $res = HTTP::Response->parse(${ $head });
+    $res->request(HTTP::Request->new($method, $url, $self->{head}, $body));
+    $res->content(${ $content });
+    return $res;
+}
+
+=begin comment
+
+=head3 C<_curl>
+
+Creates a L<WWW::Curl> object (specifically, C<WWW::Curl::Easy) to request
+C<$method>, C<$url>, and C<$body> and configured to write the response to
+C<$head> and C<$content>, which must be scalar references.
+
+=cut
+
+sub _curl {
+    my ($self, $method, $url, $body) = @_;
+    # Setup the request.
+    my $curl = WWW::Curl::Easy->new;
+    $curl->setopt(CURLOPT_NOPROGRESS, 1);
+    $curl->setopt(CURLOPT_USERAGENT, __PACKAGE__ . '/' . $self->VERSION);
+    $curl->setopt(CURLOPT_CUSTOMREQUEST, $method);
+    $curl->setopt(CURLOPT_URL, $url);
+
+    # Setup headers.
+    my $h = $self->{head};
+    $curl->setopt(CURLOPT_HTTPHEADER, [map {
+        my $n = $_;
+        map { "$n: $_" } $h->header($n)
+    } $h->header_field_names]);
+
+    # Setup the request body.
+    if ($body) {
+        open my $read, '<:raw', \$body;
+        $curl->setopt(CURLOPT_UPLOAD, 1);
+        $curl->setopt(WWW::Curl::Easy::CURLOPT_UPLOAD, 1);
+        $curl->setopt(WWW::Curl::Easy::CURLOPT_READDATA, \$read);
+    }
+
+    # Setup scalars to which to write the response headers and content.
+    my ($head, $content) = ('', '');
+    open my $head_fh, ">:raw", \$head;
+    $curl->setopt(CURLOPT_WRITEHEADER, $head_fh);
+    open my $body_fh, ">:raw", \$content;
+    $curl->setopt(CURLOPT_WRITEDATA, $body_fh);
+
+    # Limit to 5 redirects with valid auto-referer header.
+    $curl->setopt(CURLOPT_FOLLOWLOCATION, 1);
+    $curl->setopt(CURLOPT_MAXREDIRS, 5);
+    $curl->setopt(CURLOPT_AUTOREFERER, 1);
+
+    # Verify cert identification and provide a CA bundle if we have one.
+    $curl->setopt(CURLOPT_SSL_VERIFYPEER, 1);
+    $curl->setopt(CURLOPT_CAINFO, $self->{ca_bundle}) if $self->{ca_bundle};
+
+    # All set.
+    return $curl, \$head, \$content;
 }
 
 # Encode the data for a request. If the argument starts with "@", C<_data>

t/demo.t

@@ -10,6 +10,7 @@ use Test::More 'no_plan';
 use Test::MockModule;
 use Test::File::Contents;
 use Test::Exception;
+use HTTP::Response;
 use Test::NoWarnings qw(had_no_warnings);
 
 BEGIN {
@@ -37,7 +38,6 @@ sub reset_output {
 # Test just input param.
 ok my $demo = Theory::Demo->new(input => $input),
      'Should create demo with just input param';
-is_deeply $demo->{curl}, WWW::Curl::Simple->new, 'Should have curl client';
 is_deeply $demo->{head}, HTTP::Headers->new, 'Should have empty headers';
 is_deeply $demo->{headers}, ['Location'], 'Should have default emit headers';
 isa_ok $demo->{tk}, 'Term::TermKey';
@@ -58,14 +58,10 @@ ok $demo = Theory::Demo->new(
     headers   => [qw(Location Link)],
 ), 'Should create demo with all params';
 
-is_deeply $demo->{curl}, WWW::Curl::Simple->new(
-    check_ssl_certs => 1,
-    ssl_cert_bundle => 'foo',
-), 'Should have configured curl client';
-
 my $head = HTTP::Headers->new;
 $head->authorization_basic('peggy');
-is_deeply $head, $demo->{head}, , 'Should have configured headers';
+is_deeply$demo->{head}, $head, 'Should have configured headers';
+is $demo->{ca_bundle}, 'foo', 'Should have passed ca_bundle';
 is_deeply $demo->{headers}, [qw(Location Link)], 'Should have passed headers';
 isa_ok $demo->{tk}, 'Term::TermKey';
 is $demo->{prompt}, 'bagel', 'Should have specified prompt';
@@ -444,29 +440,6 @@ is_deeply $ipc->args, {
     run => [[qq{psql -tXxc "} . join(' ', @sql) . qq{"}]],
 }, 'Should have run the multiline psql command';
 
-##############################################################################
-# Mock Curl and Test request method.
-my $curl = MockCurl->new(response => HTTP::Response->new(HTTP_OK, 'OK'));
-$demo->{curl} = $curl;
-
-# Test GET request.
-ok my $res = $demo->request("GET", "/widgets"), 'Make request';
-is_deeply $res, HTTP::Response->new(HTTP_OK, 'OK'), 'Should have 200 response';
-is_deeply $curl->{requested},
-    [[HTTP::Request->new("GET", "/widgets", $demo->{head})]],
-    'Should have made the expected request';
-
-# Test POST request with body.
-$curl->setup(response => HTTP::Response->new(HTTP_CREATED, 'Created'));
-my $body = encode_utf8 'some body 😀';
-ok $res = $demo->request("POST", "/widgets", $body),
-    'Make POST request';
-is_deeply $res, HTTP::Response->new(HTTP_CREATED, 'Created'),
-    'Should have 201 response';
-is_deeply $curl->{requested},
-    [[HTTP::Request->new("POST", "/widgets", $demo->{head}, $body)]],
-    'Should have made the expected request';
-
 ##############################################################################
 # Test _content_is_json.
 for my $ct (qw(application/json application/ld+json something/xyz+json)) {
@@ -573,26 +546,41 @@ throws_ok { Theory::Demo::_data '@nonesuch.json' }
     'Should get error from _data for nonexistent file';
 
 ##############################################################################
-# Mock handle.
+# Test _curl.
+my ($curl, $head_ref, $body_ref) = $demo->_curl(GET => '/get');
+isa_ok $curl, 'WWW::Curl::Easy';
+isa_ok $head_ref, 'SCALAR';
+isa_ok $body_ref, 'SCALAR';
+
+delete $demo->{ca_bundle};
+($curl, $head_ref, $body_ref) = $demo->_curl(POST => '/get', 'content');
+isa_ok $curl, 'WWW::Curl::Easy';
+isa_ok $head_ref, 'SCALAR';
+isa_ok $body_ref, 'SCALAR';
+
+##############################################################################
+# Mock handle and _curl.
 my @handle_args;
 my $handle_ret;
 $module->mock(handle => sub { shift; @handle_args = @_; $handle_ret });
+$curl = MockCurl->new;
+my ($res_head, $res_body) =  ('HTTP/2 200', '{"id": 1234}');
+$module->mock(_curl => sub { return $curl, \$res_head, \$res_body });
 
 ##############################################################################
 # Test get.
 reset_output;
-$res = HTTP::Response->new(HTTP_OK, 'OK', [], '{"id": 1234}');
-$curl->setup(response => $res);
+my $res = HTTP::Response->new(HTTP_OK, 'OK', [], '{"id": 1234}');
 is $demo->get("/some/path"), undef, 'Should get undef from get';
 is_deeply \@handle_args, [
     $demo->request(GET => $demo->_url("/some/path")), HTTP_OK,
 ], 'Should have passed request and default code to handle';
-is $out, "GET https://hi//some/path\n", 'Should have output the GET request';
+is $out, "GET https://hi//some/path\n",
+    'Should have output the GET request';
 
 # Test get with status code.
 reset_output;
 $res = HTTP::Response->new(HTTP_ACCEPTED, 'ACCEPTED', [], '{"id": 1234}');
-$curl->setup(response => $res);
 is $demo->get("/some/path", HTTP_ACCEPTED), undef, 'Should get undef from get';
 is_deeply \@handle_args, [
     $demo->request(GET => $demo->_url("/some/path")), HTTP_ACCEPTED,
@@ -602,7 +590,6 @@ is $out, "GET https://hi//some/path\n", 'Should have output the GET request';
 # Test get_quiet
 reset_output;
 $res = HTTP::Response->new(HTTP_OK, 'OK', [], '{"id": 1234}');
-$curl->setup(response => $res);
 is $demo->get_quiet("/some/path"), undef, 'Should get undef from get_quiet';
 is_deeply \@handle_args, [
     $demo->request(GET => $demo->_url("/some/path")), HTTP_OK, 1,
@@ -612,7 +599,6 @@ is $out, "", 'Should not have output the GET request';
 # Test get_quiet with status code.
 reset_output;
 $res = HTTP::Response->new(HTTP_ACCEPTED, 'ACCEPTED', [], '{"id": 1234}');
-$curl->setup(response => $res);
 is $demo->get_quiet("/some/path", HTTP_ACCEPTED), undef,
     'Should get undef from get_quiet';
 is_deeply \@handle_args, [
@@ -624,7 +610,6 @@ is $out, "", 'Should have no output the GET request';
 # Test del.
 reset_output;
 $res = HTTP::Response->new(HTTP_NO_CONTENT, 'No Content', [], '{"id": 1234}');
-$curl->setup(response => $res);
 is $demo->del("/some/path"), undef, 'Should del undef from del';
 is_deeply \@handle_args, [
     $demo->request(DELETE => $demo->_url("/some/path")), HTTP_NO_CONTENT,
@@ -634,7 +619,6 @@ is $out, "DELETE https://hi//some/path\n", 'Should have output the DELETE reques
 # Test del with status code.
 reset_output;
 $res = HTTP::Response->new(HTTP_OK, 'OK', [], '{"id": 1234}');
-$curl->setup(response => $res);
 is $demo->del("/some/path", HTTP_OK), undef, 'Should del undef from del';
 is_deeply \@handle_args, [
     $demo->request(DELETE => $demo->_url("/some/path")), HTTP_OK,
@@ -649,7 +633,7 @@ for my $tc (
     {
         meth => 'post',
         action => 'POST',
-        body => '{"id": 1234}',
+        body => '{"id": 1234, "name": "🐥"}',
         code => HTTP_ACCEPTED,
     },
     {
@@ -696,22 +680,22 @@ for my $tc (
     },
 ) {
     reset_output;
-    my $res = HTTP::Response->new(
-        $tc->{code}, HTTP::Status::status_message($tc->{code} || $tc->{exp}),
-        [], $tc->{body},
-    );
-    $curl->setup(response => $res);
     ok my $meth = $demo->can($tc->{meth}), "can($tc->{meth})";
     is $demo->$meth($path, $tc->{body}, $tc->{code}), undef,
         "Should undef from $tc->{meth}";
-    my $data = encode_utf8 Theory::Demo::_data($tc->{body});
+    my $data = Theory::Demo::_data $tc->{body};
     is_deeply \@handle_args, [
-        $demo->request($tc->{meth}, $url, $data), $tc->{exp} || $tc->{code},
+        $demo->request($tc->{action}, $url, $data), $tc->{exp} || $tc->{code},
     ], 'Should have passed request and default code to handle';
-    is $out, "$tc->{action} $url $tc->{body}\n",
+    is $out, "$tc->{action} $url " . encode_utf8 "$tc->{body}\n",
         "Should have output the $tc->{action} request";
 }
 
+# Test request when curl returns an error.
+$curl->setup(perform => 42, strerror => 'Oops');
+throws_ok { $demo->request(GET => '/') } qr/Request failed: Oops \(42\)/,
+    'request should die when curl returns an error';
+
 ##############################################################################
 # Test tail_docker_log.
 reset_output;
@@ -842,16 +826,13 @@ MOCKS: {
     sub setup {
         my $self = shift;
         %{ $self } = (
-            response => undef,
-            requested => [],
+            perform => undef,
+            strerror => 'some error',
             @_
         );
     }
 
-    sub request {
-        my $self = shift;
-        push @{ $self->{requested} } => \@_;
-        return $self->{response};
-    }
+    sub perform  { shift->{perform} }
+    sub strerror { shift->{strerror} }
 
 }