From: Charles McGarvey Date: Fri, 17 Mar 2017 03:29:10 +0000 (-0600) Subject: add middleware X-Git-Tag: v0.901~2 X-Git-Url: https://git.dogcows.com/gitweb?p=chaz%2Fp5-HTTP-AnyUA;a=commitdiff_plain;h=cde5368e2d23e07a80fa67f670afcb99093d0f77 add middleware Includes ContentLength and Runtime as basic examples. --- diff --git a/lib/HTTP/AnyUA.pm b/lib/HTTP/AnyUA.pm index c340913..75122b8 100644 --- a/lib/HTTP/AnyUA.pm +++ b/lib/HTTP/AnyUA.pm @@ -338,11 +338,13 @@ use Scalar::Util; our $BACKEND_NAMESPACE; +our $MIDDLEWARE_NAMESPACE; our @BACKENDS; our %REGISTERED_BACKENDS; BEGIN { - $BACKEND_NAMESPACE = __PACKAGE__ . '::Backend'; + $BACKEND_NAMESPACE = __PACKAGE__ . '::Backend'; + $MIDDLEWARE_NAMESPACE = __PACKAGE__ . '::Middleware'; } @@ -509,10 +511,7 @@ sub post_form { (@_ == 3 || @_ == 4 && ref $args eq 'HASH') or _usage(q{$any_ua->post_form($url, $formdata, \%options)}); - my $headers = {}; - while (my ($key, $value) = each %{$args->{headers} || {}}) { - $headers->{lc $key} = $value; - } + my $headers = HTTP::AnyUA::Util::normalize_headers($args->{headers}); delete $args->{headers}; return $self->request(POST => $url, { @@ -552,13 +551,7 @@ sub mirror { @_ == 3 || (@_ == 4 && ref $args eq 'HASH') or _usage(q{$any_ua->mirror($url, $filepath, \%options)}); - if (exists $args->{headers}) { - my $headers = {}; - while (my ($key, $value) = each %{$args->{headers} || {}}) { - $headers->{lc($key)} = $value; - } - $args->{headers} = $headers; - } + $args->{headers} = HTTP::AnyUA::Util::normalize_headers($args->{headers}); if (-e $file and my $mtime = (stat($file))[9]) { $args->{headers}{'if-modified-since'} ||= HTTP::AnyUA::Util::http_date($mtime); @@ -613,6 +606,44 @@ sub mirror { } } +=method apply_middleware + + $any_ua->apply_middleware($middleware_package); + $any_ua->apply_middleware($middleware_package, %args); + $any_ua->apply_middleware($middleware_obj); + +Wrap the backend with some new middleware. Middleware packages are relative to the +C namespace unless prefixed with a C<+>. + +This effectively replaces the L with a new object that wraps the previous backend. + +This can be used multiple times to add multiple layers of middleware, and order matters. The last +middleware applied is the first one to see the request and last one to get the response. For +example, if you apply middleware that does logging and middleware that does caching (and +short-circuits on a cache hit), applying your logging middleware I will cause only cache +misses to be logged whereas applying your cache middleware first will allow all requests to be +logged. + +See L for more information about what middleware is and how to write your +own middleware. + +=cut + +sub apply_middleware { + my $self = shift; + my $class = shift; + + if (!ref $class) { + $class = "${MIDDLEWARE_NAMESPACE}::${class}" unless $class =~ s/^\+//; + $self->_module_loader->load($class); + } + + $self->{backend} = $class->wrap($self->backend, @_); + $self->_check_response_is_future($self->response_is_future); + + return $self; +} + =method register_backend HTTP::AnyUA->register_backend($user_agent_package => $backend_package); diff --git a/lib/HTTP/AnyUA/Middleware.pm b/lib/HTTP/AnyUA/Middleware.pm new file mode 100644 index 0000000..21b6db8 --- /dev/null +++ b/lib/HTTP/AnyUA/Middleware.pm @@ -0,0 +1,154 @@ +package HTTP::AnyUA::Middleware; +# ABSTRACT: A base class for HTTP::AnyUA middleware + +=head1 SYNOPSIS + + package HTTP::AnyUA::Middleware::MyMiddleware; + + use parent 'HTTP::AnyUA::Middleware'; + + sub request { + my ($self, $method, $url, $args) = @_; + + # Maybe do something with the request args here. + + # Let backend handle the response: + my $response = $self->backend($method, $url, $args); + + my $handle_response = sub { + my $response = shift; + + # Maybe do something with the response here. + + return $response; + }; + + if ($self->response_is_future) { + $response->transform( + done => $handle_response, + fail => $handle_response, + ); + } + else { + $response = $handle_response->($response); + } + + return $response; + } + +=head1 DESCRIPTION + +This module provides an interface for an L "middleware," which is a component that sits +between an L object and the L (which may in fact be +another middleware). + +The easiest way to use middleware is to use L. + +The middleware mechanism can be used to munge or react to requests and responses to and from the +backend user agent. Middlewares are a completely optional part of L. They can be +wrapped around each other to create multiple layers and interesting possibilities. The functionality +provided by middleware may be alternative to features provided by some of the supported user agents, +themselves, but implementing functionality on this layer makes it work for I the user agents. + +=cut + +use warnings; +use strict; + +our $VERSION = '9999.999'; # VERSION + +sub _croak { require Carp; Carp::croak(@_) } +sub _usage { _croak("Usage: @_\n") } + + +=method new + + $middleware = HTTP::AnyUA::Middleware::MyMiddleware->new($backend); + $middleware = HTTP::AnyUA::Middleware::MyMiddleware->new($backend, %args); + +Construct a new middleware. + +=cut + +sub new { + my $class = shift; + my $backend = shift or die 'Backend is required'; + my $self = bless {backend => $backend}, $class; + $self->init(@_); + return $self; +} + +=method init + +Called by the default constructor with the middleware arguments. + +This may be overridden by implementations instead of the constructor. + +=cut + +sub init {} + +=method wrap + + $middleware = HTTP::AnyUA::Middleware::MyMiddleware->wrap($backend, %args); + $middleware->wrap($backend); + +Construct a new middleware or, when called on an instance, set a new backend on an existing +middleware. + +=cut + +sub wrap { + my $self = shift; + my $backend = shift or _usage($self . q{->wrap($backend, %args)}); + + if (ref $self) { + $self->{backend} = $backend; + } + else { + $self = $self->new($backend, @_); + } + + return $self; +} + +=method request + + $response = $middleware->request($method => $url, \%options); + +Make a request, get a response. + +This should be overridden by implementations to do whatever they want with or to the request and/or +response. + +=cut + +sub request { shift->backend->request(@_) } + +=attr backend + +Get the current backend that is wrapped. + +=cut + +sub backend { shift->{backend} } + +=attr ua + +Get the backend user agent. + +=cut + +sub ua { shift->backend->ua(@_) } + +=attr response_is_future + +Get whether or not responses are L objects. Default is whatever the backend returns. + +This may be overridden by implementations. + +=cut + +sub response_is_future { shift->backend->response_is_future(@_) } + +1; diff --git a/lib/HTTP/AnyUA/Middleware/ContentLength.pm b/lib/HTTP/AnyUA/Middleware/ContentLength.pm new file mode 100644 index 0000000..750316f --- /dev/null +++ b/lib/HTTP/AnyUA/Middleware/ContentLength.pm @@ -0,0 +1,44 @@ +package HTTP::AnyUA::Middleware::ContentLength; +# ABSTRACT: Middleware to add Content-Length header automatically + +=head1 SYNOPSIS + + $any_ua->apply_middleware('ContentLength'); + +=head1 DESCRIPTION + +This middleware adds a Content-Length header to the request if the content is known (i.e. the +"content" field of the request options is a string instead of a coderef) and if the header is not +already set. + +=head1 SEE ALSO + +=for :list +* L + +=cut + +use warnings; +use strict; + +our $VERSION = '9999.999'; # VERSION + +use parent 'HTTP::AnyUA::Middleware'; + +use HTTP::AnyUA::Util; + + +sub request { + my $self = shift; + my ($method, $url, $args) = @_; + + $args->{headers} = HTTP::AnyUA::Util::normalize_headers($args->{headers}); + + if (!defined $args->{headers}{'content-length'} && $args->{content} && !ref $args->{content}) { + $args->{headers}{'content-length'} = length $args->{content}; + } + + return $self->backend->request($method, $url, $args); +} + +1; diff --git a/lib/HTTP/AnyUA/Middleware/Runtime.pm b/lib/HTTP/AnyUA/Middleware/Runtime.pm new file mode 100644 index 0000000..ed1643c --- /dev/null +++ b/lib/HTTP/AnyUA/Middleware/Runtime.pm @@ -0,0 +1,59 @@ +package HTTP::AnyUA::Middleware::Runtime; +# ABSTRACT: Middleware to determine response time + +=head1 SYNOPSIS + + $any_ua->apply_middleware('Runtime'); + +=head1 DESCRIPTION + +This middleware adds a "runtime" field to the response, the value of which is the number of seconds +it took to make the request and finish the response. + +=head1 SEE ALSO + +=for :list +* L + +=cut + +use warnings; +use strict; + +our $VERSION = '9999.999'; # VERSION + +use parent 'HTTP::AnyUA::Middleware'; + +use Time::HiRes; + + +sub request { + my $self = shift; + my ($method, $url, $args) = @_; + + my $start = [Time::HiRes::gettimeofday]; + + my $resp = $self->backend->request($method, $url, $args); + + my $handle_response = sub { + my $resp = shift; + + $resp->{runtime} = sprintf('%.6f', Time::HiRes::tv_interval($start)); + + return $resp; + }; + + if ($self->response_is_future) { + $resp->transform( + done => $handle_response, + fail => $handle_response, + ); + } + else { + $resp = $handle_response->($resp); + } + + return $resp; +} + +1; diff --git a/lib/HTTP/AnyUA/Util.pm b/lib/HTTP/AnyUA/Util.pm index 580b850..3729c56 100644 --- a/lib/HTTP/AnyUA/Util.pm +++ b/lib/HTTP/AnyUA/Util.pm @@ -1,5 +1,5 @@ package HTTP::AnyUA::Util; -# ABSTRACT: Utility subroutines for HTTP::AnyUA backends +# ABSTRACT: Utility subroutines for HTTP::AnyUA backends and middleware use warnings; use strict; @@ -13,6 +13,7 @@ our @EXPORT_OK = qw( http_headers_to_native native_to_http_request coderef_content_to_string + normalize_headers internal_exception http_date parse_http_date @@ -102,6 +103,28 @@ sub http_headers_to_native { return $native; } +=func normalize_headers + + $normalized_headers = normalize_headers(\%headers); + +Normalize headers. Currently lowercases header keys. + +=cut + +sub normalize_headers { + my $headers_in = shift; + + my $headers = {}; + + if (defined $headers_in) { + while (my ($key, $value) = each %{$headers_in || {}}) { + $headers->{lc($key)} = $value; + } + } + + return $headers; +} + =func internal_exception $response = internal_exception($content); diff --git a/t/40-middleware-content-length.t b/t/40-middleware-content-length.t new file mode 100644 index 0000000..e283454 --- /dev/null +++ b/t/40-middleware-content-length.t @@ -0,0 +1,36 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More tests => 3; + +HTTP::AnyUA->register_backend(Mock => '+MockBackend'); + +my $any_ua = HTTP::AnyUA->new(ua => 'Mock'); +my $backend = $any_ua->backend; + +$any_ua->apply_middleware('ContentLength'); + +my $url = 'http://acme.tld/'; +my $content = "hello world\n"; + +$any_ua->post($url, {content => $content}); +my $cl = ($backend->requests)[-1][2]{headers}{'content-length'}; +is $cl, length($content), 'content-length is set correctly with string content'; + +$any_ua->post($url); +$cl = ($backend->requests)[-1][2]{headers}{'content-length'}; +is $cl, undef, 'content-length is not set with no content'; + +my $chunk = 0; +my @chunk = ('some ', 'document'); +my $code = sub { return $chunk[$chunk++] }; + +$any_ua->post($url, {content => $code}); +$cl = ($backend->requests)[-1][2]{headers}{'content-length'}; +is $cl, undef, 'content-length is not set with coderef content'; + diff --git a/t/40-middleware-runtime.t b/t/40-middleware-runtime.t new file mode 100644 index 0000000..5597fda --- /dev/null +++ b/t/40-middleware-runtime.t @@ -0,0 +1,23 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More tests => 1; + +HTTP::AnyUA->register_backend(Mock => '+MockBackend'); + +my $any_ua = HTTP::AnyUA->new(ua => 'Mock'); +my $backend = $any_ua->backend; + +$any_ua->apply_middleware('Runtime'); + +my $url = 'http://acme.tld/'; + +my $resp = $any_ua->get($url); +note explain $resp; +isnt $resp->{runtime}, undef, 'runtime is defined'; +