diff options
| author | Andrej Shadura <andrewsh@debian.org> | 2019-06-23 13:50:05 -0500 |
|---|---|---|
| committer | Andrej Shadura <andrewsh@debian.org> | 2019-06-23 13:50:05 -0500 |
| commit | 48397e80cac42333dbcb124313ba9205531e2ace (patch) | |
| tree | f137711ee6884aee4d0fade6ae462880bf6d3b42 | |
Import original source of Net-Async-HTTP 0.44
55 files changed, 8811 insertions, 0 deletions
diff --git a/Build.PL b/Build.PL new file mode 100644 index 0000000..782e3f1 --- /dev/null +++ b/Build.PL @@ -0,0 +1,46 @@ +use strict; +use warnings; + +use Module::Build; + +my $build = Module::Build->new( + module_name => 'Net::Async::HTTP', + requires => { + 'Future' => '0.28', # ->set_label + 'Future::Utils' => '0.16', + 'HTTP::Request' => 0, + 'HTTP::Request::Common' => 0, + 'HTTP::Response' => 0, + 'IO::Async::Loop' => '0.59', + 'IO::Async::Stream' => '0.59', + 'IO::Async::Timer::Countdown' => 0, + 'List::Util' => "1.29", # pairs() + 'Socket' => '2.010', + 'Struct::Dumb' => '0.07', + 'URI' => 0, + 'perl' => '5.010', # // + }, + recommends => { + 'Compress::Raw::Zlib' => '2.057', # Fails with Compress::Raw::Zlib 2.056 or before + }, + build_requires => { + 'HTTP::Cookies' => 0, + 'IO::Async::Test' => 0, + 'Test::Identity' => 0, + 'Test::More' => '0.88', # done_testing + 'Test::Refcount' => 0, + }, + configure_requires => { + 'Module::Build' => '0.4004', # test_requires + }, + license => 'perl', + create_license => 1, + create_readme => 1, + meta_merge => { + resources => { + x_IRC => "irc://irc.perl.org/#io-async", + }, + }, +); + +$build->create_build_script; @@ -0,0 +1,326 @@ +Revision history for Net-Async-HTTP + +0.44 2019-02-17 14:11:57 + [BUGFIXES] + * Regnerate embedded SSL testing certs + * No actual code changes + +0.43 2018-11-14 22:05:27 + [CHANGES] + * Use IPTOS_* constants directly from Socket 2.010 + * Pass SNI hostname when making SSL connections (RT94605) + + [BUGFIXES] + * Proxy connections require full authority string (RT119961) + +0.42 2018-04-03 15:37:17 + [CHANGES] + * Optionally support SOCKS5 proxies, using Net::Async::SOCKS + (RT124729) + * Minor docs improvements + + [BUGFIXES] + * Ensure that on_header is still invoked for a final redirect that + isn't followed (RT124920) + * Better detection of $Socket::VERSION (RT122527) + +0.41 2016/06/03 19:00:47 + [BUGFIXES] + * Ensure all kept-alive connections are properly closed when removing + an instance from its containing IO::Async::Loop + +0.40 2015/07/27 19:53:19 + [CHANGES] + * Added 'on_ready' parameter to ->request method, for interacting + with the socket directly + * Allow optional restriction of connect family + +0.39 2015/07/13 15:34:29 + [CHANGES] + * Allow additional HTTP request headers to be supplied when in URI + mode + * Add require_SSL parameter that forbids plaintext requests + (RT101498) + * Announce that a future version may set a default value for + max_connections_per_host higher than 1 + + [BUGFIXES] + * Ensure that fail_on_error also applies to legacy-style + on_response+on_error continuations (RT102022) + * Avoid use of undef in an error message printing a warning + (RT101459) + +0.38 2015/06/01 15:32:57 + [CHANGES] + * More debug_printf() calls for better logging of connection-related + activity + + [BUGFIXES] + * Ensure that failed connections are removed from the parent notifier + (RT102547) + * Make sure not to call length() on undefined values (RT102023) + * Ensure that the first request after connecting is only written + after the connection has been configured and has a notifier name + +0.37 2014/12/13 15:06:06 + [CHANGES] + * Major refactoring of Net::Async::HTTP::Connection internal closure- + generation logic + + [BUGFIXES] + * Cancel pending connect Futures if pipelining means an existing + connection can be reused; handles failures better (RT99142) + * Attempt to handle the case where $f->done itself throws an + exception by at least maintaining internal state (RT100066) + +0.36 2014/10/14 12:03:07 + [CHANGES] + * Set the content of generated requests if a 'content' param is given + (RT97654) + * Store object-wide SSL params for convenience (RT98514) + * Clarify the final return value of the on_body_chunk handler + (RT98278) + * Nicer error message when a non-HTTP response header is received + (RT93231) + + [BUGFIXES] + * 3xx responses without a Location header, and non-(GET|HEAD) + requests should not be redirected (RT98093) + +0.35 2014/03/30 20:58:34 + [BUGFIXES] + * Reparse URI scheme after redirect, so host/port/SSLness are reset + correctly (RT94303) + * Requeue the next pending request after an HTTP/1.0-style EOF + (RT94304) + * Require at least Compress::Bzip2 2.10 to do bzip2 decompression + + Bugfixes sponsored by Cisco (http://www.cisco.com/) + +0.34 2014/03/27 18:26:43 + [BUGFIXES] + * Don't attempt to reconnect ready queue items that already have a + pending connection attempt (RT92904) + * Don't close over $responder, thus avoiding a reference cycle leak + (RT93232 / RT92728) + * Avoid relying on strong forward references in Future, by creating + intentional cycles on pending Futures. Workaround for bugfix in + upcoming Future release. + + Bugfixes sponsored by NET-A-PORTER (http://www.net-a-porter.com/) + +0.33 2014/01/22 23:48:40 + [CHANGES] + * Include connection flieno in notifier_name in case of multiple + connections to a given host+port + * Use different Future failure operation names for timeout and + stall_timeout + + [BUGFIXES] + * Zlib compression needs Compress::Raw::Zlib 2.057 or newer + * Ensure that unpipelined requests can be cancelled + * Ensure that other pending requests on a connection are also + errored out when connection receives EOF + +0.32 2013/11/19 14:09:18 + [CHANGES] + * Optionally decode encoded content and set the Accept-Encoding + header of outbound requests. Currently defaults off, but may become + true in a later version. + + [BUGFIXES] + * Handle resolve/connect errors and pipeline queue flushing after + cancellation correctly + +0.31 2013/11/04 18:04:30 + [CHANGES] + * Allow a plain string URI, upgrading it to a URI object (RT89269) + * Added ->POST shortcut method, similar to ->GET and ->HEAD + * Extract HTTP basic auth. information from the URL in an + HTTP::Request (RT89775) + + [BUGFIXES] + * Remember to keep resetting the stall timer when receiving body + content + * Fix awkward race between stall_timer and ->cancel + * Note dependency on Test::Refcount + +0.30 2013/10/20 02:08:01 + [CHANGES] + * Use Future->new->fail to return failing immediate Futures + * Ensure Future failures all use standard IO::Async style of + ($message, NAME, ...) + + [BUGFIXES] + * Ensure that fail_on_error doesn't cause non-error responses to fail + (RT88996) + +0.29 2013/09/22 02:50:39 + [CHANGES] + * Added 'on_body_write' callback + * Reordering of documentation to emphasise futures first + + [BUGFIXES] + * Fix handling of chunk header when split across reads + +0.28 2013/09/13 20:40:14 + [CHANGES] + * Rewrite back into being a subclass of IO::Async::Stream instead of + using IO::Async::Protocol::Stream + * IO::Async::Stream 0.59 allows stall timeout detection during writes + now as well + + [BUGFIXES] + * Closed connections should drop the ready queue, so they don't + accidentally try to process a second request + * Failure handling of corrupted chunk headers during chunked transfer + encoding + +0.27 BUGFIXES: + * Ensure that $f->cancel on a request Future actually works properly + +0.26 CHANGES: + * Added 'stall_timeout', at least for read operations + + BUGFIXES: + * Fix NaHTTP+NaHTTP::Server unit tests for minimum version + requirements + +0.25 BUGFIXES: + * Defend against ->setsockopt detecting SvPOK() of string values + * Test for both "Connection closed" and "Connection closed while + awaiting header" as OSes differ in behaviour + +0.24 CHANGES: + * Optionally set IP_TOS field in sockets + * Remember to pass 'SSL' parameter around for requests on 'https' + scheme + +0.23 BUGFIXES: + * Fix t/14conn-max.t failures - disable pipelining, wait for correct + peersock connection to become ready (it may not be [0]) + +0.22 CHANGES: + * Allow more control over per-host concurrency; either a pool with a + limit, or boundless growth of concurrency + +0.21 CHANGES: + * Optional mode in which 4xx and 5xx HTTP errors are turned into + callback errors or Future failures + * Handle incoming 1xx informational responses + * Optionally set 'Expect' header for 100 Continue response + +0.20 CHANGES: + * Improvements to timeout and cancellation handling + * Updated for Future 0.12; pass 'return' argument to + Future::Utils::repeat + * Use newer IO::Async::OS->socketpair in unit tests + +0.19 CHANGES: + * Allow $http->do_request to return a Future object yielding the + eventual response + * Added convenient $http->GET and ->HEAD methods + * Many internal neatenings and rewrites to better support Futures + +0.18 CHANGES: + * Default host/port/SSLness from URL in HTTP::Request if given + * Set Connection: keep-alive by default + * Presume that HTTP/1.1 connections can keep-alive by default + * Attempt to limit the number of outstanding requests in flight per + connection; keep others in a queue + + BUGFIXES: + * Pass the same timer object down redirects so the same overall + timeout is reused + * Fix memory leak by remembering to remove closed NaHTTP::Protocol + children from containing NaHTTP + * Correctly terminate requests to connections closed during write + * Handle trailing whitespace after Chunked encoding chunk size + (thanks David Leadbeater) + +0.17 CHANGES: + * Support optionally setting local host/port/addr (RT75431) + * Don't pipeline requests until the server is known to be at least + HTTP/1.1 + + BUGFIXES: + * Default request protocol to HTTP/1.1 so caller doesn't have to + (RT75830) + * http(s) port logic on numbers rather than protocol names (RT75615) + * Use more weaseling in timeout handlers to avoid cyclic reference + memory leak + +0.16 BUGFIXES: + * Work around HTTP::Message's non-trimming of linear whitespace + (RT72843) + +0.15 BUGFIXES: + * Better HTTP handling of "Connection: close" connections; close the + socket at the end of the response body or HEAD header. + +0.14 CHANGES: + * Per-request timeouts + * Default port to http/https if not supplied explicitly + * Fill in Response ->previous on redirects - RT72791 + * Improvements to unit tests + +0.13 BUGFIXES: + * Handle redirect to https:// as well as http:// (RT71526) + * Fix use of conditional variable declaration that breaks on + Perl 5.14 (RT71545) + * Clean up connection cache after resolve, connect or SSL failures + (RT71530) + +0.12 BUGFIXES: + * Wait for connect to complete when pipelining multiple requests down + the same connection initially (RT66189) + * When serialising a request, handle a full protocol://authority URI + by splitting protocol/authority parts out of it + +0.11 BUGFIXES: + * Fix stalling t/12request-streaming.t test script that causes lots + of FAILs at test time + +0.10 CHANGES: + * Support streaming of request body content + * Support HTTP::Cookies object as a cookie jar + * Allow proxy_host and proxy_port as ->configure parameters, to set + defaults for requests + +0.09 CHANGES: + * Use IO::Async::Protocol->connect from 0.34 + +0.08 CHANGES: + * Support streaming of response body content + * Support SSL if IO::Async::SSL is installed + +0.07 CHANGES: + * base on IO::Async::Protocol::Stream + +0.06 CHANGES: + * When POSTing content that isn't form data, expect to be given its + content type + +0.05 CHANGES: + * Added Test::Pod testing + * Created example wget-style script + * Documentation neatening + * More accurate 'requires' in Build.PL; hopefully to keep CPANTS + happy + +0.04 CHANGES: + * Added 'use warnings' + * Updated to IO::Async 0.21 style + * Various small documentation and test script updates + +0.03 CHANGES: + * Support server-local HTTP redirects + +0.02 CHANGES: + * Support HTTP redirects + + BUGFIXES: + * Declare dependency on HTTP::Request and HTTP::Response + +0.01 First version, released on an unsuspecting world. + @@ -0,0 +1,379 @@ +This software is copyright (c) 2019 by Paul Evans <leonerd@leonerd.org.uk>. + +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) 2019 by Paul Evans <leonerd@leonerd.org.uk>. + +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. + + <one line to give the program's name and a brief idea of what it does.> + Copyright (C) 19yy <name of author> + + 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. + + <signature of Ty Coon>, 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) 2019 by Paul Evans <leonerd@leonerd.org.uk>. + +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/MANIFEST b/MANIFEST new file mode 100644 index 0000000..bba5101 --- /dev/null +++ b/MANIFEST @@ -0,0 +1,55 @@ +Build.PL +Changes +examples/GET.pl +examples/parallel-put.pl +examples/PUT.pl +lib/Net/Async/HTTP.pm +lib/Net/Async/HTTP/Connection.pm +lib/Net/Async/HTTP/StallTimer.pm +LICENSE +MANIFEST This list of files +META.json +META.yml +README +t/00use.t +t/01request.t +t/02uri.t +t/03future.t +t/04fail.t +t/05redir.t +t/06close.t +t/07continue.t +t/08prepareprocess.t +t/09cookies.t +t/10request-streaming.t +t/11response-streaming.t +t/12conn-persistence.t +t/13conn-pipeline.t +t/14conn-max.t +t/15conn-errors.t +t/16max-in-flight.t +t/17on-write.t +t/18content-coding.t +t/19idle.t +t/20local-connect.t +t/21local-connect-ssl.t +t/22local-connect-pipeline.t +t/23local-connect-redir.t +t/24local-connect-redir-ssl.t +t/30timeout.t +t/31cancel.t +t/32remove.t +t/40socks.t +t/80cross-http.t +t/81cross-https.t +t/90rt75615.t +t/90rt75616.t +t/90rt92904.t +t/90rt93232.t +t/90rt99142.t +t/91rt100066.t +t/91rt102547.t +t/99pod.t +t/privkey.pem +t/regen-certs.sh +t/server.pem diff --git a/META.json b/META.json new file mode 100644 index 0000000..534a5ab --- /dev/null +++ b/META.json @@ -0,0 +1,75 @@ +{ + "abstract" : "use HTTP with C<IO::Async>", + "author" : [ + "Paul Evans <leonerd@leonerd.org.uk>" + ], + "dynamic_config" : 1, + "generated_by" : "Module::Build version 0.4224", + "license" : [ + "perl_5" + ], + "meta-spec" : { + "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", + "version" : 2 + }, + "name" : "Net-Async-HTTP", + "prereqs" : { + "build" : { + "requires" : { + "HTTP::Cookies" : "0", + "IO::Async::Test" : "0", + "Test::Identity" : "0", + "Test::More" : "0.88", + "Test::Refcount" : "0" + } + }, + "configure" : { + "requires" : { + "Module::Build" : "0.4004" + } + }, + "runtime" : { + "recommends" : { + "Compress::Raw::Zlib" : "2.057" + }, + "requires" : { + "Future" : "0.28", + "Future::Utils" : "0.16", + "HTTP::Request" : "0", + "HTTP::Request::Common" : "0", + "HTTP::Response" : "0", + "IO::Async::Loop" : "0.59", + "IO::Async::Stream" : "0.59", + "IO::Async::Timer::Countdown" : "0", + "List::Util" : "1.29", + "Socket" : "2.010", + "Struct::Dumb" : "0.07", + "URI" : "0", + "perl" : "5.010" + } + } + }, + "provides" : { + "Net::Async::HTTP" : { + "file" : "lib/Net/Async/HTTP.pm", + "version" : "0.44" + }, + "Net::Async::HTTP::Connection" : { + "file" : "lib/Net/Async/HTTP/Connection.pm", + "version" : "0.44" + }, + "Net::Async::HTTP::StallTimer" : { + "file" : "lib/Net/Async/HTTP/StallTimer.pm", + "version" : "0.44" + } + }, + "release_status" : "stable", + "resources" : { + "license" : [ + "http://dev.perl.org/licenses/" + ], + "x_IRC" : "irc://irc.perl.org/#io-async" + }, + "version" : "0.44", + "x_serialization_backend" : "JSON::PP version 4.00" +} diff --git a/META.yml b/META.yml new file mode 100644 index 0000000..505c5ea --- /dev/null +++ b/META.yml @@ -0,0 +1,50 @@ +--- +abstract: 'use HTTP with C<IO::Async>' +author: + - 'Paul Evans <leonerd@leonerd.org.uk>' +build_requires: + HTTP::Cookies: '0' + IO::Async::Test: '0' + Test::Identity: '0' + Test::More: '0.88' + Test::Refcount: '0' +configure_requires: + Module::Build: '0.4004' +dynamic_config: 1 +generated_by: 'Module::Build version 0.4224, CPAN::Meta::Converter version 2.150010' +license: perl +meta-spec: + url: http://module-build.sourceforge.net/META-spec-v1.4.html + version: '1.4' +name: Net-Async-HTTP +provides: + Net::Async::HTTP: + file: lib/Net/Async/HTTP.pm + version: '0.44' + Net::Async::HTTP::Connection: + file: lib/Net/Async/HTTP/Connection.pm + version: '0.44' + Net::Async::HTTP::StallTimer: + file: lib/Net/Async/HTTP/StallTimer.pm + version: '0.44' +recommends: + Compress::Raw::Zlib: '2.057' +requires: + Future: '0.28' + Future::Utils: '0.16' + HTTP::Request: '0' + HTTP::Request::Common: '0' + HTTP::Response: '0' + IO::Async::Loop: '0.59' + IO::Async::Stream: '0.59' + IO::Async::Timer::Countdown: '0' + List::Util: '1.29' + Socket: '2.010' + Struct::Dumb: '0.07' + URI: '0' + perl: '5.010' +resources: + IRC: irc://irc.perl.org/#io-async + license: http://dev.perl.org/licenses/ +version: '0.44' +x_serialization_backend: 'CPAN::Meta::YAML version 0.018' @@ -0,0 +1,549 @@ +NAME + + Net::Async::HTTP - use HTTP with IO::Async + +SYNOPSIS + + use IO::Async::Loop; + use Net::Async::HTTP; + use URI; + + my $loop = IO::Async::Loop->new(); + + my $http = Net::Async::HTTP->new(); + + $loop->add( $http ); + + my ( $response ) = $http->do_request( + uri => URI->new( "http://www.cpan.org/" ), + )->get; + + print "Front page of http://www.cpan.org/ is:\n"; + print $response->as_string; + +DESCRIPTION + + This object class implements an asynchronous HTTP user agent. It sends + requests to servers, returning Future instances to yield responses when + they are received. The object supports multiple concurrent connections + to servers, and allows multiple requests in the pipeline to any one + connection. Normally, only one such object will be needed per program + to support any number of requests. + + As well as using futures the module also supports a callback-based + interface. + + This module optionally supports SSL connections, if IO::Async::SSL is + installed. If so, SSL can be requested either by passing a URI with the + https scheme, or by passing a true value as the SSL parameter. + + Connection Pooling + + There are three ways in which connections to HTTP server hosts are + managed by this object, controlled by the value of + max_connections_per_host. This controls when new connections are + established to servers, as compared to waiting for existing connections + to be free, as new requests are made to them. + + They are: + + max_connections_per_host = 1 + + This is the default setting. In this mode, there will be one + connection per host on which there are active or pending requests. If + new requests are made while an existing one is outstanding, they will + be queued to wait for it. + + If pipelining is active on the connection (because both the pipeline + option is true and the connection is known to be an HTTP/1.1 server), + then requests will be pipelined into the connection awaiting their + response. If not, they will be queued awaiting a response to the + previous before sending the next. + + max_connections_per_host > 1 + + In this mode, there can be more than one connection per host. If a + new request is made, it will try to re-use idle connections if there + are any, or if they are all busy it will create a new connection to + the host, up to the configured limit. + + max_connections_per_host = 0 + + In this mode, there is no upper limit to the number of connections + per host. Every new request will try to reuse an idle connection, or + else create a new one if all the existing ones are busy. + + These modes all apply per hostname / server port pair; they do not + affect the behaviour of connections made to differing hostnames, or + differing ports on the same hostname. + +PARAMETERS + + The following named parameters may be passed to new or configure: + + user_agent => STRING + + A string to set in the User-Agent HTTP header. If not supplied, one + will be constructed that declares Net::Async::HTTP and the version + number. + + max_redirects => INT + + Optional. How many levels of redirection to follow. If not supplied, + will default to 3. Give 0 to disable redirection entirely. + + max_in_flight => INT + + Optional. The maximum number of in-flight requests to allow per host + when pipelining is enabled and supported on that host. If more requests + are made over this limit they will be queued internally by the object + and not sent to the server until responses are received. If not + supplied, will default to 4. Give 0 to disable the limit entirely. + + max_connections_per_host => INT + + Optional. Controls the maximum number of connections per + hostname/server port pair, before requests will be queued awaiting one + to be free. Give 0 to disable the limit entirely. See also the + "Connection Pooling" section documented above. + + Currently, if not supplied it will default to 1. However, it has been + found in practice that most programs will raise this limit to something + higher, perhaps 3 or 4. Therefore, a future version of this module may + set a higher value. + + To test if your application will handle this correctly, you can set a + different default by setting an environment variable: + + $ NET_ASYNC_HTTP_MAXCONNS=3 perl ... + + timeout => NUM + + Optional. How long in seconds to wait before giving up on a request. If + not supplied then no default will be applied, and no timeout will take + place. + + stall_timeout => NUM + + Optional. How long in seconds to wait after each write or read of data + on a socket, before giving up on a request. This may be more useful + than timeout on large-file operations, as it will not time out provided + that regular progress is still being made. + + proxy_host => STRING + + proxy_port => INT + + Optional. Default values to apply to each request method. + + cookie_jar => HTTP::Cookies + + Optional. A reference to a HTTP::Cookies object. Will be used to set + cookies in requests and store them from responses. + + pipeline => BOOL + + Optional. If false, disables HTTP/1.1-style request pipelining. + + family => INT + + local_host => STRING + + local_port => INT + + local_addrs => ARRAY + + local_addr => HASH or ARRAY + + Optional. Parameters to pass on to the connect method used to connect + sockets to HTTP servers. Sets the socket family and local socket + address to bind() to. For more detail, see the documentation in + IO::Async::Connector. + + fail_on_error => BOOL + + Optional. Affects the behaviour of response handling when a 4xx or 5xx + response code is received. When false, these responses will be + processed as other responses and yielded as the result of the future, + or passed to the on_response callback. When true, such an error + response causes the future to fail, or the on_error callback to be + invoked. + + The HTTP response and request objects will be passed as well as the + code and message, and the failure name will be http. + + ( $code_message, "http", $response, $request ) = $f->failure + + $on_error->( "$code $message", $response, $request ) + + read_len => INT + + write_len => INT + + Optional. Used to set the reading and writing buffer lengths on the + underlying IO::Async::Stream objects that represent connections to the + server. If not define, a default of 64 KiB will be used. + + ip_tos => INT or STRING + + Optional. Used to set the IP_TOS socket option on client sockets. If + given, should either be a IPTOS_* constant, or one of the string names + lowdelay, throughput, reliability or mincost. If undefined or left + absent, no option will be set. + + decode_content => BOOL + + Optional. If true, incoming responses that have a recognised + Content-Encoding are handled by the module, and decompressed content is + passed to the body handling callback or returned in the HTTP::Response. + See "CONTENT DECODING" below for details of which encoding types are + recognised. When this option is enabled, outgoing requests also have + the Accept-Encoding header added to them if it does not already exist. + + Currently the default is false, because this behaviour is new, but it + may default to true in a later version. Applications which care which + behaviour applies should set this to a defined value to ensure it + doesn't change. + + SSL_* + + Additionally, any parameters whose names start with SSL_ will be stored + and passed on requests to perform SSL requests. This simplifies + configuration of common SSL parameters. + + require_SSL => BOOL + + Optional. If true, then any attempt to make a request that does not use + SSL (either by calling request, or as a result of a redirection) will + immediately fail. + + SOCKS_* + + Since version 0.42. + + Additionally, any parameters whose names start with SOCKS_ will be + stored and used by Net::Async::SOCKS to establish connections via a + configured proxy. + +METHODS + + The following methods documented with a trailing call to ->get return + Future instances. + + When returning a Future, the following methods all indicate HTTP-level + errors using the Future failure name of http. If the error relates to a + specific response it will be included. The original request is also + included. + + $f->fail( $message, "http", $response, $request ) + + $response = $http->do_request( %args )->get + + Send an HTTP request to a server, returning a Future that will yield + the response. The request may be represented by an HTTP::Request + object, or a URI object, depending on the arguments passed. + + The following named arguments are used for HTTP::Requests: + + request => HTTP::Request + + A reference to an HTTP::Request object + + host => STRING + + Hostname of the server to connect to + + port => INT or STRING + + Optional. Port number or service of the server to connect to. If not + defined, will default to http or https depending on whether SSL is + being used. + + family => INT + + Optional. Restricts the socket family for connecting. If not defined, + will default to the globally-configured value in the object. + + SSL => BOOL + + Optional. If true, an SSL connection will be used. + + The following named arguments are used for URI requests: + + uri => URI or STRING + + A reference to a URI object, or a plain string giving the request + URI. If the scheme is https then an SSL connection will be used. + + method => STRING + + Optional. The HTTP method name. If missing, GET is used. + + content => STRING or ARRAY ref + + Optional. The body content to use for PUT or POST requests. + + If this is a plain scalar it will be used directly, and a + content_type field must also be supplied to describe it. + + If this is an ARRAY ref and the request method is POST, it will be + form encoded. It should contain an even-sized list of field names and + values. For more detail see "POST" in HTTP::Request::Common. + + content_type => STRING + + The type of non-form data content. + + user => STRING + + pass => STRING + + Optional. If both are given, the HTTP Basic Authorization header will + be sent with these details. + + headers => ARRAY|HASH + + Optional. If provided, contains additional HTTP headers to set on the + constructed request object. If provided as an ARRAY reference, it + should contain an even-sized list of name/value pairs. + + proxy_host => STRING + + proxy_port => INT + + Optional. Override the hostname or port number implied by the URI. + + For either request type, it takes the following arguments: + + request_body => STRING | CODE | Future + + Optional. Allows request body content to be generated by a future or + callback, rather than being provided as part of the request object. + This can either be a plain string, a CODE reference to a generator + function, or a future. + + As this is passed to the underlying IO::Async::Stream write method, + the usual semantics apply here. If passed a CODE reference, it will + be called repeatedly whenever it's safe to write. The code should + should return undef to indicate completion. If passed a Future it is + expected to eventually yield the body value. + + As with the content parameter, the content_type field should be + specified explicitly in the request header, as should the content + length (typically via the HTTP::Request content_length method). See + also examples/PUT.pl. + + expect_continue => BOOL + + Optional. If true, sets the Expect request header to the value + 100-continue and does not send the request_body parameter until a 100 + Continue response is received from the server. If an error response + is received then the request_body code, if present, will not be + invoked. + + on_ready => CODE + + Optional. A callback that is invoked once a socket connection is + established with the HTTP server, but before the request is actually + sent over it. This may be used by the client code to inspect the + socket, or perform any other operations on it. This code is expected + to return a Future; only once that has completed will the request + cycle continue. If it fails, that failure is propagated to the + caller. + + $f = $on_ready->( $connection ) + + on_redirect => CODE + + Optional. A callback that is invoked if a redirect response is + received, before the new location is fetched. It will be passed the + response and the new URL. + + $on_redirect->( $response, $location ) + + on_body_write => CODE + + Optional. A callback that is invoked after each successful syswrite + of the body content. This may be used to implement an upload progress + indicator or similar. It will be passed the total number of bytes of + body content written so far (i.e. excluding bytes consumed in the + header). + + $on_body_write->( $written ) + + max_redirects => INT + + Optional. How many levels of redirection to follow. If not supplied, + will default to the value given in the constructor. + + timeout => NUM + + stall_timeout => NUM + + Optional. Overrides the object's configured timeout values for this + one request. If not specified, will use the configured defaults. + + On a timeout, the returned future will fail with either timeout or + stall_timeout as the operation name. + + ( $message, "timeout" ) = $f->failure + + $http->do_request( %args ) + + When not returning a future, the following extra arguments are used as + callbacks instead: + + on_response => CODE + + A callback that is invoked when a response to this request has been + received. It will be passed an HTTP::Response object containing the + response the server sent. + + $on_response->( $response ) + + on_header => CODE + + Alternative to on_response. A callback that is invoked when the + header of a response has been received. It is expected to return a + CODE reference for handling chunks of body content. This CODE + reference will be invoked with no arguments once the end of the + request has been reached, and whatever it returns will be used as the + result of the returned Future, if there is one. + + $on_body_chunk = $on_header->( $header ) + + $on_body_chunk->( $data ) + $response = $on_body_chunk->() + + on_error => CODE + + A callback that is invoked if an error occurs while trying to send + the request or obtain the response. It will be passed an error + message. + + $on_error->( $message ) + + If this is invoked because of a received 4xx or 5xx error code in an + HTTP response, it will be invoked with the response and request + objects as well. + + $on_error->( $message, $response, $request ) + + $response = $http->GET( $uri, %args )->get + + $response = $http->HEAD( $uri, %args )->get + + $response = $http->PUT( $uri, $content, %args )->get + + $response = $http->POST( $uri, $content, %args )->get + + Convenient wrappers for performing GET, HEAD, PUT or POST requests with + a URI object and few if any other arguments, returning a Future. + + Remember that POST with non-form data (as indicated by a plain scalar + instead of an ARRAY reference of form data name/value pairs) needs a + content_type key in %args. + +SUBCLASS METHODS + + The following methods are intended as points for subclasses to + override, to add extra functionallity. + + $http->prepare_request( $request ) + + Called just before the HTTP::Request object is sent to the server. + + $http->process_response( $response ) + + Called after a non-redirect HTTP::Response has been received from a + server. The originating request will be set in the object. + +CONTENT DECODING + + If the required decompression modules are installed and available, + compressed content can be decoded. If the received Content-Encoding is + recognised and the required module is available, the content is + transparently decoded and the decoded content is returned in the + resulting response object, or passed to the data chunk handler. In this + case, the original Content-Encoding header will be deleted from the + response, and its value will be available instead as + X-Original-Content-Encoding. + + The following content encoding types are recognised by these modules: + + * gzip (q=0.7) and deflate (q=0.5) + + Recognised if Compress::Raw::Zlib version 2.057 or newer is + installed. + + * bzip2 (q=0.8) + + Recognised if Compress::Bzip2 version 2.10 or newer is installed. + + Other content encoding types can be registered by calling the following + method + + Net::Async::HTTP->register_decoder( $name, $q, $make_decoder ) + + Registers an encoding type called $name, at the quality value $q. In + order to decode this encoding type, $make_decoder will be invoked with + no paramters, and expected to return a CODE reference to perform one + instance of decoding. + + $decoder = $make_decoder->() + + This decoder will be invoked on string buffers to decode them until the + end of stream is reached, when it will be invoked with no arguments. + + $content = $decoder->( $encoded_content ) + $content = $decoder->() # EOS + +EXAMPLES + + Concurrent GET + + The Future-returning GET method makes it easy to await multiple URLs at + once, by using the Future::Utils fmap_void utility + + my @URLs = ( ... ); + + my $http = Net::Async::HTTP->new( ... ); + $loop->add( $http ); + + my $future = fmap_void { + my ( $url ) = @_; + $http->GET( $url ) + ->on_done( sub { + my $response = shift; + say "$url succeeded: ", $response->code; + say " Content-Type":", $response->content_type; + } ) + ->on_fail( sub { + my $failure = shift; + say "$url failed: $failure"; + } ); + } foreach => \@URLs; + + $loop->await( $future ); + +SEE ALSO + + * http://tools.ietf.org/html/rfc2616 - Hypertext Transfer Protocol -- + HTTP/1.1 + +SPONSORS + + Parts of this code, or bugfixes to it were paid for by + + * SocialFlow http://www.socialflow.com + + * Shadowcat Systems http://www.shadow.cat + + * NET-A-PORTER http://www.net-a-porter.com + + * Cisco http://www.cisco.com + +AUTHOR + + Paul Evans <leonerd@leonerd.org.uk> + diff --git a/examples/GET.pl b/examples/GET.pl new file mode 100755 index 0000000..8013522 --- /dev/null +++ b/examples/GET.pl @@ -0,0 +1,43 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use URI; + +use Getopt::Long; +use IO::Async::Loop; +use Net::Async::HTTP; + +my $FAMILY; +GetOptions( + 'local-host=s' => \my $LOCAL_HOST, + 'local-port=i' => \my $LOCAL_PORT, + 'timeout=f' => \my $TIMEOUT, + 'ipv4|4' => sub { $FAMILY = "inet" }, + 'ipv6|6' => sub { $FAMILY = "inet6" }, +) or exit 1; + +my $loop = IO::Async::Loop->new; + +my $ua = Net::Async::HTTP->new( + local_host => $LOCAL_HOST, + local_port => $LOCAL_PORT, + family => $FAMILY, + decode_content => 1, +); +$loop->add( $ua ); + +$ua->configure( timeout => $TIMEOUT ) if defined $TIMEOUT; + +$ua->GET( $ARGV[0] ) + ->on_done( sub { + my ( $response ) = @_; + + print $response->as_string; + } ) + ->on_fail( sub { + my ( $message ) = @_; + + print STDERR "Failed - $message\n"; + } )->get; diff --git a/examples/PUT.pl b/examples/PUT.pl new file mode 100755 index 0000000..a90740b --- /dev/null +++ b/examples/PUT.pl @@ -0,0 +1,125 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use URI; + +use IO::Async::Loop; +use Net::Async::HTTP; + +use POSIX qw( floor ); +use Time::HiRes qw( time ); +use Getopt::Long; + +sub usage +{ + my ( $exitcode ) = @_; + + print STDERR <<"EOF"; +Net::Async::HTTP PUT client example. + +Usage: + + $0 [-u user:pass] https://example.com/file-to-put.bin /tmp/file-to-read.bin + +If -u options are given, these will be sent as Basic auth credentials. +Different ports can be specified in the URL, e.g. + + http://example.com:12314/file.txt + +EOF +} + +# Basic commandline parameter support - -u user:password +my $userpass; +my $url; +my $src; +my $contenttype = "application/octet-stream"; + +GetOptions( + 'userpass|u=s' => \$userpass, + 'src=s' => \$src, + 'type|t=s' => \$contenttype, + + 'help|h' => sub { usage(0) }, +) or usage(1); + +my $loop = IO::Async::Loop->new; + +$url = shift @ARGV or usage(1); +$src = shift @ARGV or usage(1) if !defined $src; + +my $ua = Net::Async::HTTP->new; +$loop->add( $ua ); + +# We'll send the size as the Content-Length, and get the filehandle ready for reading +my $size = (stat $src)[7]; +open my $fh, '<', $src or die "Failed to open source file $src - $!\n"; +binmode $fh; + +# Prepare our request object +my $uri = URI->new($url) or die "Invalid URL?\n"; +my $req = HTTP::Request->new( + PUT => $uri->path, [ + 'Host' => $uri->host, + 'Content-Type' => $contenttype, + ] +); + +# Default is no protocol, we insist on HTTP/1.1 here, PUT probably requires that as a minimum anyway +$req->protocol( 'HTTP/1.1' ); +$req->authorization_basic( split m/:/, $userpass, 2 ) if defined $userpass; +$req->content_length( $size ); + +# For stats +my $total = 0; +my $last = -1; +my $start; + +$ua->do_request( + request => $req, + host => $uri->host, + port => $uri->port, + SSL => $uri->scheme eq 'https' ? 1 : 0, + + # We override the default behaviour (pulling content from HTTP::Request) by passing a callback explicitly + # Originall had "content_callback", not really sure what the best thing to call this would be though. + request_body => sub { + my ($stream) = @_; + unless (defined $start) { + $start = time; + $| = 1; + } + + # This part is the important one - read some data, and eventually return it + my $read = sysread $fh, my $buffer, 1048576; + + # Just for stats display, update every mbyte + $total += $read; + my $step = floor($total / 1048576); + if($step > $last) { + $last = $step; + my $elapsed = (time - $start) || 1; + printf("Total: %14d of %14d bytes, %5.2f%% complete, %9.3fkbyte/s \r", $total, $size, (100 * $total) / $size, ($total) / ($elapsed * 1024)); + } + + return $buffer if $read; + + # Return undef when we're done + print "\n\nComplete.\n"; + return; + }, + on_response => sub { + my ( $response ) = @_; + + close $fh or die $!; + print $response->as_string; + }, + + on_error => sub { + my ( $message ) = @_; + + print STDERR "Failed - $message\n"; + } +)->get; diff --git a/examples/parallel-put.pl b/examples/parallel-put.pl new file mode 100644 index 0000000..fbebaaf --- /dev/null +++ b/examples/parallel-put.pl @@ -0,0 +1,183 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +=pod + +A slightly longer example demonstrating multiple L<Net::Async::HTTP> clients running in parallel. Given a base URL, +this will recursively (breadth-first) scan any paths given on the command line and PUT whatever files are found. + +The resulting file structure will be flattened, there's no attempt to MKCOL the equivalent path structure on the +target server. + +=cut + +use URI; +use Async::MergePoint; +use IO::Async::Loop; +use IO::Async::Timer::Periodic; +use Net::Async::HTTP; +use POSIX qw(floor); +use Time::HiRes qw(time); +use Scalar::Util qw(weaken); +use File::Basename qw(basename); +use Format::Human::Bytes; +use Getopt::Std; + +# Basic commandline parameter support: +# * -u user:password +# * -n number of workers to start +getopt('u:n:', \my %opts); + +@ARGV || die <<"USAGE"; +Net::Async::HTTP PUT client example. + +Usage: + + $0 [-u user:pass] -n 8 http://dav.example.com file*.txt directory1 directory2 + +If -u options are given, these will be sent as Basic auth credentials. Different ports can be specified in the URL, +e.g. http://example.com:12314/file.txt. + +The -n option specifies how many parallel connections to open (default is a single connection only). + +USAGE + +my $loop = IO::Async::Loop->new; + +# Bytes transferred so far +my $total = 0; + +# Define some workers +$opts{n} ||= 1; +my @ua = map { Net::Async::HTTP->new } 1..$opts{n}; +$loop->add( $_ ) for @ua; + +my $start = time; + +# Used for pretty-printing, not essential if you don't have it installed +my $fhb = Format::Human::Bytes->new; + +# The clients are added to this, and marked as done by the workers once the current file has finished and there is nothing +# else left in the queue. Bit of a hack to pass the raw Net::Async:HTTP objects but since they each stringify to a different +# value it does the job for now, should perhaps pass an ID or something instead. +my $mp = Async::MergePoint->new( + needs => \@ua, + on_finished => sub { + my $elapsed = time - $start; + print "All done - " . $fhb->base2($total) . " in $elapsed seconds, " . $fhb->base2($total / $elapsed) . "/sec\n"; + $loop->loop_stop; + } +); + +# Expect a URL and a list of files as parameters +my ($base_url, @todo) = @ARGV; + +# Start each worker off +queue_next_item($_) for @ua; + +# Give a rough idea of progress +my $timer = IO::Async::Timer::Periodic->new( + interval => 10, + on_tick => sub { + my $elapsed = time - $start; + print ">> Transferred " . $fhb->base2($total) . " bytes in $elapsed seconds, " . $fhb->base2($total / $elapsed, 2) . "/sec\n"; + }, +); +$loop->add($timer); +$timer->start; + +# And begin looping +$loop->loop_forever; +exit; + +# Get next item from the queue and make the request +sub queue_next_item { + my $ua = shift; + + while(@todo) { + my $path = shift(@todo); + return send_file($ua, $path) if -f $path; + push @todo, glob "$path/*"; + print "Add directory $path, queue now " . @todo . "\n"; + } + $mp->done($ua); +} + +# Generate the request for the given UA and send it +sub send_file { + my $ua = shift; + my $path = shift; + + # We'll send the size as the Content-Length, and get the filehandle ready for reading + my $size = (stat $path)[7]; + open my $fh, '<', $path or die "failed to open source file $path: $!"; + binmode $fh; + + # Prepare our request object + my $uri = URI->new($base_url . '/' . basename($path)) or die "Invalid URL?"; + my $req = HTTP::Request->new( + PUT => $uri->path, [ + 'Host' => $uri->host, + # Send as binary to avoid any text-mangling process, should be overrideable from the commandline though + 'Content-Type' => 'application/octetstream' + ] + ); + # Default is no protocol, we insist on HTTP/1.1 here, PUT probably requires that as a minimum anyway + $req->protocol('HTTP/1.1'); + $req->authorization_basic(split /:/, $opts{u}, 2) if defined $opts{u}; + $req->content_length($size); + + weaken $ua; + $ua->do_request( + request => $req, + # Probably duplicating a load of logic here :( + host => $uri->host, + port => $uri->port || $uri->scheme || 80, + SSL => $uri->scheme eq 'https' ? 1 : 0, + + # We override the default behaviour (pulling content from HTTP::Request) by passing a callback explicitly + request_body => sub { + my ($stream) = @_; + + # This part is the important one - read some data, and eventually return it + my $read = sysread $fh, my $buffer, 32768; + $total += $read // 0; + return $buffer if $read; + + # Don't really need to close here, but might as well clean up as soon as we're ready + close $fh or warn $!; + undef $fh; + return; + }, + + on_response => sub { + my ($response) = @_; + if($fh) { + close $fh or die $!; + } + my $msg = $response->message; + $msg =~ s/\s+/ /ig; + $msg =~ s/(?:^\s+)|(?:\s+$)//g; # trim + print $response->code . " for $path ($size bytes) - $msg\n"; + + # haxx: if we get a server error, just repeat. + push @todo, $path if $response->code == 500; + + queue_next_item($ua); + }, + + on_error => sub { + my ( $message ) = @_; + if($fh) { + close $fh or die $!; + } + + print STDERR "Failed - $message\n"; + # Could do a $loop->loop_stop here - some failures should be fatal! + queue_next_item($ua); + } + ); +} + diff --git a/lib/Net/Async/HTTP.pm b/lib/Net/Async/HTTP.pm new file mode 100644 index 0000000..ab4b585 --- /dev/null +++ b/lib/Net/Async/HTTP.pm @@ -0,0 +1,1265 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2008-2018 -- leonerd@leonerd.org.uk + +package Net::Async::HTTP; + +use strict; +use warnings; +use 5.010; # // +use base qw( IO::Async::Notifier ); + +our $VERSION = '0.44'; + +our $DEFAULT_UA = "Perl + " . __PACKAGE__ . "/$VERSION"; +our $DEFAULT_MAXREDIR = 3; +our $DEFAULT_MAX_IN_FLIGHT = 4; +our $DEFAULT_MAX_CONNS_PER_HOST = $ENV{NET_ASYNC_HTTP_MAXCONNS} // 1; + +use Carp; + +use Net::Async::HTTP::Connection; + +use HTTP::Request; +use HTTP::Request::Common qw(); +use URI; + +use IO::Async::Stream 0.59; +use IO::Async::Loop 0.59; # ->connect( handle ) ==> $stream + +use Future 0.28; # ->set_label +use Future::Utils 0.16 qw( repeat ); + +use Scalar::Util qw( blessed reftype ); +use List::Util 1.29 qw( first pairs ); +use Socket 2.010 qw( + SOCK_STREAM IPPROTO_IP IP_TOS + IPTOS_LOWDELAY IPTOS_THROUGHPUT IPTOS_RELIABILITY IPTOS_MINCOST +); + +use constant HTTP_PORT => 80; +use constant HTTPS_PORT => 443; + +use constant READ_LEN => 64*1024; # 64 KiB +use constant WRITE_LEN => 64*1024; # 64 KiB + +use Struct::Dumb 0.07; # equallity operator overloading +struct Ready => [qw( future connecting )]; + +=head1 NAME + +C<Net::Async::HTTP> - use HTTP with C<IO::Async> + +=head1 SYNOPSIS + + use IO::Async::Loop; + use Net::Async::HTTP; + use URI; + + my $loop = IO::Async::Loop->new(); + + my $http = Net::Async::HTTP->new(); + + $loop->add( $http ); + + my ( $response ) = $http->do_request( + uri => URI->new( "http://www.cpan.org/" ), + )->get; + + print "Front page of http://www.cpan.org/ is:\n"; + print $response->as_string; + +=head1 DESCRIPTION + +This object class implements an asynchronous HTTP user agent. It sends +requests to servers, returning L<Future> instances to yield responses when +they are received. The object supports multiple concurrent connections to +servers, and allows multiple requests in the pipeline to any one connection. +Normally, only one such object will be needed per program to support any +number of requests. + +As well as using futures the module also supports a callback-based interface. + +This module optionally supports SSL connections, if L<IO::Async::SSL> is +installed. If so, SSL can be requested either by passing a URI with the +C<https> scheme, or by passing a true value as the C<SSL> parameter. + +=head2 Connection Pooling + +There are three ways in which connections to HTTP server hosts are managed by +this object, controlled by the value of C<max_connections_per_host>. This +controls when new connections are established to servers, as compared to +waiting for existing connections to be free, as new requests are made to them. + +They are: + +=over 2 + +=item max_connections_per_host = 1 + +This is the default setting. In this mode, there will be one connection per +host on which there are active or pending requests. If new requests are made +while an existing one is outstanding, they will be queued to wait for it. + +If pipelining is active on the connection (because both the C<pipeline> option +is true and the connection is known to be an HTTP/1.1 server), then requests +will be pipelined into the connection awaiting their response. If not, they +will be queued awaiting a response to the previous before sending the next. + +=item max_connections_per_host > 1 + +In this mode, there can be more than one connection per host. If a new request +is made, it will try to re-use idle connections if there are any, or if they +are all busy it will create a new connection to the host, up to the configured +limit. + +=item max_connections_per_host = 0 + +In this mode, there is no upper limit to the number of connections per host. +Every new request will try to reuse an idle connection, or else create a new +one if all the existing ones are busy. + +=back + +These modes all apply per hostname / server port pair; they do not affect the +behaviour of connections made to differing hostnames, or differing ports on +the same hostname. + +=cut + +sub _init +{ + my $self = shift; + + $self->{connections} = {}; # { "$host:$port" } -> [ @connections ] + + $self->{read_len} = READ_LEN; + $self->{write_len} = WRITE_LEN; + + $self->{max_connections_per_host} = $DEFAULT_MAX_CONNS_PER_HOST; + + $self->{ssl_params} = {}; +} + +sub _remove_from_loop +{ + my $self = shift; + + foreach my $conn ( map { @$_ } values %{ $self->{connections} } ) { + $conn->close; + } + + $self->SUPER::_remove_from_loop( @_ ); +} + +=head1 PARAMETERS + +The following named parameters may be passed to C<new> or C<configure>: + +=head2 user_agent => STRING + +A string to set in the C<User-Agent> HTTP header. If not supplied, one will +be constructed that declares C<Net::Async::HTTP> and the version number. + +=head2 max_redirects => INT + +Optional. How many levels of redirection to follow. If not supplied, will +default to 3. Give 0 to disable redirection entirely. + +=head2 max_in_flight => INT + +Optional. The maximum number of in-flight requests to allow per host when +pipelining is enabled and supported on that host. If more requests are made +over this limit they will be queued internally by the object and not sent to +the server until responses are received. If not supplied, will default to 4. +Give 0 to disable the limit entirely. + +=head2 max_connections_per_host => INT + +Optional. Controls the maximum number of connections per hostname/server port +pair, before requests will be queued awaiting one to be free. Give 0 to +disable the limit entirely. See also the L</Connection Pooling> section +documented above. + +Currently, if not supplied it will default to 1. However, it has been found in +practice that most programs will raise this limit to something higher, perhaps +3 or 4. Therefore, a future version of this module may set a higher value. + +To test if your application will handle this correctly, you can set a +different default by setting an environment variable: + + $ NET_ASYNC_HTTP_MAXCONNS=3 perl ... + +=head2 timeout => NUM + +Optional. How long in seconds to wait before giving up on a request. If not +supplied then no default will be applied, and no timeout will take place. + +=head2 stall_timeout => NUM + +Optional. How long in seconds to wait after each write or read of data on a +socket, before giving up on a request. This may be more useful than +C<timeout> on large-file operations, as it will not time out provided that +regular progress is still being made. + +=head2 proxy_host => STRING + +=head2 proxy_port => INT + +Optional. Default values to apply to each C<request> method. + +=head2 cookie_jar => HTTP::Cookies + +Optional. A reference to a L<HTTP::Cookies> object. Will be used to set +cookies in requests and store them from responses. + +=head2 pipeline => BOOL + +Optional. If false, disables HTTP/1.1-style request pipelining. + +=head2 family => INT + +=head2 local_host => STRING + +=head2 local_port => INT + +=head2 local_addrs => ARRAY + +=head2 local_addr => HASH or ARRAY + +Optional. Parameters to pass on to the C<connect> method used to connect +sockets to HTTP servers. Sets the socket family and local socket address to +C<bind()> to. For more detail, see the documentation in +L<IO::Async::Connector>. + +=head2 fail_on_error => BOOL + +Optional. Affects the behaviour of response handling when a C<4xx> or C<5xx> +response code is received. When false, these responses will be processed as +other responses and yielded as the result of the future, or passed to the +C<on_response> callback. When true, such an error response causes the future +to fail, or the C<on_error> callback to be invoked. + +The HTTP response and request objects will be passed as well as the code and +message, and the failure name will be C<http>. + + ( $code_message, "http", $response, $request ) = $f->failure + + $on_error->( "$code $message", $response, $request ) + +=head2 read_len => INT + +=head2 write_len => INT + +Optional. Used to set the reading and writing buffer lengths on the underlying +C<IO::Async::Stream> objects that represent connections to the server. If not +define, a default of 64 KiB will be used. + +=head2 ip_tos => INT or STRING + +Optional. Used to set the C<IP_TOS> socket option on client sockets. If given, +should either be a C<IPTOS_*> constant, or one of the string names +C<lowdelay>, C<throughput>, C<reliability> or C<mincost>. If undefined or left +absent, no option will be set. + +=head2 decode_content => BOOL + +Optional. If true, incoming responses that have a recognised +C<Content-Encoding> are handled by the module, and decompressed content is +passed to the body handling callback or returned in the C<HTTP::Response>. See +L</CONTENT DECODING> below for details of which encoding types are recognised. +When this option is enabled, outgoing requests also have the +C<Accept-Encoding> header added to them if it does not already exist. + +Currently the default is false, because this behaviour is new, but it may +default to true in a later version. Applications which care which behaviour +applies should set this to a defined value to ensure it doesn't change. + +=head2 SSL_* + +Additionally, any parameters whose names start with C<SSL_> will be stored and +passed on requests to perform SSL requests. This simplifies configuration of +common SSL parameters. + +=head2 require_SSL => BOOL + +Optional. If true, then any attempt to make a request that does not use SSL +(either by calling C<request>, or as a result of a redirection) will +immediately fail. + +=head2 SOCKS_* + +I<Since version 0.42.> + +Additionally, any parameters whose names start with C<SOCKS_> will be stored +and used by L<Net::Async::SOCKS> to establish connections via a configured +proxy. + +=cut + +sub configure +{ + my $self = shift; + my %params = @_; + + foreach (qw( user_agent max_redirects max_in_flight max_connections_per_host + timeout stall_timeout proxy_host proxy_port cookie_jar pipeline + family local_host local_port local_addrs local_addr fail_on_error + read_len write_len decode_content require_SSL )) + { + $self->{$_} = delete $params{$_} if exists $params{$_}; + } + + foreach ( grep { m/^SSL_/ } keys %params ) { + $self->{ssl_params}{$_} = delete $params{$_}; + } + + foreach ( grep { m/^SOCKS_/ } keys %params ) { + $self->{socks_params}{$_} = delete $params{$_}; + } + + if( exists $params{ip_tos} ) { + # TODO: This conversion should live in IO::Async somewhere + my $ip_tos = delete $params{ip_tos}; + $ip_tos = IPTOS_LOWDELAY if defined $ip_tos and $ip_tos eq "lowdelay"; + $ip_tos = IPTOS_THROUGHPUT if defined $ip_tos and $ip_tos eq "throughput"; + $ip_tos = IPTOS_RELIABILITY if defined $ip_tos and $ip_tos eq "reliability"; + $ip_tos = IPTOS_MINCOST if defined $ip_tos and $ip_tos eq "mincost"; + $self->{ip_tos} = $ip_tos; + } + + $self->SUPER::configure( %params ); + + defined $self->{user_agent} or $self->{user_agent} = $DEFAULT_UA; + defined $self->{max_redirects} or $self->{max_redirects} = $DEFAULT_MAXREDIR; + defined $self->{max_in_flight} or $self->{max_in_flight} = $DEFAULT_MAX_IN_FLIGHT; + defined $self->{pipeline} or $self->{pipeline} = 1; +} + +=head1 METHODS + +The following methods documented with a trailing call to C<< ->get >> return +L<Future> instances. + +When returning a Future, the following methods all indicate HTTP-level errors +using the Future failure name of C<http>. If the error relates to a specific +response it will be included. The original request is also included. + + $f->fail( $message, "http", $response, $request ) + +=cut + +sub connect_connection +{ + my $self = shift; + my %args = @_; + + my $conn = delete $args{conn}; + + my $host = delete $args{host}; + my $port = delete $args{port}; + + my $on_error = $args{on_error}; + + if( my $socks_params = $self->{socks_params} ) { + require Net::Async::SOCKS; + Net::Async::SOCKS->VERSION( '0.003' ); + + unshift @{ $args{extensions} }, "SOCKS"; + $args{$_} = $socks_params->{$_} for keys %$socks_params; + } + + if( $args{SSL} ) { + require IO::Async::SSL; + IO::Async::SSL->VERSION( '0.12' ); # 0.12 has ->connect(handle) bugfix + + unshift @{ $args{extensions} }, "SSL"; + } + + my $f = $conn->connect( + host => $host, + service => $port, + family => ( $args{family} || $self->{family} || 0 ), + ( map { defined $self->{$_} ? ( $_ => $self->{$_} ) : () } + qw( local_host local_port local_addrs local_addr ) ), + + %args, + )->on_done( sub { + my ( $stream ) = @_; + $stream->configure( + notifier_name => "$host:$port,fd=" . $stream->read_handle->fileno, + ); + + # Defend against ->setsockopt doing silly things like detecting SvPOK() + $stream->read_handle->setsockopt( IPPROTO_IP, IP_TOS, $self->{ip_tos}+0 ) if defined $self->{ip_tos}; + + $stream->ready; + })->on_fail( sub { + $on_error->( $conn, "$host:$port - $_[0] failed [$_[-1]]" ); + }); + + $f->on_ready( sub { undef $f } ); # intentionally cycle +} + +sub get_connection +{ + my $self = shift; + my %args = @_; + + my $loop = $self->get_loop or croak "Cannot ->get_connection without a Loop"; + + my $host = $args{host}; + my $port = $args{port}; + + my $key = "$host:$port"; + my $conns = $self->{connections}{$key} ||= []; + my $ready_queue = $self->{ready_queue}{$key} ||= []; + + # Have a look to see if there are any idle connected ones first + foreach my $conn ( @$conns ) { + $conn->is_idle and $conn->read_handle and return Future->done( $conn ); + } + + my $ready = $args{ready}; + $ready or push @$ready_queue, $ready = + Ready( $self->loop->new_future->set_label( "[ready $host:$port]" ), 0 ); + + my $f = $ready->future; + + my $max = $self->{max_connections_per_host}; + if( $max and @$conns >= $max ) { + return $f; + } + + my $conn = Net::Async::HTTP::Connection->new( + notifier_name => "$host:$port,connecting", + ready_queue => $ready_queue, + ( map { $_ => $self->{$_} } + qw( max_in_flight pipeline read_len write_len decode_content ) ), + is_proxy => $args{is_proxy}, + + on_closed => sub { + my $conn = shift; + my $http = $conn->parent; + + $conn->remove_from_parent; + @$conns = grep { $_ != $conn } @$conns; + + if( my $next = first { !$_->connecting } @$ready_queue ) { + # Requeue another connection attempt as there's still more to do + $http->get_connection( %args, ready => $next ); + } + }, + ); + + $self->add_child( $conn ); + push @$conns, $conn; + + $ready->connecting = $self->connect_connection( %args, + conn => $conn, + on_error => sub { + my $conn = shift; + + $f->fail( @_ ) unless $f->is_cancelled; + + $conn->remove_from_parent; + @$conns = grep { $_ != $conn } @$conns; + @$ready_queue = grep { $_ != $ready } @$ready_queue; + + if( my $next = first { !$_->connecting } @$ready_queue ) { + # Requeue another connection attempt as there's still more to do + $self->get_connection( %args, ready => $next ); + } + }, + )->on_cancel( sub { + $conn->remove_from_parent; + @$conns = grep { $_ != $conn } @$conns; + }); + + return $f; +} + +=head2 $response = $http->do_request( %args )->get + +Send an HTTP request to a server, returning a L<Future> that will yield the +response. The request may be represented by an L<HTTP::Request> object, or a +L<URI> object, depending on the arguments passed. + +The following named arguments are used for C<HTTP::Request>s: + +=over 8 + +=item request => HTTP::Request + +A reference to an C<HTTP::Request> object + +=item host => STRING + +Hostname of the server to connect to + +=item port => INT or STRING + +Optional. Port number or service of the server to connect to. If not defined, +will default to C<http> or C<https> depending on whether SSL is being used. + +=item family => INT + +Optional. Restricts the socket family for connecting. If not defined, will +default to the globally-configured value in the object. + +=item SSL => BOOL + +Optional. If true, an SSL connection will be used. + +=back + +The following named arguments are used for C<URI> requests: + +=over 8 + +=item uri => URI or STRING + +A reference to a C<URI> object, or a plain string giving the request URI. If +the scheme is C<https> then an SSL connection will be used. + +=item method => STRING + +Optional. The HTTP method name. If missing, C<GET> is used. + +=item content => STRING or ARRAY ref + +Optional. The body content to use for C<PUT> or C<POST> requests. + +If this is a plain scalar it will be used directly, and a C<content_type> +field must also be supplied to describe it. + +If this is an ARRAY ref and the request method is C<POST>, it will be form +encoded. It should contain an even-sized list of field names and values. For +more detail see L<HTTP::Request::Common/POST>. + +=item content_type => STRING + +The type of non-form data C<content>. + +=item user => STRING + +=item pass => STRING + +Optional. If both are given, the HTTP Basic Authorization header will be sent +with these details. + +=item headers => ARRAY|HASH + +Optional. If provided, contains additional HTTP headers to set on the +constructed request object. If provided as an ARRAY reference, it should +contain an even-sized list of name/value pairs. + +=item proxy_host => STRING + +=item proxy_port => INT + +Optional. Override the hostname or port number implied by the URI. + +=back + +For either request type, it takes the following arguments: + +=over 8 + +=item request_body => STRING | CODE | Future + +Optional. Allows request body content to be generated by a future or +callback, rather than being provided as part of the C<request> object. This +can either be a plain string, a C<CODE> reference to a generator function, or +a future. + +As this is passed to the underlying L<IO::Async::Stream> C<write> method, the +usual semantics apply here. If passed a C<CODE> reference, it will be called +repeatedly whenever it's safe to write. The code should should return C<undef> +to indicate completion. If passed a C<Future> it is expected to eventually +yield the body value. + +As with the C<content> parameter, the C<content_type> field should be +specified explicitly in the request header, as should the content length +(typically via the L<HTTP::Request> C<content_length> method). See also +F<examples/PUT.pl>. + +=item expect_continue => BOOL + +Optional. If true, sets the C<Expect> request header to the value +C<100-continue> and does not send the C<request_body> parameter until a +C<100 Continue> response is received from the server. If an error response is +received then the C<request_body> code, if present, will not be invoked. + +=item on_ready => CODE + +Optional. A callback that is invoked once a socket connection is established +with the HTTP server, but before the request is actually sent over it. This +may be used by the client code to inspect the socket, or perform any other +operations on it. This code is expected to return a C<Future>; only once that +has completed will the request cycle continue. If it fails, that failure is +propagated to the caller. + + $f = $on_ready->( $connection ) + +=item on_redirect => CODE + +Optional. A callback that is invoked if a redirect response is received, +before the new location is fetched. It will be passed the response and the new +URL. + + $on_redirect->( $response, $location ) + +=item on_body_write => CODE + +Optional. A callback that is invoked after each successful C<syswrite> of the +body content. This may be used to implement an upload progress indicator or +similar. It will be passed the total number of bytes of body content written +so far (i.e. excluding bytes consumed in the header). + + $on_body_write->( $written ) + +=item max_redirects => INT + +Optional. How many levels of redirection to follow. If not supplied, will +default to the value given in the constructor. + +=item timeout => NUM + +=item stall_timeout => NUM + +Optional. Overrides the object's configured timeout values for this one +request. If not specified, will use the configured defaults. + +On a timeout, the returned future will fail with either C<timeout> or +C<stall_timeout> as the operation name. + + ( $message, "timeout" ) = $f->failure + +=back + +=head2 $http->do_request( %args ) + +When not returning a future, the following extra arguments are used as +callbacks instead: + +=over 8 + +=item on_response => CODE + +A callback that is invoked when a response to this request has been received. +It will be passed an L<HTTP::Response> object containing the response the +server sent. + + $on_response->( $response ) + +=item on_header => CODE + +Alternative to C<on_response>. A callback that is invoked when the header of a +response has been received. It is expected to return a C<CODE> reference for +handling chunks of body content. This C<CODE> reference will be invoked with +no arguments once the end of the request has been reached, and whatever it +returns will be used as the result of the returned C<Future>, if there is one. + + $on_body_chunk = $on_header->( $header ) + + $on_body_chunk->( $data ) + $response = $on_body_chunk->() + +=item on_error => CODE + +A callback that is invoked if an error occurs while trying to send the request +or obtain the response. It will be passed an error message. + + $on_error->( $message ) + +If this is invoked because of a received C<4xx> or C<5xx> error code in an +HTTP response, it will be invoked with the response and request objects as +well. + + $on_error->( $message, $response, $request ) + +=back + +=cut + +sub _do_one_request +{ + my $self = shift; + my %args = @_; + + my $host = delete $args{host}; + my $port = delete $args{port}; + my $request = delete $args{request}; + my $SSL = delete $args{SSL}; + + my $stall_timeout = $args{stall_timeout} // $self->{stall_timeout}; + + $self->prepare_request( $request ); + + if( $self->{require_SSL} and not $SSL ) { + return Future->fail( "Non-SSL request is not allowed with 'require_SSL' set", + http => undef, $request ); + } + + return $self->get_connection( + host => $args{proxy_host} || $self->{proxy_host} || $host, + port => $args{proxy_port} || $self->{proxy_port} || $port, + is_proxy => !!( $args{proxy_host} || $self->{proxy_host} ), + ( defined $args{family} ? ( family => $args{family} ) : () ), + $SSL ? ( + SSL => 1, + SSL_hostname => $host, + %{ $self->{ssl_params} }, + ( map { m/^SSL_/ ? ( $_ => $args{$_} ) : () } keys %args ), + ) : (), + )->then( sub { + my ( $conn ) = @_; + $args{on_ready} ? $args{on_ready}->( $conn )->then_done( $conn ) + : Future->done( $conn ) + })->then( sub { + my ( $conn ) = @_; + + return $conn->request( + request => $request, + stall_timeout => $stall_timeout, + %args, + $SSL ? ( SSL => 1 ) : (), + ); + } ); +} + +sub _should_redirect +{ + my ( $response ) = @_; + + # Should only redirect if we actually have a Location header + return 0 unless $response->is_redirect and defined $response->header( "Location" ); + + my $req_method = $response->request->method; + # Should only redirect GET or HEAD requests + return $req_method eq "GET" || $req_method eq "HEAD"; +} + +sub _do_request +{ + my $self = shift; + my %args = @_; + + my $host = $args{host}; + my $port = $args{port}; + my $ssl = $args{SSL}; + + my $on_header = delete $args{on_header}; + + my $redirects = defined $args{max_redirects} ? $args{max_redirects} : $self->{max_redirects}; + + my $request = $args{request}; + my $response; + my $reqf; + # Defeat prototype + my $future = &repeat( $self->_capture_weakself( sub { + my $self = shift; + my ( $previous_f ) = @_; + + if( $previous_f ) { + my $previous_response = $previous_f->get; + $args{previous_response} = $previous_response; + + my $location = $previous_response->header( "Location" ); + + if( $location =~ m{^http(?:s?)://} ) { + # skip + } + elsif( $location =~ m{^/} ) { + my $hostport = ( $port != HTTP_PORT ) ? "$host:$port" : $host; + $location = "http://$hostport" . $location; + } + else { + return Future->fail( "Unrecognised Location: $location", http => $previous_response, $request ); + } + + my $loc_uri = URI->new( $location ); + unless( $loc_uri ) { + return Future->fail( "Unable to parse '$location' as a URI", http => $previous_response, $request ); + } + + $self->debug_printf( "REDIRECT $loc_uri" ); + + $args{on_redirect}->( $previous_response, $location ) if $args{on_redirect}; + + %args = $self->_make_request_for_uri( $loc_uri, %args ); + $request = $args{request}; + + undef $host; undef $port; undef $ssl; + } + + my $uri = $request->uri; + if( defined $uri->scheme and $uri->scheme =~ m/^http(s?)$/ ) { + $host = $uri->host if !defined $host; + $port = $uri->port if !defined $port; + $ssl = ( $uri->scheme eq "https" ); + } + + defined $host or croak "Expected 'host'"; + defined $port or $port = ( $ssl ? HTTPS_PORT : HTTP_PORT ); + + return $reqf = $self->_do_one_request( + host => $host, + port => $port, + SSL => $ssl, + %args, + on_header => $self->_capture_weakself( sub { + my $self = shift; + ( $response ) = @_; + + # Consume and discard the entire body of a redirect + return sub { + return if @_; + return $response; + } if $redirects and $response->is_redirect; + + return $on_header->( $response ); + } ), + ); + } ), + while => sub { + my $f = shift; + return 0 if $f->failure or $f->is_cancelled; + return _should_redirect( $response ) && $redirects--; + } ); + + if( $self->{fail_on_error} ) { + $future = $future->then_with_f( sub { + my ( $f, $resp ) = @_; + my $code = $resp->code; + + if( $code =~ m/^[45]/ ) { + my $message = $resp->message; + $message =~ s/\r$//; # HTTP::Message bug + + return Future->fail( "$code $message", http => $resp, $request ); + } + + return $f; + }); + } + + return $future; +} + +sub do_request +{ + my $self = shift; + my %args = @_; + + if( my $uri = delete $args{uri} ) { + %args = $self->_make_request_for_uri( $uri, %args ); + } + elsif( !defined $args{request} ) { + croak "Require either 'uri' or 'request' argument"; + } + + if( $args{on_header} ) { + # ok + } + elsif( $args{on_response} or defined wantarray ) { + $args{on_header} = sub { + my ( $response ) = @_; + return sub { + if( @_ ) { + $response->add_content( @_ ); + } + else { + return $response; + } + }; + } + } + else { + croak "Expected 'on_response' or 'on_header' as CODE ref or to return a Future"; + } + + my $on_error = delete $args{on_error}; + my $timeout = defined $args{timeout} ? $args{timeout} : $self->{timeout}; + + my $future = $self->_do_request( %args ); + + if( defined $timeout ) { + $future = Future->wait_any( + $future, + $self->loop->timeout_future( after => $timeout ) + ->transform( fail => sub { "Timed out", timeout => } ), + ); + } + + $future->on_done( $self->_capture_weakself( sub { + my $self = shift; + my $response = shift; + $self->process_response( $response ); + } ) ); + + $future->on_fail( sub { + my ( $message, $name, @rest ) = @_; + $on_error->( $message, @rest ); + }) if $on_error; + + if( my $on_response = delete $args{on_response} ) { + $future->on_done( sub { + my ( $response ) = @_; + $on_response->( $response ); + }); + } + + # DODGY HACK: + # In void context we'll lose reference on the ->wait_any Future, so the + # timeout logic will never happen. So lets purposely create a cycle by + # capturing the $future in on_done/on_fail closures within itself. This + # conveniently clears them out to drop the ref when done. + return $future if defined wantarray; + + $future->on_ready( sub { undef $future } ); +} + +sub _make_request_for_uri +{ + my $self = shift; + my ( $uri, %args ) = @_; + + if( !ref $uri ) { + $uri = URI->new( $uri ); + } + elsif( blessed $uri and !$uri->isa( "URI" ) ) { + croak "Expected 'uri' as a URI reference"; + } + + my $method = delete $args{method} || "GET"; + + $args{host} = $uri->host; + $args{port} = $uri->port; + + my $request; + + if( $method eq "POST" ) { + defined $args{content} or croak "Expected 'content' with POST method"; + + # Lack of content_type didn't used to be a failure condition: + ref $args{content} or defined $args{content_type} or + carp "No 'content_type' was given with 'content'"; + + # This will automatically encode a form for us + $request = HTTP::Request::Common::POST( $uri, Content => $args{content}, Content_Type => $args{content_type} ); + } + else { + $request = HTTP::Request->new( $method, $uri ); + if( defined $args{content} ) { + defined $args{content_type} or carp "No 'content_type' was given with 'content'"; + + $request->content( $args{content} ); + $request->content_type( $args{content_type} // "" ); + } + } + + $request->protocol( "HTTP/1.1" ); + $request->header( Host => $uri->host ); + + my $headers = $args{headers}; + if( $headers and reftype $headers eq "ARRAY" ) { + $request->header( @$_ ) for pairs @$headers; + } + elsif( $headers and reftype $headers eq "HASH" ) { + $request->header( $_, $headers->{$_} ) for keys %$headers; + } + + my ( $user, $pass ); + + if( defined $uri->userinfo ) { + ( $user, $pass ) = split( m/:/, $uri->userinfo, 2 ); + } + elsif( defined $args{user} and defined $args{pass} ) { + $user = $args{user}; + $pass = $args{pass}; + } + + if( defined $user and defined $pass ) { + $request->authorization_basic( $user, $pass ); + } + + $args{request} = $request; + + return %args; +} + +=head2 $response = $http->GET( $uri, %args )->get + +=head2 $response = $http->HEAD( $uri, %args )->get + +=head2 $response = $http->PUT( $uri, $content, %args )->get + +=head2 $response = $http->POST( $uri, $content, %args )->get + +Convenient wrappers for performing C<GET>, C<HEAD>, C<PUT> or C<POST> requests +with a C<URI> object and few if any other arguments, returning a C<Future>. + +Remember that C<POST> with non-form data (as indicated by a plain scalar +instead of an C<ARRAY> reference of form data name/value pairs) needs a +C<content_type> key in C<%args>. + +=cut + +sub GET +{ + my $self = shift; + my ( $uri, @args ) = @_; + return $self->do_request( method => "GET", uri => $uri, @args ); +} + +sub HEAD +{ + my $self = shift; + my ( $uri, @args ) = @_; + return $self->do_request( method => "HEAD", uri => $uri, @args ); +} + +sub PUT +{ + my $self = shift; + my ( $uri, $content, @args ) = @_; + return $self->do_request( method => "PUT", uri => $uri, content => $content, @args ); +} + +sub POST +{ + my $self = shift; + my ( $uri, $content, @args ) = @_; + return $self->do_request( method => "POST", uri => $uri, content => $content, @args ); +} + +=head1 SUBCLASS METHODS + +The following methods are intended as points for subclasses to override, to +add extra functionallity. + +=cut + +=head2 $http->prepare_request( $request ) + +Called just before the C<HTTP::Request> object is sent to the server. + +=cut + +sub prepare_request +{ + my $self = shift; + my ( $request ) = @_; + + $request->init_header( 'User-Agent' => $self->{user_agent} ) if length $self->{user_agent}; + $request->init_header( "Connection" => "keep-alive" ); + + $self->{cookie_jar}->add_cookie_header( $request ) if $self->{cookie_jar}; +} + +=head2 $http->process_response( $response ) + +Called after a non-redirect C<HTTP::Response> has been received from a server. +The originating request will be set in the object. + +=cut + +sub process_response +{ + my $self = shift; + my ( $response ) = @_; + + $self->{cookie_jar}->extract_cookies( $response ) if $self->{cookie_jar}; +} + +=head1 CONTENT DECODING + +If the required decompression modules are installed and available, compressed +content can be decoded. If the received C<Content-Encoding> is recognised and +the required module is available, the content is transparently decoded and the +decoded content is returned in the resulting response object, or passed to the +data chunk handler. In this case, the original C<Content-Encoding> header will +be deleted from the response, and its value will be available instead as +C<X-Original-Content-Encoding>. + +The following content encoding types are recognised by these modules: + +=over 4 + +=cut + +=item * gzip (q=0.7) and deflate (q=0.5) + +Recognised if L<Compress::Raw::Zlib> version 2.057 or newer is installed. + +=cut + +if( eval { require Compress::Raw::Zlib and $Compress::Raw::Zlib::VERSION >= 2.057 } ) { + my $make_zlib_decoder = sub { + my ( $bits ) = @_; + my $inflator = Compress::Raw::Zlib::Inflate->new( + -ConsumeInput => 0, + -WindowBits => $bits, + ); + sub { + my $output; + my $status = @_ ? $inflator->inflate( $_[0], $output ) + : $inflator->inflate( "", $output, 1 ); + die "$status\n" if $status && $status != Compress::Raw::Zlib::Z_STREAM_END(); + return $output; + }; + }; + + # RFC1950 + __PACKAGE__->register_decoder( + deflate => 0.5, sub { $make_zlib_decoder->( 15 ) }, + ); + + # RFC1952 + __PACKAGE__->register_decoder( + gzip => 0.7, sub { $make_zlib_decoder->( Compress::Raw::Zlib::WANT_GZIP() ) }, + ); +} + +=item * bzip2 (q=0.8) + +Recognised if L<Compress::Bzip2> version 2.10 or newer is installed. + +=cut + +if( eval { require Compress::Bzip2 and $Compress::Bzip2::VERSION >= 2.10 } ) { + __PACKAGE__->register_decoder( + bzip2 => 0.8, sub { + my $inflator = Compress::Bzip2::inflateInit(); + sub { + return unless my ( $in ) = @_; + my $out = $inflator->bzinflate( \$in ); + die $inflator->bzerror."\n" if !defined $out; + return $out; + }; + } + ); +} + +=back + +Other content encoding types can be registered by calling the following method + +=head2 Net::Async::HTTP->register_decoder( $name, $q, $make_decoder ) + +Registers an encoding type called C<$name>, at the quality value C<$q>. In +order to decode this encoding type, C<$make_decoder> will be invoked with no +paramters, and expected to return a CODE reference to perform one instance of +decoding. + + $decoder = $make_decoder->() + +This decoder will be invoked on string buffers to decode them until +the end of stream is reached, when it will be invoked with no arguments. + + $content = $decoder->( $encoded_content ) + $content = $decoder->() # EOS + +=cut + +{ + my %DECODERS; # {$name} = [$q, $make_decoder] + + sub register_decoder + { + shift; + my ( $name, $q, $make_decoder ) = @_; + + $DECODERS{$name} = [ $q, $make_decoder ]; + } + + sub can_decode + { + shift; + if( @_ ) { + my ( $name ) = @_; + + return unless my $d = $DECODERS{$name}; + return $d->[1]->(); + } + else { + my @ds = sort { $DECODERS{$b}[0] <=> $DECODERS{$a}[0] } keys %DECODERS; + return join ", ", map { "$_;q=$DECODERS{$_}[0]" } @ds; + } + } +} + +=head1 EXAMPLES + +=head2 Concurrent GET + +The C<Future>-returning C<GET> method makes it easy to await multiple URLs at +once, by using the L<Future::Utils> C<fmap_void> utility + + my @URLs = ( ... ); + + my $http = Net::Async::HTTP->new( ... ); + $loop->add( $http ); + + my $future = fmap_void { + my ( $url ) = @_; + $http->GET( $url ) + ->on_done( sub { + my $response = shift; + say "$url succeeded: ", $response->code; + say " Content-Type":", $response->content_type; + } ) + ->on_fail( sub { + my $failure = shift; + say "$url failed: $failure"; + } ); + } foreach => \@URLs; + + $loop->await( $future ); + +=cut + +=head1 SEE ALSO + +=over 4 + +=item * + +L<http://tools.ietf.org/html/rfc2616> - Hypertext Transfer Protocol -- HTTP/1.1 + +=back + +=head1 SPONSORS + +Parts of this code, or bugfixes to it were paid for by + +=over 2 + +=item * + +SocialFlow L<http://www.socialflow.com> + +=item * + +Shadowcat Systems L<http://www.shadow.cat> + +=item * + +NET-A-PORTER L<http://www.net-a-porter.com> + +=item * + +Cisco L<http://www.cisco.com> + +=back + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/Net/Async/HTTP/Connection.pm b/lib/Net/Async/HTTP/Connection.pm new file mode 100644 index 0000000..0cfbd67 --- /dev/null +++ b/lib/Net/Async/HTTP/Connection.pm @@ -0,0 +1,639 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2008-2015 -- leonerd@leonerd.org.uk + +package Net::Async::HTTP::Connection; + +use strict; +use warnings; + +our $VERSION = '0.44'; + +use Carp; + +use base qw( IO::Async::Stream ); +IO::Async::Stream->VERSION( '0.59' ); # ->write( ..., on_write ) + +use Net::Async::HTTP::StallTimer; + +use HTTP::Response; + +my $CRLF = "\x0d\x0a"; # More portable than \r\n + +use Struct::Dumb; +struct Responder => [qw( on_read on_error stall_timer is_done )]; + +# Detect whether HTTP::Message properly trims whitespace in header values. If +# it doesn't, we have to deploy a workaround to fix them up. +# https://rt.cpan.org/Ticket/Display.html?id=75224 +use constant HTTP_MESSAGE_TRIMS_LWS => HTTP::Message->parse( "Name: value " )->header("Name") eq "value"; + +=head1 NAME + +C<Net::Async::HTTP::Connection> - HTTP client protocol handler + +=head1 DESCRIPTION + +This class provides a connection to a single HTTP server, and is used +internally by L<Net::Async::HTTP>. It is not intended for general use. + +=cut + +sub _init +{ + my $self = shift; + $self->SUPER::_init( @_ ); + + $self->{requests_in_flight} = 0; +} + +sub configure +{ + my $self = shift; + my %params = @_; + + foreach (qw( pipeline max_in_flight ready_queue decode_content is_proxy )) { + $self->{$_} = delete $params{$_} if exists $params{$_}; + } + + if( my $on_closed = $params{on_closed} ) { + $params{on_closed} = sub { + my $self = shift; + + $self->debug_printf( "CLOSED in-flight=$self->{requests_in_flight}" ); + + $self->error_all( "Connection closed" ); + + undef $self->{ready_queue}; + $on_closed->( $self ); + }; + } + + croak "max_in_flight parameter required, may be zero" unless defined $self->{max_in_flight}; + + $self->SUPER::configure( %params ); +} + +sub should_pipeline +{ + my $self = shift; + return $self->{pipeline} && + $self->{can_pipeline} && + ( !$self->{max_in_flight} || $self->{requests_in_flight} < $self->{max_in_flight} ); +} + +sub connect +{ + my $self = shift; + my %args = @_; + + $self->debug_printf( "CONNECT $args{host}:$args{service}" ); + + defined wantarray or die "VOID ->connect"; + + $self->SUPER::connect( + socktype => "stream", + %args + )->on_done( sub { + $self->debug_printf( "CONNECTED" ); + }); +} + +sub ready +{ + my $self = shift; + + my $queue = $self->{ready_queue} or return; + + if( $self->should_pipeline ) { + $self->debug_printf( "READY pipelined" ); + while( @$queue && $self->should_pipeline ) { + my $ready = shift @$queue; + my $f = $ready->future; + next if $f->is_cancelled; + + $ready->connecting and $ready->connecting->cancel; + + $f->done( $self ); + } + } + elsif( @$queue and $self->is_idle ) { + $self->debug_printf( "READY non-pipelined" ); + while( @$queue ) { + my $ready = shift @$queue; + my $f = $ready->future; + next if $f->is_cancelled; + + $ready->connecting and $ready->connecting->cancel; + + $f->done( $self ); + last; + } + } + else { + $self->debug_printf( "READY cannot-run queue=%d idle=%s", + scalar @$queue, $self->is_idle ? "Y" : "N"); + } +} + +sub is_idle +{ + my $self = shift; + return $self->{requests_in_flight} == 0; +} + +sub on_read +{ + my $self = shift; + my ( $buffref, $closed ) = @_; + + while( my $head = $self->{responder_queue}[0]) { + shift @{ $self->{responder_queue} } and next if $head->is_done; + + $head->stall_timer->reset if $head->stall_timer; + + my $ret = $head->on_read->( $self, $buffref, $closed, $head ); + + if( defined $ret ) { + return $ret if !ref $ret; + + $head->on_read = $ret; + return 1; + } + + $head->is_done or die "ARGH: undef return without being marked done"; + + shift @{ $self->{responder_queue} }; + return 1 if !$closed and length $$buffref; + return; + } + + # Reinvoked after switch back to baseline, but may be idle again + return if $closed or !length $$buffref; + + $self->invoke_error( "Spurious on_read of connection while idle", + http_connection => read => $$buffref ); + $$buffref = ""; +} + +sub on_write_eof +{ + my $self = shift; + $self->error_all( "Connection closed", http => undef, undef ); +} + +sub error_all +{ + my $self = shift; + + while( my $head = shift @{ $self->{responder_queue} } ) { + $head->on_error->( @_ ) unless $head->is_done; + } +} + +sub request +{ + my $self = shift; + my %args = @_; + + my $on_header = $args{on_header} or croak "Expected 'on_header' as a CODE ref"; + + my $req = $args{request}; + ref $req and $req->isa( "HTTP::Request" ) or croak "Expected 'request' as a HTTP::Request reference"; + + $self->debug_printf( "REQUEST %s %s", $req->method, $req->uri ); + + my $request_body = $args{request_body}; + my $expect_continue = !!$args{expect_continue}; + + my $method = $req->method; + + if( $method eq "POST" or $method eq "PUT" or length $req->content ) { + $req->init_header( "Content-Length", length $req->content ); + } + + if( $expect_continue ) { + $req->init_header( "Expect", "100-continue" ); + } + + if( $self->{decode_content} ) { + #$req->init_header( "Accept-Encoding", Net::Async::HTTP->can_decode ) + $req->init_header( "Accept-Encoding", "gzip" ); + } + + my $f = $self->loop->new_future + ->set_label( "$method " . $req->uri ); + + # TODO: Cancelling a request Future shouldn't necessarily close the socket + # if we haven't even started writing the request yet. But we can't know + # that currently. + $f->on_cancel( sub { + $self->debug_printf( "CLOSE on_cancel" ); + $self->close_now; + }); + + my $stall_timer; + if( $args{stall_timeout} ) { + $stall_timer = Net::Async::HTTP::StallTimer->new( + delay => $args{stall_timeout}, + future => $f, + ); + $self->add_child( $stall_timer ); + # Don't start it yet + + my $remove_timer = sub { + $self->remove_child( $stall_timer ) if $stall_timer; + undef $stall_timer; + }; + + $f->on_ready( $remove_timer ); + } + + my $on_body_write; + if( $stall_timer or $args{on_body_write} ) { + my $inner_on_body_write = $args{on_body_write}; + my $written = 0; + $on_body_write = sub { + $stall_timer->reset if $stall_timer; + $inner_on_body_write->( $written += $_[1] ) if $inner_on_body_write; + }; + } + + my $write_request_body = defined $request_body ? sub { + my ( $self ) = @_; + $self->write( $request_body, + on_write => $on_body_write + ); + } : undef; + + # Unless the request method is CONNECT, or we are connecting to a + # non-transparent proxy, the URL is not allowed to contain + # an authority; only path + # Take a copy of the headers since we'll be hacking them up + my $headers = $req->headers->clone; + my $path; + if( $method eq "CONNECT" ) { + $path = $req->uri->as_string; + } + else { + my $uri = $req->uri; + if ( $self->{is_proxy} ) { + $path = $uri->as_string; + } + else { + $path = $uri->path_query; + $path = "/$path" unless $path =~ m{^/}; + } + my $authority = $uri->authority; + if( defined $authority and + my ( $user, $pass, $host ) = $authority =~ m/^(.*?):(.*)@(.*)$/ ) { + $headers->init_header( Host => $host ); + $headers->authorization_basic( $user, $pass ); + } + else { + $headers->init_header( Host => $authority ); + } + } + + my $protocol = $req->protocol || "HTTP/1.1"; + my @headers = ( "$method $path $protocol" ); + $headers->scan( sub { push @headers, "$_[0]: $_[1]" } ); + + $stall_timer->start if $stall_timer; + $stall_timer->reason = "writing request" if $stall_timer; + + my $on_header_write = $stall_timer ? sub { $stall_timer->reset } : undef; + + $self->write( join( $CRLF, @headers ) . + $CRLF . $CRLF, + on_write => $on_header_write ); + + $self->write( $req->content, + on_write => $on_body_write ) if length $req->content; + $write_request_body->( $self ) if $write_request_body and !$expect_continue; + + $self->write( "", on_flush => sub { + return unless $stall_timer; # test again in case it was cancelled in the meantime + $stall_timer->reset; + $stall_timer->reason = "waiting for response"; + }) if $stall_timer; + + $self->{requests_in_flight}++; + + push @{ $self->{responder_queue} }, Responder( + $self->_mk_on_read_header( + $req, $args{previous_response}, $expect_continue ? $write_request_body : undef, $on_header, $stall_timer, $f + ), + sub { $f->fail( @_ ) unless $f->is_ready; }, # on_error + $stall_timer, + 0, # is_done + ); + + return $f; +} + +sub _mk_on_read_header +{ + shift; # $self + my ( $req, $previous_response, $write_request_body, $on_header, $stall_timer, $f ) = @_; + + sub { + my ( $self, $buffref, $closed, $responder ) = @_; + + if( $stall_timer ) { + $stall_timer->reason = "receiving response header"; + $stall_timer->reset; + } + + if( length $$buffref >= 4 and $$buffref !~ m/^HTTP/ ) { + $self->debug_printf( "ERROR fail" ); + $f->fail( "Did not receive HTTP response from server", http => undef, $req ) unless $f->is_cancelled; + $self->close_now; + } + + unless( $$buffref =~ s/^(.*?$CRLF$CRLF)//s ) { + if( $closed ) { + $self->debug_printf( "ERROR closed" ); + $f->fail( "Connection closed while awaiting header", http => undef, $req ) unless $f->is_cancelled; + $self->close_now; + } + return 0; + } + + my $header = HTTP::Response->parse( $1 ); + # HTTP::Response doesn't strip the \rs from this + ( my $status_line = $header->status_line ) =~ s/\r$//; + + unless( HTTP_MESSAGE_TRIMS_LWS ) { + my @headers; + $header->scan( sub { + my ( $name, $value ) = @_; + s/^\s+//, s/\s+$// for $value; + push @headers, $name => $value; + } ); + $header->header( @headers ) if @headers; + } + + my $protocol = $header->protocol; + if( $protocol =~ m{^HTTP/1\.(\d+)$} and $1 >= 1 ) { + $self->{can_pipeline} = 1; + } + + if( $header->code =~ m/^1/ ) { # 1xx is not a final response + $self->debug_printf( "HEADER [provisional] %s", $status_line ); + $write_request_body->( $self ) if $write_request_body; + return 1; + } + + $header->request( $req ); + $header->previous( $previous_response ) if $previous_response; + + $self->debug_printf( "HEADER %s", $status_line ); + + my $on_body_chunk = $on_header->( $header ); + + my $code = $header->code; + + my $content_encoding = $header->header( "Content-Encoding" ); + + my $decoder; + if( $content_encoding and + $decoder = Net::Async::HTTP->can_decode( $content_encoding ) ) { + $header->init_header( "X-Original-Content-Encoding" => $header->remove_header( "Content-Encoding" ) ); + } + + # can_pipeline is set for HTTP/1.1 or above; presume it can keep-alive if set + my $connection_close = lc( $header->header( "Connection" ) || ( $self->{can_pipeline} ? "keep-alive" : "close" ) ) + eq "close"; + + if( $connection_close ) { + $self->{max_in_flight} = 1; + } + elsif( defined( my $keep_alive = lc( $header->header("Keep-Alive") || "" ) ) ) { + my ( $max ) = ( $keep_alive =~ m/max=(\d+)/ ); + $self->{max_in_flight} = $max if $max && $max < $self->{max_in_flight}; + } + + my $on_more = sub { + my ( $chunk ) = @_; + + if( $decoder and not eval { $chunk = $decoder->( $chunk ); 1 } ) { + $self->debug_printf( "ERROR decode failed" ); + $f->fail( "Decode error $@", http => undef, $req ); + $self->close; + return undef; + } + + $on_body_chunk->( $chunk ); + + return 1; + }; + my $on_done = sub { + # TODO: IO::Async probably ought to do this. We need to fire the + # on_closed event _before_ calling on_body_chunk, to clear the + # connection cache in case another request comes - e.g. HEAD->GET + $self->close if $connection_close; + + my $final; + if( $decoder and not eval { $final = $decoder->(); 1 } ) { + $self->debug_printf( "ERROR decode failed" ); + $f->fail( "Decode error $@", http => undef, $req ); + $self->close; + return undef; + } + + $on_body_chunk->( $final ) if defined $final and length $final; + + my $response = $on_body_chunk->(); + my $e = eval { $f->done( $response ) unless $f->is_cancelled; 1 } ? undef : $@; + + $self->{requests_in_flight}--; + $self->debug_printf( "DONE remaining in-flight=$self->{requests_in_flight}" ); + $self->ready; + + if( defined $e ) { + chomp $e; + $self->invoke_error( $e, perl => ); + # This might not return, if it top-level croaks + } + + return undef; # Finished + }; + + # RFC 2616 says "HEAD" does not have a body, nor do any 1xx codes, nor + # 204 (No Content) nor 304 (Not Modified) + if( $req->method eq "HEAD" or $code =~ m/^1..$/ or $code eq "204" or $code eq "304" ) { + $self->debug_printf( "BODY done [none]" ); + $responder->is_done++; + + return $on_done->(); + } + + my $transfer_encoding = $header->header( "Transfer-Encoding" ); + my $content_length = $header->content_length; + + if( defined $transfer_encoding and $transfer_encoding eq "chunked" ) { + $self->debug_printf( "BODY chunks" ); + + $stall_timer->reason = "receiving body chunks" if $stall_timer; + return $self->_mk_on_read_chunked( $req, $on_more, $on_done, $f ); + } + elsif( defined $content_length ) { + $self->debug_printf( "BODY length $content_length" ); + + if( $content_length == 0 ) { + $self->debug_printf( "BODY done [length=0]" ); + $responder->is_done++; + + return $on_done->(); + } + + $stall_timer->reason = "receiving body" if $stall_timer; + return $self->_mk_on_read_length( $content_length, $req, $on_more, $on_done, $f ); + } + else { + $self->debug_printf( "BODY until EOF" ); + + $stall_timer->reason = "receiving body until EOF" if $stall_timer; + return $self->_mk_on_read_until_eof( $req, $on_more, $on_done, $f ); + } + }; +} + +sub _mk_on_read_chunked +{ + shift; # $self + my ( $req, $on_more, $on_done, $f ) = @_; + + my $chunk_length; + + sub { + my ( $self, $buffref, $closed, $responder ) = @_; + + if( !defined $chunk_length and $$buffref =~ s/^(.*?)$CRLF// ) { + my $header = $1; + + # Chunk header + unless( $header =~ s/^([A-Fa-f0-9]+).*// ) { + $f->fail( "Corrupted chunk header", http => undef, $req ) unless $f->is_cancelled; + $self->close_now; + return 0; + } + + $chunk_length = hex( $1 ); + return 1 if $chunk_length; + + return $self->_mk_on_read_chunk_trailer( $req, $on_more, $on_done, $f ); + } + + # Chunk is followed by a CRLF, which isn't counted in the length; + if( defined $chunk_length and length( $$buffref ) >= $chunk_length + 2 ) { + # Chunk body + my $chunk = substr( $$buffref, 0, $chunk_length, "" ); + + unless( $$buffref =~ s/^$CRLF// ) { + $self->debug_printf( "ERROR chunk without CRLF" ); + $f->fail( "Chunk of size $chunk_length wasn't followed by CRLF", http => undef, $req ) unless $f->is_cancelled; + $self->close; + } + + undef $chunk_length; + + return $on_more->( $chunk ); + } + + if( $closed ) { + $self->debug_printf( "ERROR closed" ); + $f->fail( "Connection closed while awaiting chunk", http => undef, $req ) unless $f->is_cancelled; + } + return 0; + }; +} + +sub _mk_on_read_chunk_trailer +{ + shift; # $self + my ( $req, $on_more, $on_done, $f ) = @_; + + my $trailer = ""; + + sub { + my ( $self, $buffref, $closed, $responder ) = @_; + + if( $closed ) { + $self->debug_printf( "ERROR closed" ); + $f->fail( "Connection closed while awaiting chunk trailer", http => undef, $req ) unless $f->is_cancelled; + } + + $$buffref =~ s/^(.*)$CRLF// or return 0; + $trailer .= $1; + + return 1 if length $1; + + # TODO: Actually use the trailer + + $self->debug_printf( "BODY done [chunked]" ); + $responder->is_done++; + + return $on_done->(); + }; +} + +sub _mk_on_read_length +{ + shift; # $self + my ( $content_length, $req, $on_more, $on_done, $f ) = @_; + + sub { + my ( $self, $buffref, $closed, $responder ) = @_; + + # This will truncate it if the server provided too much + my $content = substr( $$buffref, 0, $content_length, "" ); + $content_length -= length $content; + + return undef unless $on_more->( $content ); + + if( $content_length == 0 ) { + $self->debug_printf( "BODY done [length]" ); + $responder->is_done++; + + return $on_done->(); + } + + if( $closed ) { + $self->debug_printf( "ERROR closed" ); + $f->fail( "Connection closed while awaiting body", http => undef, $req ) unless $f->is_cancelled; + } + return 0; + }; +} + +sub _mk_on_read_until_eof +{ + shift; # $self + my ( $req, $on_more, $on_done, $f ) = @_; + + sub { + my ( $self, $buffref, $closed, $responder ) = @_; + + my $content = $$buffref; + $$buffref = ""; + + return undef unless $on_more->( $content ); + + return 0 unless $closed; + + $self->debug_printf( "BODY done [eof]" ); + $responder->is_done++; + return $on_done->(); + }; +} + +=head1 AUTHOR + +Paul Evans <leonerd@leonerd.org.uk> + +=cut + +0x55AA; diff --git a/lib/Net/Async/HTTP/StallTimer.pm b/lib/Net/Async/HTTP/StallTimer.pm new file mode 100644 index 0000000..02fca86 --- /dev/null +++ b/lib/Net/Async/HTTP/StallTimer.pm @@ -0,0 +1,36 @@ +# You may distribute under the terms of either the GNU General Public License +# or the Artistic License (the same terms as Perl itself) +# +# (C) Paul Evans, 2014 -- leonerd@leonerd.org.uk + +package Net::Async::HTTP::StallTimer; + +use strict; +use warnings; +use base qw( IO::Async::Timer::Countdown ); + +our $VERSION = '0.44'; + +sub _init +{ + my $self = shift; + my ( $params ) = @_; + $self->SUPER::_init( $params ); + + $self->{future} = delete $params->{future}; +} + +sub reason :lvalue { shift->{stall_reason} } + +sub on_expire +{ + my $self = shift; + + my $conn = $self->parent; + + $self->{future}->fail( "Stalled while ${\$self->reason}", stall_timeout => ); + + $conn->close_now; +} + +0x55AA; diff --git a/t/00use.t b/t/00use.t new file mode 100644 index 0000000..b7e97d0 --- /dev/null +++ b/t/00use.t @@ -0,0 +1,10 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +use_ok( "Net::Async::HTTP" ); + +done_testing; diff --git a/t/01request.t b/t/01request.t new file mode 100644 index 0000000..ce56199 --- /dev/null +++ b/t/01request.t @@ -0,0 +1,571 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Identity; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers +); + +ok( defined $http, 'defined $http' ); +isa_ok( $http, "Net::Async::HTTP", '$http isa Net::Async::HTTP' ); + +$loop->add( $http ); + +my $hostnum = 0; + +sub do_test_req +{ + my $name = shift; + my %args = @_; + + my $response; + my $error; + + my $request = $args{req}; + my $host = $args{no_host} ? $request->uri->host : $http->{proxy_host} || "host$hostnum"; $hostnum++; + my $service = $http->{proxy_port} || 80; + + my $peersock; + no warnings 'redefine'; + local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + $args{host} eq $host or die "Expected $args{host} eq $host"; + $args{service} eq $service or die "Expected $args{service} eq $service"; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); + }; + + my $future = $http->do_request( + request => $request, + ( $args{no_host} ? () : ( host => $host ) ), + + timeout => 10, + + on_response => sub { $response = $_[0] }, + on_error => sub { $error = $_[0] }, + ); + $future->on_fail( sub { $future->get } ) unless $args{expect_error}; + + ok( defined $future, "\$future defined for $name" ); + + wait_for { $peersock }; + + # Wait for the client to send its request + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $request_stream =~ s/^(.*)$CRLF//; + my $req_firstline = $1; + + is( $req_firstline, $args{expect_req_firstline}, "First line for $name" ); + + $request_stream =~ s/^(.*)$CRLF$CRLF//s; + my %req_headers = map { m/^([^:]+):\s+(.*)$/g } split( m/$CRLF/, $1 ); + + my $req_content; + if( defined( my $len = $req_headers{'Content-Length'} ) ) { + wait_for { length( $request_stream ) >= $len }; + + $req_content = substr( $request_stream, 0, $len ); + substr( $request_stream, 0, $len ) = ""; + } + + my $expect_req_headers = $args{expect_req_headers}; + + foreach my $header ( keys %$expect_req_headers ) { + is( $req_headers{$header}, $expect_req_headers->{$header}, "Expected value for $header" ); + } + + if( defined $args{expect_req_content} ) { + is( $req_content, $args{expect_req_content}, "Request content for $name" ); + } + + $peersock->syswrite( $args{response} ); + $peersock->close if $args{close_after_response}; + + # Future shouldn't be ready yet + ok( !$future->is_ready, "\$future is not ready before response given for $name" ); + + # Wait for the server to finish its response + wait_for { defined $response or defined $error }; + + if( $args{expect_error} ) { + ok( defined $error, "Expected error for $name" ); + return; + } + else { + ok( !defined $error, "Failed to error for $name" ); + if( defined $error ) { + diag( "Got error $error" ); + } + } + + identical( $response->request, $request, "\$response->request is \$request for $name" ); + + ok( $future->is_ready, "\$future is now ready after response given for $name" ); + identical( scalar $future->get, $response, "\$future->get yields \$response for $name" ); + + if( exists $args{expect_res_code} ) { + is( $response->code, $args{expect_res_code}, "Result code for $name" ); + } + + if( exists $args{expect_res_content} ) { + is( $response->content, $args{expect_res_content}, "Result content for $name" ); + } + + if( exists $args{expect_res_headers} ) { + my %h = map { $_ => $response->header( $_ ) } $response->header_field_names; + + is_deeply( \%h, $args{expect_res_headers}, "Result headers for $name" ); + } +} + +my $req; + +$req = HTTP::Request->new( HEAD => "/some/path", [ Host => "myhost" ] ); + +do_test_req( "simple HEAD", + req => $req, + + expect_req_firstline => "HEAD /some/path HTTP/1.1", + expect_req_headers => { + Host => "myhost", + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 13$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: keep-alive$CRLF" . + $CRLF, + + expect_res_code => 200, + expect_res_headers => { + 'Content-Length' => 13, + 'Content-Type' => "text/plain", + 'Connection' => "keep-alive", + }, + expect_res_content => "", +); + +$req = HTTP::Request->new( GET => "/some/path", [ Host => "myhost" ] ); + +do_test_req( "simple GET", + req => $req, + host => "myhost", + + expect_req_firstline => "GET /some/path HTTP/1.1", + expect_req_headers => { + Host => "myhost", + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 13$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + $CRLF . + "Hello, world!", + + expect_res_code => 200, + expect_res_headers => { + 'Content-Length' => 13, + 'Content-Type' => "text/plain", + 'Connection' => "Keep-Alive", + }, + expect_res_content => "Hello, world!", +); + +$req = HTTP::Request->new( GET => "http://myhost/some/path" ); + +do_test_req( "GET to full URL", + req => $req, + host => "myhost", + + expect_req_firstline => "GET /some/path HTTP/1.1", + expect_req_headers => { + Host => "myhost", + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 13$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + $CRLF . + "Hello, world!", + + expect_res_code => 200, + expect_res_headers => { + 'Content-Length' => 13, + 'Content-Type' => "text/plain", + 'Connection' => "Keep-Alive", + }, + expect_res_content => "Hello, world!", +); + +{ + $http->configure( proxy_host => 'proxyhost', proxy_port => 3128 ); + + do_test_req( "GET over proxy", + req => $req, + host => "myhost", + + expect_req_firstline => "GET http://myhost/some/path HTTP/1.1", + expect_req_headers => { + Host => "myhost", + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 13$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + $CRLF . + "Hello, world!", + + expect_res_code => 200, + expect_res_headers => { + 'Content-Length' => 13, + 'Content-Type' => "text/plain", + 'Connection' => "Keep-Alive", + }, + expect_res_content => "Hello, world!", + ); + + $http->configure( proxy_host => undef, proxy_port => undef ); +} + +$req = HTTP::Request->new( GET => "/empty", [ Host => "myhost" ] ); + +do_test_req( "GET with empty body", + req => $req, + host => "myhost", + + expect_req_firstline => "GET /empty HTTP/1.1", + expect_req_headers => { + Host => "myhost", + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + $CRLF, + + expect_res_code => 200, + expect_res_headers => { + 'Content-Length' => 0, + 'Content-Type' => "text/plain", + 'Connection' => "Keep-Alive", + }, + expect_res_content => "", +); + +$req = HTTP::Request->new( GET => "/" ); + +do_test_req( "GET with no response headers", + req => $req, + host => "myhost", + + expect_req_firstline => "GET / HTTP/1.1", + expect_req_headers => { + Host => "myhost", + }, + + response => "HTTP/1.0 200 OK$CRLF". + $CRLF . + "Your data here", + close_after_response => 1, + + expect_res_code => 200, + expect_req_headers => {}, + expect_res_content => "Your data here", +); + +$req = HTTP::Request->new( GET => "/somethingmissing", [ Host => "somewhere" ] ); + +do_test_req( "GET not found", + req => $req, + host => "somewhere", + + expect_req_firstline => "GET /somethingmissing HTTP/1.1", + expect_req_headers => { + Host => "somewhere", + }, + + response => "HTTP/1.1 404 Not Found$CRLF" . + "Content-Length: 0$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + $CRLF, + + expect_res_code => 404, + expect_res_headers => { + 'Content-Length' => 0, + 'Content-Type' => "text/plain", + 'Connection' => "Keep-Alive", + }, + expect_res_content => "", +); + +$req = HTTP::Request->new( GET => "/stream", [ Host => "somewhere" ] ); + +do_test_req( "GET chunks", + req => $req, + host => "somewhere", + + expect_req_firstline => "GET /stream HTTP/1.1", + expect_req_headers => { + Host => "somewhere", + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 13$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + "Transfer-Encoding: chunked$CRLF" . + $CRLF . + "7$CRLF" . "Hello, " . $CRLF . + # Handle trailing whitespace on chunk size + "6 $CRLF" . "world!" . $CRLF . + "0$CRLF" . + "$CRLF", + + expect_res_code => 200, + expect_res_headers => { + 'Content-Length' => 13, + 'Content-Type' => "text/plain", + 'Connection' => "Keep-Alive", + 'Transfer-Encoding' => "chunked", + }, + expect_res_content => "Hello, world!", +); + +do_test_req( "GET chunks LWS stripping", + req => $req, + host => "somewhere", + + expect_req_firstline => "GET /stream HTTP/1.1", + expect_req_headers => { + Host => "somewhere", + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 13$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + "Transfer-Encoding: chunked $CRLF" . + $CRLF . + "7$CRLF" . "Hello, " . $CRLF . + "6$CRLF" . "world!" . $CRLF . + "0$CRLF" . + "$CRLF", + + expect_res_code => 200, + expect_res_headers => { + 'Content-Length' => 13, + 'Content-Type' => "text/plain", + 'Connection' => "Keep-Alive", + 'Transfer-Encoding' => "chunked", + }, + expect_res_content => "Hello, world!", +); + +do_test_req( "GET chunks corrupted", + req => $req, + host => "somewhere", + + expect_req_firstline => "GET /stream HTTP/1.1", + expect_req_headers => { + Host => "somewhere", + }, + + response => "HTTP/1.1 500 Internal Server Error$CRLF" . + "Content-Length: 21$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + "Transfer-Encoding: chunked$CRLF" . + $CRLF . + "Internal Server Error" . $CRLF, # no chunk header + close_after_response => 1, + + expect_error => 1, +); + +$req = HTTP::Request->new( GET => "/untileof", [ Host => "somewhere" ] ); + +do_test_req( "GET unspecified length", + req => $req, + host => "somewhere", + + expect_req_firstline => "GET /untileof HTTP/1.1", + expect_req_headers => { + Host => "somewhere", + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: close$CRLF" . + $CRLF . + "Some more content here", + close_after_response => 1, + + expect_res_code => 200, + expect_res_headers => { + 'Content-Type' => "text/plain", + 'Connection' => "close", + }, + expect_res_content => "Some more content here", +); + +do_test_req( "GET unspecified length LWS stripping", + req => $req, + host => "somewhere", + + expect_req_firstline => "GET /untileof HTTP/1.1", + expect_req_headers => { + Host => "somewhere", + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: close $CRLF" . + $CRLF . + "Some more content here", + close_after_response => 1, + + expect_res_code => 200, + expect_res_headers => { + 'Content-Type' => "text/plain", + 'Connection' => "close", + }, + expect_res_content => "Some more content here", +); + +$req = HTTP::Request->new( POST => "/handler", [ Host => "somewhere" ], "New content" ); + +do_test_req( "simple POST", + req => $req, + host => "somewhere", + + expect_req_firstline => "POST /handler HTTP/1.1", + expect_req_headers => { + Host => "somewhere", + 'Content-Length' => 11, + }, + expect_req_content => "New content", + + response => "HTTP/1.1 201 Created$CRLF" . + "Content-Length: 11$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + $CRLF . + "New content", + + expect_res_code => 201, + expect_res_headers => { + 'Content-Length' => 11, + 'Content-Type' => "text/plain", + 'Connection' => "Keep-Alive", + }, + expect_res_content => "New content", +); + +$req = HTTP::Request->new( PUT => "/handler", [ Host => "somewhere" ], "New content" ); + +do_test_req( "simple PUT", + req => $req, + host => "somewhere", + + expect_req_firstline => "PUT /handler HTTP/1.1", + expect_req_headers => { + Host => "somewhere", + 'Content-Length' => 11, + }, + expect_req_content => "New content", + + response => "HTTP/1.1 201 Created$CRLF" . + "Content-Length: 0$CRLF" . + "Connection: Keep-Alive$CRLF" . + $CRLF, + + expect_res_code => 201, + expect_res_headers => { + 'Content-Length' => 0, + 'Connection' => "Keep-Alive", + }, +); + +$req = HTTP::Request->new( GET => "http://somehost/with/path" ); + +do_test_req( "request-implied host", + req => $req, + no_host => 1, + + expect_req_firstline => "GET /with/path HTTP/1.1", + expect_req_headers => { + Host => "somehost", + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 2$CRLF" . + "Content-Type: text/plain$CRLF" . + $CRLF . + "OK", + + expect_res_code => 200, +); + +$req = HTTP::Request->new( GET => "http://user:pass\@somehost2/with/secret" ); + +do_test_req( "request-implied authentication", + req => $req, + no_host => 1, + + expect_req_firstline => "GET /with/secret HTTP/1.1", + expect_req_headers => { + Host => "somehost2", + Authorization => "Basic dXNlcjpwYXNz", # determined using 'wget' + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 4$CRLF" . + "Content-Type: text/plain$CRLF" . + $CRLF . + "Booo", + + expect_res_code => 200, +); + +$req = HTTP::Request->new( GET => "/", [ Host => "myhost" ] ); + +do_test_req( "Non-HTTP response", + req => $req, + host => "myhost", + + expect_req_firstline => "GET / HTTP/1.1", + expect_req_headers => { + Host => "myhost", + }, + + response => "Some other protocol, sorry\n", + + expect_error => 1, +); + +done_testing; diff --git a/t/02uri.t b/t/02uri.t new file mode 100644 index 0000000..cff36dd --- /dev/null +++ b/t/02uri.t @@ -0,0 +1,392 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers +); + +$loop->add( $http ); + +# Most of this function copypasted from t/01http-req.t + +sub do_test_uri +{ + my $name = shift; + my %args = @_; + + my $response; + my $error; + + my $peersock; + no warnings 'redefine'; + local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + $args{service} eq "80" or die "Expected $args{service} eq 80"; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); + }; + + $http->do_request( + uri => $args{uri}, + method => $args{method}, + user => $args{user}, + pass => $args{pass}, + headers => $args{headers}, + content => $args{content}, + content_type => $args{content_type}, + + on_response => sub { $response = $_[0] }, + on_error => sub { $error = $_[0] }, + ); + + wait_for { $peersock }; + + # Wait for the client to send its request + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $request_stream =~ s/^(.*)$CRLF//; + my $req_firstline = $1; + + is( $req_firstline, $args{expect_req_firstline}, "First line for $name" ); + + $request_stream =~ s/^(.*)$CRLF$CRLF//s; + my %req_headers = map { m/^(.*?):\s+(.*)$/g } split( m/$CRLF/, $1 ); + + my $req_content; + if( defined( my $len = $req_headers{'Content-Length'} ) ) { + wait_for { length( $request_stream ) >= $len }; + + $req_content = substr( $request_stream, 0, $len ); + substr( $request_stream, 0, $len ) = ""; + } + + my $expect_req_headers = $args{expect_req_headers}; + + foreach my $header ( keys %$expect_req_headers ) { + is( $req_headers{$header}, $expect_req_headers->{$header}, "Expected value for $header" ); + } + + if( defined $args{expect_req_content} ) { + is( $req_content, $args{expect_req_content}, "Request content for $name" ); + } + + $peersock->syswrite( $args{response} ); + + # Wait for the server to finish its response + wait_for { defined $response or defined $error }; + + if( $args{expect_error} ) { + ok( defined $error, "Expected error for $name" ); + return; + } + else { + ok( !defined $error, "Failed to error for $name" ); + if( defined $error ) { + diag( "Got error $error" ); + } + } + + if( exists $args{expect_res_code} ) { + is( $response->code, $args{expect_res_code}, "Result code for $name" ); + } + + if( exists $args{expect_res_content} ) { + is( $response->content, $args{expect_res_content}, "Result content for $name" ); + } + + if( exists $args{expect_res_headers} ) { + my %h = map { $_ => $response->header( $_ ) } $response->header_field_names; + + is_deeply( \%h, $args{expect_res_headers}, "Result headers for $name" ); + } +} + +do_test_uri( "simple HEAD", + method => "HEAD", + uri => URI->new( "http://host0/some/path" ), + + expect_req_firstline => "HEAD /some/path HTTP/1.1", + expect_req_headers => { + Host => "host0", + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 13$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + $CRLF, + + expect_res_code => 200, + expect_res_headers => { + 'Content-Length' => 13, + 'Content-Type' => "text/plain", + 'Connection' => "Keep-Alive", + }, + expect_res_content => "", +); + +do_test_uri( "simple GET", + method => "GET", + uri => URI->new( "http://host1/some/path" ), + + expect_req_firstline => "GET /some/path HTTP/1.1", + expect_req_headers => { + Host => "host1", + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 13$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + $CRLF . + "Hello, world!", + + expect_res_code => 200, + expect_res_headers => { + 'Content-Length' => 13, + 'Content-Type' => "text/plain", + 'Connection' => "Keep-Alive", + }, + expect_res_content => "Hello, world!", +); + +do_test_uri( "GET with params", + method => "GET", + uri => URI->new( "http://host2/cgi?param=value" ), + + expect_req_firstline => "GET /cgi?param=value HTTP/1.1", + expect_req_headers => { + Host => "host2", + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 11$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + $CRLF . + "CGI content", + + expect_res_code => 200, + expect_res_headers => { + 'Content-Length' => 11, + 'Content-Type' => "text/plain", + 'Connection' => "Keep-Alive", + }, + expect_res_content => "CGI content", +); + +do_test_uri( "authenticated GET", + method => "GET", + uri => URI->new( "http://host3/secret" ), + user => "user", + pass => "pass", + + expect_req_firstline => "GET /secret HTTP/1.1", + expect_req_headers => { + Host => "host3", + Authorization => "Basic dXNlcjpwYXNz", # determined using 'wget' + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 18$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + $CRLF . + "For your eyes only", + + expect_res_code => 200, + expect_res_headers => { + 'Content-Length' => 18, + 'Content-Type' => "text/plain", + 'Connection' => "Keep-Alive", + }, + expect_res_content => "For your eyes only", +); + +do_test_uri( "authenticated GET (URL embedded)", + method => "GET", + uri => URI->new( "http://user:pass\@host4/private" ), + + expect_req_firstline => "GET /private HTTP/1.1", + expect_req_headers => { + Host => "host4", + Authorization => "Basic dXNlcjpwYXNz", # determined using 'wget' + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 6$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + $CRLF . + "Shhhh!", + + expect_res_code => 200, + expect_res_headers => { + 'Content-Length' => 6, + 'Content-Type' => "text/plain", + 'Connection' => "Keep-Alive", + }, + expect_res_content => "Shhhh!", +); + +do_test_uri( "GET with additional headers from ARRAY", + method => "GET", + uri => URI->new( "http://host5/" ), + headers => [ + "X-Net-Async-HTTP", "Test", + ], + + expect_req_firstline => "GET / HTTP/1.1", + expect_req_headers => { + Host => "host5", + "X-Net-Async-HTTP" => "Test", + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . + $CRLF, + + expect_res_code => 200, +); + +do_test_uri( "GET with additional headers from HASH", + method => "GET", + uri => URI->new( "http://host6/" ), + headers => { + "X-Net-Async-HTTP", "Test", + }, + + expect_req_firstline => "GET / HTTP/1.1", + expect_req_headers => { + Host => "host6", + "X-Net-Async-HTTP" => "Test", + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . + $CRLF, + + expect_res_code => 200, +); + +do_test_uri( "simple PUT", + method => "PUT", + uri => URI->new( "http://host7/resource" ), + content => "The content", + content_type => "text/plain", + + expect_req_firstline => "PUT /resource HTTP/1.1", + expect_req_headers => { + Host => "host7", + 'Content-Length' => 11, + 'Content-Type' => "text/plain", + }, + expect_req_content => "The content", + + response => "HTTP/1.1 201 Created$CRLF" . + "Content-Length: 0$CRLF" . + "Connection: Keep-Alive$CRLF" . + $CRLF, + + expect_res_code => 201, + expect_res_headers => { + 'Content-Length' => 0, + 'Connection' => "Keep-Alive", + }, +); + +do_test_uri( "simple POST", + method => "POST", + uri => URI->new( "http://host8/handler" ), + content => "New content", + content_type => "text/plain", + + expect_req_firstline => "POST /handler HTTP/1.1", + expect_req_headers => { + Host => "host8", + 'Content-Length' => 11, + 'Content-Type' => "text/plain", + }, + expect_req_content => "New content", + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 11$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + $CRLF . + "New content", + + expect_res_code => 200, + expect_res_headers => { + 'Content-Length' => 11, + 'Content-Type' => "text/plain", + 'Connection' => "Keep-Alive", + }, + expect_res_content => "New content", +); + +do_test_uri( "form POST", + method => "POST", + uri => URI->new( "http://host9/handler" ), + content => [ param => "value", another => "value with things" ], + + expect_req_firstline => "POST /handler HTTP/1.1", + expect_req_headers => { + Host => "host9", + 'Content-Length' => 37, + 'Content-Type' => "application/x-www-form-urlencoded", + }, + expect_req_content => "param=value&another=value+with+things", + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 4$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + $CRLF . + "Done", + + expect_res_code => 200, + expect_res_headers => { + 'Content-Length' => 4, + 'Content-Type' => "text/plain", + 'Connection' => "Keep-Alive", + }, + expect_res_content => "Done", +); + +do_test_uri( "plain string URI", + method => "GET", + uri => "http://host10/path", + + expect_req_firstline => "GET /path HTTP/1.1", + expect_req_headers => { + Host => "host10", + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . + "$CRLF", + + expect_res_code => 200, +); + +done_testing; diff --git a/t/03future.t b/t/03future.t new file mode 100644 index 0000000..f8efcee --- /dev/null +++ b/t/03future.t @@ -0,0 +1,112 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers +); + +$loop->add( $http ); + +{ + my $peersock; + no warnings 'redefine'; + local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); + }; + + my $request = HTTP::Request->new( + GET => "/some/path", + [ Host => "myhost" ] + ); + + my $future = $http->do_request( + host => "myhost", + request => $request, + ); + + ok( defined $future, '$future defined for request' ); + + wait_for { $peersock }; + + # Wait for the client to send its request + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->syswrite( join( $CRLF, + "HTTP/1.1 200 OK", + "Content-Type: text/plain", + "Content-Length: 12", + "" ) . $CRLF . + "Hello world!" + ); + + wait_for { $future->is_ready }; + + my $response = $future->get; + isa_ok( $response, "HTTP::Response", '$future->get for request' ); + + is( $response->code, 200, '$response->code for request' ); +} + +{ + my $peersock; + no warnings 'redefine'; + local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); + }; + + my $future = $http->do_request( + method => "GET", + uri => URI->new( "http://host0/some/path" ), + ); + + ok( defined $future, '$future defined for uri' ); + + wait_for { $peersock }; + + # Wait for the client to send its request + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->syswrite( join( $CRLF, + "HTTP/1.1 200 OK", + "Content-Type: text/plain", + "Content-Length: 12", + "" ) . $CRLF . + "Hello world!" + ); + + wait_for { $future->is_ready }; + + my $response = $future->get; + isa_ok( $response, "HTTP::Response", '$future->get for uri' ); + + is( $response->code, 200, '$response->code for uri' ); +} + +done_testing; diff --git a/t/04fail.t b/t/04fail.t new file mode 100644 index 0000000..fa618ad --- /dev/null +++ b/t/04fail.t @@ -0,0 +1,183 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers +); + +$loop->add( $http ); + +my $peersock; +no warnings 'redefine'; +local *IO::Async::Handle::connect = sub { + my $self = shift; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); +}; + +# fail_on_error false +{ + $http->configure( fail_on_error => 0 ); + + my $request = HTTP::Request->new( + GET => "/some/path", + [ Host => "myhost" ] + ); + + my $future = $http->do_request( + method => "GET", + uri => URI->new( "http://host0/some/path" ), + ); + + ok( defined $future, '$future defined for request' ); + + wait_for { $peersock }; + + # Wait for the client to send its request + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->syswrite( join( $CRLF, + "HTTP/1.1 404 Not Found", + "Content-Type: text/plain", + "Content-Length: 9", + "" ) . $CRLF . + "Not Found" + ); + + wait_for { $future->is_ready }; + + my $response = $future->get; + isa_ok( $response, "HTTP::Response", '$future->get for fail_on_error false' ); + + is( $response->code, 404, '$response->code for fail_on_error false' ); +} + +# fail_on_error true +{ + $http->configure( fail_on_error => 1 ); + + my $request = HTTP::Request->new( + GET => "/some/path", + [ Host => "myhost" ] + ); + + my ( $response_c, $request_c ); + my $future = $http->do_request( + method => "GET", + uri => URI->new( "http://host0/some/path" ), + on_error => sub { + ( my $message, $response_c, $request_c ) = @_; + is( $message, "404 Not Found", '$message to on_error' ); + }, + ); + + ok( defined $future, '$future defined for request' ); + + wait_for { $peersock }; + + # Wait for the client to send its request + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->syswrite( join( $CRLF, + "HTTP/1.1 404 Not Found", + "Content-Type: text/plain", + "Content-Length: 9", + "" ) . $CRLF . + "Not Found" + ); + + wait_for { $future->is_ready }; + + is( scalar $future->failure, "404 Not Found", '$future->failure for fail_on_error true' ); + my ( undef, undef, $response_f, $request_f ) = $future->failure; + + is( $response_f->code, 404, '$response_f->code for fail_on_error true' ); + is( $response_c->code, 404, '$response_c->code for fail_on_error true' ); + + is( $request_f->uri, "http://host0/some/path", '$request_f->uri for fail_on_error true' ); + is( $request_c->uri, "http://host0/some/path", '$request_f->uri for fail_on_error true' ); + + # Now check that non-errors don't fail + $future = $http->do_request( + method => "GET", + uri => URI->new( "http://host0/other/path" ), + ); + + $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->syswrite( join( $CRLF, + "HTTP/1.1 200 OK", + "Content-Type: text/plain", + "Content-Length: 9", + "" ) . $CRLF . + "Here I am" + ); + + wait_for { $future->is_ready }; + my $response = $future->get; + + is( $response->code, 200, '$response->code for non-fail' ); +} + +# fail_on_error non-Future (RT102022) +{ + $http->configure( fail_on_error => 1 ); + + my $request = HTTP::Request->new( + GET => "/some/path", + [ Host => "myhost" ] + ); + + my ( $response_c, $request_c ); + $http->do_request( + method => "GET", + uri => URI->new( "http://host0/some/path" ), + on_response => sub { + die "Test failed - on_response with $_[0]"; + }, + on_error => sub { + ( my $message, $response_c, $request_c ) = @_; + is( $message, "404 Not Found", '$message to on_error' ); + }, + ); + + wait_for { $peersock }; + + # Wait for the client to send its request + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->syswrite( join( $CRLF, + "HTTP/1.1 404 Not Found", + "Content-Type: text/plain", + "Content-Length: 9", + "" ) . $CRLF . + "Not Found" + ); + + wait_for { defined $response_c }; + + is( $response_c->code, 404, '$response_c->code for fail_on_error true' ); + is( $request_c->uri, "http://host0/some/path", '$request_f->uri for fail_on_error true' ); +} + +done_testing; diff --git a/t/05redir.t b/t/05redir.t new file mode 100644 index 0000000..9cdc217 --- /dev/null +++ b/t/05redir.t @@ -0,0 +1,262 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Identity; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers +); + +$loop->add( $http ); + +{ + my $redir_response; + my $location; + + my $response; + + my $peersock; + no warnings 'redefine'; + local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + $args{host} eq "host0" or die "Expected $args{host} eq host0"; + $args{service} eq "80" or die "Expected $args{service} eq 80"; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); + }; + + my $future = $http->do_request( + uri => URI->new( "http://host0/doc" ), + + timeout => 10, + + on_response => sub { $response = $_[0] }, + on_redirect => sub { ( $redir_response, $location ) = @_ }, + on_error => sub { die "Test died early - $_[0]" }, + ); + + ok( defined $future, '$future defined for redirect' ); + + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $request_stream =~ s/^(.*)$CRLF//; + my $req_firstline = $1; + + is( $req_firstline, "GET /doc HTTP/1.1", 'First line for request' ); + + # Trim headers + $request_stream =~ s/^(.*)$CRLF$CRLF//s; + + $peersock->syswrite( "HTTP/1.1 301 Moved Permanently$CRLF" . + "Content-Length: 0$CRLF" . + "Location: http://host0/get_doc?name=doc$CRLF" . + "Connection: Keep-Alive$CRLF" . + "$CRLF" ); + + wait_for { defined $location }; + + is( $location, "http://host0/get_doc?name=doc", 'Redirect happens' ); + + ok( !$future->is_ready, '$future is not yet ready after redirect' ); + + $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $request_stream =~ s/^(.*)$CRLF//; + $req_firstline = $1; + + is( $req_firstline, "GET /get_doc?name=doc HTTP/1.1", 'First line for redirected request' ); + + # Trim headers + $request_stream =~ s/^(.*)$CRLF$CRLF//s; + + $peersock->syswrite( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 8$CRLF". + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + "$CRLF" . + "Document" ); + + wait_for { defined $response }; + + is( $response->content_type, "text/plain", 'Content type of final response' ); + is( $response->content, "Document", 'Content of final response' ); + + isa_ok( $response->previous, "HTTP::Response", '$response->previous' ); + + my $previous = $response->previous; + isa_ok( $previous->request->uri, "URI", 'Previous request URI is a URI' ); + is( $previous->request->uri, "http://host0/doc", 'Previous request URI string' ); + + ok( $future->is_ready, '$future is now ready for final response' ); + identical( scalar $future->get, $response, '$future->get yields final response' ); +} + +{ + my $redir_response; + my $location; + + my $response; + + my $peersock; + no warnings 'redefine'; + local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + $args{host} eq "host1" or die "Expected $args{host} eq host1"; + $args{service} eq "80" or die "Expected $args{service} eq 80"; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); + }; + + $http->do_request( + uri => URI->new( "http://host1/somedir" ), + + timeout => 10, + + on_response => sub { $response = $_[0] }, + on_redirect => sub { ( $redir_response, $location ) = @_ }, + on_error => sub { die "Test died early - $_[0]" }, + ); + + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $request_stream =~ s/^(.*)$CRLF//; + my $req_firstline = $1; + + is( $req_firstline, "GET /somedir HTTP/1.1", 'First line for request for local redirect' ); + + # Trim headers + $request_stream =~ s/^(.*)$CRLF$CRLF//s; + + $peersock->syswrite( "HTTP/1.1 301 Moved Permanently$CRLF" . + "Content-Length: 0$CRLF" . + "Location: /somedir/$CRLF" . + "$CRLF" ); + + undef $location; + wait_for { defined $location }; + + is( $location, "http://host1/somedir/", 'Local redirect happens' ); + + $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $request_stream =~ s/^(.*)$CRLF//; + $req_firstline = $1; + + is( $req_firstline, "GET /somedir/ HTTP/1.1", 'First line for locally redirected request' ); + + # Trim headers + $request_stream =~ s/^(.*)$CRLF$CRLF//s; + + $peersock->syswrite( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 9$CRLF". + "Content-Type: text/plain$CRLF" . + "$CRLF" . + "Directory" ); + + undef $response; + wait_for { defined $response }; + + is( $response->content_type, "text/plain", 'Content type of final response to local redirect' ); + is( $response->content, "Directory", 'Content of final response to local redirect' ); +} + +# 304 Not Modified should not redirect (RT98093) +{ + my $peersock; + no warnings 'redefine'; + local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + $args{host} eq "host2" or die "Expected $args{host} eq host2"; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); + }; + + my $f = $http->do_request( + uri => URI->new( "http://host2/unmod" ), + + on_redirect => sub { die "Should not be redirected" }, + ); + + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->syswrite( "HTTP/1.1 304 Not Modified$CRLF" . + $CRLF ); # 304 has no body + + wait_for { $f->is_ready }; + + my $response = $f->get; + is( $response->code, 304, 'HTTP 304 response not redirected' ); +} + +# Methods other than GET and HEAD should not redirect +{ + my $peersock; + no warnings 'redefine'; + local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + $args{host} eq "host3" or die "Expected $args{host} eq host3"; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); + }; + + my $f = $http->do_request( + method => "PUT", + uri => URI->new( "http://host3/somewhere" ), + content => "new content", + content_type => "text/plain", + + on_redirect => sub { die "Should not be redirected" }, + ); + + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->syswrite( "HTTP/1.1 301 Moved Permanently$CRLF" . + "Content-Length: 0$CRLF" . + "Location: /somewhere/else$CRLF" . + $CRLF ); + + wait_for { $f->is_ready }; + + my $response = $f->get; + is( $response->code, 301, 'POST request not redirected' ); +} + +done_testing; diff --git a/t/06close.t b/t/06close.t new file mode 100644 index 0000000..9fb2f6e --- /dev/null +++ b/t/06close.t @@ -0,0 +1,109 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +$SIG{PIPE} = "IGNORE"; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new; +$loop->add( $http ); + +my $host = "host.example"; + +my $peersock; +no warnings 'redefine'; +local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + $args{host} eq $host or die "Expected $args{host} eq $host"; + $args{service} eq "80" or die "Expected $args{service} eq 80"; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); +}; + +# HTTP/1.1 pipelining - if server closes after first request, others should fail +{ + my @f = map { $http->do_request( + request => HTTP::Request->new( GET => "/$_", [ Host => $host ] ), + host => $host, + ) } 1 .. 3; + + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $request_stream = ""; + + $peersock->print( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . + $CRLF ); + + wait_for { $f[0]->is_ready }; + ok( !$f[0]->failure, 'First request succeeds before EOF' ); + + $peersock->close; + + wait_for { $f[1]->is_ready }; + ok( $f[1]->failure, 'Second request fails after EOF' ); + + # Not sure which error will happen + like( scalar $f[1]->failure, qr/^Connection closed($| while awaiting header)/, + 'Queued request gets connection closed error' ); + + wait_for { $f[2]->is_ready }; + ok( $f[2]->failure ); +} + +# HTTP/1.0 connection: close behaviour. second request should get written +{ + my @f = map { $http->do_request( + request => HTTP::Request->new( GET => "/$_", [ Host => $host ] ), + host => $host, + ) } 1 .. 2; + + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $request_stream = ""; + + $peersock->print( "HTTP/1.0 200 OK$CRLF" . + "Content-Type: text/plain$CRLF" . + $CRLF . + "Hello " ); + $peersock->close; + undef $peersock; + + wait_for { $f[0]->is_ready }; + ok( !$f[0]->failure, 'First request succeeds after HTTP/1.0 EOF' ); + + wait_for { defined $peersock }; + ok( defined $peersock, 'A second connection is made' ); + + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->print( "HTTP/1.0 200 OK$CRLF" . + "Content-Type: text/plain$CRLF" . + $CRLF . + "World!" ); + $peersock->close; + undef $peersock; + + wait_for { $f[1]->is_ready }; + ok( !$f[1]->failure, 'Second request succeeds after second HTTP/1.0 EOF' ); +} + +done_testing; diff --git a/t/07continue.t b/t/07continue.t new file mode 100644 index 0000000..6bf309f --- /dev/null +++ b/t/07continue.t @@ -0,0 +1,79 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +$SIG{PIPE} = "IGNORE"; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new; +$loop->add( $http ); + +my $peersock; +no warnings 'redefine'; +local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + $args{host} eq "host0" or die "Expected $args{host} eq host0"; + $args{service} eq "80" or die "Expected $args{service} eq 80"; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); +}; + +my $body_sent; +my $resp; +$http->do_request( + method => "PUT", + uri => URI->new( "http://host0/" ), + expect_continue => 1, + content_type => "text/plain", + request_body => sub { + return undef if $body_sent; + $body_sent++; + return "Here is the body content\n"; + }, + on_response => sub { $resp = shift }, + on_error => sub { die "Test failed early - $_[-1]" }, +); + +wait_for { defined $peersock }; + +my $request_stream = ""; +wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; +$request_stream =~ s/^(.*?$CRLF$CRLF)//s; +my $header = HTTP::Request->parse( $1 ); + +is( $header->header( "Expect" ), "100-continue", 'Received Expect header' ); + +ok( !$body_sent, 'request_body not yet invoked before 100 Continue' ); + +$peersock->print( "HTTP/1.1 100 Continue$CRLF" . + $CRLF ); + +wait_for { $body_sent }; +ok( !defined $resp, '$resp not yet defined after 100 Continue' ); + +$peersock->print( "HTTP/1.1 201 Created$CRLF" . + "Content-Length: 0$CRLF" . + $CRLF ); + +wait_for { defined $resp }; + +ok( defined $resp, '$resp now defined after 201 Created' ); +is( $resp->code, 201, '$resp->code is 201' ); + +done_testing; diff --git a/t/08prepareprocess.t b/t/08prepareprocess.t new file mode 100644 index 0000000..f34fdae --- /dev/null +++ b/t/08prepareprocess.t @@ -0,0 +1,100 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = TestingHTTP->new( + user_agent => "", # Don't put one in request headers +); + +ok( defined $http, 'defined $http' ); +isa_ok( $http, "Net::Async::HTTP", '$http isa Net::Async::HTTP' ); + +$loop->add( $http ); + +my $peersock; + +no warnings 'redefine'; +local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + $args{host} eq "some.server" or die "Expected $args{host} eq some.server"; + $args{service} eq "80" or die "Expected $args{service} eq 80"; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); +}; + +my $response; + +$http->do_request( + uri => URI->new( "http://some.server/here" ), + + on_response => sub { $response = $_[0] }, + on_error => sub { die "Test died early - $_[0]" }, +); + +my $request_stream = ""; +wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + +$request_stream =~ s/^(.*)$CRLF//; +my $req_firstline = $1; + +is( $req_firstline, "GET /here HTTP/1.1", 'First line for request' ); + +# Trim headers +$request_stream =~ s/^(.*)$CRLF$CRLF//s; +my %req_headers = map { m/^(.*?):\s+(.*)$/g } split( m/$CRLF/, $1 ); + +is( $req_headers{"X-Request-Foo"}, "Bar", 'Request sets X-Request-Foo header' ); + +$peersock->syswrite( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 7$CRLF". + "Content-Type: text/plain$CRLF" . + "X-Response-Foo: Splot$CRLF" . + "$CRLF" . + "Blahbla" ); + +my $response_header_X; + +undef $response; +wait_for { defined $response }; + +is( $response_header_X, "Splot", 'Response processed' ); + +done_testing; + +package TestingHTTP; +use base qw( Net::Async::HTTP ); + +sub prepare_request +{ + my $self = shift; + my ( $request ) = @_; + $self->SUPER::prepare_request( $request ); + + $request->header( "X-Request-Foo" => "Bar" ); +} + +sub process_response +{ + my $self = shift; + my ( $response ) = @_; + $self->SUPER::process_response( $response ); + + $response_header_X = $response->header( "X-Response-Foo" ); +} diff --git a/t/09cookies.t b/t/09cookies.t new file mode 100644 index 0000000..68f17ca --- /dev/null +++ b/t/09cookies.t @@ -0,0 +1,139 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use HTTP::Cookies; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $cookie_jar = HTTP::Cookies->new; + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers + cookie_jar => $cookie_jar, +); + +$loop->add( $http ); + +my $peersock; + +sub do_test_req +{ + my $name = shift; + my %args = @_; + + no warnings 'redefine'; + local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + $args{host} eq "myhost" or die "Expected $args{host} eq myhost"; + $args{service} eq "80" or die "Expected $args{service} eq 80"; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); + }; + + my $response; + my $error; + + my $request = $args{req}; + + $http->do_request( + request => $request, + host => "myhost", + + on_response => sub { $response = $_[0] }, + on_error => sub { $error = $_[0] }, + ); + + # Wait for the client to send its request + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + # Ignore first line + $request_stream =~ s/^(.*)$CRLF//; + + $request_stream =~ s/^(.*)$CRLF$CRLF//s; + my %req_headers = map { m/^(.*?):\s+(.*)$/g } split( m/$CRLF/, $1 ); + + my $req_content; + if( defined( my $len = $req_headers{'Content-Length'} ) ) { + wait_for { length( $request_stream ) >= $len }; + + $req_content = substr( $request_stream, 0, $len ); + substr( $request_stream, 0, $len ) = ""; + } + + my $expect_req_headers = $args{expect_req_headers}; + + foreach my $header ( keys %$expect_req_headers ) { + is( $req_headers{$header}, $expect_req_headers->{$header}, "Expected value for $header" ); + } + + $peersock->syswrite( $args{response} ); + + # Wait for the server to finish its response + wait_for { defined $response or defined $error }; + + my %h = map { $_ => $response->header( $_ ) } $response->header_field_names; + + is_deeply( \%h, $args{expect_res_headers}, "Result headers for $name" ); +} + +my $req; + +$req = HTTP::Request->new( GET => "http://myhost/", [ Host => "myhost" ] ); + +do_test_req( "set cookie", + req => $req, + + expect_req_headers => { + Host => "myhost", + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Set-Cookie: X_TEST=MyCookie; path=/$CRLF" . + "Content-Length: 0$CRLF" . + $CRLF, + + expect_res_headers => { + 'Content-Length' => 0, + 'Set-Cookie' => "X_TEST=MyCookie; path=/", + }, +); + +$req = HTTP::Request->new( POST => "http://myhost/", [ Host => "myhost" ] ); + +do_test_req( "get cookie", + req => $req, + + expect_req_headers => { + Host => "myhost", + Cookie => "X_TEST=MyCookie", + Cookie2 => '$Version="1"', + 'Content-Length' => 0, + }, + + response => "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . + $CRLF, + + expect_res_headers => { + 'Content-Length' => 0, + }, +); + +done_testing; diff --git a/t/10request-streaming.t b/t/10request-streaming.t new file mode 100644 index 0000000..6b0df01 --- /dev/null +++ b/t/10request-streaming.t @@ -0,0 +1,155 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers +); + +$loop->add( $http ); + +my $peersock; + +no warnings 'redefine'; +local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); +}; + +{ + my $req = HTTP::Request->new( PUT => "/handler", [ Host => "somewhere" ]); + $req->content_length( 21 ); # set this manually based on what we plan to send + + my $response; + + my $done = 0; + $http->do_request( + request => $req, + host => "myhost", + + request_body => sub { + if( !$done ) { + pass( "Callback after headers sent" ); + $done++; + return "Content from callback"; + } + elsif( $done == 1 ) { + pass( "Second request seen, returning undef" ); + $done++; + return undef; + } + else { + fail( "called request_body too many times" ); + } + }, + + on_response => sub { $response = $_[0] }, + on_error => sub { die "Test died early - $_[0]" }, + ); + + + # Wait for the client to send its request + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $request_stream =~ s/^(.*)$CRLF//; + my $req_firstline = $1; + + is( $req_firstline, "PUT /handler HTTP/1.1", 'First line for streaming PUT' ); + + $request_stream =~ s/^(.*)$CRLF$CRLF//s; + my %req_headers = map { m/^(.*?):\s+(.*)$/g } split( m/$CRLF/, $1 ); + + is_deeply( \%req_headers, + { + 'Host' => "somewhere", + 'Content-Length' => 21, + 'Connection' => 'keep-alive', + }, + 'Request headers for streaming PUT' + ); + + my $req_content; + if( defined( my $len = $req_headers{'Content-Length'} ) ) { + wait_for_stream { length( $request_stream ) >= $len } $peersock => $request_stream; + + $req_content = substr( $request_stream, 0, $len ); + substr( $request_stream, 0, $len ) = ""; + } + + is( $req_content, "Content from callback", 'Request content for streaming PUT' ); + + $peersock->syswrite( "HTTP/1.1 201 Created$CRLF" . + "Content-Length: 0$CRLF" . + "Connection: Keep-Alive$CRLF" . + $CRLF ); + + wait_for { defined $response }; + + is( $response->code, 201, 'Result code for streaming PUT' ); + + my %res_headers = map { $_ => $response->header( $_ ) } $response->header_field_names; + is_deeply( \%res_headers, + { + 'Content-Length' => 0, + 'Connection' => "Keep-Alive", + }, + 'Result headers for streaming PUT' + ); +} + +{ + my $req = HTTP::Request->new( PUT => "/handler", [ Host => "somewhere" ]); + $req->content_length( 15 ); + + my $body_f = $loop->new_future; + + my $response; + $http->do_request( + request => $req, + request_body => $body_f, + host => "myhost", + + on_response => sub { $response = $_[0] }, + on_error => sub { die "Test died early - $_[0]" }, + ); + + # Wait for the client to send its request + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + $request_stream =~ s/^(.*)$CRLF$CRLF//s; + + $body_f->done( "Delayed content" ); + + wait_for_stream { length $request_stream >= 15 } $peersock => $request_stream; + + is( $request_stream, "Delayed content" ); + + $peersock->syswrite( "HTTP/1.1 201 Created$CRLF" . + "Content-Length: 0$CRLF" . + "Connection: Keep-Alive$CRLF" . + $CRLF ); + + wait_for { defined $response }; + + is( $response->code, 201, 'Result code for streaming PUT from Future' ); +} + +done_testing; diff --git a/t/11response-streaming.t b/t/11response-streaming.t new file mode 100644 index 0000000..67ddcf7 --- /dev/null +++ b/t/11response-streaming.t @@ -0,0 +1,219 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers +); + +$loop->add( $http ); + +my $peersock; + +no warnings 'redefine'; +local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); +}; + +{ + my $header; + my $body; + my $body_is_done; + + $http->do_request( + uri => URI->new( "http://my.server/here" ), + + on_header => sub { + ( $header ) = @_; + $body = ""; + return sub { + @_ ? $body .= $_[0] : $body_is_done++; + } + }, + on_error => sub { die "Test died early - $_[0]" }, + ); + + # Wait for request but don't really care what it actually is + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->syswrite( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 15$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + "$CRLF" ); + + wait_for { defined $header }; + + isa_ok( $header, "HTTP::Response", '$header for Content-Length' ); + is( $header->content_length, 15, '$header->content_length' ); + is( $header->content_type, "text/plain", '$header->content_type' ); + + $peersock->syswrite( "Hello, " ); + + wait_for { length $body == 7 }; + + is( $body, "Hello, ", '$body partial Content-Length' ); + + $peersock->syswrite( "world!$CRLF" ); + + wait_for { $body_is_done }; + is( $body, "Hello, world!$CRLF", '$body' ); +} + +{ + my $header; + my $body; + my $body_is_done; + + $http->do_request( + uri => URI->new( "http://my.server/here" ), + + on_header => sub { + ( $header ) = @_; + $body = ""; + return sub { + @_ ? $body .= $_[0] : $body_is_done++; + } + }, + on_error => sub { die "Test died early - $_[0]" }, + ); + + # Wait for request but don't really care what it actually is + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->syswrite( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 15$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: Keep-Alive$CRLF" . + "Transfer-Encoding: chunked$CRLF" . + "$CRLF" ); + + wait_for { defined $header }; + + isa_ok( $header, "HTTP::Response", '$header for chunked' ); + is( $header->content_length, 15, '$header->content_length' ); + is( $header->content_type, "text/plain", '$header->content_type' ); + + $peersock->syswrite( "7$CRLF" . "Hello, " . $CRLF ); + + wait_for { length $body == 7 }; + is( $body, "Hello, ", '$body partial chunked' ); + + $peersock->syswrite( "8$CRLF" . "world!$CRLF" . $CRLF ); + + wait_for { length $body == 15 }; + is( $body, "Hello, world!$CRLF", '$body partial(2) chunked' ); + + $peersock->syswrite( "0$CRLF" . $CRLF ); + + wait_for { $body_is_done }; + is( $body, "Hello, world!$CRLF", '$body chunked' ); +} + +{ + my $header; + my $body; + my $body_is_done; + + $http->do_request( + uri => URI->new( "http://my.server/here" ), + + on_header => sub { + ( $header ) = @_; + $body = ""; + return sub { + @_ ? $body .= $_[0] : $body_is_done++; + } + }, + on_error => sub { die "Test died early - $_[0]" }, + ); + + # Wait for request but don't really care what it actually is + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->syswrite( "HTTP/1.0 200 OK$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: close$CRLF" . + "$CRLF" ); + + wait_for { defined $header }; + + isa_ok( $header, "HTTP::Response", '$header for EOF' ); + is( $header->content_type, "text/plain", '$header->content_type' ); + + $peersock->syswrite( "Hello, " ); + + wait_for { length $body == 7 }; + + is( $body, "Hello, ", '$body partial EOF' ); + + $peersock->syswrite( "world!$CRLF" ); + + wait_for { length $body == 15 }; + + is( $body, "Hello, world!$CRLF", '$body' ); + + $peersock->close; + + wait_for { $body_is_done }; +} + +# on_header should see a redirect once we run out of indirections (RT124920) +{ + my $header; + + $http->do_request( + uri => URI->new( "http://my.server.here/" ), + max_redirects => 1, + + on_header => sub { + ( $header ) = @_; + return sub {}; + }, + on_error => sub { die "Test died early - $_[0]" }, + ); + + # Wait for request but don't really care what it actually is + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->syswrite( "HTTP/1.1 301 Moved Permanently$CRLF" . + "Content-Length: 0$CRLF" . + "Location: http://my.server.here/elsewhere$CRLF" . + "Connection: Keep-Alive$CRLF" . + "$CRLF" ); + + $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->syswrite( "HTTP/1.1 301 Moved Permanently$CRLF" . + "Content-Length: 0$CRLF" . + "Location: http://my.server.here/try-again$CRLF" . + "Connection: Keep-Alive$CRLF" . + "$CRLF" ); + + wait_for { defined $header }; +} + +done_testing; diff --git a/t/12conn-persistence.t b/t/12conn-persistence.t new file mode 100644 index 0000000..26e3d75 --- /dev/null +++ b/t/12conn-persistence.t @@ -0,0 +1,194 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Identity; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers +); + +$loop->add( $http ); + +foreach my $close ( 0, 1, 2 ) { + # We'll run an almost-identical test three times, with different server responses. + # 0 == keepalive + # 1 == close + # 2 == close with no Content-Length + + my $peersock; + my $connections = 0; + + no warnings 'redefine'; + local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + $connections++; + + $args{host} eq "host$close" or die "Expected $args{host} eq host$close"; + $args{service} eq "80" or die "Expected $args{service} eq 80"; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); + }; + + my $response; + + # placate IO::Async bug where this returns () instead of 0 + is( scalar $http->children || 0, 0, 'scalar $http->children 0 initially' ); + + my $future = $http->do_request( + uri => URI->new( "http://host$close/first" ), + + on_response => sub { $response = $_[0] }, + on_error => sub { die "Test died early - $_[0]" }, + ); + + ok( defined $future, 'defined $future' ); + + wait_for { $peersock }; + is( $connections, 1, '->connect called once for first request' ); + is( scalar $http->children, 1, 'scalar $http->children 1 after first request' ); + + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $request_stream =~ s/^(.*)$CRLF//; + my $req_firstline = $1; + + is( $req_firstline, "GET /first HTTP/1.1", 'First line for first request' ); + + ok( !$future->is_ready, '$future is not ready before response given' ); + + $peersock->syswrite( "HTTP/1.1 200 OK$CRLF" . + ( $close == 2 ? "" : "Content-Length: 3$CRLF" ) . + "Content-Type: text/plain$CRLF" . + ( $close ? "Connection: close$CRLF" : "Connection: Keep-Alive$CRLF" ) . + "$CRLF" . + "1st" ); + $peersock->close, undef $peersock if $close; + + undef $response; + wait_for { defined $response }; + + if( $close ) { + is( scalar $http->children, 0, 'scalar $http->children now 0 again after first response' ); + } + else { + is( scalar $http->children, 1, 'scalar $http->children still 1 after first response' ); + } + + is( $response->content, "1st", 'Content of first response' ); + identical( scalar $future->get, $response, '$future->get for first request' ); + + my $inner_response; + my $inner_future; + $future = $http->do_request( + uri => URI->new( "http://host$close/second" ), + + on_response => sub { + $response = $_[0]; + $inner_future = $http->do_request( + uri => URI->new( "http://host$close/inner" ), + on_response => sub { $inner_response = $_[0] }, + on_error => sub { die "Test died early - $_[0]" }, + ); + }, + on_error => sub { die "Test died early - $_[0]" }, + ); + + wait_for { $peersock }; + + if( $close ) { + is( $connections, 2, '->connect called again for second request to same server' ); + } + else { + is( $connections, 1, '->connect not called again for second request to same server' ); + } + + is( scalar $http->children, 1, 'scalar $http->children 1 after second request to same server' ); + + $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $request_stream =~ s/^(.*)$CRLF//; + $req_firstline = $1; + + is( $req_firstline, "GET /second HTTP/1.1", 'First line for second request' ); + + ok( !$future->is_ready, '$future is not ready before response given for second request' ); + + $peersock->syswrite( "HTTP/1.1 200 OK$CRLF" . + ( $close == 2 ? "" : "Content-Length: 3$CRLF" ) . + "Content-Type: text/plain$CRLF" . + ( $close ? "Connection: close$CRLF" : "Connection: Keep-Alive$CRLF" ) . + "$CRLF" . + "2nd" ); + $peersock->close, undef $peersock if $close; + + undef $response; + wait_for { defined $response }; + + is( $response->content, "2nd", 'Content of second response' ); + identical( scalar $future->get, $response, '$future->get for second request' ); + + ok( defined $inner_future, 'defined $inner_future' ); + + wait_for { $peersock }; + + if( $close ) { + is( $connections, 3, '->connect called again for inner request to same server' ); + } + else { + is( $connections, 1, '->connect not called again for inner request to same server' ); + } + + $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $request_stream =~ s/^(.*)$CRLF//; + $req_firstline = $1; + + is( $req_firstline, "GET /inner HTTP/1.1", 'First line for inner request' ); + + $peersock->syswrite( "HTTP/1.1 200 OK$CRLF" . + ( $close == 2 ? "" : "Content-Length: 3$CRLF" ) . + "Content-Type: text/plain$CRLF" . + ( $close ? "Connection: close$CRLF" : "Connection: Keep-Alive$CRLF" ) . + "$CRLF" . + "3rd" ); + $peersock->close if $close; + + undef $inner_response; + wait_for { defined $inner_response }; + + is( $inner_response->content, "3rd", 'Content of inner response' ); + identical( scalar $inner_future->get, $inner_response, '$inner_future->get for inner request' ); + + if( $close ) { + is( scalar $http->children, 0, 'scalar $http->children now 0 again after inner response' ); + } + else { + is( scalar $http->children, 1, 'scalar $http->children still 1 after inner response' ); + } + + # Drain connections for next test + undef $peersock; + wait_for { scalar $http->children == 0 }; +} + +done_testing; diff --git a/t/13conn-pipeline.t b/t/13conn-pipeline.t new file mode 100644 index 0000000..ef80cf4 --- /dev/null +++ b/t/13conn-pipeline.t @@ -0,0 +1,132 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $test_mode; + +# Most of this function copypasted from t/01http-req.t +sub do_uris +{ + my %wait; + my $wait_id = 0; + + my $http = Net::Async::HTTP->new( pipeline => not( $test_mode eq "no_pipeline" ) ); + $loop->add( $http ); + + my $peersock; + + no warnings 'redefine'; + local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + $args{service} eq "80" or die "Expected $args{service} eq 80"; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); + }; + + while( my ( $uri, $on_resp ) = splice @_, 0, 2 ) { + $wait{$wait_id} = 1; + + my $id = $wait_id; + + $http->do_request( + uri => $uri, + method => 'GET', + + timeout => 10, + + on_response => sub { $on_resp->( @_ ); delete $wait{$id} }, + on_error => sub { die "Test failed early - $_[-1]" }, + ); + + $wait_id++; + } + + my $request_stream = ""; + my $not_first = 0; + + while( keys %wait ) { + # Wait for the client to send its request + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $request_stream =~ s/^(.*)$CRLF//; + my $req_firstline = $1; + + $request_stream =~ s/^(.*?)$CRLF$CRLF//s; + my %req_headers = map { m/^(.*?):\s+(.*)$/g } split( m/$CRLF/, $1 ); + + if( $test_mode ne "pipeline" ) { + is( length $request_stream, 0, "Stream is idle after request for $test_mode" ); + } + elsif( keys %wait > 1 && $not_first++ ) { + # Just in case it wasn't flushed yet, wait for another request to be + # written anyway before we respond to this one + wait_for_stream { length $request_stream } $peersock => $request_stream; + ok( length $request_stream > 0, "Stream is not idle after middle request for $test_mode" ); + } + + my $req_content; + if( defined( my $len = $req_headers{'Content-Length'} ) ) { + wait_for { length( $request_stream ) >= $len }; + + $req_content = substr( $request_stream, 0, $len ); + substr( $request_stream, 0, $len ) = ""; + } + + my $waitcount = keys %wait; + + my $body = "$req_firstline"; + + my $protocol = "HTTP/1.1"; + $protocol = "HTTP/1.0" if $test_mode eq "http/1.0"; + + $peersock->syswrite( "$protocol 200 OK$CRLF" . + "Content-Length: " . length( $body ) . $CRLF . + "Connection: Keep-Alive$CRLF" . + $CRLF . + $body ); + + # Wait for the server to finish its response + wait_for { keys %wait < $waitcount }; + } + + $loop->remove( $http ); +} + +# foreach $test_mode doesn't quite work as expected +foreach (qw( pipeline no_pipeline http/1.0 )) { + $test_mode = $_; + + do_uris( + URI->new( "http://server/path/1" ) => sub { + my ( $req ) = @_; + is( $req->content, "GET /path/1 HTTP/1.1", "First of three pipeline for $test_mode" ); + }, + URI->new( "http://server/path/2" ) => sub { + my ( $req ) = @_; + is( $req->content, "GET /path/2 HTTP/1.1", "Second of three pipeline for $test_mode" ); + }, + URI->new( "http://server/path/3" ) => sub { + my ( $req ) = @_; + is( $req->content, "GET /path/3 HTTP/1.1", "Third of three pipeline for $test_mode" ); + }, + ); +} + +done_testing; diff --git a/t/14conn-max.t b/t/14conn-max.t new file mode 100644 index 0000000..15e44da --- /dev/null +++ b/t/14conn-max.t @@ -0,0 +1,105 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Identity; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers + pipeline => 0, # Disable pipelining or we'll break the tests +); + +$loop->add( $http ); + +my @peersocks; + +no warnings 'redefine'; +local *IO::Async::Handle::connect = sub { + my $self = shift; + + my ( $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + push @peersocks, $peersock; + + return Future->new->done( $self ); +}; + +foreach my $max ( 1, 2, 0 ) { + $http->configure( max_connections_per_host => $max ); + + my @done; + foreach my $idx ( 0 .. 2 ) { + $http->do_request( + request => HTTP::Request->new( GET => "/" ), + host => "myhost", + on_response => sub { $done[$idx]++ }, + on_error => sub { }, + ) + } + + ## First batch of requests looks the same in all cases + + my $expect_conns = $max || 3; + is( scalar @peersocks, $expect_conns, "Expected number of connections for max=$max" ); + + # Wait for all the pending requests to be written + my @buffers; + wait_for_stream { ($buffers[$_]||"") =~ m/$CRLF$CRLF/ } $peersocks[$_] => $buffers[$_] for 0 .. $#peersocks; + $_ = "" for @buffers; + + # Write responses for all + $_->syswrite( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . $CRLF ) for @peersocks; + + wait_for { $done[$_] } for 0 .. $expect_conns-1; + + if( $max == 1 ) { + # The other two requests come over the same initial socket + wait_for_stream { ($buffers[0]||"") =~ m/$CRLF$CRLF/ } $peersocks[0] => $buffers[0]; + $_ = "" for @buffers; + $peersocks[0]->syswrite( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . $CRLF ); + wait_for { $done[1] }; + + wait_for_stream { ($buffers[0]||"") =~ m/$CRLF$CRLF/ } $peersocks[0] => $buffers[0]; + $_ = "" for @buffers; + $peersocks[0]->syswrite( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . $CRLF ); + } + elsif( $max == 2 ) { + # The third request will come over one of these $peersocks again, but we don't know which + my $peersock; + { + $loop->watch_io( handle => $peersocks[0], on_read_ready => sub { $peersock = $peersocks[0] } ); + $loop->watch_io( handle => $peersocks[1], on_read_ready => sub { $peersock = $peersocks[1] } ); + wait_for { defined $peersock }; + $loop->unwatch_io( handle => $_, on_read_ready => 1 ) for @peersocks; + } + + wait_for_stream { ($buffers[0]||"") =~ m/$CRLF$CRLF/ } $peersock => $buffers[0]; + $_ = "" for @buffers; + $peersock->syswrite( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . $CRLF ); + } + + wait_for { $done[0] && $done[1] && $done[2] }; + ok( 1, "All three requests are now done for max=$max" ); + + undef @peersocks; + + # CHEATING + $_->remove_from_parent for @{ delete $http->{connections}{"myhost:80"} }; +} + +done_testing; diff --git a/t/15conn-errors.t b/t/15conn-errors.t new file mode 100644 index 0000000..f26bcb2 --- /dev/null +++ b/t/15conn-errors.t @@ -0,0 +1,64 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Identity; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers +); + +$loop->add( $http ); + +# connect errors +{ + my @on_connect_errors; + + no warnings 'redefine'; + local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + my $f = $self->loop->new_future; + + push @on_connect_errors, sub { $f->fail( @_ ) }; + + return $f; + }; + + my $f1 = $http->do_request( + uri => URI->new( "http://hostname/first" ), + ); + my $f2 = $http->do_request( + uri => URI->new( "http://hostname/second" ), + ); + + is( scalar @on_connect_errors, 1, '1 on_connect_errors queued before first connect error' ); + ok( !$f1->is_ready, '$f1 still pending before connect error' ); + + ( shift @on_connect_errors )->( connect => "No route to host" ); + + wait_for { $f1->is_ready }; + is( scalar $f1->failure, "hostname:80 - connect failed [No route to host]", '$f1->failure' ); + + is( scalar @on_connect_errors, 1, '1 on_connect_errors queued before second connect error' ); + ok( !$f2->is_ready, '$f2 still pending before connect error' ); + + ( shift @on_connect_errors )->( connect => "No route to host" ); + + wait_for { $f2->is_ready }; + is( scalar $f2->failure, "hostname:80 - connect failed [No route to host]", '$f2->failure' ); +} + +done_testing; diff --git a/t/16max-in-flight.t b/t/16max-in-flight.t new file mode 100644 index 0000000..d6a8b11 --- /dev/null +++ b/t/16max-in-flight.t @@ -0,0 +1,101 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + max_in_flight => 2 +); +$loop->add( $http ); + +my $host = "host.example"; + +my $peersock; +no warnings 'redefine'; +local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + $args{host} eq $host or die "Expected $args{host} eq $host"; + $args{service} eq "80" or die "Expected $args{service} eq 80"; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); +}; + +my @resp; +$http->do_request( + request => HTTP::Request->new( GET => "/$_", [ Host => $host ] ), + host => $host, + on_response => sub { push @resp, shift }, + on_error => sub { die "Test died early - $_[-1]" }, +) for 0 .. 3; + +wait_for { $peersock }; + +# CHEATING +my $conn = $http->{connections}->{"$host:80"}->[0] or die "Unable to find connection object"; +ref $conn eq "Net::Async::HTTP::Connection" or die "Unable to find connection object"; + +my $request_stream = ""; +wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + +ok( $request_stream =~ m[^GET /0 HTTP/1\.1$CRLF.*?$CRLF$CRLF$]s, 'Request stream contains first request only' ); +$request_stream = ""; + +# CHEATING +is( scalar @{ $conn->{ready_queue} }, 3, '3 requests still queued' ); + +$peersock->print( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . + "$CRLF" ); + +wait_for { $resp[0] }; +is( $resp[0]->code, 200, 'Request /0 responded OK' ); + +wait_for_stream { $request_stream =~ m/(?:.*$CRLF$CRLF){2}/s } $peersock => $request_stream; + +ok( $request_stream =~ m[^GET /1 HTTP/1\.1$CRLF.*?${CRLF}${CRLF}GET /2 HTTP/1\.1$CRLF.*?${CRLF}${CRLF}$]s, + 'Request stream contains second and third requests after first response' ); +$request_stream = ""; + +# CHEATING +is( scalar @{ $conn->{ready_queue} }, 1, '1 request still queued' ); + +$peersock->print( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 1$CRLF" . + "$CRLF" . + "A" ); +$peersock->print( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 2$CRLF" . + "$CRLF" . + "AB" ); + +wait_for { $resp[2] }; +is( $resp[1]->content, "A", 'Request /1 content' ); +is( $resp[2]->content, "AB", 'Request /2 content' ); + +wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; +ok( $request_stream =~ m[^GET /3 HTTP/1\.1$CRLF.*?$CRLF$CRLF$]s, 'Request stream contains final request' ); + +$peersock->print( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . + "$CRLF" ); + +wait_for { $resp[3] }; +is( $resp[3]->code, 200, 'Request /3 responded OK' ); + +done_testing; diff --git a/t/17on-write.t b/t/17on-write.t new file mode 100644 index 0000000..a29121f --- /dev/null +++ b/t/17on-write.t @@ -0,0 +1,68 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers +); + +$loop->add( $http ); + +my $peersock; + +no warnings 'redefine'; +local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + $self->configure( write_len => 10 ); + + return Future->new->done( $self ); +}; + +{ + my @written; + my $req_f = $http->do_request( + request => HTTP::Request->new( PUT => "/content", [ Host => "somewhere" ] ), + host => "somewhere", + request_body => "X" x 100, + + on_body_write => sub { push @written, $_[0] }, + ); + + defined $peersock or die "No peersock\n"; + + # Wait for the client to send its request + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + $request_stream =~ s/^(.*)$CRLF$CRLF//s; + wait_for_stream { $request_stream =~ m/X{100}/ } $peersock => $request_stream; + + $peersock->syswrite( "HTTP/1.1 201 Created$CRLF" . + "Content-Length: 0$CRLF" . + "Connection: Keep-Alive$CRLF" . + $CRLF ); + + wait_for { $req_f->is_ready }; + + is_deeply( \@written, + [ 10, 20, 30, 40, 50, 60, 70, 80, 90, 100 ], + 'on_body_write invoked per body write call' ); +} + +done_testing; diff --git a/t/18content-coding.t b/t/18content-coding.t new file mode 100644 index 0000000..030585e --- /dev/null +++ b/t/18content-coding.t @@ -0,0 +1,144 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers + decode_content => 1, +); +$loop->add( $http ); + +my $TEST_CONTENT = "Here is the compressed content\n"; + +my $peersock; +no warnings 'redefine'; +local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + $args{host} eq "host" or die "Expected $args{host} eq 'host'"; + $args{service} eq "80" or die "Expected $args{service} eq 80"; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); +}; + +# RFC 2616 "gzip" +SKIP: { + skip "Compress::Raw::Zlib not available", 4 unless eval { require Compress::Raw::Zlib and $Compress::Raw::Zlib::VERSION >= 2.057 }; + diag( "Using optional dependency Compress::Raw::Zlib $Compress::Raw::Zlib::VERSION" ); + + my $f = $http->GET( "http://host/gzip" ); + $f->on_fail( sub { $f->get } ); + + { + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + my ( undef, @headers ) = split m/$CRLF/, $request_stream; + ok( scalar( grep { m/^Accept-Encoding: / } @headers ), 'Request as an Accept-Encoding header' ); + + my $compressor = Compress::Raw::Zlib::Deflate->new( + -WindowBits => Compress::Raw::Zlib::WANT_GZIP(), + -AppendOutput => 1, + ); + my $content = ""; + $compressor->deflate( $TEST_CONTENT, $content ); + $compressor->flush( $content ); + + $peersock->syswrite( sprintf "HTTP/1.1 200 OK$CRLF" . + "Content-Length: %d$CRLF" . + "Content-Type: text/plain$CRLF" . + "Content-Encoding: gzip$CRLF" . + $CRLF . "%s", + length $content, $content ); + } + + my $response = $f->get; + + is( $response->content, $TEST_CONTENT, '$response->content is decompressed from gzip' ); + ok( !defined $response->header( "Content-Encoding" ), '$response has no Content-Encoding' ); + is( $response->header( "X-Original-Content-Encoding" ), "gzip", '$response has X-Original-Content-Encoding' ); +} + +# RFC 2616 "deflate" +SKIP: { + skip "Compress::Raw::Zlib not available", 3 unless eval { require Compress::Raw::Zlib and $Compress::Raw::Zlib::VERSION >= 2.057 }; + + my $f = $http->GET( "http://host/deflate" ); + $f->on_fail( sub { $f->get } ); + + { + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + my $compressor = Compress::Raw::Zlib::Deflate->new( + -WindowBits => 15, + -AppendOutput => 1, + ); + my $content = ""; + $compressor->deflate( $TEST_CONTENT, $content ); + $compressor->flush( $content ); + + $peersock->syswrite( sprintf "HTTP/1.1 200 OK$CRLF" . + "Content-Length: %d$CRLF" . + "Content-Type: text/plain$CRLF" . + "Content-Encoding: deflate$CRLF" . + $CRLF . "%s", + length $content, $content ); + } + + my $response = $f->get; + + is( $response->content, $TEST_CONTENT, '$response->content is decompressed from deflate' ); + ok( !defined $response->header( "Content-Encoding" ), '$response has no Content-Encoding' ); + is( $response->header( "X-Original-Content-Encoding" ), "deflate", '$response has X-Original-Content-Encoding' ); +} + +SKIP: { + # Compress::Bzip2 2.09 appears to fail + skip "Compress::Bzip2 not available", 3 unless eval { require Compress::Bzip2 and $Compress::Bzip2::VERSION >= 2.10 }; + diag( "Using optional dependency Compress::Bzip2 $Compress::Bzip2::VERSION" ); + + my $f = $http->GET( "http://host/bzip2" ); + $f->on_fail( sub { $f->get } ); + + { + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + my $compressor = Compress::Bzip2::bzdeflateInit(); + my $content = ""; + $content .= $compressor->bzdeflate( my $tmp = $TEST_CONTENT ); + $content .= $compressor->bzclose; + + $peersock->syswrite( sprintf "HTTP/1.1 200 OK$CRLF" . + "Content-Length: %d$CRLF" . + "Content-Type: text/plain$CRLF" . + "Content-Encoding: bzip2$CRLF" . + $CRLF . "%s", + length $content, $content ); + } + + my $response = $f->get; + + is( $response->content, $TEST_CONTENT, '$response->content is decompressed from bzip2' ); + ok( !defined $response->header( "Content-Encoding" ), '$response has no Content-Encoding' ); + is( $response->header( "X-Original-Content-Encoding" ), "bzip2", '$response has X-Original-Content-Encoding' ); +} + +done_testing; diff --git a/t/19idle.t b/t/19idle.t new file mode 100644 index 0000000..f55adb4 --- /dev/null +++ b/t/19idle.t @@ -0,0 +1,65 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Identity; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my @on_error; + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers + + on_error => sub { + my ( undef, @args ) = @_; + + push @on_error, [ @args ]; + }, +); + +$loop->add( $http ); + +# spurious trailing content +{ + my $peersock; + no warnings 'redefine'; + local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); + }; + + my $f = $http->do_request( + request => HTTP::Request->new( GET => "http://host/" ), + ); + + wait_for { $peersock }; + + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->print( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 11$CRLF" . + $CRLF . + "Hello world" . + "more stuff here" ); + + wait_for { $f->is_ready }; + ok( !$f->failure, '$f is ready and does not fail' ); +} + +done_testing; diff --git a/t/20local-connect.t b/t/20local-connect.t new file mode 100644 index 0000000..3fda97d --- /dev/null +++ b/t/20local-connect.t @@ -0,0 +1,92 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers +); + +$loop->add( $http ); + +my $port; +$loop->listen( + host => "127.0.0.1", + service => 0, + socktype => "stream", + + on_listen => sub { + $port = shift->sockport; + }, + + on_stream => sub { + my ( $stream ) = @_; + + $stream->configure( + on_read => sub { + my ( $self, $buffref ) = @_; + return 0 unless $$buffref =~ m/$CRLF$CRLF/; + + $self->write( "HTTP/1.1 200 OK$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: close$CRLF" . + "$CRLF" . + "OK" ); + + $self->close_when_empty; + + return 0; + }, + ); + + $loop->add( $stream ); + }, + + on_listen_error => sub { die "Test failed early - $_[-1]" }, + on_resolve_error => sub { die "Test failed early - $_[-1]" }, +); + +wait_for { defined $port }; + +my $local_uri = URI->new( "http://127.0.0.1:$port/" ); + +my $response; + +my $connected_port; + +$http->do_request( + uri => $local_uri, + + on_ready => sub { + my ( $conn ) = @_; + $connected_port = $conn->read_handle->peerport; + + Future->done; + }, + + on_response => sub { + $response = $_[0]; + }, + + on_error => sub { die "Test failed early - $_[-1]" }, +); + +wait_for { defined $response }; + +is( $response->content_type, "text/plain", '$response->content_type' ); +is( $response->content, "OK", '$response->content' ); + +is( $connected_port, $port, 'peerport visible within on_ready' ); + +done_testing; diff --git a/t/21local-connect-ssl.t b/t/21local-connect-ssl.t new file mode 100644 index 0000000..1c9d159 --- /dev/null +++ b/t/21local-connect-ssl.t @@ -0,0 +1,111 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +eval { + require IO::Async::SSL; + IO::Async::SSL->VERSION( '0.12' ); +} or plan skip_all => "No IO::Async::SSL"; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers + + # This also checks that object-wide SSL params are applied + SSL_verify_mode => 0, +); + +$loop->add( $http ); + +my $port; +$loop->SSL_listen( + host => "127.0.0.1", + service => 0, + socktype => "stream", + + SSL_key_file => "t/privkey.pem", + SSL_cert_file => "t/server.pem", + + on_listen => sub { + $port = shift->sockport; + }, + + on_stream => sub { + my ( $stream ) = @_; + + # SNI - RT#94605 + SKIP: { + skip "SSL server does not support SNI", 1 unless IO::Socket::SSL->can_server_sni; + + my $sslsocket = $stream->read_handle; + is( $sslsocket->get_servername, "127.0.0.1", '->get_servername on server' ); + } + + $stream->configure( + on_read => sub { + my ( $self, $buffref ) = @_; + return 0 unless $$buffref =~ m/$CRLF$CRLF/; + + $self->write( "HTTP/1.1 200 OK$CRLF" . + "Content-Type: text/plain$CRLF" . + "Connection: close$CRLF" . + "$CRLF" . + "OK" ); + + $self->close_when_empty; + + return 0; + }, + ); + + $loop->add( $stream ); + }, + + on_listen_error => sub { die "Test failed early - $_[-1]" }, + on_resolve_error => sub { die "Test failed early - $_[-1]" }, + on_ssl_error => sub { die "Test failed early - $_[-1]" }, +); + +wait_for { defined $port }; + +my $local_uri = URI->new( "https://127.0.0.1:$port/" ); + +my $response; + +$http->do_request( + uri => $local_uri, + + on_response => sub { + $response = $_[0]; + }, + + on_error => sub { die "Test failed early - $_[-1]" }, +); + +wait_for { defined $response }; + +is( $response->content_type, "text/plain", '$response->content_type' ); +is( $response->content, "OK", '$response->content' ); + +# require_SSL +{ + $http->configure( require_SSL => 1 ); + + my $f = $http->GET( "http://127.0.0.1:$port/" ); + + ok( $f->failure, '->GET on http with require_SSL fails' ); + like( scalar $f->failure, qr/require_SSL/, 'require_SSL failure' ); +} + +done_testing; diff --git a/t/22local-connect-pipeline.t b/t/22local-connect-pipeline.t new file mode 100644 index 0000000..0ccd4fb --- /dev/null +++ b/t/22local-connect-pipeline.t @@ -0,0 +1,83 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers +); + +$loop->add( $http ); + +my $port; +$loop->listen( + host => "127.0.0.1", + service => 0, + socktype => "stream", + + on_listen => sub { + $port = shift->sockport; + }, + + on_stream => sub { + my ( $stream ) = @_; + + $stream->configure( + on_read => sub { + my ( $self, $buffref ) = @_; + return 0 unless $$buffref =~ s/^(.*?)$CRLF$CRLF//s; + + $self->write( "HTTP/1.1 200 OK$CRLF" . + "Content-Type: text/plain$CRLF" . + "Content-Length: 2$CRLF" . + "Connection: Keep-Alive$CRLF" . + "$CRLF" . + "OK" ); + + return 1; + }, + ); + + $loop->add( $stream ); + }, + + on_listen_error => sub { die "Test failed early - $_[-1]" }, + on_resolve_error => sub { die "Test failed early - $_[-1]" }, +); + +wait_for { defined $port }; + +my @local_uris = map { URI->new( "http://127.0.0.1:$port/page/$_" ) } 1 .. 2; + +my @responses; + +$http->do_request( + uri => $_, + + on_response => sub { + push @responses, $_[0]; + }, + + on_error => sub { die "Test failed early - $_[-1]" }, +) for @local_uris; + +wait_for { @responses == 2 }; + +is( $responses[0]->content_type, "text/plain", '$response->content_type' ); +is( $responses[0]->content, "OK", '$response->content' ); + +is( $responses[1]->content_type, "text/plain", '$response->content_type' ); +is( $responses[1]->content, "OK", '$response->content' ); + +done_testing; diff --git a/t/23local-connect-redir.t b/t/23local-connect-redir.t new file mode 100644 index 0000000..8f9ceaf --- /dev/null +++ b/t/23local-connect-redir.t @@ -0,0 +1,88 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers +); + +$loop->add( $http ); + +my $port; +$loop->listen( + host => "127.0.0.1", + service => 0, + socktype => "stream", + + on_listen => sub { + $port = shift->sockport; + }, + + on_stream => sub { + my ( $stream ) = @_; + + $stream->configure( + on_read => sub { + my ( $self, $buffref ) = @_; + return 0 unless $$buffref =~ s/^(.*?)$CRLF$CRLF//s; + + my $header = $1; + + my $response = ( $header =~ m{^GET /redir} ) + ? "HTTP/1.1 301 Moved Permanently$CRLF" . + "Content-Length: 0$CRLF" . + "Location: http://127.0.0.1:$port/moved$CRLF" . + "Connection: close$CRLF" . + "$CRLF" + : "HTTP/1.1 200 OK$CRLF" . + "Content-Type: text/plain$CRLF" . + "Content-Length: 2$CRLF" . + "Connection: close$CRLF" . + "$CRLF" . + "OK"; + + $self->write( $response ); + + return 1; + }, + ); + + $loop->add( $stream ); + }, + + on_listen_error => sub { die "Test failed early - $_[-1]" }, + on_resolve_error => sub { die "Test failed early - $_[-1]" }, +); + +wait_for { defined $port }; + +my $response; + +$http->do_request( + uri => URI->new( "http://127.0.0.1:$port/redir" ), + + on_response => sub { + $response = $_[0]; + }, + + on_error => sub { die "Test failed early - $_[-1]" }, +); + +wait_for { defined $response }; + +is( $response->content_type, "text/plain", '$response->content_type' ); +is( $response->content, "OK", '$response->content' ); + +done_testing; diff --git a/t/24local-connect-redir-ssl.t b/t/24local-connect-redir-ssl.t new file mode 100644 index 0000000..f9ac518 --- /dev/null +++ b/t/24local-connect-redir-ssl.t @@ -0,0 +1,117 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +eval { + require IO::Async::SSL; + IO::Async::SSL->VERSION( '0.12' ); +} or plan skip_all => "No IO::Async::SSL"; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers +); + +$loop->add( $http ); + +my $redir_url; + +my $port; +$loop->SSL_listen( + host => "127.0.0.1", + service => 0, + socktype => "stream", + + SSL_key_file => "t/privkey.pem", + SSL_cert_file => "t/server.pem", + + on_listen => sub { + $port = shift->sockport; + }, + + on_stream => sub { + my ( $stream ) = @_; + + $stream->configure( + on_read => sub { + my ( $self, $buffref ) = @_; + return 0 unless $$buffref =~ s/^(.*?)$CRLF$CRLF//s; + + my $header = $1; + + my $response = ( $header =~ m{^GET /redir} ) + ? "HTTP/1.1 301 Moved Permanently$CRLF" . + "Content-Length: 0$CRLF" . + "Location: $redir_url$CRLF" . + "Connection: Keep-Alive$CRLF" . + "$CRLF" + : "HTTP/1.1 200 OK$CRLF" . + "Content-Type: text/plain$CRLF" . + "Content-Length: 2$CRLF" . + "Connection: Keep-Alive$CRLF" . + "$CRLF" . + "OK"; + + $self->write( $response ); + + return 1; + }, + ); + + $loop->add( $stream ); + }, + + on_listen_error => sub { die "Test failed early - $_[-1]" }, + on_resolve_error => sub { die "Test failed early - $_[-1]" }, + on_ssl_error => sub { die "Test failed early - $_[-1]" }, +); + +wait_for { defined $port }; + +$redir_url = "https://127.0.0.1:$port/moved"; + +my $response; + +$http->do_request( + uri => URI->new( "https://127.0.0.1:$port/redir" ), + + SSL_verify_mode => 0, + + on_response => sub { + $response = $_[0]; + }, + + on_error => sub { die "Test failed early - $_[-1]" }, +); + +wait_for { defined $response }; + +is( $response->content_type, "text/plain", '$response->content_type' ); +is( $response->content, "OK", '$response->content' ); + +# require_SSL +{ + $http->configure( require_SSL => 1 ); + + $redir_url = "http://127.0.0.1:$port/moved_to_plaintext"; + + my $f = $http->GET( "https://127.0.0.1:$port/redir" ); + + wait_for { $f->is_ready }; + + ok( $f->failure, '->GET on http with require_SSL fails' ); + like( scalar $f->failure, qr/require_SSL/, 'require_SSL failure' ); +} + +done_testing; diff --git a/t/30timeout.t b/t/30timeout.t new file mode 100644 index 0000000..05bd6ae --- /dev/null +++ b/t/30timeout.t @@ -0,0 +1,209 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Refcount; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +use Errno qw( EAGAIN ); + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new(); + +$loop->add( $http ); + +my $peersock; + +no warnings 'redefine'; +my $latest_connection; +local *IO::Async::Handle::connect = sub { + $latest_connection = my $self = shift; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); +}; + +{ + my $errcount; + my $error; + + my $future = $http->do_request( + uri => URI->new( "http://my.server/doc" ), + + timeout => 0.1, # Really quick for testing + + on_response => sub { die "Test died early - got a response but shouldn't have" }, + on_error => sub { $errcount++; $error = $_[0] }, + ); + + is_refcount( $http, 2, '$http refcount 2 after ->do_request with timeout' ); + + wait_for { defined $error }; + + is( $error, "Timed out", 'Received timeout error' ); + is( $errcount, 1, 'on_error invoked once' ); + + ok( $future->is_ready, '$future is ready after timeout' ); + is( scalar $future->failure, "Timed out", '$future->failure after timeout' ); + is( ( $future->failure )[1], "timeout", '$future->failure [1] is timeout' ); + + is_refcount( $http, 2, '$http refcount 2 after ->do_request with timeout fails' ); +} + +{ + my $errcount; + my $error; + + my $future = $http->do_request( + uri => URI->new( "http://my.server/redir" ), + + timeout => 0.1, # Really quick for testing + + on_response => sub { die "Test died early - got a response but shouldn't have" }, + on_error => sub { $errcount++; $error = $_[0] }, + ); + + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $request_stream =~ s/^(.*)$CRLF//; + + $peersock->syswrite( "HTTP/1.1 301 Moved Permanently$CRLF" . + "Content-Length: 0$CRLF" . + "Location: http://my.server/get_doc?name=doc$CRLF" . + "Connection: Keep-Alive$CRLF" . + "$CRLF" ); + + wait_for { defined $error }; + + is( $error, "Timed out", 'Received timeout error from redirect' ); + is( $errcount, 1, 'on_error invoked once from redirect' ); + + ok( $future->is_ready, '$future is ready after timeout' ); + is( scalar $future->failure, "Timed out", '$future->failure after timeout' ); + is( ( $future->failure )[1], "timeout", '$future->failure [1] is timeout' ); +} + +{ + my $error; + my $errcount; + + $http->do_request( + uri => URI->new( "http://my.server/first" ), + + timeout => 0.1, # Really quick for testing + + on_response => sub { die "Test died early - got a response but shouldn't have" }, + on_error => sub { $errcount++; $error = $_[0] }, + ); + + my $error2; + my $errcount2; + + $http->do_request( + uri => URI->new( "http://my.server/second" ), + + timeout => 0.3, + + on_response => sub { die "Test died early - got a response but shouldn't have" }, + on_error => sub { $errcount2++; $error2 = $_[0] }, + ); + + wait_for { defined $error }; + is( $error, "Timed out", 'Received timeout error from pipeline' ); + is( $errcount, 1, 'on_error invoked once from pipeline' ); + + wait_for { defined $error2 }; + is( $error2, "Timed out", 'Received timeout error from pipeline(2)' ); + is( $errcount2, 1, 'on_error invoked once from pipeline(2)' ); +} + +# Stall during write +{ + my $future = $http->do_request( + uri => URI->new( "http://stalling.server/write" ), + + stall_timeout => 0.1, + ); + + # Much hackery for unit-testing purposes + $latest_connection->configure( + writer => sub { $! = EAGAIN; return undef }, + ); + + wait_for { $future->is_ready }; + is( scalar $future->failure, "Stalled while writing request", '$future->failure for stall during write' ); + is( ( $future->failure )[1], "stall_timeout", '$future->failure [1] is stall_timeout' ); +} + +# Stall during header read +{ + my $future = $http->do_request( + uri => URI->new( "http://stalling.server/header" ), + + stall_timeout => 0.1, + ); + + # Don't write anything + + wait_for { $future->is_ready }; + is( scalar $future->failure, "Stalled while waiting for response", '$future->failure for stall during response header' ); + is( ( $future->failure )[1], "stall_timeout", '$future->failure [1] is stall_timeout' ); +} + +# Stall during header read +{ + my $future = $http->do_request( + uri => URI->new( "http://stalling.server/read" ), + + stall_timeout => 0.1, + ); + + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->syswrite( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 100$CRLF" ); # unfinished + + wait_for { $future->is_ready }; + is( scalar $future->failure, "Stalled while receiving response header", '$future->failure for stall during response header' ); + is( ( $future->failure )[1], "stall_timeout", '$future->failure [1] is stall_timeout' ); +} + +# Stall during body read +{ + my $future = $http->do_request( + uri => URI->new( "http://stalling.server/read" ), + + stall_timeout => 0.1, + ); + + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->syswrite( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 100$CRLF" . + $CRLF ); + $peersock->syswrite( "some of the content" ); # unfinished + + wait_for { $future->is_ready }; + is( scalar $future->failure, "Stalled while receiving body", '$future->failure for stall during response body' ); + is( ( $future->failure )[1], "stall_timeout", '$future->failure [1] is stall_timeout' ); +} + +$loop->remove( $http ); + +is_oneref( $http, '$http has refcount 1 before EOF' ); + +done_testing; diff --git a/t/31cancel.t b/t/31cancel.t new file mode 100644 index 0000000..aa8ada4 --- /dev/null +++ b/t/31cancel.t @@ -0,0 +1,143 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers + pipeline => 1, + max_connections_per_host => 1, +); + +$loop->add( $http ); + +my $peersock; +no warnings 'redefine'; +local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + $peersock->blocking(0); + + return Future->new->done( $self ); +}; + +# Cancellation +{ + undef $peersock; + my $f1 = $http->do_request( + method => "GET", + uri => URI->new( "http://host1/some/path" ), + ); + + wait_for { $peersock }; + + $f1->cancel; + + wait_for { my $ret = sysread($peersock, my $buffer, 1); defined $ret and $ret == 0 }; + ok( 1, '$peersock closed' ); + + # Retry after cancel should establish another connection + + undef $peersock; + my $f2 = $http->do_request( + method => "GET", + uri => URI->new( "http://host1/some/path" ), + ); + + wait_for { $peersock }; + + # Wait for the client to send its request + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->syswrite( join( $CRLF, + "HTTP/1.1 200 OK", + "Content-Type: text/plain", + "Content-Length: 12", + "" ) . $CRLF . + "Hello world!" + ); + + wait_for { $f2->is_ready }; + $f2->get; +} + +# Cancelling a pending unpipelined request +{ + undef $peersock; + + # Make first -one- request/response to establish HTTP/1.1 pipeline ability + my $f0 = $http->do_request( + method => "GET", + uri => URI->new( "http://host2/" ), + ); + + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $peersock->syswrite( join( $CRLF, + "HTTP/1.1 200 OK", + "Content-Length: 0", + "" ) . $CRLF + ); + + wait_for { $f0->is_ready }; + + my ( $f1, $f2, $f3 ) = map { + $http->do_request( + method => "GET", + uri => URI->new( "http://host2/req/$_" ), + ); + } 1, 2, 3; + + wait_for { $peersock }; + + # cancel $f2 - 1 and 3 should still complete + $f2->cancel; + + # Wait for the $f1 and $f3 + $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + like( $request_stream, qr(^GET /req/1 HTTP/1.1), '$f1 request written' ); + $request_stream = ""; + + $peersock->syswrite( join( $CRLF, + "HTTP/1.1 200 OK", + "Content-Length: 0", + "" ) . $CRLF + ); + + wait_for { $f1->is_ready }; + ok( $f1->is_done, '$f1 is done' ); + + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + like( $request_stream, qr(^GET /req/3 HTTP/1.1), '$f3 request written' ); + $request_stream = ""; + + $peersock->syswrite( join( $CRLF, + "HTTP/1.1 200 OK", + "Content-Length: 0", + "" ) . $CRLF + ); + + wait_for { $f3->is_ready }; + ok( $f3->is_done, '$f3 is done' ); +} + +done_testing; diff --git a/t/32remove.t b/t/32remove.t new file mode 100644 index 0000000..b849fe1 --- /dev/null +++ b/t/32remove.t @@ -0,0 +1,66 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Refcount; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new; +$loop->add( $http ); + +my $host = "host.example"; + +my $peersock; +no warnings 'redefine'; +local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + + $args{host} eq $host or die "Expected $args{host} eq $host"; + $args{service} eq "80" or die "Expected $args{service} eq 80"; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->new->done( $self ); +}; + +my $f = $http->do_request( + request => HTTP::Request->new( GET => "/", [ Host => $host ] ), + host => $host, +); + +my $request_stream = ""; +wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + +$request_stream = ""; + +$peersock->print( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . + $CRLF ); + +wait_for { $f->is_ready }; + +# gut-wrenching +my $conn = $http->{connections}{"$host:80"}[0]; +ok( $conn, 'Found a connection' ); + +# 1 internally in the $http, 2 in IO::Async internals, 1 here +is_refcount( $conn, 4, 'Connection has 4 references' ); + +$loop->remove( $http ); +undef $http; + +is_oneref( $conn, 'Connection has 1 reference remaining at EOF' ); + +done_testing; diff --git a/t/40socks.t b/t/40socks.t new file mode 100644 index 0000000..c7d104e --- /dev/null +++ b/t/40socks.t @@ -0,0 +1,108 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +BEGIN { + eval { + require Net::Async::SOCKS; + Net::Async::SOCKS->VERSION( '0.003' ); + } or plan skip_all => "No Net::Async::SOCKS"; +} + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers + SOCKS_host => "socks.host", + SOCKS_port => "1234", +); + +$loop->add( $http ); + +my %connect_args; +my $connect_f; + +no warnings 'redefine'; +local *IO::Async::Loop::SOCKS_connect = sub { + shift; + ( %connect_args ) = @_; + + return $connect_f = Future->new; +}; + +my $f = $http->do_request( + uri => URI->new( "http://remote-site-here/" ), +); + +# Check that ->SOCKS_connect was invoked correctly +my $handle; +{ + wait_for { keys %connect_args }; + + $handle = delete $connect_args{handle}; + delete @connect_args{qw( SSL on_error )}; + is_deeply( \%connect_args, + { + family => 0, + socktype => "stream", + host => "remote-site-here", + service => 80, + is_proxy => '', + + SOCKS_host => "socks.host", + SOCKS_port => 1234, + }, + 'SOCKS_connect invoked' + ); +} + +# Set up a socket connection +my $peersock; +{ + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $handle->set_handle( $selfsock ); + + $connect_f->done( $handle ); +} + +# Handle request/response cycle +{ + my $request_stream = ""; + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + + $request_stream =~ s/^(.*)$CRLF//; + is( $1, "GET / HTTP/1.1", + 'Received request firstline' ); + + $request_stream =~ s/^(.*)$CRLF$CRLF//s; + my %req_headers = map { m/^([^:]+):\s+(.*)$/g } split( m/$CRLF/, $1 ); + + is_deeply( \%req_headers, + { + Host => "remote-site-here", + Connection => "keep-alive", + }, + 'Received request headers' ); + + $peersock->syswrite( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . + $CRLF ); +} + +wait_for { $f->is_ready }; + +my $response = $f->get; + +is( $response->code, 200, '$response' ); + +done_testing; diff --git a/t/80cross-http.t b/t/80cross-http.t new file mode 100644 index 0000000..01939e9 --- /dev/null +++ b/t/80cross-http.t @@ -0,0 +1,76 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use IO::Async::Stream; + +unless( eval { require Net::Async::HTTP::Server and + Net::Async::HTTP::Server->VERSION( '0.03' ) } ) { + plan skip_all => "Net::Async::HTTP::Server 0.03 is not available"; +} +unless( eval { require Net::Async::HTTP } ) { + plan skip_all => "Net::Async::HTTP is not available"; +} + +my $CRLF = "\x0d\x0a"; + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $server = Net::Async::HTTP::Server->new( + on_request => sub { + my $self = shift; + my ( $req ) = @_; + + my $content = "Response to " . join " ", $req->method, $req->path, "with " . length( $req->body ) . " bytes"; + + $req->write( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: " . length( $content ) . $CRLF . + "Content-Type: text/plain$CRLF" . + $CRLF . + $content + ); + + $req->done; + }, +); + +$loop->add( $server ); + +$loop->add( my $client = Net::Async::HTTP->new ); + +my ( $host, $port ); +$server->listen( + addr => { family => "inet", socktype => "stream", ip => "127.0.0.1", port => 0 }, + on_listen => sub { + my $socket = $_[0]->read_handle; + $host = $socket->sockhost; + $port = $socket->sockport; + }, + on_listen_error => sub { die "Cannot listen - $_[-1]\n" }, +); + +wait_for { defined $host and defined $port }; + +my $response; + +$client->do_request( + uri => URI->new( "http://$host:$port/" ), + on_response => sub { + ( $response ) = @_; + }, + on_error => sub { die "Test failed early - $_[-1]\n" }, +); + +wait_for { $response }; + +is( $response->code, 200, '$response->code' ); +is( $response->content_type, "text/plain", '$response->content_type' ); +is( $response->content, "Response to GET / with 0 bytes", '$response->content' ); + +done_testing; diff --git a/t/81cross-https.t b/t/81cross-https.t new file mode 100644 index 0000000..b0fc710 --- /dev/null +++ b/t/81cross-https.t @@ -0,0 +1,83 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use IO::Async::Stream; + +unless( eval { require Net::Async::HTTP::Server and + Net::Async::HTTP::Server->VERSION( '0.06' ) } ) { + plan skip_all => "Net::Async::HTTP::Server 0.06 is not available"; +} +unless( eval { require Net::Async::HTTP } ) { + plan skip_all => "Net::Async::HTTP is not available"; +} +unless( eval { require IO::Async::SSL and + IO::Async::SSL->VERSION( '0.12' ) } ) { + plan skip_all => "IO::Async::SSL is not available"; +} + +my $CRLF = "\x0d\x0a"; + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $server = Net::Async::HTTP::Server->new( + on_request => sub { + my $self = shift; + my ( $req ) = @_; + + my $content = "Response to " . join " ", $req->method, $req->path, "with " . length( $req->body ) . " bytes"; + + $req->write( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: " . length( $content ) . $CRLF . + "Content-Type: text/plain$CRLF" . + $CRLF . + $content + ); + + $req->done; + }, +); + +$loop->add( $server ); + +$loop->add( my $client = Net::Async::HTTP->new ); + +my ( $host, $port ); +$server->listen( + addr => { family => "inet", socktype => "stream", ip => "127.0.0.1", port => 0 }, + on_listen => sub { + my $socket = $_[0]->read_handle; + $host = $socket->sockhost; + $port = $socket->sockport; + }, + + extensions => [qw( SSL )], + SSL_key_file => "t/privkey.pem", + SSL_cert_file => "t/server.pem", +)->get; + +my $response; + +$client->do_request( + uri => URI->new( "https://$host:$port/" ), + SSL_verify_mode => 0, + + on_response => sub { + ( $response ) = @_; + }, + on_error => sub { die "Test failed early - $_[0]\n" }, +); + +wait_for { $response }; + +is( $response->code, 200, '$response->code' ); +is( $response->content_type, "text/plain", '$response->content_type' ); +is( $response->content, "Response to GET / with 0 bytes", '$response->content' ); + +done_testing; diff --git a/t/90rt75615.t b/t/90rt75615.t new file mode 100644 index 0000000..8cba89d --- /dev/null +++ b/t/90rt75615.t @@ -0,0 +1,102 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers +); + +$loop->add( $http ); + +my $port; +$loop->listen( + host => "127.0.0.1", + service => 0, + socktype => "stream", + + on_listen => sub { + $port = shift->sockport; + }, + + on_stream => sub { + my ( $stream ) = @_; + + $stream->configure( + on_read => sub { + my ( $self, $buffref ) = @_; + return 0 unless $$buffref =~ s/^(.*?)$CRLF$CRLF//s; + + my $header = $1; + + my $response = ( $header =~ m{^GET /redir} ) + ? "HTTP/1.1 301 Moved Permanently$CRLF" . + "Content-Length: 0$CRLF" . + "Location: /moved$CRLF" . + "Connection: close$CRLF" . + "$CRLF" + : "HTTP/1.1 200 OK$CRLF" . + "Content-Type: text/plain$CRLF" . + "Content-Length: 2$CRLF" . + "Connection: close$CRLF" . + "$CRLF" . + "OK"; + + $self->write( $response ); + + return 1; + }, + ); + + $loop->add( $stream ); + }, + + on_listen_error => sub { die "Test failed early - $_[-1]" }, + on_resolve_error => sub { die "Test failed early - $_[-1]" }, +); + +wait_for { defined $port }; + +my $code = \&IO::Async::Handle::connect; +no warnings 'redefine'; +local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + $args{service} = $port if $args{service} eq '80'; + $code->($self, %args); +}; + +my $response; + +my $req = HTTP::Request->new(GET => '/redir'); +$req->protocol('HTTP/1.1'); +$req->header(Host => '127.0.0.1'); +$http->do_request( + method => "GET", + host => '127.0.0.1', + request => $req, + + on_response => sub { + $response = $_[0]; + }, + + on_error => sub { die "Test failed early - $_[-1]" }, +); + +wait_for { defined $response }; + +is( $response->content_type, "text/plain", '$response->content_type' ); +is( $response->content, "OK", '$response->content' ); + +done_testing; diff --git a/t/90rt75616.t b/t/90rt75616.t new file mode 100644 index 0000000..f2193f8 --- /dev/null +++ b/t/90rt75616.t @@ -0,0 +1,103 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers +); + +$loop->add( $http ); + +my $port; +$loop->listen( + host => "127.0.0.1", + service => 0, + socktype => "stream", + + on_listen => sub { + $port = shift->sockport; + }, + + on_stream => sub { + my ( $stream ) = @_; + + $stream->configure( + on_read => sub { + my ( $self, $buffref ) = @_; + return 0 unless $$buffref =~ s/^(.*?)$CRLF$CRLF//s; + + my $header = $1; + + my $response = ( $header =~ m{^GET /redir} ) + ? "HTTP/1.1 301 Moved Permanently$CRLF" . + "Content-Length: 0$CRLF" . + "Location: /moved$CRLF" . + "Connection: close$CRLF" . + "$CRLF" + : "HTTP/1.1 200 OK$CRLF" . + "Content-Type: text/plain$CRLF" . + "Content-Length: 2$CRLF" . + "Connection: close$CRLF" . + "$CRLF" . + "OK"; + + $self->write( $response ); + + return 1; + }, + ); + + $loop->add( $stream ); + }, + + on_listen_error => sub { die "Test failed early - $_[-1]" }, + on_resolve_error => sub { die "Test failed early - $_[-1]" }, +); + +wait_for { defined $port }; + +my $code = \&IO::Async::Handle::connect; +no warnings 'redefine'; +local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + $args{service} = $port if $args{service} eq 'http'; + $args{service} = $port if $args{service} == 80; + $code->($self, %args); +}; + +my $response; + +my $req = HTTP::Request->new(GET => '/redir'); +$req->protocol('HTTP/1.1'); +$req->header(Host => '127.0.0.1'); +$http->do_request( + method => "GET", + host => '127.0.0.1', + request => $req, + + on_response => sub { + $response = $_[0]; + }, + + on_error => sub { die "Test failed early - $_[-1]" }, +); + +wait_for { defined $response }; + +is( $response->content_type, "text/plain", '$response->content_type' ); +is( $response->content, "OK", '$response->content' ); + +done_testing; diff --git a/t/90rt92904.t b/t/90rt92904.t new file mode 100644 index 0000000..7c2534a --- /dev/null +++ b/t/90rt92904.t @@ -0,0 +1,44 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $loop = IO::Async::Loop->new; +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + max_connections_per_host => 2, +); + +$loop->add( $http ); + +my @conn_f; +no warnings 'redefine'; +local *IO::Async::Loop::connect = sub { + shift; + my %args = @_; + $args{host} eq "localhost" or die "Cannot fake connect - expected host 'localhost'"; + $args{service} eq "5000" or die "Cannot fake connect - expected service '5000'"; + + push @conn_f, my $f = $loop->new_future; + return $f; +}; + +my @f = map { $http->do_request(uri=>'http://localhost:5000/') } 0 .. 1; + +is( scalar @conn_f, 2, 'Two pending connect() attempts after two concurrent ->do_request' ); + +# Fail them both +( shift @conn_f )->fail( "Connection refused", connect => ) for 0 .. 1; + +ok( $f[$_]->is_ready && $f[$_]->failure, "Request [$_] Future fails after connect failure" ) for 0 .. 1; + +ok( !@conn_f, 'No more pending connect() attempts' ); + +done_testing; diff --git a/t/90rt93232.t b/t/90rt93232.t new file mode 100644 index 0000000..9c11277 --- /dev/null +++ b/t/90rt93232.t @@ -0,0 +1,78 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use Test::Refcount; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers +); + +$loop->add( $http ); + +my $port; +$loop->listen( + host => "127.0.0.1", + service => 0, + socktype => "stream", + + on_listen => sub { + $port = shift->sockport; + }, + + on_stream => sub { + my ( $stream ) = @_; + + $stream->configure( + on_read => sub { + my ( $self, $buffref ) = @_; + return 0 unless $$buffref =~ s/^(.*?)$CRLF$CRLF//s; + + my $header = $1; + + $self->write( + "HTTP/1.1 200 OK$CRLF" . + "Content-Type: text/plain$CRLF" . + "Content-Length: 2$CRLF" . + "Connection: close$CRLF" . + "$CRLF" . + "OK" + ); + + return 1; + }, + ); + + $loop->add( $stream ); + }, +)->get; + +my $on_body_chunk; + +$http->do_request( + method => "GET", + host => "127.0.0.1", + port => $port, + request => HTTP::Request->new(GET => "/"), + + on_header => sub { + my ( $header ) = @_; + # Needs to be a real closure + return $on_body_chunk = sub { $header = $header; 1 }; + }, +)->get; + +is_oneref( $on_body_chunk, '$on_body_chunk has refcount 1 before EOF' ); + +done_testing; diff --git a/t/90rt99142.t b/t/90rt99142.t new file mode 100644 index 0000000..453a1d4 --- /dev/null +++ b/t/90rt99142.t @@ -0,0 +1,93 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers + max_connections_per_host => 2, +); + +$loop->add( $http ); + +{ + my @pending; + no warnings 'redefine'; + *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + $args{host} eq "localhost" or die "Cannot fake connect - expected host 'localhost'"; + $args{service} eq "5000" or die "Cannot fake connect - expected service '5000'"; + + push @pending, [ $self, my $f = $loop->new_future ]; + return $f; + }; + + sub await_connection + { + wait_for { scalar @pending }; + + return @{ shift @pending }; + } +} + +# Make a first connection +my $req_f1 = $http->GET( "http://localhost:5000/1" ); +my $peersock; +{ + my ( $conn, $conn_f ) = await_connection; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $conn->set_handle( $selfsock ); + + $conn_f->done( $conn ); +} + +# Before the first is ready, make a second one +my $req_f2 = $http->GET( "http://localhost:5000/2" ); +my ( $conn2, $conn_f2 ) = await_connection; +ok( $conn_f2, 'Second connection request is pending' ); + +# Gutwrenching +is( scalar @{ $http->{connections}{"localhost:5000"} }, 2, + '$http has two pending connections to localhost:5000' ); + +my $request_stream = ""; +wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + +like( $request_stream, qr(^GET /1), 'First request written' ); +$request_stream = ""; + +# Respond with HTTP/1.1 so client knows it can pipeline +$peersock->syswrite( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . + $CRLF ); + +wait_for { $req_f1->is_ready }; +ok( $req_f1->is_done, '$req_f1 is done after first response' ); + +# At this point, req 2 should already be made down the socket +wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + +like( $request_stream, qr(^GET /2), 'Second request written down first socket' ); + +# And $conn_f2 should already be cancelled +ok( $conn_f2->is_cancelled, '$conn_f2 now cancelled' ); + +# Gutwrenching +is( scalar @{ $http->{connections}{"localhost:5000"} }, 1, + '$http has only one connection to localhost:5000 at EOF' ); + +done_testing; diff --git a/t/91rt100066.t b/t/91rt100066.t new file mode 100644 index 0000000..f6eb95d --- /dev/null +++ b/t/91rt100066.t @@ -0,0 +1,120 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +my $CRLF = "\x0d\x0a"; # because \r\n isn't portable + +my $loop = IO::Async::Loop->new(); +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + user_agent => "", # Don't put one in request headers +); + +$loop->add( $http ); + +my $peersock; +no warnings 'redefine'; +local *IO::Async::Handle::connect = sub { + my $self = shift; + my %args = @_; + $args{host} eq "localhost" or die "Cannot fake connect - expected host 'localhost'"; + $args{service} eq "5000" or die "Cannot fake connect - expected service '5000'"; + + ( my $selfsock, $peersock ) = IO::Async::OS->socketpair() or die "Cannot create socket pair - $!"; + $self->set_handle( $selfsock ); + + return Future->done( $self ); +}; + +# Without on_error +{ + my $f1 = $http->GET( "http://localhost:5000/1" ) + ->on_done( sub { die "Oopsie" } ); + + my $f2 = $http->GET( "http://localhost:5000/2" ); + + wait_for { defined $peersock }; + + my $request_stream = ""; + + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + pass( "First request is made" ); + + $request_stream =~ s/^.*$CRLF$CRLF//s; + + $peersock->syswrite( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . + $CRLF ); + + my $e = eval { $loop->loop_once(0) for 1 .. 5; 1 } ? undef : $@; + like( $e, qr/^Oopsie at \Q$0\E line \d+/, + 'Oopsie exception caught at loop toplevel' ); + + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + pass( "Second request is made after first one dies at ->done" ); + + $request_stream =~ s/^.*$CRLF$CRLF//s; + + $peersock->syswrite( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . + $CRLF ); + + wait_for { $f2->is_ready }; + ok( !$f2->failure, '$f2 completes successfully' ); +} + +# With on_error +{ + my $error; + $http->configure( + on_error => sub { ( undef, $error ) = @_; }, + ); + + my $f1 = $http->GET( "http://localhost:5000/1" ) + ->on_done( sub { die "Oopsie" } ); + + my $f2 = $http->GET( "http://localhost:5000/2" ); + + wait_for { defined $peersock }; + + my $request_stream = ""; + + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + pass( "First request is made" ); + + $request_stream =~ s/^.*$CRLF$CRLF//s; + + $peersock->syswrite( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . + $CRLF ); + + my $e = eval { $loop->loop_once(0) for 1 .. 5; 1 } ? undef : $@; + ok( !defined $e, 'Loop toplevel does not catch exception' ) or + diag( "Caught exception was: $e" ); + + like( $error, qr/^Oopsie at \Q$0\E line \d+/, + 'Oopsie exception caught by on_error handler' ); + + wait_for_stream { $request_stream =~ m/$CRLF$CRLF/ } $peersock => $request_stream; + pass( "Second request is made after first one dies at ->done" ); + + $request_stream =~ s/^.*$CRLF$CRLF//s; + + $peersock->syswrite( "HTTP/1.1 200 OK$CRLF" . + "Content-Length: 0$CRLF" . + $CRLF ); + + wait_for { $f2->is_ready }; + ok( !$f2->failure, '$f2 completes successfully' ); +} + +done_testing; diff --git a/t/91rt102547.t b/t/91rt102547.t new file mode 100644 index 0000000..fa2e9d5 --- /dev/null +++ b/t/91rt102547.t @@ -0,0 +1,58 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; +use IO::Async::Test; +use IO::Async::Loop; + +use Net::Async::HTTP; + +# When connections failed, they weren't being removed from memory +# so we'd slowly leak + +my $loop = IO::Async::Loop->new; +testing_loop( $loop ); + +my $http = Net::Async::HTTP->new( + max_connections_per_host => 2, +); + +$loop->add( $http ); + +my @conn_f; +my @remove_f; + +no warnings 'redefine'; +local *IO::Async::Loop::connect = sub { + shift; + my %args = @_; + $args{host} eq "localhost" or die "Cannot fake connect - expected host 'localhost'"; + $args{service} eq "5000" or die "Cannot fake connect - expected service '5000'"; + + push @conn_f, my $f = $loop->new_future; + return $f; +}; + +my $old = \&IO::Async::Notifier::remove_from_parent; + +# Make sure these actually get removed! +local *IO::Async::Notifier::remove_from_parent = sub { + my $self = shift; + push @remove_f, $self; + return $old->($self, @_); +}; + +my @f = map { $http->do_request(uri=>'http://localhost:5000/') } 0 .. 2; + +is( scalar @conn_f, 2, 'Two pending connect() attempts after two concurrent ->do_request' ); + +# Fail them all +( shift @conn_f )->fail( "Connection refused", connect => ) for 0 .. 2; + +ok( !@conn_f, 'No more pending connect() attempts' ); + +is( scalar @remove_f, 3, 'Three connect() attempts removed after connection failure' ); + +done_testing; diff --git a/t/99pod.t b/t/99pod.t new file mode 100644 index 0000000..eb319fb --- /dev/null +++ b/t/99pod.t @@ -0,0 +1,11 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More; + +eval "use Test::Pod 1.00"; +plan skip_all => "Test::Pod 1.00 required for testing POD" if $@; + +all_pod_files_ok(); diff --git a/t/privkey.pem b/t/privkey.pem new file mode 100644 index 0000000..0e466a6 --- /dev/null +++ b/t/privkey.pem @@ -0,0 +1,27 @@ +-----BEGIN RSA PRIVATE KEY----- +MIIEowIBAAKCAQEAk9NZtcKAu9FqMKWOdtn5QHtqgMbVhiGmUfpR6ropmqFciu+V +jZD+30WSBOzCEuO7bYSz5s5X33qi+lna3DzEfgJ4DvZtkO1D0Wg4zQn6oYA2ZhlC +b0dnmW2eWEiTmDT375DLq5U3TMH9TWEtxgn5EXdV8gW2wyDxnx4ax5FTNx6X6Ek/ +7pr2G46+ezfON2jymYPCM23U7yROu/WlZ6vz3hnafSc9zCjHsdLRQVvjoBOCXuKx +PCN0KppCMCq0cA43fe5Y5bQnLydhghsEpuWTJpd37ioWlV6lbqJpqinruOxwh4YY +N8czxHZ1L+4A0Aoq3HLQpUleeLh1TdLv7OqSZQIDAQABAoIBABs/adnG8FOuVhSB +b7EYnIj2Nrtl6xW+Phn+Ofs6NVD7TUOOxdJCV7hv6mpd+afhsjqNq1tvzWK0CDZ9 +OYo+6TkQ23Bmm+uK0GVZAJ9Kp5f9Ogm3vjckwkPVoMpFFm+H0+uklOYbqwXK/BW3 +Q+itDevaQ01JIFb3S5I4ylbewqf2A/KTfosVUgkrv4U1wcr8DYat8baplfy0sp0j +Q9w8P4HH4UOZL9OAjKABXLw7xDc5kvYxG1aLPf55QryEHmyr3SpRxwnK0c7/LwHZ +1lqhKnyUiDzD/yyxNMzTWQeaohV6MMb2MysAx7AiL09WLzc4gIzUIQYfeiCdHSoQ +vbN7IAECgYEAw9tcSDgyi+ucRY9DOtRDGeNONhgds6Hzkeed0eNap7qDfTeRcfsF +2sCgxStyAMmwx+cMrRwA3yINkcdc68RpKDCxADD7Mk6wxys4PkNAJYiV5giupMAp +U1L276op+14yL36/DKAt95M6Xhp44l+Mvpfc001nrTW2SbeuoDD9wuUCgYEAwTgr +VVOn4el3izYZua/S7rGO4nj/KaUfdZXUPqyqOYgirQy9DlhrJTdtHW3kc47jXDX4 +OuSoa3Xqli2o7qFBKfUaZKrZmcwZD6L9Y0kKBj9s9DM1roMlA3wiBylJ/ZNughyi +jMDhvVwWdwJaXOJBPgqBWggwWh48MuTZ49HHGYECgYB5vgPZvFznDnhf4JJYohJn +qBw4kbr8qsF9Qyydh6YVNmF/VygoYnGcLTqB9ORzSuuBBsShYhPEnyUyJWtD/h2j +ZsjPJqMt/S3zT5ExWpon+oO6rlDoha3qZlqqVOqtnjqxvSZCUdrg1npkfi4AAIa6 +/ii8i5PTXdzGa8+3MVy7ZQKBgG5S0AtMVNNdJvDJ1y57AglgQKF3TNpOegP9pM6U +cC2hWYtNdrU2Lxd06kyfbo28zHzeI/ocjT2uel99erOmRzrZxFQuaUizjKus+Nkz +3xFqLZ/RjZkzMHMo8ZT9Mk4jXDnWd8m+aCZi6kDRix714SK3hNwPSOxrzxuQKAk4 +wmIBAoGBAK9F/ejKimwBpzQ0kv90i8j5NyGTJNnI/tjls/KaQrnI0b/VqqRnI/xk +Dm1lJabaUAG5P51b2KwitnKo7/+dhcG2hOtxJdUKGPVLzeRhfEx1KXx8bTMg9nvu +n5sP1sN9Sw+jjpHm3r+YD/+QNK1eiVcAO0D6FcxSRKQ5ztHZt1tw +-----END RSA PRIVATE KEY----- diff --git a/t/regen-certs.sh b/t/regen-certs.sh new file mode 100755 index 0000000..9790ddf --- /dev/null +++ b/t/regen-certs.sh @@ -0,0 +1,3 @@ +#!/bin/sh +openssl genrsa -out privkey.pem +openssl req -new -x509 -key privkey.pem -out server.pem diff --git a/t/server.pem b/t/server.pem new file mode 100644 index 0000000..e472001 --- /dev/null +++ b/t/server.pem @@ -0,0 +1,21 @@ +-----BEGIN CERTIFICATE----- +MIIDazCCAlOgAwIBAgIUHVSMA9ScUWYlkkHEQWBDJr+wNTswDQYJKoZIhvcNAQEL +BQAwRTELMAkGA1UEBhMCQVUxEzARBgNVBAgMClNvbWUtU3RhdGUxITAfBgNVBAoM +GEludGVybmV0IFdpZGdpdHMgUHR5IEx0ZDAeFw0xOTAyMTcxNDA0MzZaFw0xOTAz +MTkxNDA0MzZaMEUxCzAJBgNVBAYTAkFVMRMwEQYDVQQIDApTb21lLVN0YXRlMSEw +HwYDVQQKDBhJbnRlcm5ldCBXaWRnaXRzIFB0eSBMdGQwggEiMA0GCSqGSIb3DQEB +AQUAA4IBDwAwggEKAoIBAQCT01m1woC70WowpY522flAe2qAxtWGIaZR+lHquima +oVyK75WNkP7fRZIE7MIS47tthLPmzlffeqL6WdrcPMR+AngO9m2Q7UPRaDjNCfqh +gDZmGUJvR2eZbZ5YSJOYNPfvkMurlTdMwf1NYS3GCfkRd1XyBbbDIPGfHhrHkVM3 +HpfoST/umvYbjr57N843aPKZg8IzbdTvJE679aVnq/PeGdp9Jz3MKMex0tFBW+Og +E4Je4rE8I3QqmkIwKrRwDjd97ljltCcvJ2GCGwSm5ZMml3fuKhaVXqVuommqKeu4 +7HCHhhg3xzPEdnUv7gDQCircctClSV54uHVN0u/s6pJlAgMBAAGjUzBRMB0GA1Ud +DgQWBBRcIn5rxKiGpScWWrKkmbJ64+09AjAfBgNVHSMEGDAWgBRcIn5rxKiGpScW +WrKkmbJ64+09AjAPBgNVHRMBAf8EBTADAQH/MA0GCSqGSIb3DQEBCwUAA4IBAQBo +PLlcaXaVvZ0K3fN+t3Ijs6QAWEZr0yH6WTT4g4+KTTSulIWAsNLaaTgbmb1qfJkz +gGXXuhjNFY2BbD9YuBZP02SeNgc0vL/UnRCGTSy7akK6jV+v0fblwaye01Fg5Plp +Yh114haTA9rwQ4geXKMl70KIoB71zR6MYcNPjDYHt0WiNJqGOgvYdO6d276AccDn +CP66xnx9//7ynYcHcCkhf7+5YzUv7eiNo995W9A6xUWHLq52jj0DqCpwofIoJXHx +CQ15c38qYcrmzG8X7oXL+vTLIvpj2tsRjPrf0q0Q+epHonxkxo6b+h/7g4mHyIig +yEe8MNBTU/gOTGGL8XnK +-----END CERTIFICATE----- |