From d28db1f43ff4cfb6ebb77e3b6513a9eb96e2d77d Mon Sep 17 00:00:00 2001 From: "David E. Wheeler" Date: Sat, 30 Aug 2025 15:55:25 -0400 Subject: [PATCH] Replace WWW::Curl::Simple with WWW::Curl::Easy `Simple` only handles GET and POST requests, unfortunately, so skip it and use `Easy` directly. Add a new method, `_curl`, that creates an `Easy` with everything properly configured, including a custom user agent, basic auth headers, other headers, the request body, and CA validation. It returns the object and references to scalars into which the headers and content will be populated when it executes. Revamp the `t/demo.t` to do basic validation that the method works, then add `t/request.t` to do live testing of its functionality. Have it rely on an environment variable for the base URL it tests against, and load the `go-httpbin` service for local, reliable testing. For whatever reason it returns 100 for requests with a body while httpbingo.org returns 200, so the test accepts either response code. --- .github/workflows/test.yaml | 7 +++ Makefile | 2 +- lib/Theory/Demo.pm | 91 ++++++++++++++++++++++++++++------- t/demo.t | 91 ++++++++++++++--------------------- t/request.t | 94 +++++++++++++++++++++++++++++++++++++ 5 files changed, 213 insertions(+), 72 deletions(-) create mode 100644 t/request.t diff --git a/.github/workflows/test.yaml b/.github/workflows/test.yaml index 010eeca..0d8c7f9 100644 --- a/.github/workflows/test.yaml +++ b/.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'] }} diff --git a/Makefile b/Makefile index fc90221..bbb1c95 100644 --- a/Makefile +++ b/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 diff --git a/lib/Theory/Demo.pm b/lib/Theory/Demo.pm index a0d3ec2..36b9e49 100644 --- a/lib/Theory/Demo.pm +++ b/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 -Creates and returns an L 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. 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. =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 object (specifically, C, 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> diff --git a/t/demo.t b/t/demo.t index 8f32168..7e7934e 100644 --- a/t/demo.t +++ b/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} } } \ No newline at end of file diff --git a/t/request.t b/t/request.t new file mode 100644 index 0000000..90f92c8 --- /dev/null +++ b/t/request.t @@ -0,0 +1,94 @@ +#!/usr/bin/perl -w + +use v5.28; +use strict; +use warnings; +use utf8; + +use Encode qw(encode_utf8); +use HTTP::Status qw(:constants status_message); +use JSON::PP; +use MIME::Base64; +use Test::More; +use Test::NoWarnings qw(had_no_warnings); +use Theory::Demo; + +BEGIN { $ENV{TERM} = "vt100" } + +isa_ok my $demo = Theory::Demo->new( + input => -1, + user => 'theory', + base_url => $ENV{HTTPBIN_URL} || 'https://httpbingo.org/', +), 'Theory::Demo'; + +my $base_head = HTTP::Headers->new; +$base_head->authorization_basic('theory'); +$base_head->user_agent("Theory::Demo/" . Theory::Demo->VERSION); + +for my $tc ( + { + test => "GET request", + meth => 'GET', + path => 'get', + code => HTTP_OK, + head => $base_head, + }, + { + test => "POST request", + meth => 'POST', + path => 'post', + head => $base_head, + body => '{"id": 42, "icon": "🥑"}', + }, + { + test => "PUT request", + meth => 'PUT', + path => 'put', + head => $base_head, + body => '{"id": 42, "icon": "🥑"}', + }, + { + test => "PATCH request", + meth => 'PATCH', + path => 'patch', + head => $base_head, + body => '{"id": 42, "icon": "🥑"}', + }, + { + test => "DELETE request", + meth => 'DELETE', + path => 'delete', + head => $base_head, + }, + { + test => "QUERY request", + meth => 'QUERY', + path => 'anything', + head => $base_head, + body => '{"id": 42, "icon": "🥑"}', + }, +) { + subtest $tc->{test} => sub { + my $req_body = $tc->{body} ? encode_utf8 $tc->{body} : undef; + ok my $res = $demo->request( + $tc->{meth} => $demo->_url($tc->{path}), + $req_body, + ), $tc->{test}; + ok +(grep { $res->code == $_ } (100, 200)), + "$tc->{test} should have status 100 or 200"; + ok my $body = decode_json($res->decoded_content), "$tc->{test} decode JSON body"; + is $body->{method}, $tc->{meth}, "$tc->{test} should have sent $tc->{meth} request"; + ok my $head = $body->{headers}, "$tc->{test} should have sent headers"; + for my $hn ($tc->{head}->header_field_names) { + is_deeply $head->{$hn}, [$tc->{head}->header($hn)], + "$tc->{test} should have sent $hn header"; + } + if ($req_body) { + my $exp = 'data:application/octet-stream;base64,' . encode_base64 $req_body, ''; + is $body->{data}, $exp, "$tc->{test} should have submitted body"; + } + } +} + +had_no_warnings; +done_testing;