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;