From b671717fae8b8c6b3f22355f4c16b5cbe0a8ffd0 Mon Sep 17 00:00:00 2001 From: Charles McGarvey Date: Sun, 26 Feb 2017 23:40:38 -0700 Subject: [PATCH 1/1] initial commit --- .gitignore | 11 + .travis.yml | 20 + Changes | 4 + LICENSE | 379 ++++++++++++ Makefile | 26 + dist.ini | 25 + lib/HTTP/AnyUA.pm | 724 +++++++++++++++++++++++ lib/HTTP/AnyUA/Backend.pm | 129 ++++ lib/HTTP/AnyUA/Backend/AnyEvent/HTTP.pm | 146 +++++ lib/HTTP/AnyUA/Backend/Furl.pm | 73 +++ lib/HTTP/AnyUA/Backend/HTTP/AnyUA.pm | 38 ++ lib/HTTP/AnyUA/Backend/HTTP/Tiny.pm | 30 + lib/HTTP/AnyUA/Backend/LWP/UserAgent.pm | 75 +++ lib/HTTP/AnyUA/Backend/Mojo/UserAgent.pm | 155 +++++ lib/HTTP/AnyUA/Backend/Net/Curl/Easy.pm | 230 +++++++ lib/HTTP/AnyUA/Util.pm | 285 +++++++++ t/01-new.t | 19 + t/02-shortcuts.t | 24 + t/03-post_form.t | 29 + t/04-internal-exception.t | 36 ++ t/10-get.t | 71 +++ t/11-post.t | 55 ++ t/12-put.t | 56 ++ t/13-head.t | 54 ++ t/14-delete.t | 52 ++ t/15-custom-method.t | 56 ++ t/20-data_callback.t | 59 ++ t/21-basic-auth.t | 62 ++ t/22-redirects.t | 93 +++ t/23-content-coderef.t | 65 ++ t/app.psgi | 46 ++ t/lib/MockBackend.pm | 45 ++ t/lib/Server.pm | 185 ++++++ t/lib/Util.pm | 343 +++++++++++ 34 files changed, 3700 insertions(+) create mode 100644 .gitignore create mode 100644 .travis.yml create mode 100644 Changes create mode 100644 LICENSE create mode 100644 Makefile create mode 100644 dist.ini create mode 100644 lib/HTTP/AnyUA.pm create mode 100644 lib/HTTP/AnyUA/Backend.pm create mode 100644 lib/HTTP/AnyUA/Backend/AnyEvent/HTTP.pm create mode 100644 lib/HTTP/AnyUA/Backend/Furl.pm create mode 100644 lib/HTTP/AnyUA/Backend/HTTP/AnyUA.pm create mode 100644 lib/HTTP/AnyUA/Backend/HTTP/Tiny.pm create mode 100644 lib/HTTP/AnyUA/Backend/LWP/UserAgent.pm create mode 100644 lib/HTTP/AnyUA/Backend/Mojo/UserAgent.pm create mode 100644 lib/HTTP/AnyUA/Backend/Net/Curl/Easy.pm create mode 100644 lib/HTTP/AnyUA/Util.pm create mode 100644 t/01-new.t create mode 100644 t/02-shortcuts.t create mode 100644 t/03-post_form.t create mode 100644 t/04-internal-exception.t create mode 100644 t/10-get.t create mode 100644 t/11-post.t create mode 100644 t/12-put.t create mode 100644 t/13-head.t create mode 100644 t/14-delete.t create mode 100644 t/15-custom-method.t create mode 100644 t/20-data_callback.t create mode 100644 t/21-basic-auth.t create mode 100644 t/22-redirects.t create mode 100644 t/23-content-coderef.t create mode 100644 t/app.psgi create mode 100644 t/lib/MockBackend.pm create mode 100644 t/lib/Server.pm create mode 100644 t/lib/Util.pm diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..2810278 --- /dev/null +++ b/.gitignore @@ -0,0 +1,11 @@ +*.bs +*.o +*.tar* +*~ +/.build +/.perl-version +/HTTP-AnyUA-* +/MYMETA.* +/blib +/local* +/pm_to_blib diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 0000000..c0fa429 --- /dev/null +++ b/.travis.yml @@ -0,0 +1,20 @@ +sudo: false +language: perl +perl: + - '5.24' + - '5.22' + - '5.20' + - '5.18' + - '5.16' + - '5.14' +matrix: + fast_finish: true +before_install: + - git config --global user.name "TravisCI" + - git config --global user.email $HOSTNAME":not-for-mail@travis-ci.org" +install: + - cpanm --quiet --notest --skip-satisfied Dist::Zilla + - "dzil authordeps --missing | grep -vP '[^\\w:]' | xargs -n 5 -P 10 cpanm --quiet --notest" + - "dzil listdeps --author --missing | grep -vP '[^\\w:]' | cpanm --verbose" +script: + - dzil smoke --release --author diff --git a/Changes b/Changes new file mode 100644 index 0000000..18e1475 --- /dev/null +++ b/Changes @@ -0,0 +1,4 @@ +Revision history for HTTP-AnyUA. + +{{$NEXT}} + diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..a2abd4e --- /dev/null +++ b/LICENSE @@ -0,0 +1,379 @@ +This software is copyright (c) 2017 by Charles McGarvey. + +This is free software; you can redistribute it and/or modify it under +the same terms as the Perl 5 programming language system itself. + +Terms of the Perl programming language system itself + +a) the GNU General Public License as published by the Free + Software Foundation; either version 1, or (at your option) any + later version, or +b) the "Artistic License" + +--- The GNU General Public License, Version 1, February 1989 --- + +This software is Copyright (c) 2017 by Charles McGarvey. + +This is free software, licensed under: + + The GNU General Public License, Version 1, February 1989 + + GNU GENERAL PUBLIC LICENSE + Version 1, February 1989 + + Copyright (C) 1989 Free Software Foundation, Inc. + 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + Preamble + + The license agreements of most software companies try to keep users +at the mercy of those companies. By contrast, our General Public +License is intended to guarantee your freedom to share and change free +software--to make sure the software is free for all its users. The +General Public License applies to the Free Software Foundation's +software and to any other program whose authors commit to using it. +You can use it for your programs, too. + + When we speak of free software, we are referring to freedom, not +price. Specifically, the General Public License is designed to make +sure that you have the freedom to give away or sell copies of free +software, that you receive source code or can get it if you want it, +that you can change the software or use pieces of it in new free +programs; and that you know you can do these things. + + To protect your rights, we need to make restrictions that forbid +anyone to deny you these rights or to ask you to surrender the rights. +These restrictions translate to certain responsibilities for you if you +distribute copies of the software, or if you modify it. + + For example, if you distribute copies of a such a program, whether +gratis or for a fee, you must give the recipients all the rights that +you have. You must make sure that they, too, receive or can get the +source code. And you must tell them their rights. + + We protect your rights with two steps: (1) copyright the software, and +(2) offer you this license which gives you legal permission to copy, +distribute and/or modify the software. + + Also, for each author's protection and ours, we want to make certain +that everyone understands that there is no warranty for this free +software. If the software is modified by someone else and passed on, we +want its recipients to know that what they have is not the original, so +that any problems introduced by others will not reflect on the original +authors' reputations. + + The precise terms and conditions for copying, distribution and +modification follow. + + GNU GENERAL PUBLIC LICENSE + TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION + + 0. This License Agreement applies to any program or other work which +contains a notice placed by the copyright holder saying it may be +distributed under the terms of this General Public License. The +"Program", below, refers to any such program or work, and a "work based +on the Program" means either the Program or any work containing the +Program or a portion of it, either verbatim or with modifications. Each +licensee is addressed as "you". + + 1. You may copy and distribute verbatim copies of the Program's source +code as you receive it, in any medium, provided that you conspicuously and +appropriately publish on each copy an appropriate copyright notice and +disclaimer of warranty; keep intact all the notices that refer to this +General Public License and to the absence of any warranty; and give any +other recipients of the Program a copy of this General Public License +along with the Program. You may charge a fee for the physical act of +transferring a copy. + + 2. You may modify your copy or copies of the Program or any portion of +it, and copy and distribute such modifications under the terms of Paragraph +1 above, provided that you also do the following: + + a) cause the modified files to carry prominent notices stating that + you changed the files and the date of any change; and + + b) cause the whole of any work that you distribute or publish, that + in whole or in part contains the Program or any part thereof, either + with or without modifications, to be licensed at no charge to all + third parties under the terms of this General Public License (except + that you may choose to grant warranty protection to some or all + third parties, at your option). + + c) If the modified program normally reads commands interactively when + run, you must cause it, when started running for such interactive use + in the simplest and most usual way, to print or display an + announcement including an appropriate copyright notice and a notice + that there is no warranty (or else, saying that you provide a + warranty) and that users may redistribute the program under these + conditions, and telling the user how to view a copy of this General + Public License. + + d) You may charge a fee for the physical act of transferring a + copy, and you may at your option offer warranty protection in + exchange for a fee. + +Mere aggregation of another independent work with the Program (or its +derivative) on a volume of a storage or distribution medium does not bring +the other work under the scope of these terms. + + 3. You may copy and distribute the Program (or a portion or derivative of +it, under Paragraph 2) in object code or executable form under the terms of +Paragraphs 1 and 2 above provided that you also do one of the following: + + a) accompany it with the complete corresponding machine-readable + source code, which must be distributed under the terms of + Paragraphs 1 and 2 above; or, + + b) accompany it with a written offer, valid for at least three + years, to give any third party free (except for a nominal charge + for the cost of distribution) a complete machine-readable copy of the + corresponding source code, to be distributed under the terms of + Paragraphs 1 and 2 above; or, + + c) accompany it with the information you received as to where the + corresponding source code may be obtained. (This alternative is + allowed only for noncommercial distribution and only if you + received the program in object code or executable form alone.) + +Source code for a work means the preferred form of the work for making +modifications to it. For an executable file, complete source code means +all the source code for all modules it contains; but, as a special +exception, it need not include source code for modules which are standard +libraries that accompany the operating system on which the executable +file runs, or for standard header files or definitions files that +accompany that operating system. + + 4. You may not copy, modify, sublicense, distribute or transfer the +Program except as expressly provided under this General Public License. +Any attempt otherwise to copy, modify, sublicense, distribute or transfer +the Program is void, and will automatically terminate your rights to use +the Program under this License. However, parties who have received +copies, or rights to use copies, from you under this General Public +License will not have their licenses terminated so long as such parties +remain in full compliance. + + 5. By copying, distributing or modifying the Program (or any work based +on the Program) you indicate your acceptance of this license to do so, +and all its terms and conditions. + + 6. Each time you redistribute the Program (or any work based on the +Program), the recipient automatically receives a license from the original +licensor to copy, distribute or modify the Program subject to these +terms and conditions. You may not impose any further restrictions on the +recipients' exercise of the rights granted herein. + + 7. The Free Software Foundation may publish revised and/or new versions +of the General Public License from time to time. Such new versions will +be similar in spirit to the present version, but may differ in detail to +address new problems or concerns. + +Each version is given a distinguishing version number. If the Program +specifies a version number of the license which applies to it and "any +later version", you have the option of following the terms and conditions +either of that version or of any later version published by the Free +Software Foundation. If the Program does not specify a version number of +the license, you may choose any version ever published by the Free Software +Foundation. + + 8. If you wish to incorporate parts of the Program into other free +programs whose distribution conditions are different, write to the author +to ask for permission. For software which is copyrighted by the Free +Software Foundation, write to the Free Software Foundation; we sometimes +make exceptions for this. Our decision will be guided by the two goals +of preserving the free status of all derivatives of our free software and +of promoting the sharing and reuse of software generally. + + NO WARRANTY + + 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY +FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN +OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES +PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED +OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS +TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE +PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, +REPAIR OR CORRECTION. + + 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING +WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR +REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, +INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING +OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED +TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY +YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER +PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE +POSSIBILITY OF SUCH DAMAGES. + + END OF TERMS AND CONDITIONS + + Appendix: How to Apply These Terms to Your New Programs + + If you develop a new program, and you want it to be of the greatest +possible use to humanity, the best way to achieve this is to make it +free software which everyone can redistribute and change under these +terms. + + To do so, attach the following notices to the program. It is safest to +attach them to the start of each source file to most effectively convey +the exclusion of warranty; and each file should have at least the +"copyright" line and a pointer to where the full notice is found. + + + Copyright (C) 19yy + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 1, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA + + +Also add information on how to contact you by electronic and paper mail. + +If the program is interactive, make it output a short notice like this +when it starts in an interactive mode: + + Gnomovision version 69, Copyright (C) 19xx name of author + Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. + This is free software, and you are welcome to redistribute it + under certain conditions; type `show c' for details. + +The hypothetical commands `show w' and `show c' should show the +appropriate parts of the General Public License. Of course, the +commands you use may be called something other than `show w' and `show +c'; they could even be mouse-clicks or menu items--whatever suits your +program. + +You should also get your employer (if you work as a programmer) or your +school, if any, to sign a "copyright disclaimer" for the program, if +necessary. Here a sample; alter the names: + + Yoyodyne, Inc., hereby disclaims all copyright interest in the + program `Gnomovision' (a program to direct compilers to make passes + at assemblers) written by James Hacker. + + , 1 April 1989 + Ty Coon, President of Vice + +That's all there is to it! + + +--- The Artistic License 1.0 --- + +This software is Copyright (c) 2017 by Charles McGarvey. + +This is free software, licensed under: + + The Artistic License 1.0 + +The Artistic License + +Preamble + +The intent of this document is to state the conditions under which a Package +may be copied, such that the Copyright Holder maintains some semblance of +artistic control over the development of the package, while giving the users of +the package the right to use and distribute the Package in a more-or-less +customary fashion, plus the right to make reasonable modifications. + +Definitions: + + - "Package" refers to the collection of files distributed by the Copyright + Holder, and derivatives of that collection of files created through + textual modification. + - "Standard Version" refers to such a Package if it has not been modified, + or has been modified in accordance with the wishes of the Copyright + Holder. + - "Copyright Holder" is whoever is named in the copyright or copyrights for + the package. + - "You" is you, if you're thinking about copying or distributing this Package. + - "Reasonable copying fee" is whatever you can justify on the basis of media + cost, duplication charges, time of people involved, and so on. (You will + not be required to justify it to the Copyright Holder, but only to the + computing community at large as a market that must bear the fee.) + - "Freely Available" means that no fee is charged for the item itself, though + there may be fees involved in handling the item. It also means that + recipients of the item may redistribute it under the same conditions they + received it. + +1. You may make and give away verbatim copies of the source form of the +Standard Version of this Package without restriction, provided that you +duplicate all of the original copyright notices and associated disclaimers. + +2. You may apply bug fixes, portability fixes and other modifications derived +from the Public Domain or from the Copyright Holder. A Package modified in such +a way shall still be considered the Standard Version. + +3. You may otherwise modify your copy of this Package in any way, provided that +you insert a prominent notice in each changed file stating how and when you +changed that file, and provided that you do at least ONE of the following: + + a) place your modifications in the Public Domain or otherwise make them + Freely Available, such as by posting said modifications to Usenet or an + equivalent medium, or placing the modifications on a major archive site + such as ftp.uu.net, or by allowing the Copyright Holder to include your + modifications in the Standard Version of the Package. + + b) use the modified Package only within your corporation or organization. + + c) rename any non-standard executables so the names do not conflict with + standard executables, which must also be provided, and provide a separate + manual page for each non-standard executable that clearly documents how it + differs from the Standard Version. + + d) make other distribution arrangements with the Copyright Holder. + +4. You may distribute the programs of this Package in object code or executable +form, provided that you do at least ONE of the following: + + a) distribute a Standard Version of the executables and library files, + together with instructions (in the manual page or equivalent) on where to + get the Standard Version. + + b) accompany the distribution with the machine-readable source of the Package + with your modifications. + + c) accompany any non-standard executables with their corresponding Standard + Version executables, giving the non-standard executables non-standard + names, and clearly documenting the differences in manual pages (or + equivalent), together with instructions on where to get the Standard + Version. + + d) make other distribution arrangements with the Copyright Holder. + +5. You may charge a reasonable copying fee for any distribution of this +Package. You may charge any fee you choose for support of this Package. You +may not charge a fee for this Package itself. However, you may distribute this +Package in aggregate with other (possibly commercial) programs as part of a +larger (possibly commercial) software distribution provided that you do not +advertise this Package as a product of your own. + +6. The scripts and library files supplied as input to or produced as output +from the programs of this Package do not automatically fall under the copyright +of this Package, but belong to whomever generated them, and may be sold +commercially, and may be aggregated with this Package. + +7. C or perl subroutines supplied by you and linked into this Package shall not +be considered part of this Package. + +8. The name of the Copyright Holder may not be used to endorse or promote +products derived from this software without specific prior written permission. + +9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED +WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF +MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. + +The End + diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..c192c97 --- /dev/null +++ b/Makefile @@ -0,0 +1,26 @@ + +# This is not a Perl distribution, but it can build one using Dist::Zilla. + +CPANM = cpanm +DZIL = dzil +PERL = perl +PROVE = prove + +all: bootstrap dist + +bootstrap: + $(CPANM) Dist::Zilla + $(DZIL) authordeps --missing | $(CPANM) + $(DZIL) listdeps --develop --missing | $(CPANM) + +clean: + $(DZIL) $@ + +dist: + $(DZIL) build + +test: + $(PROVE) -l + +.PHONY: all bootstrap clean dist test + diff --git a/dist.ini b/dist.ini new file mode 100644 index 0000000..d554bf6 --- /dev/null +++ b/dist.ini @@ -0,0 +1,25 @@ + +name = HTTP-AnyUA +author = Charles McGarvey +copyright_holder = Charles McGarvey +copyright_year = 2017 +license = Perl_5 + +[@Author::CCM] +AutoPrereqs.skip[0] = ^(AnyEvent::.+|HTTP::Request|Net::Curl::Easy)$ +AutoPrereqs.skip[1] = ^(JSON|AnyEvent|Plack::.+|Mojo::.+)$ + +[Prereqs / RuntimeSuggests] +HTTP::Tiny = 0 + +[Prereqs / TestSuggests] +AnyEvent::HTTP = 0 +Furl = 0 +HTTP::Tiny = 0 +JSON = 0 +LWP::UserAgent = 0 +Mojo::UserAgent = 0 +Net::Curl::Easy = 0 +Plack::Runner = 0 +Starman = 0 + diff --git a/lib/HTTP/AnyUA.pm b/lib/HTTP/AnyUA.pm new file mode 100644 index 0000000..d9e4a7a --- /dev/null +++ b/lib/HTTP/AnyUA.pm @@ -0,0 +1,724 @@ +package HTTP::AnyUA; +# ABSTRACT: An HTTP user agent programming interface unification layer + +=head1 SYNOPSIS + + my $any_ua = HTTP::AnyUA->new(ua => LWP::UserAgent->new); + # OR: my $any_ua = HTTP::AnyUA->new(ua => Furl->new); + # OR: my $any_ua = HTTP::AnyUA->new(ua => HTTP::Tiny->new); + # etc... + + my $response = $any_ua->get('http://www.example.com/'); + + print "$response->{status} $response->{reason}\n"; + + while (my ($k, $v) = each %{$response->{headers}}) { + for (ref $v eq 'ARRAY' ? @$v : $v) { + print "$k: $_\n"; + } + } + + print $response->{content} if length $response->{content}; + + ### Non-blocking user agents cause Future objects to be returned: + + my $any_ua = HTTP::AnyUA->new(ua => HTTP::Tiny->new, response_is_future => 1); + # OR: my $any_ua = HTTP::AnyUA->new(ua => 'AnyEvent::HTTP'); + # OR: my $any_ua = HTTP::AnyUA->new(ua => Mojo::UserAgent->new); + # etc... + + my $future = $any_ua->get('http://www.example.com/'); + + $future->on_done(sub { + my $response = shift; + + print "$response->{status} $response->{reason}\n"; + + while (my ($k, $v) = each %{$response->{headers}}) { + for (ref $v eq 'ARRAY' ? @$v : $v) { + print "$k: $_\n"; + } + } + + print $response->{content} if length $response->{content}; + }); + + $future->on_fail(sub { print STDERR "Oh no!!\n" }); + +=head1 DESCRIPTION + +This module provides a small wrapper for unifying the programming interfaces of several different +actual user agents (HTTP clients) under one B interface. + +Rather than providing yet another programming interface for you to learn, HTTP::AnyUA follows the +L interface. This also means that you can plug in any supported HTTP client +(L, L, etc.) and use it as if it were L. + +There are a lot of great HTTP clients available for Perl, each with different goals, different +feature sets, and of course different programming interfaces! If you're an end user, you can just +pick one of these clients according to the needs of your project (or personal preference). But if +you're writing a module that needs to interface with a web server (like perhaps a RESTful API +wrapper) and you want your users to be able to use whatever HTTP client they want, HTTP::AnyUA can +help you support that! + +It's a good idea to let the end user pick whatever HTTP client they want to use, because they're the +one who knows the requirements of their application or script. If you're writing an event-driven +application, you'll need to use a non-blocking user agent like L. If you're writing +a simple command-line script, you may decide that your priority is to minimize dependencies and so +may want to go with L. + +Unfortunately, many modules on CPAN are hardcoded to work with specific HTTP clients, leaving the +end user unable to use the HTTP client that would be best for them. Although the end user won't -- +or at least doesn't need to -- use HTTP::AnyUA directly, they will benefit from client choice if +their third-party modules use HTTP::AnyUA or something like it. + +The primary goal of HTTP::AnyUA is to make it easy for module developers to write HTTP code once +that can work with any HTTP client the end user may decide to plug in. A secondary goal is to make +it easy for anyone to add support for new or yet-unsupported user agents. + +=head1 SUPPORTED USER AGENTS + +=for :list +* L +* L +* L - a little bit meta, but why not? +* L +* L +* L +* L + +Any HTTP client that inherits from one of these in a well-behaved manner should also be supported. + +Of course, there are many other HTTP clients on CPAN that HTTP::AnyUA doesn't yet support. I'm more +than happy to help add support for others, so send me a message if you know of an HTTP client that +needs support. See L for how to write support for a new HTTP client. + +=head1 NON-BLOCKING USER AGENTS + +HTTP::AnyUA tries to target the L interface, which is a blocking interface. This means +that when you call L, it is supposed to not return until either the response is received +or an error occurs. This doesn't jive well with non-blocking HTTP clients which expect the flow to +reenter an event loop so that the request can complete concurrently. + +In order to reconcile this, a L will be returned instead of the normal hashref response if +the wrapped HTTP client is non-blocking (such as L or L). This +L object may be used to set up callbacks that will be called when the request is completed. +You can call L to know if the response is or will be a L. + +This is typically okay for the end user; since they're the one who chose which HTTP client to use in +the first place, they should know whether they should expect a L or a direct response when +they make an HTTP request, but it does add some burden on you as a module writer because if you ever +need to examine the response, you may need to write code like this: + + my $resp = $any_ua->get('http://www.perl.org/'); + + if ($any_ua->response_is_future) { + $resp->on_done(sub { + my $real_resp = shift; + handle_response($real_resp); + }); + } + else { + handle_response($resp); # response is the real response already + } + +This actually isn't too annoying to deal with in practice, but you can avoid it if you like by +forcing the response to always be a L. Just set the L attribute. Then +you don't need to do an if-else because the response will always be the same type: + + $any_ua->response_is_future(1); + + my $resp = $any_ua->get('http://www.perl.org/'); + + $resp->on_done(sub { # response is always a Future + my $real_resp = shift; + handle_response($real_resp); + }); + +Note that this doesn't make a blocking HTTP client magically non-blocking. The call to L +will still block if the client is blocking, and your "done" callback will simply be fired +immediately. But this does let you write the same code in your module and have it work regardless of +whether the underlying HTTP client is blocking or non-blocking. + +The default behavior is to return a direct hashref response if the HTTP client is blocking and +a L if the client is non-blocking. It's up to you to decide whether or not to set +C, and you should also consider whether you want to expose the possibility of +either type of response or always returning L objects to the end user of your module. It +doesn't matter for users who choose non-blocking HTTP clients because they will be using L +objects either way, but users who know they are using a blocking HTTP client may appreciate not +having to deal with L objects at all. + +=head1 FREQUENTLY ASKED QUESTIONS + +=head2 How do I set up proxying, SSL, cookies, timeout, etc.? + +HTTP::AnyUA provides a common interface for I HTTP clients, not for instantiating or +configuring them. Proxying, SSL, and other custom settings can be configured directly through the +underlying HTTP client; see the documentation for your particular user agent to learn how to +configure these things. + +L is a bit of a special case because there is no instantiated object representing +the client. For this particular user agent, you can configure the backend to pass a default set of +options whenever it calls C. See L: + + $any_ua->backend->options({recurse => 5, timeout => 15}); + +If you are a module writer, you should probably receive a user agent from your end user and leave +this type of configuration up to them. + +=head2 Why use HTTP::AnyUA instead of some other HTTP client? + +Maybe you shouldn't. If you're an end user writing a script or application, you can just pick the +HTTP client that suits you best and use it. For example, if you're writing a L app, +you're not going wrong by using L; it's loaded with features and is well-integrated +with that particular environment. + +As an end user, you I wrap the HTTP client you pick in an HTTP::AnyUA object, but the only +reason to do this is if you prefer using the L interface. + +The real benefit of HTTP::AnyUA (or something like it) is if module writers use it to allow end +users of their modules to be able to plug in whatever HTTP client they want. For example, a module +that implements an API wrapper that has a hard dependency on L or even L +is essentially useless for non-blocking applications. If the same hypothetical module had been +written using HTTP::AnyUA then it would be useful in any scenario. + +=head2 Why use the HTTP::Tiny interface? + +The L interface is simple but provides all the essential functionality needed for +a capable HTTP client and little more. That makes it easy to provide an implementation for, and it +also makes it straightforward for module authors to use. + +Marrying the L interface with L gives us these benefits for both blocking and +non-blocking modules and applications. + +=head1 SPECIFICATION + +This section specifies a standard set of data structures that can be used to make a request and get +a response from a user agent. This is the specification HTTP::AnyUA uses for its programming +interface. It is heavily based on L's interface, and parts of this specification were +adapted or copied verbatim from that module's documentation. The intent is for this specification to +be written such that L is already a compliant implementor of the specification (at least +as of the specification's publication date). + +=head2 The Request + +A request is a tuple of the form C<(Method, URL)> or C<(Method, URL, Options)>. + +=head3 Method + +Method B be a string representing the HTTP verb. This is commonly C<"GET">, C<"POST">, +C<"HEAD">, C<"DELETE">, etc. + +=head3 URL + +URL B be a string representing the remote resource to be acted upon. The URL B have +unsafe characters escaped and international domain names encoded before being passed to the user +agent. A user agent B generated a C<"Host"> header based on the URL in accordance with RFC +2616; a user agent B throw an error if a C<"Host"> header is given with the L. + +=head3 Options + +Options, if present, B be a hash reference containing zero or more of the following keys with +appropriate values. A user agent B support more options than are specified here. + +=head4 headers + +The value for the C key B be a hash reference containing zero or more HTTP header +names (as keys) and header values. The value for a header B be either a string containing the +header value OR an array reference where each item is a string. If the value for a header is an +array reference, the user agent B output the header multiple times with each value in the +array. + +User agents B may add headers, but B replace user-specified headers unless +otherwise documented. + +=head4 content + +The value for the C key B be a string OR a code reference. If the value is a string, +its contents will be included with the request as the body. If the value is a code reference, the +referenced code will be called iteratively to produce the body of the request, and the code B +return an empty string or undef value to indicate the end of the request body. If the value is +a code reference, a user agent B use chunked transfer encoding if it supports it, otherwise +a user agent B completely drain the code of content before sending the request. + +=head4 data_callback + +The value for the C key B be a code reference that will be called zero or more +times, once for each "chunk" of response body received. A user agent B send the entire response +body in one call. The referenced code B be given two arguments; the first is a string +containing a chunk of the response body, the second is an in-progress L. + +=head2 The Response + +A response B be a hash reference containg some required keys and values. A response B +contain some optional keys and values. + +=head3 success + +A response B include a C key, the value of which is a boolean indicating whether or +not the request is to be considered a success (true is a success). Unless otherwise documented, +a successful result means that the operation returned a 2XX status code. + +=head3 url + +A response B include a C key, the value of which is the URL that provided the response. +This is the URL used in the request unless there were redirections, in which case it is the last URL +queried in a rediretion chain. + +=head3 status + +A response B include a C key, the value of which is the HTTP status code of the +response. If an internal exception occurs (e.g. connection error), then the status code B be +C<599>. + +=head3 reason + +A response B include a C key, the value of which is the response phrase returned by +the server OR "Internal Exception" if an internal exception occurred. + +=head3 content + +A response B include a C key, the value of which is the response body returned by the +server OR the text of the exception if an internal exception occurred. This field B be missing +or empty if the server provided no response OR if the body was already provided via +L. + +=head3 headers + +A response B include a C key, the value of which is a hash reference containing +zero or more HTTP header names (as keys) and header values. Keys B be lowercased. The value +for a header B be either a string containing the header value OR an array reference where each +item is the value of one of the repeated headers. + +=head3 redirects + +A response B include a C key, the value of which is an array reference of one or +more responses from redirections that occurred to fulfill the current request, in chronological +order. + +=head1 ENVIRONMENT + +=for :list +* C - If 1, print some info useful for debugging to C. + +=head1 CAVEATS + +Not all HTTP clients implement the same features or in the same ways. While the point of HTTP::AnyUA +is to hide those differences, you may notice some (hopefully) I differences when +plugging in different clients. For example, L sets some headers on the response such +as C and C that won't appear when using other clients. Little differences +like these probably aren't big deal. Other differences may be a bigger deal, depending on what's +important to you. For example, some clients (like L) may do chunked transfer encoding in +situations where other clients won't (probably because they don't support it). It's not a goal of +this project to eliminate I of the differences, but if you come across a difference that is +significant enough that you think you need to detect the user agent and write special logic, I would +like to learn about your use case. + +=head1 SEE ALSO + +These modules share similar goals or provide overlapping functionality: + +=for :list +* L +* L +* L +* L + +=cut + +use 5.010; +use warnings; +use strict; + +our $VERSION = '9999.999'; # VERSION + +use HTTP::AnyUA::Util; +use Module::Loader; +use Scalar::Util; + + +our $BACKEND_NAMESPACE; +our @BACKENDS; +our %REGISTERED_BACKENDS; + +BEGIN { + $BACKEND_NAMESPACE = __PACKAGE__ . '::Backend'; +} + + +sub _debug_log { print STDERR join(' ', @_), "\n" if $ENV{PERL_HTTP_ANYUA_DEBUG} } + +sub _croak { require Carp; Carp::croak(@_) } +sub _usage { _croak("Usage: @_\n") } + + +=method new + + $any_ua = HTTP::AnyUA->new(ua => $user_agent, %attr); + $any_ua = HTTP::AnyUA->new($user_agent, %attr); + +Construct a new HTTP::AnyUA. + +=cut + +sub new { + my $class = shift; + unshift @_, 'ua' if @_ % 2; + my %args = @_; + $args{ua} or _usage(q{HTTP::AnyUA->new(ua => $user_agent, %attr)}); + + my $self; + my @attr = qw(ua backend response_is_future); + + for my $attr (@attr) { + $self->{$attr} = $args{$attr} if defined $args{$attr}; + } + + bless $self, $class; + + $self->_debug_log('Created with user agent', $self->ua); + + # call accessors to get the checks to run + $self->ua; + $self->response_is_future($args{response_is_future}) if defined $args{response_is_future}; + + return $self; +} + +=attr ua + +Get the user agent that was passed to L. + +=cut + +sub ua { shift->{ua} or _croak 'User agent is required' } + +=attr response_is_future + +Get and set whether or not responses are L objects. + +=cut + +sub response_is_future { + my $self = shift; + my $val = shift; + + if (defined $val) { + $self->_debug_log('Set response_is_future to', $val ? 'ON' : 'OFF'); + + $self->_check_response_is_future($val); + $self->{response_is_future} = $val; + + $self->_module_loader->load('Future') if $self->{response_is_future}; + } + elsif (!defined $self->{response_is_future} && $self->{backend}) { + $self->{response_is_future} = $self->backend->response_is_future; + + $self->_module_loader->load('Future') if $self->{response_is_future}; + } + + return $self->{response_is_future} || ''; +} + +=attr backend + +Get the backend instance. You normally shouldn't need this. + +=cut + +sub backend { + my $self = shift; + + return $self->{backend} if defined $self->{backend}; + + $self->{backend} = $self->_build_backend; + $self->_check_response_is_future($self->response_is_future); + + return $self->{backend}; +} + +=method request + + $response = $any_ua->request($method, $url); + $response = $any_ua->request($method, $url, \%options); + +Make a L, get a L. + +Compare to L. + +=cut + +sub request { + my ($self, $method, $url, $args) = @_; + $args ||= {}; + @_ == 3 || (@_ == 4 && ref $args eq 'HASH') + or _usage(q{$any_ua->request($method, $url, \%options)}); + + my $resp = eval { $self->backend->request(uc($method) => $url, $args) }; + if (my $err = $@) { + return $self->_wrap_internal_exception($err); + } + + return $self->_wrap_response($resp); +} + +=method get, head, put, post, delete + + $response = $any_ua->get($url); + $response = $any_ua->get($url, \%options); + $response = $any_ua->head($url); + $response = $any_ua->head($url, \%options); + # etc. + +Shortcuts for L where the method is the method name rather than the first argument. + +Compare to LheadEputEpostEdelete>. + +=cut + +# adapted from HTTP/Tiny.pm +for my $sub_name (qw{get head put post delete}) { + my %swap = (SUBNAME => $sub_name, METHOD => uc($sub_name)); + my $code = q[ +sub {{SUBNAME}} { + my ($self, $url, $args) = @_; + @_ == 2 || (@_ == 3 && ref $args eq 'HASH') + or _usage(q{$any_ua->{{SUBNAME}}($url, \%options)}); + return $self->request('{{METHOD}}', $url, $args); +} + ]; + $code =~ s/\{\{([A-Z_]+)\}\}/$swap{$1}/ge; + eval $code; ## no critic +} + +=method post_form + + $response = $any_ua->post_form($url, $formdata); + $response = $any_ua->post_form($url, $formdata, \%options); + +Does a C request with the form data encoded and sets the C header to +C. + +Compare to L. + +=cut + +# adapted from HTTP/Tiny.pm +sub post_form { + my ($self, $url, $data, $args) = @_; + (@_ == 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; + } + delete $args->{headers}; + + return $self->request(POST => $url, { + %$args, + content => HTTP::AnyUA::Util::www_form_urlencode($data), + headers => { + %$headers, + 'content-type' => 'application/x-www-form-urlencoded', + }, + }); +} + +=method mirror + + $response = $http->mirror($url, $filepath, \%options); + if ($response->{success}) { + print "$filepath is up to date\n"; + } + +Does a C request and saves the downloaded document to a file. If the file already exists, its +timestamp will be sent using the C request header (which you can override). If +the server responds with a C<304> (Not Modified) status, the C field will be true; this is +usually only the case for C<2XX> statuses. If the server responds with a C header, +the file will be updated to have the same modification timestamp. + +Compare to L. This version differs slightly in that this returns internal +exception responses (for cases like being unable to write the file locally, etc.) rather than +actually throwing the exceptions. The reason for this is that exceptions as responses are easier to +deal with for non-blocking HTTP clients, and the fact that this method throws exceptions in +L seems like an inconsistency in its interface. + +=cut + +# adapted from HTTP/Tiny.pm +sub mirror { + my ($self, $url, $file, $args) = @_; + @_ == 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; + } + + if (-e $file and my $mtime = (stat($file))[9]) { + $args->{headers}{'if-modified-since'} ||= HTTP::AnyUA::Util::http_date($mtime); + } + my $tempfile = $file . int(rand(2**31)); + + # set up the response body to be written to the file + require Fcntl; + sysopen(my $fh, $tempfile, Fcntl::O_CREAT()|Fcntl::O_EXCL()|Fcntl::O_WRONLY()) + or return $self->_wrap_internal_exception(qq/Error: Could not create temporary file $tempfile for downloading: $!\n/); + binmode $fh; + $args->{data_callback} = sub { print $fh $_[0] }; + + my $resp = $self->request(GET => $url, $args); + + my $finish = sub { + my $resp = shift; + + close $fh + or return HTTP::AnyUA::Util::internal_exception(qq/Error: Caught error closing temporary file $tempfile: $!\n/); + + if ($resp->{success}) { + rename($tempfile, $file) + or return HTTP::AnyUA::Util::internal_exception(qq/Error replacing $file with $tempfile: $!\n/); + my $lm = $resp->{headers}{'last-modified'}; + if ($lm and my $mtime = HTTP::AnyUA::Util::parse_http_date($lm)) { + utime($mtime, $mtime, $file); + } + } + unlink($tempfile); + + $resp->{success} ||= $resp->{status} eq '304'; + + return $resp; + }; + + if ($self->response_is_future) { + return $resp->followed_by(sub { + my $future = shift; + my @resp = $future->is_done ? $future->get : $future->failure; + my $resp = $finish->(@resp); + if ($resp->{success}) { + return Future->done(@resp); + } + else { + return Future->fail(@resp); + } + }); + } + else { + return $finish->($resp); + } +} + +=method register_backend + + HTTP::AnyUA->register_backend($user_agent_package => $backend_package); + HTTP::AnyUA->register_backend('MyAgent' => 'MyBackend'); # HTTP::AnyUA::Backend::MyBackend + HTTP::AnyUA->register_backend('LWP::UserAgent' => '+SpecialBackend'); # SpecialBackend + +Register a backend for a new user agent type or override a default backend. Backend packages are +relative to the C namespace unless prefixed with a C<+>. + +If you only need to set a backend as a one-off thing, you could also pass an instantiated backend to +L. + +=cut + +sub register_backend { + my ($class, $ua_type, $backend_class) = @_; + @_ == 3 or _usage(q{HTTP::AnyUA->register_backend($ua_type, $backend_package)}); + + if ($backend_class) { + $backend_class = "${BACKEND_NAMESPACE}::${backend_class}" unless $backend_class =~ s/^\+//; + $REGISTERED_BACKENDS{$ua_type} = $backend_class; + } + else { + delete $REGISTERED_BACKENDS{$ua_type}; + } +} + + +# turn a response into a Future if it needs to be +sub _wrap_response { + my $self = shift; + my $resp = shift; + + if ($self->response_is_future && !$self->backend->response_is_future) { + # wrap the response in a Future + if ($resp->{success}) { + $self->_debug_log('Wrapped successful response in a Future'); + $resp = Future->done($resp); + } + else { + $self->_debug_log('Wrapped failed response in a Future'); + $resp = Future->fail($resp); + } + } + + return $resp; +} + +sub _wrap_internal_exception { shift->_wrap_response(HTTP::AnyUA::Util::internal_exception(@_)) } + +# get a module loader object +sub _module_loader { shift->{_module_loader} ||= Module::Loader->new } + +# get a list of potential backends that may be able to handle the user agent +sub _build_backend { + my $self = shift; + my $ua = shift || $self->ua or _croak 'User agent is required'; + + my $ua_type = Scalar::Util::blessed($ua); + + my @classes; + + if ($ua_type) { + push @classes, $REGISTERED_BACKENDS{$ua_type} if $REGISTERED_BACKENDS{$ua_type}; + + push @classes, "${BACKEND_NAMESPACE}::${ua_type}"; + + if (!@BACKENDS) { + # search for some backends to try + @BACKENDS = sort $self->_module_loader->find_modules($BACKEND_NAMESPACE); + $self->_debug_log('Found backends to try (' . join(', ', @BACKENDS) . ')'); + } + + for my $backend_type (@BACKENDS) { + my $plugin = $backend_type; + $plugin =~ s/^\Q${BACKEND_NAMESPACE}\E:://; + push @classes, $backend_type if $ua->isa($plugin); + } + } + else { + push @classes, $REGISTERED_BACKENDS{$ua} if $REGISTERED_BACKENDS{$ua}; + push @classes, "${BACKEND_NAMESPACE}::${ua}"; + } + + for my $class (@classes) { + if (eval { $self->_module_loader->load($class); 1 }) { + $self->_debug_log("Found usable backend (${class})"); + return $class->new($self->ua); + } + else { + $self->_debug_log($@); + } + } + + _croak 'Cannot find a usable backend that supports the given user agent'; +} + +# make sure the response_is_future setting is compatible with the backend +sub _check_response_is_future { + my $self = shift; + my $val = shift; + + # make sure the user agent is not non-blocking + if (!$val && $self->{backend} && $self->backend->response_is_future) { + _croak 'Cannot disable response_is_future with a non-blocking user agent'; + } +} + +1; diff --git a/lib/HTTP/AnyUA/Backend.pm b/lib/HTTP/AnyUA/Backend.pm new file mode 100644 index 0000000..26ccb2d --- /dev/null +++ b/lib/HTTP/AnyUA/Backend.pm @@ -0,0 +1,129 @@ +package HTTP::AnyUA::Backend; +# ABSTRACT: A base class for HTTP::AnyUA backends + +=head1 SYNOPSIS + + package HTTP::AnyUA::Backend::MyUserAgent; + + use parent 'HTTP::AnyUA::Backend'; + + sub response_is_future { 0 } + + sub request { + my ($self, $method, $url, $args) = @_; + + my $ua = $self->ua; + + # Here is where you transform the arguments into a request that $ua + # understands, make the request against $ua and get a response, and + # transform the response to the expected hashref form. + + my $resp = $ua->make_request(); + + return $resp; + } + + ### Non-blocking user agents return responses as Future objects: + + sub response_is_future { 1 } + + sub request { + my ($self, $method, $url, $args) = @_; + + my $ua = $self->ua; + + my $future = Future->new; + + # Again, this example glosses over transforming the request and response + # to and from the actual user agent, but such details are the whole + # point of a backend. + + $ua->nonblocking_callback(sub { + my $resp = shift; + + if ($resp->{success}) { + $future->done($resp); + } + else { + $future->fail($resp); + } + }); + + return $future; + } + +=head1 DESCRIPTION + +This module provides an interface for an L "backend," which is an adapter that adds +support for using a type of user agent with L. + +This class should not be instantiated directly, but it may be convenient for backend implementations +to subclass it. + +At its core, a backend simply takes a set of standard arguments that represent an HTTP request, +transforms that request into a form understood by an underlying user agent, calls upon the user +agent to make the request and get a response, and then transforms that response into a standard +form. The standard forms for the request and response are based on L's arguments and +return value to and from its L method. + +=head1 SEE ALSO + +=for :list +* L - Explanation of the request arguments +* L - Explanation of the response + +=cut + +use warnings; +use strict; + +our $VERSION = '9999.999'; # VERSION + + +=method new + + $backend = HTTP::AnyUA::Backend::MyUserAgent->new($my_user_agent); + +Construct a new backend. + +=cut + +sub new { + my $class = shift; + my $ua = shift or die 'User agent is required'; + bless {ua => $ua}, $class; +} + +=method request + + $response = $backend->request($method => $url, \%options); + +Make a request, get a response. + +This must be overridden by implementations. + +=cut + +sub request { + die 'Not yet implemented'; +} + +=attr ua + +Get the user agent that was passed to L. + +=cut + +sub ua { shift->{ua} } + +=attr response_is_future + +Get whether or not responses are L objects. Default is false. + +This may be overridden by implementations. + +=cut + +sub response_is_future { 0 } + +1; diff --git a/lib/HTTP/AnyUA/Backend/AnyEvent/HTTP.pm b/lib/HTTP/AnyUA/Backend/AnyEvent/HTTP.pm new file mode 100644 index 0000000..14f3b28 --- /dev/null +++ b/lib/HTTP/AnyUA/Backend/AnyEvent/HTTP.pm @@ -0,0 +1,146 @@ +package HTTP::AnyUA::Backend::AnyEvent::HTTP; +# ABSTRACT: A unified programming interface for AnyEvent::HTTP + +=head1 DESCRIPTION + +This module adds support for the HTTP client L to be used with the unified +programming interface provided by L. + +=head1 SEE ALSO + +=for :list +* L + +=cut + +use warnings; +use strict; + +our $VERSION = '9999.999'; # VERSION + +use parent 'HTTP::AnyUA::Backend'; + +use Future; +use HTTP::AnyUA::Util; + + +=method options + + $backend->options(\%options); + +Get and set default arguments to C. + +=cut + +sub options { @_ == 2 ? $_[0]->{options} = pop : $_[0]->{options} } + +sub response_is_future { 1 } + +sub request { + my $self = shift; + my ($method, $url, $args) = @_; + + my %opts = $self->_munge_request($method, $url, $args); + my $future = Future->new; + + require AnyEvent::HTTP; + AnyEvent::HTTP::http_request($method => $url, %opts, sub { + my $resp = $self->_munge_response(@_, $args->{data_callback}); + + if ($resp->{success}) { + $future->done($resp); + } + else { + $future->fail($resp); + } + }); + + return $future; +} + + +sub _munge_request { + my $self = shift; + my $method = shift; + my $url = shift; + my $args = shift || {}; + + my %opts = %{$self->options || {}}; + + if (my $headers = $args->{headers}) { + # munge headers + my %headers; + for my $header (keys %$headers) { + my $value = $headers->{$header}; + $value = join(', ', @$value) if ref($value) eq 'ARRAY'; + $headers{$header} = $value; + } + $opts{headers} = \%headers; + } + + my @url_parts = HTTP::AnyUA::Util::split_url($url); + if (my $auth = $url_parts[4] and !$opts{headers}{'authorization'}) { + # handle auth in the URL + require MIME::Base64; + $opts{headers}{'authorization'} = 'Basic ' . MIME::Base64::encode_base64($auth, ''); + } + + my $content = HTTP::AnyUA::Util::coderef_content_to_string($args->{content}); + $opts{body} = $content if $content; + + if (my $data_cb = $args->{data_callback}) { + # stream the response + $opts{on_body} = sub { + my $data = shift; + $data_cb->($data, $self->_munge_response(undef, @_)); + 1; # continue + }; + } + + return %opts; +} + +sub _munge_response { + my $self = shift; + my $data = shift; + my $headers = shift; + my $data_cb = shift; + + # copy headers because http_request will continue to use the original + my %headers = %$headers; + + my $code = delete $headers{Status}; + my $reason = delete $headers{Reason}; + my $url = delete $headers{URL}; + + my $resp = { + success => 200 <= $code && $code <= 299, + url => $url, + status => $code, + reason => $reason, + headers => \%headers, + }; + + my $version = delete $headers{HTTPVersion}; + $resp->{protocol} = "HTTP/$version" if $version; + + $resp->{content} = $data if $data && !$data_cb; + + my @redirects; + my $redirect = delete $headers{Redirect}; + while ($redirect) { + # delete pseudo-header first so redirects aren't recursively munged + my $next = delete $redirect->[1]{Redirect}; + unshift @redirects, $self->_munge_response(@$redirect); + $redirect = $next; + } + $resp->{redirects} = \@redirects if @redirects; + + if (590 <= $code && $code <= 599) { + HTTP::AnyUA::Util::internal_exception($reason, $resp); + } + + return $resp; +} + +1; diff --git a/lib/HTTP/AnyUA/Backend/Furl.pm b/lib/HTTP/AnyUA/Backend/Furl.pm new file mode 100644 index 0000000..b25642f --- /dev/null +++ b/lib/HTTP/AnyUA/Backend/Furl.pm @@ -0,0 +1,73 @@ +package HTTP::AnyUA::Backend::Furl; +# ABSTRACT: A unified programming interface for Furl + +=head1 DESCRIPTION + +This module adds support for the HTTP client L to be used with the unified programming +interface provided by L. + +=head1 CAVEATS + +=for :list +* L doesn't keep a list of requests and responses along a redirect chain. As such, the C +field in the response is always the same as the URL of the original request, and the C +field is never used. + +=head1 SEE ALSO + +=for :list +* L + +=cut + +use warnings; +use strict; + +our $VERSION = '9999.999'; # VERSION + +use parent 'HTTP::AnyUA::Backend'; + +use HTTP::AnyUA::Util; + + +sub request { + my $self = shift; + my ($method, $url, $args) = @_; + + local $args->{content} = HTTP::AnyUA::Util::coderef_content_to_string($args->{content}); + + my $request = HTTP::AnyUA::Util::native_to_http_request(@_); + my $ua_resp = $self->ua->request($request); + + return $self->_munge_response($ua_resp, $args->{data_callback}); +} + +sub _munge_response { + my $self = shift; + my $ua_resp = shift; + my $data_cb = shift; + + my $resp = { + success => !!$ua_resp->is_success, + url => $ua_resp->request->uri->as_string, + status => $ua_resp->code, + reason => $ua_resp->message, + headers => HTTP::AnyUA::Util::http_headers_to_native($ua_resp->headers), + }; + + $resp->{protocol} = $ua_resp->protocol if $ua_resp->protocol; + + if ($resp->{headers}{'x-internal-response'}) { + HTTP::AnyUA::Util::internal_exception($ua_resp->content, $resp); + } + elsif ($data_cb) { + $data_cb->($ua_resp->content, $resp); + } + else { + $resp->{content} = $ua_resp->content; + } + + return $resp; +} + +1; diff --git a/lib/HTTP/AnyUA/Backend/HTTP/AnyUA.pm b/lib/HTTP/AnyUA/Backend/HTTP/AnyUA.pm new file mode 100644 index 0000000..4c3aa5c --- /dev/null +++ b/lib/HTTP/AnyUA/Backend/HTTP/AnyUA.pm @@ -0,0 +1,38 @@ +package HTTP::AnyUA::Backend::HTTP::AnyUA; +# ABSTRACT: A unified programming interface for HTTP::AnyUA + +=head1 DESCRIPTION + +This module adds support for the HTTP client L to be used with the unified programming +interface provided by L. + +Mind blown. + +=head1 SEE ALSO + +=for :list +* L + +=cut + +use warnings; +use strict; + +our $VERSION = '9999.999'; # VERSION + +use parent 'HTTP::AnyUA::Backend'; + + +sub response_is_future { + my $self = shift; + + return $self->ua->response_is_future; +} + +sub request { + my $self = shift; + + return $self->ua->request(@_); +} + +1; diff --git a/lib/HTTP/AnyUA/Backend/HTTP/Tiny.pm b/lib/HTTP/AnyUA/Backend/HTTP/Tiny.pm new file mode 100644 index 0000000..8fdaa57 --- /dev/null +++ b/lib/HTTP/AnyUA/Backend/HTTP/Tiny.pm @@ -0,0 +1,30 @@ +package HTTP::AnyUA::Backend::HTTP::Tiny; +# ABSTRACT: A unified programming interface for HTTP::Tiny + +=head1 DESCRIPTION + +This module adds support for the HTTP client L to be used with the unified programming +interface provided by L. + +=head1 SEE ALSO + +=for :list +* L + +=cut + +use warnings; +use strict; + +our $VERSION = '9999.999'; # VERSION + +use parent 'HTTP::AnyUA::Backend'; + + +sub request { + my $self = shift; + + return $self->ua->request(@_); +} + +1; diff --git a/lib/HTTP/AnyUA/Backend/LWP/UserAgent.pm b/lib/HTTP/AnyUA/Backend/LWP/UserAgent.pm new file mode 100644 index 0000000..0839f01 --- /dev/null +++ b/lib/HTTP/AnyUA/Backend/LWP/UserAgent.pm @@ -0,0 +1,75 @@ +package HTTP::AnyUA::Backend::LWP::UserAgent; +# ABSTRACT: A unified programming interface for LWP::UserAgent + +=head1 DESCRIPTION + +This module adds support for the HTTP client L to be used with the unified +programming interface provided by L. + +=head1 SEE ALSO + +=for :list +* L + +=cut + +use warnings; +use strict; + +our $VERSION = '9999.999'; # VERSION + +use parent 'HTTP::AnyUA::Backend'; + +use HTTP::AnyUA::Util; + + +sub request { + my $self = shift; + my ($method, $url, $args) = @_; + + my $r = HTTP::AnyUA::Util::native_to_http_request(@_); + + my $ua_resp = $self->ua->request($r); + + return $self->_munge_response($ua_resp, $args->{data_callback}); +} + + +sub _munge_response { + my $self = shift; + my $ua_resp = shift; + my $data_cb = shift; + my $recurse = shift; + + my $resp = { + success => !!$ua_resp->is_success, + url => $ua_resp->request->uri->as_string, + status => $ua_resp->code, + reason => $ua_resp->message, + headers => HTTP::AnyUA::Util::http_headers_to_native($ua_resp->headers), + }; + + $resp->{protocol} = $ua_resp->protocol if $ua_resp->protocol; + + if (!$recurse) { + for my $redirect ($ua_resp->redirects) { + push @{$resp->{redirects} ||= []}, $self->_munge_response($redirect, undef, 1); + } + } + + my $content_ref = $ua_resp->content_ref; + + if (($resp->{headers}{'client-warning'} || '') eq 'Internal response') { + HTTP::AnyUA::Util::internal_exception($$content_ref, $resp); + } + elsif ($data_cb) { + $data_cb->($$content_ref, $resp); + } + else { + $resp->{content} = $$content_ref; + } + + return $resp; +} + +1; diff --git a/lib/HTTP/AnyUA/Backend/Mojo/UserAgent.pm b/lib/HTTP/AnyUA/Backend/Mojo/UserAgent.pm new file mode 100644 index 0000000..003d10f --- /dev/null +++ b/lib/HTTP/AnyUA/Backend/Mojo/UserAgent.pm @@ -0,0 +1,155 @@ +package HTTP::AnyUA::Backend::Mojo::UserAgent; +# ABSTRACT: A unified programming interface for Mojo::UserAgent + +=head1 DESCRIPTION + +This module adds support for the HTTP client L to be used with the unified +programming interface provided by L. + +=head1 CAVEATS + +=for :list +* The C field in the response has the auth portion (if any) removed from the URL. + +=head1 SEE ALSO + +=for :list +* L + +=cut + +use warnings; +use strict; + +our $VERSION = '9999.999'; # VERSION + +use parent 'HTTP::AnyUA::Backend'; + +use Future; +use Scalar::Util; + + +sub response_is_future { 1 } + +sub request { + my $self = shift; + my ($method, $url, $args) = @_; + + my $future = Future->new; + + my $tx = $self->_munge_request(@_); + + $self->ua->start($tx => sub { + my $ua = shift; + my $tx = shift; + + my $resp = $self->_munge_response($tx, $args->{data_callback}); + + if ($resp->{success}) { + $future->done($resp); + } + else { + $future->fail($resp); + } + }); + + return $future; +} + + +sub _munge_request { + my $self = shift; + my $method = shift; + my $url = shift; + my $args = shift; + + my $headers = $args->{headers} || {}; + my $content = $args->{content}; + + my @content; + + my $content_length; + if ($content) { + for my $header (keys %$headers) { + if (lc($header) eq 'content-length') { + $content_length = $headers->{$header}; + last; + } + } + + # if we don't know the length we have to just read it all in + $content = HTTP::AnyUA::Util::coderef_content_to_string($content) if !$content_length; + + push @content, $content if ref($content) ne 'CODE'; + } + + my $tx = $self->ua->build_tx($method => $url => $headers => @content); + + if (ref($content) eq 'CODE') { + $tx->req->headers->content_length($content_length); + # stream the request + my $drain; + $drain = sub { + my $body = shift; + my $chunk = $content->() || ''; + undef $drain if !$chunk; + $body->write($chunk, $drain); + }; + $tx->req->content->$drain; + } + + if (my $data_cb = $args->{data_callback}) { + # stream the response + my $tx_copy = $tx; + Scalar::Util::weaken($tx_copy); + $tx->res->content->unsubscribe('read')->on(read => sub { + my ($content, $bytes) = @_; + my $resp = $self->_munge_response($tx_copy, undef); + $data_cb->($bytes, $resp); + }); + } + + return $tx; +} + +sub _munge_response { + my $self = shift; + my $tx = shift; + my $data_cb = shift; + my $recurse = shift; + + my $resp = { + success => !!$tx->res->is_success, + url => $tx->req->url->to_string, + status => $tx->res->code, + reason => $tx->res->message, + headers => {}, + }; + + # lowercase header keys + my $headers = $tx->res->headers->to_hash; + for my $header (keys %$headers) { + $resp->{headers}{lc($header)} = delete $headers->{$header}; + } + + my $version = $tx->res->version; + $resp->{protocol} = "HTTP/$version" if $version; + + if (!$recurse) { + for my $redirect (@{$tx->redirects}) { + push @{$resp->{redirects} ||= []}, $self->_munge_response($redirect, undef, 1); + } + } + + my $err = $tx->error; + if ($err and !$err->{code}) { + return HTTP::AnyUA::Util::internal_exception($err->{message}, $resp); + } + + my $body = $tx->res->body; + $resp->{content} = $body if $body && !$data_cb; + + return $resp; +} + +1; diff --git a/lib/HTTP/AnyUA/Backend/Net/Curl/Easy.pm b/lib/HTTP/AnyUA/Backend/Net/Curl/Easy.pm new file mode 100644 index 0000000..7c645cd --- /dev/null +++ b/lib/HTTP/AnyUA/Backend/Net/Curl/Easy.pm @@ -0,0 +1,230 @@ +package HTTP::AnyUA::Backend::Net::Curl::Easy; +# ABSTRACT: A unified programming interface for Net::Curl::Easy + +=head1 DESCRIPTION + +This module adds support for the HTTP client L to be used with the unified +programming interface provided by L. + +=head1 CAVEATS + +=for :list +* The C field in the response is currently unsupported. + +=head1 SEE ALSO + +=for :list +* L + +=cut + +use warnings; +use strict; + +our $VERSION = '9999.999'; # VERSION + +use parent 'HTTP::AnyUA::Backend'; + +use HTTP::AnyUA::Util; +use Scalar::Util; + + +sub request { + my $self = shift; + my ($method, $url, $args) = @_; + + my $ua = $self->ua; + + # reset + $ua->setopt(Net::Curl::Easy::CURLOPT_HTTPGET(), 0); + $ua->setopt(Net::Curl::Easy::CURLOPT_NOBODY(), 0); + $ua->setopt(Net::Curl::Easy::CURLOPT_READFUNCTION(), undef); + $ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDS(), undef); + $ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDSIZE(), 0); + + if ($method eq 'GET') { + $ua->setopt(Net::Curl::Easy::CURLOPT_HTTPGET(), 1); + } + elsif ($method eq 'HEAD') { + $ua->setopt(Net::Curl::Easy::CURLOPT_NOBODY(), 1); + } + + if (my $content = $args->{content}) { + if (ref($content) eq 'CODE') { + my $content_length; + for my $header (keys %{$args->{headers} || {}}) { + if (lc($header) eq 'content-length') { + $content_length = $args->{headers}{$header}; + last; + } + } + + if ($content_length) { + my $chunk; + $ua->setopt(Net::Curl::Easy::CURLOPT_READFUNCTION(), sub { + my $ua = shift; + my $maxlen = shift; + + if (!$chunk) { + $chunk = $content->(); + return 0 if !$chunk; + } + + my $part = substr($chunk, 0, $maxlen, ''); + return \$part; + }); + $ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDSIZE(), $content_length); + } + else { + # if we don't know the length we have to just read it all in + $content = HTTP::AnyUA::Util::coderef_content_to_string($content); + } + } + if (ref($content) ne 'CODE') { + $ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDS(), $content); + $ua->setopt(Net::Curl::Easy::CURLOPT_POSTFIELDSIZE(), length $content); + } + } + + $ua->setopt(Net::Curl::Easy::CURLOPT_URL(), $url); + $ua->setopt(Net::Curl::Easy::CURLOPT_CUSTOMREQUEST(), $method); + + # munge headers + my @headers; + for my $header (keys %{$args->{headers} || {}}) { + my $value = $args->{headers}{$header}; + my @values = ref($value) eq 'ARRAY' ? @$value : $value; + for my $v (@values) { + push @headers, "${header}: $v"; + } + } + $ua->setopt(Net::Curl::Easy::CURLOPT_HTTPHEADER(), \@headers) if @headers; + + my @hdrdata; + + $ua->setopt(Net::Curl::Easy::CURLOPT_HEADERFUNCTION(), sub { + my $ua = shift; + my $data = shift; + my $size = length $data; + + my %headers = _parse_header($data); + + if ($headers{Status}) { + push @hdrdata, {}; + } + + my $resp_headers = $hdrdata[-1]; + + for my $key (keys %headers) { + if (!$resp_headers->{$key}) { + $resp_headers->{$key} = $headers{$key}; + } + else { + if (ref($resp_headers->{$key}) ne 'ARRAY') { + $resp_headers->{$key} = [$resp_headers->{$key}]; + } + push @{$resp_headers->{$key}}, $headers{$key}; + } + } + + return $size; + }); + + my $resp_body = ''; + + my $data_cb = $args->{data_callback}; + my $copy = $self; + Scalar::Util::weaken($copy); + $ua->setopt(Net::Curl::Easy::CURLOPT_WRITEFUNCTION(), sub { + my $ua = shift; + my $data = shift; + my $fh = shift; + my $size = length $data; + + if ($data_cb) { + my $resp = $copy->_munge_response(undef, undef, [@hdrdata], $data_cb); + $data_cb->($data, $resp); + } + else { + print $fh $data; + } + + return $size; + }); + open(my $fileb, '>', \$resp_body); + $ua->setopt(Net::Curl::Easy::CURLOPT_WRITEDATA(), $fileb); + + eval { $ua->perform }; + my $ret = $@; + + return $self->_munge_response($ret, $resp_body, [@hdrdata], $data_cb); +} + + +sub _munge_response { + my $self = shift; + my $error = shift; + my $body = shift; + my $hdrdata = shift; + my $data_cb = shift; + + my %headers = %{pop @$hdrdata || {}}; + + my $code = delete $headers{Status} || $self->ua->getinfo(Net::Curl::Easy::CURLINFO_RESPONSE_CODE()) || 599; + my $reason = delete $headers{Reason}; + my $url = $self->ua->getinfo(Net::Curl::Easy::CURLINFO_EFFECTIVE_URL()); + + my $resp = { + success => 200 <= $code && $code <= 299, + url => $url, + status => $code, + reason => $reason, + headers => \%headers, + }; + + my $version = delete $headers{HTTPVersion} || _http_version($self->ua->getinfo(Net::Curl::Easy::CURLINFO_HTTP_VERSION())); + $resp->{protocol} = "HTTP/$version" if $version; + + # We have the headers for the redirect chain in $hdrdata, but we don't have the contents, and we + # would also need to reconstruct the URLs. + + if ($error) { + my $err = $self->ua->strerror($error); + return HTTP::AnyUA::Util::internal_exception($err, $resp); + } + + $resp->{content} = $body if $body && !$data_cb; + + return $resp; +} + +# get the HTTP version according to the user agent object +sub _http_version { + my $version = shift; + return $version == Net::Curl::Easy::CURL_HTTP_VERSION_1_0() ? '1.0' : + $version == Net::Curl::Easy::CURL_HTTP_VERSION_1_1() ? '1.1' : + $version == Net::Curl::Easy::CURL_HTTP_VERSION_2_0() ? '2.0' : ''; +} + +# parse a header line (or status line) and return as key-value pairs +sub _parse_header { + my $data = shift; + + $data =~ s/[\x0A\x0D]*$//; + + if ($data =~ m!^HTTP/([0-9.]+) [\x09\x20]+ (\d{3}) [\x09\x20]+ ([^\x0A\x0D]*)!x) { + return ( + HTTPVersion => $1, + Status => $2, + Reason => $3, + ); + } + + my ($key, $val) = split(/:\s*/, $data, 2); + return if !$key; + return (lc($key) => $val); +} + +# no Net::Curl::Easy; + +1; diff --git a/lib/HTTP/AnyUA/Util.pm b/lib/HTTP/AnyUA/Util.pm new file mode 100644 index 0000000..580b850 --- /dev/null +++ b/lib/HTTP/AnyUA/Util.pm @@ -0,0 +1,285 @@ +package HTTP::AnyUA::Util; +# ABSTRACT: Utility subroutines for HTTP::AnyUA backends + +use warnings; +use strict; + +our $VERSION = '9999.999'; # VERSION + +use Exporter qw(import); + + +our @EXPORT_OK = qw( + http_headers_to_native + native_to_http_request + coderef_content_to_string + internal_exception + http_date + parse_http_date + uri_escape + www_form_urlencode +); + + +sub _croak { require Carp; Carp::croak(@_) } +sub _usage { _croak("Usage: @_\n") } + +=func coderef_content_to_string + + $content = coderef_content_to_string(\&code); + $content = coderef_content_to_string($content); # noop + +Convert a coderef into a string of content by iteratively calling the coderef and concatenating the +chunks it provides until the coderef returns undef or an empty string. + +=cut + +sub coderef_content_to_string { + my $content = shift; + + return $content if !$content; + + if (ref($content) eq 'CODE') { + # drain the request body + my $body = ''; + while (my $chunk = $content->()) { + $body .= $chunk; + } + $content = $body; + } + + return $content; +} + +=func native_to_http_request + + $http_request = native_to_http_request($method, $url); + $http_request = native_to_http_request($method, $url, \%options); + +Convert a "native" request tuple to an L object. + +=cut + +sub native_to_http_request { + my $method = shift; + my $url = shift; + my $args = shift || {}; + + my $headers = []; + my $content = $args->{content}; # works as either scalar or coderef + + # flatten headers + for my $header (keys %{$args->{headers} || {}}) { + my $value = $args->{headers}{$header}; + my @values = ref($value) eq 'ARRAY' ? @$value : ($value); + for my $v (@values) { + push @$headers, ($header => $v); + } + } + + require HTTP::Request; + return HTTP::Request->new($method, $url, $headers, $content); +} + +=func http_headers_to_native + + $headers = http_headers_to_native($http_headers); + +Convert an L object to a "native" hashref. + +=cut + +sub http_headers_to_native { + my $http_headers = shift; + + my $native; + + for my $header ($http_headers->header_field_names) { + my @values = $http_headers->header($header); + $native->{lc($header)} = @values == 1 ? $values[0] : [@values]; + } + + return $native; +} + +=func internal_exception + + $response = internal_exception($content); + $response = internal_exception($content, $response); + +Create an internal exception response. If an existing response is passed, that response will have +its fields modified to become an internal exception. + +=cut + +sub internal_exception { + my $e = shift or _usage(q{internal_exception($exception)}); + my $resp = shift || {}; + + $e = "$e"; + + $resp->{headers}{'client-original-status'} = $resp->{status} if $resp->{status}; + $resp->{headers}{'client-original-reason'} = $resp->{reason} if $resp->{reason}; + + $resp->{success} = ''; + $resp->{status} = 599; + $resp->{reason} = 'Internal Exception'; + $resp->{content} = $e; + $resp->{headers}{'content-type'} = 'text/plain'; + $resp->{headers}{'content-length'} = length $e; + + return $resp; +} + +=func split_url + + ($scheme, $host, $port, $path_query, $auth) = split_url($url); + +Split a URL into its components. + +=cut + +# adapted from HTTP/Tiny.pm +sub split_url { + my $url = shift or _usage(q{split_url($url)}); + + # URI regex adapted from the URI module + my ($scheme, $host, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)> + or die(qq/Cannot parse URL: '$url'\n/); + + $scheme = lc $scheme; + $path_query = "/$path_query" unless $path_query =~ m<\A/>; + + my $auth = ''; + if ( (my $i = index $host, '@') != -1 ) { + # user:pass@host + $auth = substr $host, 0, $i, ''; # take up to the @ for auth + substr $host, 0, 1, ''; # knock the @ off the host + + # userinfo might be percent escaped, so recover real auth info + $auth =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; + } + my $port = $host =~ s/:(\d*)\z// && length $1 ? $1 + : $scheme eq 'http' ? 80 + : $scheme eq 'https' ? 443 + : undef; + + return ($scheme, (length $host ? lc $host : "localhost") , $port, $path_query, $auth); +} + +=func http_date + + $http_date = http_date($epoch_time); + +Convert an epoch time into a date format suitable for HTTP. + +=cut + +# Date conversions adapted from HTTP::Date +# adapted from HTTP/Tiny.pm +my $DoW = 'Sun|Mon|Tue|Wed|Thu|Fri|Sat'; +my $MoY = 'Jan|Feb|Mar|Apr|May|Jun|Jul|Aug|Sep|Oct|Nov|Dec'; +sub http_date { + my $time = shift or _usage(q{http_date($time)}); + my ($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($time); + return sprintf('%s, %02d %s %04d %02d:%02d:%02d GMT', + substr($DoW,$wday*4,3), + $mday, substr($MoY,$mon*4,3), $year+1900, + $hour, $min, $sec + ); +} + +=func parse_http_date + + $epoch_time = parse_http_date($http_date); + +Convert an HTTP date into an epoch time. Returns undef if the date cannot be parsed. + +=cut + +# adapted from HTTP/Tiny.pm +sub parse_http_date { + my $str = shift or _usage(q{parse_http_date($str)}); + my @tl_parts; + if ($str =~ /^[SMTWF][a-z]+, +(\d{1,2}) ($MoY) +(\d\d\d\d) +(\d\d):(\d\d):(\d\d) +GMT$/) { + @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3); + } + elsif ($str =~ /^[SMTWF][a-z]+, +(\d\d)-($MoY)-(\d{2,4}) +(\d\d):(\d\d):(\d\d) +GMT$/ ) { + @tl_parts = ($6, $5, $4, $1, (index($MoY,$2)/4), $3); + } + elsif ($str =~ /^[SMTWF][a-z]+ +($MoY) +(\d{1,2}) +(\d\d):(\d\d):(\d\d) +(?:[^0-9]+ +)?(\d\d\d\d)$/ ) { + @tl_parts = ($5, $4, $3, $2, (index($MoY,$1)/4), $6); + } + require Time::Local; + return eval { + my $t = @tl_parts ? Time::Local::timegm(@tl_parts) : -1; + $t < 0 ? undef : $t; + }; +} + +=func uri_escape + + $escaped = uri_escape($unescaped); + +Escape a string for use in a URL query param or as C data. + +=cut + +# URI escaping adapted from URI::Escape +# c.f. http://www.w3.org/TR/html4/interact/forms.html#h-17.13.4.1 +# perl 5.6 ready UTF-8 encoding adapted from JSON::PP +# adapted from HTTP/Tiny.pm +my %escapes = map { chr($_) => sprintf('%%%02X', $_) } 0..255; +$escapes{' '} = '+'; +my $unsafe_char = qr/[^A-Za-z0-9\-\._~]/; + +sub uri_escape { + my $str = shift or _usage(q{uri_escape($str)}); + if ($] ge '5.008') { + utf8::encode($str); + } + else { + $str = pack('U*', unpack('C*', $str)) # UTF-8 encode a byte string + if (length $str == do { use bytes; length $str }); + $str = pack('C*', unpack('C*', $str)); # clear UTF-8 flag + } + $str =~ s/($unsafe_char)/$escapes{$1}/ge; + return $str; +} + +=func www_form_urlencode + + $bytes = www_form_urlencode(\%form_data); + $bytes = www_form_urlencode(\@form_data); + +Encode a hashref or arrayref as C data. + +=cut + +# adapted from HTTP/Tiny.pm +sub www_form_urlencode { + my $data = shift; + ($data && ref $data) + or _usage(q{www_form_urlencode($dataref)}); + (ref $data eq 'HASH' || ref $data eq 'ARRAY') + or _croak("form data must be a hash or array reference\n"); + + my @params = ref $data eq 'HASH' ? %$data : @$data; + @params % 2 == 0 + or _croak("form data reference must have an even number of terms\n"); + + my @terms; + while (@params) { + my ($key, $value) = splice(@params, 0, 2); + if (ref $value eq 'ARRAY') { + unshift @params, map { $key => $_ } @$value; + } + else { + push @terms, join('=', map { uri_escape($_) } $key, $value); + } + } + + return join('&', ref($data) eq 'ARRAY' ? @terms : sort @terms); +} + +1; diff --git a/t/01-new.t b/t/01-new.t new file mode 100644 index 0000000..4362ef3 --- /dev/null +++ b/t/01-new.t @@ -0,0 +1,19 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::Exception; +use Test::More tests => 3; + +my $any_ua1 = HTTP::AnyUA->new(ua => 'Mock'); +ok $any_ua1, 'can construct a new HTTP::AnyUA'; + +my $any_ua2 = HTTP::AnyUA->new('Mock'); +ok $any_ua2, 'can construct a new HTTP::AnyUA'; + +throws_ok { HTTP::AnyUA->new() } qr/^Usage:/, 'constructor requires user agent'; + diff --git a/t/02-shortcuts.t b/t/02-shortcuts.t new file mode 100644 index 0000000..768c4bd --- /dev/null +++ b/t/02-shortcuts.t @@ -0,0 +1,24 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More tests => 10; + +HTTP::AnyUA->register_backend(Mock => '+MockBackend'); + +my $any_ua = HTTP::AnyUA->new(ua => 'Mock'); +my $backend = $any_ua->backend; + +my $url = 'http://acme.tld/'; + +for my $shortcut (qw{get head put post delete}) { + my $resp = $any_ua->$shortcut($url); + my $request = ($backend->requests)[-1]; + is $request->[0], uc($shortcut), "$shortcut shortcut makes a request with the correct method"; + is $request->[1], $url, "$shortcut shortcut makes a request with the correct URL"; +} + diff --git a/t/03-post_form.t b/t/03-post_form.t new file mode 100644 index 0000000..d6746e6 --- /dev/null +++ b/t/03-post_form.t @@ -0,0 +1,29 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More tests => 4; + +HTTP::AnyUA->register_backend(Mock => '+MockBackend'); + +my $any_ua = HTTP::AnyUA->new(ua => 'Mock'); +my $backend = $any_ua->backend; + +my $url = 'http://acme.tld/'; +my $form = { + foo => 'bar', + baz => 42, +}; +my $resp = $any_ua->post_form($url, $form); + +my $request = ($backend->requests)[-1]; + +is $request->[0], 'POST', 'post_form request method is POST'; +is $request->[1], $url, 'post_form request URL is correct'; +is $request->[2]{content}, 'baz=42&foo=bar', 'post_form request body is correct'; +is $request->[2]{headers}{'content-type'}, 'application/x-www-form-urlencoded', 'post_form request content-type header is correct'; + diff --git a/t/04-internal-exception.t b/t/04-internal-exception.t new file mode 100644 index 0000000..3e02360 --- /dev/null +++ b/t/04-internal-exception.t @@ -0,0 +1,36 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:test :ua); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 3; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new($ua, response_is_future => 1); + + my $url = 'invalidscheme://acme.tld/hello'; + my $future = $any_ua->get($url); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + + note explain 'RESPONSE: ', $resp; + + is_response_reason($resp, 'Internal Exception'); + is_response_status($resp, 599); + is_response_success($resp, 0); + }); + + return $future; +}; + diff --git a/t/10-get.t b/t/10-get.t new file mode 100644 index 0000000..6d2e203 --- /dev/null +++ b/t/10-get.t @@ -0,0 +1,71 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +my $server = start_server('t/app.psgi'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 14; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new($ua, response_is_future => 1); + + my $path = '/get-document'; + my $url = $server->url . $path; + my $future = $any_ua->get($url, { + headers => { + 'x-test-custom' => 'whatever', + 'x-test-multi' => [qw(foo bar baz)], + }, + }); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 5 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, 'GET', 'correct method sent'); + is($env->{REQUEST_URI}, $path, 'correct url sent'); + is($env->{content}, '', 'no body sent'); + is($env->{HTTP_X_TEST_CUSTOM}, 'whatever', 'custom header sent'); + like($env->{HTTP_X_TEST_MULTI}, qr/foo,\s*bar,\s*baz/, 'multi-value header sent'); + } + + is_response_content($resp, 'this is a document'); + is_response_reason($resp, 'OK'); + is_response_status($resp, 200); + is_response_success($resp, 1); + is_response_url($resp, $url); + is_response_header($resp, 'content-type', 'text/plain'); + is_response_header($resp, 'content-length', 18); + is_response_header($resp, 'x-foo', 'bar'); + response_protocol_ok($resp); + }); + + return $future; +}; + +# test: +# X custom headers +# X repeat headers (arrayref value) +# X stream request +# X stream response +# X redirect log +# X internal errors +# X all methods: get, post, put, head, delete, custom +# X basic auth in URL + diff --git a/t/11-post.t b/t/11-post.t new file mode 100644 index 0000000..80fc830 --- /dev/null +++ b/t/11-post.t @@ -0,0 +1,55 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +my $server = start_server('t/app.psgi'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 10; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new(ua => $ua, response_is_future => 1); + + my $path = '/create-document'; + my $url = $server->url . $path; + my $future = $any_ua->post($url, { + headers => {'content-type' => 'text/plain'}, + content => 'some document', + }); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 3 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, 'POST', 'correct method sent'); + is($env->{REQUEST_URI}, $path, 'correct url sent'); + is($env->{content}, 'some document', 'correct body sent'); + } + + is_response_content($resp, 'created document'); + is_response_reason($resp, 'Created'); + is_response_status($resp, 201); + is_response_success($resp, 1); + is_response_url($resp, $url); + is_response_header($resp, 'content-type', 'text/plain'); + response_protocol_ok($resp); + }); + + return $future; +}; + diff --git a/t/12-put.t b/t/12-put.t new file mode 100644 index 0000000..c6adb78 --- /dev/null +++ b/t/12-put.t @@ -0,0 +1,56 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +my $server = start_server('t/app.psgi'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 9; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new(ua => $ua, response_is_future => 1); + + my $path = '/modify-document'; + my $url = $server->url . $path; + my $future = $any_ua->put($url, { + headers => {'content-type' => 'text/plain'}, + content => 'some document', + }); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 3 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, 'PUT', 'correct method sent'); + is($env->{REQUEST_URI}, $path, 'correct url sent'); + is($env->{content}, 'some document', 'correct body sent'); + } + + is_response_reason($resp, 'No Content'); + is_response_status($resp, 204); + is_response_success($resp, 1); + is_response_url($resp, $url); + response_protocol_ok($resp); + + my $body = ref($resp) eq 'HASH' && $resp->{content}; + ok(!$body, 'response body is empty'); + }); + + return $future; +}; + diff --git a/t/13-head.t b/t/13-head.t new file mode 100644 index 0000000..9e68542 --- /dev/null +++ b/t/13-head.t @@ -0,0 +1,54 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +my $server = start_server('t/app.psgi'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 10; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new(ua => $ua, response_is_future => 1); + + my $path = '/get-document'; + my $url = $server->url . $path; + my $future = $any_ua->head($url); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 2 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, 'HEAD', 'correct method sent'); + is($env->{REQUEST_URI}, $path, 'correct url sent'); + } + + is_response_reason($resp, 'OK'); + is_response_status($resp, 200); + is_response_success($resp, 1); + is_response_url($resp, $url); + is_response_header($resp, 'content-type', 'text/plain'); + is_response_header($resp, 'content-length', 18); + response_protocol_ok($resp); + + my $body = ref($resp) eq 'HASH' && $resp->{content}; + ok(!$body, 'response body is empty'); + }); + + return $future; +}; + diff --git a/t/14-delete.t b/t/14-delete.t new file mode 100644 index 0000000..86682e4 --- /dev/null +++ b/t/14-delete.t @@ -0,0 +1,52 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +my $server = start_server('t/app.psgi'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 8; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new(ua => $ua, response_is_future => 1); + + my $path = '/modify-document'; + my $url = $server->url . $path; + my $future = $any_ua->delete($url); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 2 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, 'DELETE', 'correct method sent'); + is($env->{REQUEST_URI}, $path, 'correct url sent'); + } + + is_response_reason($resp, 'No Content'); + is_response_status($resp, 204); + is_response_success($resp, 1); + is_response_url($resp, $url); + response_protocol_ok($resp); + + my $body = ref($resp) eq 'HASH' && $resp->{content}; + ok(!$body, 'response body is empty'); + }); + + return $future; +}; + diff --git a/t/15-custom-method.t b/t/15-custom-method.t new file mode 100644 index 0000000..7dc7ab2 --- /dev/null +++ b/t/15-custom-method.t @@ -0,0 +1,56 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +my $server = start_server('t/app.psgi'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 13; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new(ua => $ua, response_is_future => 1); + + my $method = 'FOOBAR'; + my $path = '/get-document'; + my $url = $server->url . $path; + my $future = $any_ua->request($method => $url, {headers => {'x-test-custom' => 'whatever'}}); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 4 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, $method, 'correct method sent'); + is($env->{REQUEST_URI}, $path, 'correct url sent'); + is($env->{content}, '', 'no body sent'); + is($env->{HTTP_X_TEST_CUSTOM}, 'whatever', 'custom header sent'); + } + + is_response_content($resp, 'this is a document'); + is_response_reason($resp, 'OK'); + is_response_status($resp, 200); + is_response_success($resp, 1); + is_response_url($resp, $url); + is_response_header($resp, 'content-type', 'text/plain'); + is_response_header($resp, 'content-length', 18); + is_response_header($resp, 'x-foo', 'bar'); + response_protocol_ok($resp); + }); + + return $future; +}; + diff --git a/t/20-data_callback.t b/t/20-data_callback.t new file mode 100644 index 0000000..1e8847c --- /dev/null +++ b/t/20-data_callback.t @@ -0,0 +1,59 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +my $server = start_server('t/app.psgi'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 13; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new($ua, response_is_future => 1); + + my $path = '/get-document'; + my $url = $server->url . $path; + my $body = ''; + my $future = $any_ua->get($url, { + data_callback => sub { my ($part, $resp) = @_; $body .= $part; }, + }); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 3 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, 'GET', 'correct method sent'); + is($env->{REQUEST_URI}, $path, 'correct url sent'); + is($env->{content}, '', 'no body sent'); + } + + is($body, 'this is a document', 'streamed response content matches'); + ok($resp && !$resp->{content}, 'content in response structure is empty'); + + is_response_reason($resp, 'OK'); + is_response_status($resp, 200); + is_response_success($resp, 1); + is_response_url($resp, $url); + is_response_header($resp, 'content-type', 'text/plain'); + is_response_header($resp, 'content-length', 18); + is_response_header($resp, 'x-foo', 'bar'); + response_protocol_ok($resp); + }); + + return $future; +}; + diff --git a/t/21-basic-auth.t b/t/21-basic-auth.t new file mode 100644 index 0000000..0631e28 --- /dev/null +++ b/t/21-basic-auth.t @@ -0,0 +1,62 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +my $server = start_server('t/app.psgi'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 12; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new($ua, response_is_future => 1); + + my $user = 'bob'; + my $pass = 'opensesame'; + my $auth = 'Ym9iOm9wZW5zZXNhbWU='; + my $path = '/get-document'; + my $url = $server->url . $path; + $url =~ s!^(https?://)!${1}${user}:${pass}\@!; + my $future = $any_ua->get($url); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 4 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, 'GET', 'correct method sent'); + is($env->{REQUEST_URI}, $path, 'correct url sent'); + is($env->{content}, '', 'no body sent'); + is($env->{HTTP_AUTHORIZATION}, "Basic $auth", 'correct authorization sent'); + } + + is_response_content($resp, 'this is a document'); + is_response_reason($resp, 'OK'); + is_response_status($resp, 200); + is_response_success($resp, 1); + TODO: { + local $TODO = 'some user agents strip the auth from the URL'; + # Mojo::UserAgent strips the auth from the URL + is_response_url($resp, $url); + }; + is_response_header($resp, 'content-type', 'text/plain'); + is_response_header($resp, 'content-length', 18); + response_protocol_ok($resp); + }); + + return $future; +}; + diff --git a/t/22-redirects.t b/t/22-redirects.t new file mode 100644 index 0000000..d3491f4 --- /dev/null +++ b/t/22-redirects.t @@ -0,0 +1,93 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +my $server = start_server('t/app.psgi'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 29; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new($ua, response_is_future => 1); + + # enable redirects for useragents that don't do it by default + if ($ua->isa('Mojo::UserAgent')) { + $ua->max_redirects(5); + } + elsif ($ua->isa('Net::Curl::Easy')) { + $ua->setopt(Net::Curl::Easy::CURLOPT_FOLLOWLOCATION(), 1); + } + + my $path = '/foo'; + my $url = $server->url . $path; + my $future = $any_ua->get($url); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 3 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, 'GET', 'correct method sent'); + is($env->{REQUEST_URI}, '/baz', 'correct url sent'); + is($env->{content}, '', 'no body sent'); + } + + is_response_content($resp, 'you found it'); + is_response_reason($resp, 'OK'); + is_response_status($resp, 200); + is_response_success($resp, 1); + TODO: { + local $TODO = 'some user agents do not support this correctly'; + # Furl has the URL from the original request, not the last request + is_response_url($resp, $server->url . '/baz'); + }; + is_response_header($resp, 'content-type', 'text/plain'); + is_response_header($resp, 'content-length', 12); + response_protocol_ok($resp); + + SKIP: { + skip 'no redirect chain', 18 if !$resp || !$resp->{redirects}; + + my $chain = $resp->{redirects}; + isa_ok($chain, 'ARRAY', 'redirect chain'); + is(scalar @$chain, 2, 'redirect chain has two redirections'); + + my $r1 = $chain->[0]; + is_response_content($r1, 'the thing you seek is not here'); + is_response_reason($r1, 'Found'); + is_response_status($r1, 302); + is_response_success($r1, 0); + is_response_url($r1, $server->url . '/foo'); + is_response_header($r1, 'content-type', 'text/plain'); + is_response_header($r1, 'content-length', 30); + response_protocol_ok($r1); + + my $r2 = $chain->[1]; + is_response_content($r2, 'not here either'); + is_response_reason($r2, 'Moved Permanently'); + is_response_status($r2, 301); + is_response_success($r2, 0); + is_response_url($r2, $server->url . '/bar'); + is_response_header($r2, 'content-type', 'text/plain'); + is_response_header($r2, 'content-length', 15); + response_protocol_ok($r2); + } + }); + + return $future; +}; + diff --git a/t/23-content-coderef.t b/t/23-content-coderef.t new file mode 100644 index 0000000..c87833c --- /dev/null +++ b/t/23-content-coderef.t @@ -0,0 +1,65 @@ +#!perl + +use warnings; +use strict; + +use lib 't/lib'; + +use HTTP::AnyUA; +use Test::More; +use Util qw(:server :test :ua); + +# using Starman because we need a server that can handle chunked requests +my $server = start_server('t/app.psgi', type => 'Starman'); + +plan tests => scalar user_agents; + +test_all_user_agents { + plan tests => 10; + + my $ua = shift; + my $any_ua = HTTP::AnyUA->new(ua => $ua, response_is_future => 1); + + if ($ua->isa('Mojo::UserAgent')) { + # disable keep-alive to avoid Mojo::Reactor::EV warnings + $ua->max_connections(0); + } + + my $chunk = 0; + my @chunk = ('some ', 'document'); + my $code = sub { return $chunk[$chunk++] }; + + my $path = '/create-document'; + my $url = $server->url . $path; + my $future = $any_ua->post($url, { + headers => {'content-type' => 'text/plain'}, + content => $code, + }); + + $future->on_ready(sub { + my $self = shift; + my $resp = $self->is_done ? $self->get : $self->failure; + my $env = $server->read_env; + + note explain 'RESPONSE: ', $resp; + note explain 'ENV: ', $env; + + SKIP: { + skip 'unexpected env', 3 if ref($env) ne 'HASH'; + is($env->{REQUEST_METHOD}, 'POST', 'correct method sent'); + is($env->{REQUEST_URI}, $path, 'correct url sent'); + is($env->{content}, 'some document', 'correct body sent'); + } + + is_response_content($resp, 'created document'); + is_response_reason($resp, 'Created'); + is_response_status($resp, 201); + is_response_success($resp, 1); + is_response_url($resp, $url); + is_response_header($resp, 'content-type', 'text/plain'); + response_protocol_ok($resp); + }); + + return $future; +}; + diff --git a/t/app.psgi b/t/app.psgi new file mode 100644 index 0000000..c860c07 --- /dev/null +++ b/t/app.psgi @@ -0,0 +1,46 @@ +# A little plack app for testing HTTP::AnyUA + +# When a request is made, the environment will be sent back to the test which will assert that the +# request was made correctly. + +use Plack::Builder; +use Util qw(send_env); + +builder { + + mount '/create-document' => sub { + my $env = shift; + send_env($env); + [201, ['Content-Type' => 'text/plain'], ['created document']]; + }; + + mount '/get-document' => sub { + my $env = shift; + send_env($env); + [200, ['Content-Type' => 'text/plain', 'x-foo' => 'bar'], ['this is a document']]; + }; + + mount '/modify-document' => sub { + my $env = shift; + send_env($env); + [204, [], ['']]; + }; + + mount '/foo' => sub { + [302, ['Content-Type' => 'text/plain', 'Location' => '/bar'], ['the thing you seek is not here']]; + }; + mount '/bar' => sub { + [301, ['Content-Type' => 'text/plain', 'Location' => '/baz'], ['not here either']]; + }; + mount '/baz' => sub { + my $env = shift; + send_env($env); + [200, ['Content-Type' => 'text/plain'], ['you found it']]; + }; + + mount '/' => sub { + [200, ['Content-Type' => 'text/plain'], ['this is a test server']]; + }; + +} + diff --git a/t/lib/MockBackend.pm b/t/lib/MockBackend.pm new file mode 100644 index 0000000..c8b6535 --- /dev/null +++ b/t/lib/MockBackend.pm @@ -0,0 +1,45 @@ +package MockBackend; +# ABSTRACT: A backend for testing HTTP::AnyUA + +use warnings; +use strict; + +use parent 'HTTP::AnyUA::Backend'; + + +=method response + + $response = $backend->response; + $response = $backend->response($response); + +Get and set the response hashref or L that this backend will always respond with. + +=cut + +sub response { @_ == 2 ? $_[0]->{response} = pop : $_[0]->{response} } + +=method requests + + @requests = $backend->requests; + +Get the requests the backend has handled so far. + +=cut + +sub requests { @{$_[0]->{requests} || []} } + +sub request { + my $self = shift; + + push @{$self->{requests} ||= []}, [@_]; + + return $self->response || { + success => '', + status => 599, + reason => 'Internal Exception', + content => "No response mocked.\n", + }; +} + + +1; diff --git a/t/lib/Server.pm b/t/lib/Server.pm new file mode 100644 index 0000000..fbac0da --- /dev/null +++ b/t/lib/Server.pm @@ -0,0 +1,185 @@ +package Server; +# ABSTRACT: A runner for test HTTP servers + +=head1 SYNOPSIS + + use Server; + my $server = Server->new('app.psgi'); + +=head1 DESCRIPTION + +Throws up an HTTP server on a random port, suitable for testing. Server logs will be printed to +C as test notes. + +=cut + +use warnings; +use strict; + +use IO::Handle; +use Plack::Runner; +use Util qw(recv_env); + +=method new + + $server = Server->new($path); + $server = Server->new(\&app); + $server = Server->new(\&app, type => 'Starman'); + +Construct and L a new test HTTP server. + +=cut + +sub new { + my $class = shift; + my $app = shift or die 'PSGI app required'; + my %args = @_; + + $args{type} ||= 'HTTP::Server::PSGI'; + + my $self = bless {app => $app, %args}, $class; + return $self->start; +} + +=attr app + +Get the app that was passed to L. + +=attr in + +Get a filehandle for reading the server's STDOUT. + +=attr pid + +Get the process identifier of the server. + +=attr port + +Get the port number the server is listening on. + +=attr url + +Get the URL for the server. + +=attr type + +Get the type of server that was passed to L. + +=cut + +sub app { shift->{app} } +sub in { shift->{in} } +sub pid { shift->{pid} } +sub port { shift->{port} } +sub url { 'http://localhost:' . shift->port } +sub type { shift->{type} } + +=method start + + $server->start; + +Start the server. + +=cut + +sub start { + my $self = shift; + + # do not start on top of an already-started server + return $self if $self->{pid}; + + my $type = $self->type; + + my $pid = open(my $pipe, '-|'); + defined $pid or die "fork failed: $!"; + + $pipe->autoflush(1); + + if ($pid) { + my $port = <$pipe>; + die 'Could not start test server' if !$port; + chomp $port; + + $self->{in} = $pipe; + $self->{pid} = $pid; + $self->{port} = $port; + } + else { + tie *STDERR, 'Server::RedirectToTestHarness'; + + autoflush STDOUT 1; + + for my $try (1..10) { + my $port_num = $ENV{PERL_HTTP_ANYUA_TEST_PORT} || int(rand(32768)) + 32768; + print STDERR sprintf('Try %02d - Attempting to start a server on port %d for testing...', $try, $port_num); + + local $SIG{ALRM} = sub { print "$port_num\n" }; + alarm 1; + + eval { + my $runner = Plack::Runner->new; + $runner->parse_options('-s', $type, '-p', $port_num); + $runner->run($self->app); + }; + warn $@ if $@; + + alarm 0; + } + + print STDERR "Giving up..."; + exit; + } + + return $self; +} + +=method stop + + $server->stop; + +Stop the server. Called implicitly by C. + +=cut + +sub stop { + my $self = shift; + + if (my $pid = $self->pid) { + kill 'TERM', $pid; + waitpid $pid, 0; + $? = 0; # don't let child exit status affect parent + } + %$self = (app => $self->app); +} + +sub DESTROY { + my $self = shift; + $self->stop; +} + + +=method read_env + + $env = $server->read_env; + +Read a L environment from the server, sent by L. + +=cut + +sub read_env { + my $self = shift; + return recv_env($self->in or die 'Not connected'); +} + + +{ + package Server::RedirectToTestHarness; + + use Test::More (); + + sub TIEHANDLE { bless {} } + sub PRINT { shift; Test::More::note('Server: ', @_) } + sub PRINTF { shift; Test::More::note('Server: ', sprintf(@_)) } +} + +1; diff --git a/t/lib/Util.pm b/t/lib/Util.pm new file mode 100644 index 0000000..892e085 --- /dev/null +++ b/t/lib/Util.pm @@ -0,0 +1,343 @@ +package Util; +# ABSTRACT: Utility subroutines for testing HTTP::AnyUA + +=head1 SYNOPSIS + + use Util qw(:server :test :ua); + +=cut + +use warnings; +use strict; + +use Exporter qw(import); +use Future; +use Test2::API qw(context release); +use Test::More; + +our @EXPORT_OK = qw( + recv_env + send_env + start_server + use_server + + is_response_content + is_response_header + is_response_reason + is_response_status + is_response_success + is_response_url + response_protocol_ok + + test_all_user_agents + test_user_agent + user_agents +); +our %EXPORT_TAGS = ( + server => [qw( + recv_env + send_env + start_server + use_server + )], + test => [qw( + is_response_content + is_response_header + is_response_reason + is_response_status + is_response_success + is_response_url + response_protocol_ok + )], + ua => [qw( + test_all_user_agents + test_user_agent + user_agents + )], +); + +our @USER_AGENTS = qw( + AnyEvent::HTTP + Furl + HTTP::Tiny + LWP::UserAgent + Mojo::UserAgent + Net::Curl::Easy +); +our %USER_AGENT_TEST_WRAPPER; + +sub _croak { require Carp; Carp::croak(@_) } +sub _carp { require Carp; Carp::carp(@_) } + + +=func use_server + + use_server; + +Try to use the test server package. If it fails, the test plan is set to C. + +=cut + +sub use_server { + eval 'use Server'; + if (my $err = $@) { + diag $err; + plan skip_all => 'Could not compile test server runner.'; + } +} + +=func start_server + + $server = start_server('app.psgi'); + +Start a test server. + +=cut + +sub start_server { + use_server; + my $server = eval { Server->new(@_) }; + if (my $err = $@) { + diag $err; + plan skip_all => 'Could not start test server.'; + } + return $server; +} + +=func send_env + + send_env(\%env); + +Encode and send a L environment over C, to be received by L. + +=cut + +sub send_env { + my $env = shift || {}; + my $fh = shift || *STDOUT; + + my %data = map { !/^psgi/ ? ($_ => $env->{$_}) : () } keys %$env; + + # read in the request body + my $buffer; + my $body = ''; + $env->{'psgix.input.buffered'} or die 'Expected buffered input'; + while (1) { + my $bytes = $env->{'psgi.input'}->read($buffer, 32768); + defined $bytes or die 'Error while reading input stream'; + last if !$bytes; + $body .= $buffer; + } + $data{content} = $body; + + require JSON; + print $fh JSON::encode_json(\%data), "\n"; +} + +=func recv_env + + my $env = recv_env($fh); + +Receive and decode a L environment over a filehandle, sent by L. + +=cut + +sub recv_env { + my $fh = shift; + + my $data = <$fh>; + + require JSON; + return JSON::decode_json($data); +} + + +=func is_response_content, is_response_reason, is_response_status, is_response_success, is_response_url, is_response_header + + is_response_content($resp, $body, $test_name); + is_response_content($resp, $body); + # etc. + +Test a response for various fields. + +=cut + +sub is_response_content { my $ctx = context; release $ctx, _test_response_field($_[0], 'content', @_[1,2]) } +sub is_response_reason { my $ctx = context; release $ctx, _test_response_field($_[0], 'reason', @_[1,2]) } +sub is_response_status { my $ctx = context; release $ctx, _test_response_field($_[0], 'status', @_[1,2]) } +sub is_response_success { my $ctx = context; release $ctx, _test_response_field($_[0], 'success', @_[1,2], 'bool') } +sub is_response_url { my $ctx = context; release $ctx, _test_response_field($_[0], 'url', @_[1,2]) } +sub is_response_header { my $ctx = context; release $ctx, _test_response_header(@_) } + +=func response_protocol_ok + + response_protocol_ok($resp); + +Test that a response protocol is well-formed. + +=cut + +sub response_protocol_ok { + my ($resp) = @_; + my $ctx = context; + my $test; + if (ref($resp) ne 'HASH') { + $test = isa_ok($resp, 'HASH', 'response'); + } + else { + my $proto = $resp->{protocol}; + $test = ok(!$proto || $proto =~ m!^HTTP/!, 'response protocol matches or is missing'); + } + release $ctx, $test; +} + +sub _test_response_field { + my ($resp, $key, $val, $name, $type) = @_; + if (ref($resp) ne 'HASH') { + return isa_ok($resp, 'HASH', 'response'); + } + elsif (defined $val) { + $type ||= ''; + if ($type eq 'bool') { + my $disp = $val ? 'true' : 'false'; + return is(!!$resp->{$key}, !!$val, $name || "response $key matches \"$disp\""); + } + else { + my $disp = $val; + $disp =~ s/(.{40}).{4,}/$1.../; + return is($resp->{$key}, $val, $name || "response $key matches \"$disp\""); + } + } + else { + return ok(exists $resp->{$key}, $name || "response $key exists"); + } +} + +sub _test_response_header { + my ($resp, $key, $val, $name) = @_; + if (ref($resp) ne 'HASH') { + return isa_ok($resp, 'HASH', 'response'); + } + elsif (ref($resp->{headers}) ne 'HASH') { + return isa_ok($resp, 'HASH', 'response headers'); + } + elsif (defined $val) { + my $disp = $val; + $disp =~ s/(.{40}).{4,}/$1.../; + return is($resp->{headers}{$key}, $val, $name || "response header \"$key\" matches \"$disp\""); + } + else { + return ok(exists $resp->{headers}{$key}, $name || "response header $key exists"); + } +} + + +=func user_agents + + @user_agents = user_agents; + +Get a list of user agents available for testing. Shortcut for C<@Util::USER_AGENTS>. + +=cut + +sub user_agents { @USER_AGENTS } + +=func test_user_agent + + test_user_agent($ua_type, \&test); + +Run a subtest against one user agent. + +=cut + +sub test_user_agent { + my $name = shift; + my $code = shift; + + my $wrapper = $USER_AGENT_TEST_WRAPPER{$name} || sub { + my $name = shift; + my $code = shift; + + if (!eval "require $name") { + diag $@; + return; + } + + my $ua = $name->new; + $code->($ua); + + return 1; + }; + + # this is quite gross, but we don't want any active event loops from preventing us from + # committing suicide if things are looking deadlocked + local $SIG{ALRM} = sub { $@ = 'Deadlock or test is slow'; _carp $@; exit 1 }; + alarm 5; + my $ret = $wrapper->($name, $code); + alarm 0; + + plan skip_all => "Cannot create user agent ${name}" if !$ret; +} + +=func test_all_user_agents + + test_all_user_agents { ... }; + +Run the same subtest against all user agents returned by L. + +=cut + +sub test_all_user_agents(&) { + my $code = shift; + + for my $name (user_agents) { + subtest $name => sub { + test_user_agent($name, $code); + }; + } +} + + +$USER_AGENT_TEST_WRAPPER{'AnyEvent::HTTP'} = sub { + my $name = shift; + my $code = shift; + + if (!eval "require $name") { + diag $@; + return; + } + + require AnyEvent; + my $cv = AnyEvent->condvar; + + my $ua = 'AnyEvent::HTTP'; + my @futures = $code->($ua); + my $waiting = Future->wait_all(@futures)->on_ready(sub { $cv->send }); + + $cv->recv; + + return 1; +}; + +$USER_AGENT_TEST_WRAPPER{'Mojo::UserAgent'} = sub { + my $name = shift; + my $code = shift; + + if (!eval "require $name") { + diag $@; + return; + } + + require Mojo::IOLoop; + my $loop = Mojo::IOLoop->singleton; + + my $ua = Mojo::UserAgent->new; + my @futures = $code->($ua); + my $waiting = Future->wait_all(@futures)->on_ready(sub { $loop->reset }); + + $loop->start; + + return 1; +}; + +1; -- 2.43.0