S3 (empty) → 0.1.0.0

raw patch · 8 files changed

+2552/−0 lines, 8 filesdep +Preludedep +Xdep +basesetup-changed

Dependencies added: Prelude, X, base, base-encoding, base-noprelude, bytestring, cryptohash-md5, cryptohash-sha1, cryptohash-sha256, deepseq, hashable, http-io-streams, io-streams, text, text-short, time

Files

• LICENSE +675/−0
• S3.cabal +65/−0
• Setup.hs +2/−0
• src/Internal.hs +178/−0
• src/Network/S3.hs +979/−0
• src/Network/S3/Signature.hs +230/−0
• src/Network/S3/Types.hs +213/−0
• src/Network/S3/XML.hs +210/−0

@@ -0,0 +1,675 @@+              GNU GENERAL PUBLIC LICENSE+                Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                     Preamble++  The GNU General Public License is a free, copyleft license for+software and other kinds of works.++  The licenses for most software and other practical works are designed+to take away your freedom to share and change the works.  By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.  We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors.  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), 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 prevent others from denying you+these rights or asking you to surrender the rights.  Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received.  You must make sure that they, too, receive+or can get the source code.  And you must show them these terms so they+know their rights.++  Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++  For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software.  For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++  Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so.  This is fundamentally incompatible with the aim of+protecting users' freedom to change the software.  The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable.  Therefore, we+have designed this version of the GPL to prohibit the practice for those+products.  If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++  Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary.  To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++  The precise terms and conditions for copying, distribution and+modification follow.++                TERMS AND CONDITIONS++  0. Definitions.++  "This License" refers to version 3 of the GNU General Public License.++  "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++  "The Program" refers to any copyrightable work licensed under this+License.  Each licensee is addressed as "you".  "Licensees" and+"recipients" may be individuals or organizations.++  To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy.  The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++  A "covered work" means either the unmodified Program or a work based+on the Program.++  To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy.  Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++  To "convey" a work means any kind of propagation that enables other+parties to make or receive copies.  Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++  An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License.  If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++  1. Source Code.++  The "source code" for a work means the preferred form of the work+for making modifications to it.  "Object code" means any non-source+form of a work.++  A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++  The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form.  A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++  The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities.  However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work.  For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++  The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++  The Corresponding Source for a work in source code form is that+same work.++  2. Basic Permissions.++  All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met.  This License explicitly affirms your unlimited+permission to run the unmodified Program.  The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work.  This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++  You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force.  You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright.  Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++  Conveying under any other circumstances is permitted solely under+the conditions stated below.  Sublicensing is not allowed; section 10+makes it unnecessary.++  3. Protecting Users' Legal Rights From Anti-Circumvention Law.++  No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++  When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++  4. Conveying Verbatim Copies.++  You may convey 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;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++  You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++  5. Conveying Modified Source Versions.++  You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++    a) The work must carry prominent notices stating that you modified+    it, and giving a relevant date.++    b) The work must carry prominent notices stating that it is+    released under this License and any conditions added under section+    7.  This requirement modifies the requirement in section 4 to+    "keep intact all notices".++    c) You must license the entire work, as a whole, under this+    License to anyone who comes into possession of a copy.  This+    License will therefore apply, along with any applicable section 7+    additional terms, to the whole of the work, and all its parts,+    regardless of how they are packaged.  This License gives no+    permission to license the work in any other way, but it does not+    invalidate such permission if you have separately received it.++    d) If the work has interactive user interfaces, each must display+    Appropriate Legal Notices; however, if the Program has interactive+    interfaces that do not display Appropriate Legal Notices, your+    work need not make them do so.++  A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit.  Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++  6. Conveying Non-Source Forms.++  You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++    a) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by the+    Corresponding Source fixed on a durable physical medium+    customarily used for software interchange.++    b) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by a+    written offer, valid for at least three years and valid for as+    long as you offer spare parts or customer support for that product+    model, to give anyone who possesses the object code either (1) a+    copy of the Corresponding Source for all the software in the+    product that is covered by this License, on a durable physical+    medium customarily used for software interchange, for a price no+    more than your reasonable cost of physically performing this+    conveying of source, or (2) access to copy the+    Corresponding Source from a network server at no charge.++    c) Convey individual copies of the object code with a copy of the+    written offer to provide the Corresponding Source.  This+    alternative is allowed only occasionally and noncommercially, and+    only if you received the object code with such an offer, in accord+    with subsection 6b.++    d) Convey the object code by offering access from a designated+    place (gratis or for a charge), and offer equivalent access to the+    Corresponding Source in the same way through the same place at no+    further charge.  You need not require recipients to copy the+    Corresponding Source along with the object code.  If the place to+    copy the object code is a network server, the Corresponding Source+    may be on a different server (operated by you or a third party)+    that supports equivalent copying facilities, provided you maintain+    clear directions next to the object code saying where to find the+    Corresponding Source.  Regardless of what server hosts the+    Corresponding Source, you remain obligated to ensure that it is+    available for as long as needed to satisfy these requirements.++    e) Convey the object code using peer-to-peer transmission, provided+    you inform other peers where the object code and Corresponding+    Source of the work are being offered to the general public at no+    charge under subsection 6d.++  A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++  A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling.  In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage.  For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product.  A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++  "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source.  The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++  If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information.  But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++  The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed.  Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++  Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++  7. Additional Terms.++  "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law.  If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++  When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it.  (Additional permissions may be written to require their own+removal in certain cases when you modify the work.)  You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++  Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++    a) Disclaiming warranty or limiting liability differently from the+    terms of sections 15 and 16 of this License; or++    b) Requiring preservation of specified reasonable legal notices or+    author attributions in that material or in the Appropriate Legal+    Notices displayed by works containing it; or++    c) Prohibiting misrepresentation of the origin of that material, or+    requiring that modified versions of such material be marked in+    reasonable ways as different from the original version; or++    d) Limiting the use for publicity purposes of names of licensors or+    authors of the material; or++    e) Declining to grant rights under trademark law for use of some+    trade names, trademarks, or service marks; or++    f) Requiring indemnification of licensors and authors of that+    material by anyone who conveys the material (or modified versions of+    it) with contractual assumptions of liability to the recipient, for+    any liability that these contractual assumptions directly impose on+    those licensors and authors.++  All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10.  If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term.  If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++  If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++  Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++  8. Termination.++  You may not propagate or modify a covered work except as expressly+provided under this License.  Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++  However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++  Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++  Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License.  If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++  9. Acceptance Not Required for Having Copies.++  You are not required to accept this License in order to receive or+run a copy of the Program.  Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance.  However,+nothing other than this License grants you permission to propagate or+modify any covered work.  These actions infringe copyright if you do+not accept this License.  Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++  10. Automatic Licensing of Downstream Recipients.++  Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License.  You are not responsible+for enforcing compliance by third parties with this License.++  An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations.  If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++  You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License.  For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++  11. Patents.++  A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based.  The+work thus licensed is called the contributor's "contributor version".++  A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version.  For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++  Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++  In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement).  To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++  If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients.  "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++  If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++  A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License.  You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++  Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++  12. No Surrender of Others' Freedom.++  If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all.  For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++  13. Use with the GNU Affero General Public License.++  Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work.  The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++  14. Revised Versions of this License.++  The Free Software Foundation may publish revised and/or new versions of+the GNU 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 that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation.  If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++  If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++  Later license versions may give you additional or different+permissions.  However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++  15. Disclaimer of Warranty.++  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.++  16. Limitation of Liability.++  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+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.++  17. Interpretation of Sections 15 and 16.++  If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++              END OF TERMS AND CONDITIONS++     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 the public, 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+state 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) <year>  <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 3 of the License, 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, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++  If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++    <program>  Copyright (C) <year>  <name of author>+    This program 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, your program's commands+might be different; for a GUI interface, you would use an "about box".++  You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++  The GNU General Public License does not permit incorporating your program+into proprietary programs.  If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library.  If this is what you want to do, use the GNU Lesser General+Public License instead of this License.  But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.+             

@@ -0,0 +1,65 @@+cabal-version:       2.2+name:                S3+version:             0.1.0.0++license:             GPL-3.0-or-later+license-file:        LICENSE+author:              Herbert Valerio Riedel+maintainer:          hvr@gnu.org+bug-reports:         https://github.com/hvr/S3/issues+category:            Network+build-type:          Simple+synopsis:            Library for accessing S3 compatible storage services+description:+  This library provides a lightweight API for interacting with storage services compatible with Amazon's <https://en.wikipedia.org/wiki/Amazon_S3 Simple Storage Service> or S3 protocol.+  .+  The current version of this library provides support for+  .+   * Creating, listing, and deleting buckets+   * Creating, copying, listing, and deleting objects+   * Conditionally (i.e. via @if-match@/@if-none-match@) creating, listing, and deleting objects+   * Setting canned ACLs on bucket and object creation+   * AWS Signature protocols version 2 and version 4+  .+  See the "Network.S3" module for documentation and usage examples.++source-repository head+  type: git+  location: https://github.com/hvr/S3.git++library+  default-language:  Haskell2010+  exposed-modules:   Network.S3+  other-modules:     Internal+                     Network.S3.Types+                     Network.S3.Signature+                     Network.S3.XML+  build-depends:+    , Prelude              ^>= 0.1.0.1+    , X                    ^>= 0.3.0+    , base-encoding        ^>= 0.1.0+    , bytestring           ^>= 0.10+    , cryptohash-md5       ^>= 0.11.100+    , cryptohash-sha1      ^>= 0.11.100+    , cryptohash-sha256    ^>= 0.11.100+    , deepseq              ^>= 1.3+                        || ^>= 1.4+    , http-io-streams      ^>= 0.1.0.0+    , hashable             ^>= 1.2.7+                        || ^>= 1.3.0+    , io-streams           ^>= 1.5+    , text                 ^>= 1.2.3+    , text-short           ^>= 0.1.2+    , time                 ^>= 1.5+                        || ^>= 1.6+                        || ^>= 1.8.0.2++  if impl(ghc >= 7.10)+     build-depends: base (>= 4.8.0.0 && < 4.12) || ^>= 4.12.0.0+     mixins: base hiding (Prelude)+  else+     build-depends: base-noprelude ^>= 4.7.0.0++  hs-source-dirs:    src++  ghc-options:       -Wall -fno-warn-deprecations

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,178 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings          #-}++{-++Copyright (c) 2016-2019  Herbert Valerio Riedel <hvr@gnu.org>++ This file is free software: you may copy, redistribute and/or modify it+ under the terms of the GNU General Public License as published by the+ Free Software Foundation, either version 3 of the License, or (at your+ option) any later version.++ This file 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 (see `LICENSE`).  If not, see+ <https://www.gnu.org/licenses/gpl-3.0.html>.++-}++-- |+-- Copyright: © Herbert Valerio Riedel 2016-2018+-- SPDX-License-Identifier: GPL-3.0-or-later+--+module Internal+    ( module Internal+    , ByteString+    , ShortByteString+    , ShortText+    , T.Text+    , Proxy(..)+    , NFData(rnf), force+    , UTCTime+    , Hashable+    , ap+    ) where++import qualified Codec.Base16                  as B16+import qualified Codec.Base64                  as B64+import           Control.DeepSeq+import           Control.Monad                 (ap)+import qualified Crypto.Hash.MD5               as MD5+import qualified Crypto.Hash.SHA256            as SHA256+import           Data.ByteString               (ByteString)+import qualified Data.ByteString               as BS+import qualified Data.ByteString.Char8         as BC8+import qualified Data.ByteString.Lazy          as BL+import qualified Data.ByteString.Lazy.Internal+import           Data.ByteString.Short         (ShortByteString, fromShort,+                                                toShort)+import qualified Data.ByteString.Short         as SBS+import           Data.Hashable+import           Data.Proxy+import           Data.Text                     (Text)+import qualified Data.Text                     as T+import qualified Data.Text.Encoding            as T+import           Data.Text.Short               (ShortText)+import           Data.Time                     (UTCTime)++newtype SHA256Val = SHA256Val ShortByteString+                  deriving (Eq,Ord,Hashable,NFData,Typeable)++instance Show SHA256Val where+    show = show . sha256hex++sha256hash :: BL.ByteString -> SHA256Val+sha256hash = SHA256Val . toShort . SHA256.hashlazy++sha256hex :: SHA256Val -> ByteString+sha256hex (SHA256Val x) = B16.encode (fromShort x)++-- | MD5 Hash+newtype MD5Val = MD5Val ShortByteString+               deriving (Eq,Ord,Hashable,NFData,Typeable)++instance Show MD5Val where+    show = show . md5hex++instance IsString MD5Val where+    fromString = fromMaybe (error "invalid MD5Val string-literal") . md5unhex . fromString++-- | Compute MD5 hash+md5hash :: BL.ByteString -> MD5Val+md5hash = MD5Val . toShort . MD5.hashlazy++-- | Hex-encode MD5 digest value+md5hex :: MD5Val -> ByteString+md5hex (MD5Val x) = B16.encode x++-- i.e. RFC1864+md5b64 :: MD5Val -> ByteString+md5b64 (MD5Val x) = B64.encode x++-- | Hex-decode MD5 digest value+md5unhex :: ByteString -> Maybe MD5Val+md5unhex x = case B16.decode x of+    Right d -> md5FromSBS d+    _       -> Nothing++-- | Extract MD5 digest value+md5ToSBS :: MD5Val -> ShortByteString+md5ToSBS (MD5Val x) = x++-- | Construct MD5 digest value from 16 octets+md5FromSBS :: ShortByteString -> Maybe MD5Val+md5FromSBS d | SBS.length d == 16 = Just (MD5Val d)+             | otherwise          = Nothing++-- Special reserved 'SHA256Val'+md5zero :: MD5Val+md5zero = MD5Val $ toShort $ BS.replicate 16 0++strictPair :: a -> b -> (a,b)+strictPair !a !b = (a,b)++-- | AWS S3 specific URL encoding+urlEncode :: Bool -> ByteString -> ByteString+urlEncode escapeSlash = BC8.concatMap go+  where+    go c | inRng '0' '9' c ||+           inRng 'a' 'z' c ||+           inRng 'A' 'Z' c ||+           c `elem` ['-','_','.','~'] = BC8.singleton c++         | c == '/' = if escapeSlash then "%2F" else BC8.singleton c++         | otherwise = let (h,l) = quotRem (fromIntegral $ fromEnum c) 0x10+                       in BS.pack [0x25, hex h, hex l]++    inRng x y c = c >= x && c <= y++    hex j | j < 10    = 0x30 + j+          | otherwise = 0x37 + j -- uppercase letters++urlDecodeTextUtf8 :: Text -> Maybe Text+urlDecodeTextUtf8 t0+  | (_,[]) <- chunks = Just t' -- shortcut+  | all ((==2) . T.length . fst) (snd chunks) = T.concat <$> mchunks3+  | otherwise = Nothing+  where+    mchunks3 = h chunks2+      where+        h (c1,cs) = (:) c1 . mconcat <$> mapM go cs++    go :: (Text,Text) -> Maybe [Text]+    go (x,y) = do x'  <- e2m (B16.decode x)+                  x'' <- e2m (T.decodeUtf8' x')+                  pure [x'', y]++    chunks2 = compact [] <$> chunks++    compact acc [] = [(T.concat (reverse acc),"") | not (null acc) ]+    compact acc ((octet,""):rest) = compact (octet:acc) rest+    compact acc ((octet,chunk):rest)+      | null acc = (octet,chunk) : compact [] rest+      | otherwise = (T.concat (reverse (octet:acc)),chunk) : compact [] rest++    chunks = case T.splitOn "%" t' of+               []     -> undefined -- impossible+               [_]    -> (t0,[])+               (x:xs) -> (x,fmap (T.splitAt 2) xs)++    -- MinIO appears to use application/x-www-form-urlencoded rules+    t' | T.any (=='+') t0 = T.map (\c -> if c == '+' then ' ' else c) t0+       | otherwise        = t0++e2m :: Either a1 a2 -> Maybe a2+e2m = either (\_->Nothing) Just++mkChunk :: ByteString -> BL.ByteString -> BL.ByteString+mkChunk bs bl+  | BS.null bs = bl+  | otherwise = Data.ByteString.Lazy.Internal.Chunk bs bl

@@ -0,0 +1,979 @@+{-# LANGUAGE DeriveDataTypeable  #-}+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-++Copyright (c) 2016-2019  Herbert Valerio Riedel <hvr@gnu.org>++ This file is free software: you may copy, redistribute and/or modify it+ under the terms of the GNU General Public License as published by the+ Free Software Foundation, either version 3 of the License, or (at your+ option) any later version.++ This file 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 (see `LICENSE`).  If not, see+ <https://www.gnu.org/licenses/gpl-3.0.html>.++-}++-- |+-- Copyright: © Herbert Valerio Riedel 2016-2019+-- SPDX-License-Identifier: GPL-3.0-or-later+--+-- Simple lightweight S3 API implementation+--+-- This implementation has been tested succesfully against MinIO's, Dreamhost's, and AWS' S3 server implementations+--+-- == API Usage Example+--+-- The example below shows how to create, populate, list, and finally destroy a bucket again.+--+-- @+--  -- demo credentials for http://play.min.io/+--  let s3cfg = 'defaultS3Cfg' { 's3cfgBaseUrl' = \"https://play.min.io:9000\" }+--      creds = 'Credentials' \"Q3AM3UQ867SPQQA43P2F\" \"zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG\"+--+--  -- we'll create this bucket and delete it again+--  let testBucket = 'BucketId' "haskell-test-bucket-42"+--+--  'withConnection' s3cfg $ \conn -> do+--    'createBucket' conn creds testBucket Nothing+--+--    etag1 <- 'putObject' conn creds testBucket ('ObjKey' \"folder\/file1\") \"content1\" (CType \"text\/plain\") Nothing+--    etag2 <- 'putObject' conn creds testBucket ('ObjKey' \"file2\") \"content2\" (CType \"text\/plain\") Nothing+--+--    -- will list the key \"file2\" and the common-prefix \"folder\/\"+--    print =<< 'listObjects' conn creds testBucket 'nullObjKey' (Just \'\/\')+--    -- will list only the key \"folder\/file1\"+--    print =<< 'listObjects' conn creds testBucket ('ObjKey' \"folder\/\") (Just \'\/\')+--    -- will list the two keys \"folder\/file1\" and \"file2\" (and no common prefix)+--    print =<< 'listObjects' conn creds testBucket 'nullObjKey' Nothing+--+--    -- ...and now we remove the two objects we created above+--    'deleteObject' conn creds testBucket ('ObjKey' \"folder\/file1\")+--    'deleteObject' conn creds testBucket ('ObjKey' \"file2\")+--+--    'deleteBucket' conn creds testBucket+-- @+--+module Network.S3+    ( -- * Operations on Buckets+      BucketId(..)+    , BucketInfo(..)+    , Acl(..)++    , listBuckets+    , createBucket+    , deleteBucket++    , listObjects+    , listObjectsFold+    , listObjectsChunk++      -- * Operations on Objects++      -- ** Object keys+    , ObjKey(..), isNullObjKey, nullObjKey++      -- ** Object metadata+    , ObjMetaInfo(..)+    , CType(..), noCType+    , ETag(..)++      -- *** MD5 hashes+    , MD5Val+    , md5hash+    , md5hex+    , md5unhex+    , md5ToSBS+    , md5FromSBS++      -- ** Operations+    , putObject+    , copyObject+    , getObject+    , deleteObject++      -- ** Conditional operations+    , Condition(..)+    , putObjectCond+    , getObjectCond+    , deleteObjectCond++      -- * Errors+    , ErrorCode(..)+    , ProtocolError(..)++      -- * Authentication+    , Credentials(..), noCredentials++      -- * Connection handling+    , S3Cfg(..), defaultS3Cfg+    , SignatureVersion(..)++    , Connection+    , withConnection+    , connect+    , close+    ) where++import           Internal+import           Network.S3.Signature+import           Network.S3.Types+import           Network.S3.XML++import           Control.Concurrent+import           Control.Exception+import qualified Data.ByteString         as BS+import qualified Data.ByteString.Builder as Builder+import qualified Data.ByteString.Char8   as BC8+import qualified Data.ByteString.Lazy    as BL+import qualified Data.ByteString.Short   as BSS+import           Data.Char+import qualified Data.Text               as T+import qualified Data.Text.IO            as T+import qualified Data.Text.Lazy.Encoding as TL+import qualified Data.Text.Short         as TS+import           Data.Time.Clock         (getCurrentTime)+import qualified Network.Http.Client     as HC+import qualified System.IO.Streams       as Streams+import qualified Text.XML                as X++-- | Protocol-level errors and exceptions+data ProtocolError+     = ProtocolInconsistency String+     | HttpFailure !SomeException+     | UnexpectedResponse {- code -} !Int+                       {- message -} !ShortByteString+                  {- content-type -} !ShortByteString+                          {- body -} BL.ByteString+     deriving (Show, Typeable, Generic)++instance Exception ProtocolError++-- | S3-level errors+data ErrorCode+     = AccessDenied+     | BucketAlreadyExists -- not owned by you+     | BucketAlreadyOwnedByYou+     | BucketNotEmpty+     | MalformedXML+     | NoSuchBucket+     | NoSuchKey+     | InvalidArgument+     | InvalidDigest+     | SignatureDoesNotMatch+     | UnknownError !ShortText+     deriving (Show, Typeable, Generic)++instance Exception ErrorCode+instance NFData ErrorCode++errorToErrorCode :: Error -> ErrorCode+errorToErrorCode (Error x) = case x of+    "AccessDenied"            -> AccessDenied+    "BucketAlreadyExists"     -> BucketAlreadyExists+    "BucketAlreadyOwnedByYou" -> BucketAlreadyOwnedByYou+    "BucketNotEmpty"          -> BucketNotEmpty+    "MalformedXML"            -> MalformedXML+    "NoSuchBucket"            -> NoSuchBucket+    "NoSuchKey"               -> NoSuchKey+    "InvalidArgument"         -> InvalidArgument+    "InvalidDigest"           -> InvalidDigest+    "SignatureDoesNotMatch"   -> SignatureDoesNotMatch+    _                         -> UnknownError x++urlEncodeObjKey, urlEncodeObjKeyQry :: ObjKey -> ByteString+urlEncodeObjKey = urlEncode False . TS.toByteString . unObjKey+urlEncodeObjKeyQry = urlEncode True . TS.toByteString . unObjKey++s3'ObjKey :: X.LName -> Bool -> X.Element -> Either String ObjKey+s3'ObjKey ln False el = ObjKey <$> xsd'string (s3qname ln) el+s3'ObjKey ln True el = do+  s <- xsd'string (s3qname ln) el+  case TS.fromText <$> urlDecodeTextUtf8 s of+    Just s' -> pure (ObjKey s')+    Nothing -> Left ("<" <> showQN (X.elName el) <> "> failed to url-decode ObjKey")++objUrlPath :: BucketId -> ObjKey -> UrlPath+objUrlPath (BucketId bucketId) objkey = "/" <> BSS.fromShort bucketId <> "/" <> urlEncodeObjKey objkey++bucketUrlPath :: BucketId -> UrlPath+bucketUrlPath (BucketId bucketId) = "/" <> BSS.fromShort bucketId++withAWSHeaders :: Connection -> (AWSHeaders -> IO b) -> IO b+withAWSHeaders conn cont = do+  now <- getCurrentTime++  cont AWSHeaders+         { ahdrMethod        = HC.GET+         , ahdrUrlPath       = "/"+         , ahdrUrlQuery      = mempty+         , ahdrTimestamp     = now+         , ahdrContentType   = noCType+         , ahdrContentHashes = Nothing+         , ahdrExtraHeaders  = []+         , ahdrSigType       = s3cfgSigVersion $ s3connCfg conn+         , ahdrHost          = s3connHost conn+         , ahdrRegion        = s3cfgRegion $ s3connCfg conn+         }++-- | List buckets owned by user+listBuckets :: Connection+            -> Credentials+            -> IO [BucketInfo]+listBuckets conn creds = withAWSHeaders conn $ \awsh -> do+    let q = HC.buildRequest1 $+              setAWSRequest creds awsh+                { ahdrMethod        = HC.GET+                , ahdrUrlPath       = "/"+                }++    (resp,mtmp) <- doHttpReqXml conn q HC.emptyBody++    case HC.getStatusCode resp of+      200 -> pure ()+      _   -> throwUnexpectedXmlResp resp mtmp++    case maybe (Left "empty body") parseXML mtmp of+      Right (ListAllMyBucketsResult bs) -> pure bs+      Left err -> throwProtoFail $ "ListAllMyBucketsResult: " <> err++-- | Create bucket+createBucket :: Connection+             -> Credentials+             -> BucketId+             -> Maybe Acl+             -> IO ()+createBucket conn creds bid macl = withAWSHeaders conn $ \awsh -> do+    let q = HC.buildRequest1 $+              setAWSRequest creds awsh+                { ahdrMethod        = HC.PUT+                , ahdrUrlPath       = bucketUrlPath bid+                , ahdrExtraHeaders  = hdrs+                }++    (resp, mtmp) <- doHttpReqXml conn q HC.emptyBody++    case HC.getStatusCode resp of+      200 -> pure ()+      _   -> throwUnexpectedXmlResp resp mtmp+  where+    hdrs = case macl of+             Nothing  -> []+             Just acl -> [("x-amz-acl", acl2str acl)]++-- | Delete bucket+--+-- __NOTE__: Most S3 implementations require the bucket to be empty before it can be deleted. See documentation of 'listObjectsFold' for a code example deleting a non-empty bucket.+deleteBucket :: Connection+               -> Credentials+               -> BucketId+               -> IO ()+deleteBucket conn creds bid = withAWSHeaders conn $ \awsh -> do+    let q = HC.buildRequest1 $+              setAWSRequest creds awsh+                { ahdrMethod        = HC.DELETE+                , ahdrUrlPath       = bucketUrlPath bid+                }++    (resp, mtmp) <- doHttpReqXml conn q HC.emptyBody++    case HC.getStatusCode resp of+      204 -> pure ()+      _   -> throwUnexpectedXmlResp resp mtmp++    pure ()++----------------------------------------------------------------------------++-- | Represents a single-threaded HTTP channel to the S3 service+data Connection = S3Conn (MVar HC.Connection) !ByteString !S3Cfg++s3connCfg :: Connection -> S3Cfg+s3connCfg (S3Conn _ _ cfg) = cfg++s3connHost :: Connection -> ByteString+s3connHost (S3Conn _ h _) = h++-- | Simple single-connection 'bracket' style combinator over 'connect' and 'close'+--+-- If you need resource pool management you can use 'connect' in combination with packages such as [resource-pool](http://hackage.haskell.org/package/resource-pool).+withConnection :: S3Cfg -> (Connection -> IO a) -> IO a+withConnection cfg@S3Cfg{..} = bracket (connect cfg) close++-- | Create HTTP(s) connection based on 'S3Cfg'+connect :: S3Cfg -> IO Connection+connect cfg@S3Cfg{..} = do+  c  <- HC.establishConnection s3cfgBaseUrl+  c' <- newMVar c+  pure (S3Conn c' (cHost c) cfg)++-- | Close connection constructed via 'connect'+close :: Connection -> IO ()+close (S3Conn cref _ _) = withMVar cref HC.closeConnection++cHost :: HC.Connection -> ByteString+cHost c = HC.getHostname c (HC.buildRequest1 (pure ()))+++-- low-level helper+doHttpReq :: Bool -> Connection -> HC.Request+          -> (Streams.OutputStream Builder.Builder -> IO ())+          -> IO (HC.Response, BL.ByteString)+doHttpReq isProtocol (S3Conn cref _ S3Cfg{..}) q body = withMVar cref $ \c -> do+    when s3cfgDebug $ do+      BS.putStrLn sep1+      T.putStr (T.pack $ show q)+      BS.putStrLn sep2++    (resp,bs) <- handle exh $ do+      () <- HC.sendRequest c q body+      HC.receiveResponse c concatHandler++    when s3cfgDebug $ do+      T.putStr (T.pack $ show resp)+      unless (BL.null bs) $ do+        BS.putStrLn sep2+        if isProtocol || HC.getStatusCode resp /= 200+          then BL.putStrLn bs+          else T.putStrLn (T.pack $ "[non-protocol body with size=" <> show (BL.length bs) <> "]")+      BS.putStrLn sep3++    pure (resp, bs)+  where+    sep1 = "/==========================================================================\\"+    sep2 = "----------------------------------------------------------------------------"+    sep3 = "\\==========================================================================/"++    exh ex = throwIO (HttpFailure ex)++    concatHandler :: HC.Response -> Streams.InputStream ByteString -> IO (HC.Response,BL.ByteString)+    concatHandler res i1 = do+      xs <- Streams.toList i1+      return (res, BL.fromChunks xs)++doHttpReqXml :: Connection -> HC.Request+             -> (Streams.OutputStream Builder.Builder -> IO ())+             -> IO (HC.Response, Maybe X.Element)+doHttpReqXml cn rq body = do+  (resp,bs) <- doHttpReq True cn rq body++  case fromMaybe mempty $ HC.getHeader resp "content-type" of+    ct | isXmlMimeType ct -> do+           txt <- either (\_ -> throwProtoFail "failed to decode UTF-8 content from server") pure (TL.decodeUtf8' bs)+           case X.parseXMLRoot txt of+             Left _  -> throwProtoFail "received malformed XML response from server"+             Right x -> pure (resp,Just $! X.rootElement x)+       | HC.getStatusCode resp == 204 -> pure (resp, Nothing)+       | HC.getStatusCode resp == 200, BL.null bs -> pure (resp, Nothing)+       | otherwise -> throwUnexpectedResp resp bs+++getCT :: HC.Response -> CType+getCT resp = case HC.getHeader resp "Content-Type" of+               Nothing -> noCType+               Just bs -> maybe noCType CType (TS.fromByteString bs)++-- c.f. RFC 7303+isXmlMimeType :: ByteString -> Bool+isXmlMimeType bs = case type_subtype of+                     "application/xml" -> True+                     "text/xml"        -> True+                     _                 -> False+  where+    type_subtype = BC8.map toLower $ BC8.takeWhile (not . \c -> isSpace c || c == ';') bs++throwUnexpectedResp :: HC.Response -> BL.ByteString -> IO a+throwUnexpectedResp resp bs+  = case fromMaybe mempty $ HC.getHeader resp "Content-Type" of+      ct | isXmlMimeType ct+         , Right e <- decodeXML bs -> throwIO $! errorToErrorCode e+         | otherwise -> genEx ct++  where+    genEx ct = throwIO $! UnexpectedResponse (HC.getStatusCode resp) (BSS.toShort $ HC.getStatusMessage resp) (BSS.toShort ct) bs+++throwUnexpectedXmlResp :: HC.Response -> Maybe X.Element -> IO a+throwUnexpectedXmlResp resp Nothing+  = throwIO $! UnexpectedResponse (HC.getStatusCode resp)+                                  (BSS.toShort $ HC.getStatusMessage resp)+                                  (maybe mempty BSS.toShort $ HC.getHeader resp "Content-Type")+                                  mempty+throwUnexpectedXmlResp resp (Just x) = case parseXML x of+    Right e -> throwIO $! errorToErrorCode e+    Left _  -> genEx+  where+    genEx = throwIO $! UnexpectedResponse (HC.getStatusCode resp) (BSS.toShort $ HC.getStatusMessage resp) "application/xml" (TL.encodeUtf8 (X.serializeXMLDoc x))++throwProtoFail :: String -> IO a+throwProtoFail = throwIO . ProtocolInconsistency++----------------------------------------------------------------------------++{-+-- | Stream bucket listing of objects+listStreamAllObjects :: Connection -> Credentials -> BucketId -> ObjKey -> Maybe Char -> IO S3ListStream+listStreamAllObjects (S3Conn _ cfg) creds bid pfx0 delim0 = go isNullObjKey Nothing -- FIXME+  where+    go :: ObjKey -> Maybe Connection -> IO S3ListStream+    go mmarker Nothing = do+        res <- try $ connect cfg+        case res of+          Left e  -> pure (S3ListEx e (go mmarker Nothing))+          Right c -> go mmarker (Just c)+    go mmarker (Just c) = do+        res <- try $ listObjectsChunk c creds bid pfx0 mmarker delim0+        case res of+          Left e -> pure (S3ListEx e (go mmarker Nothing))+          Right (nextMarker, objs, pfxs)+              | not (TS.null nextMarker) -> do+                    pure $ S3ListFrag objs pfxs+                                      (go nextMarker (Just c))+                                      (close c)+              | otherwise -> do+                    close c+                    if null objs+                        then pure S3ListDone+                        else pure $ S3ListFrag objs pfxs+                                               (pure S3ListDone)+                                               (pure ())+++data S3ListStream+    = S3ListFrag  [ObjMetaInfo] [ObjKey]  {- next -}  (IO S3ListStream) {- terminate -} (IO ())+    | S3ListEx    SomeException  {- retry -} (IO S3ListStream) {- terminates by default -}+    | S3ListDone {- terminates by default -}++-}++-- | List all objects in a bucket+--+-- This operation may cause multiple HTTP requests to be issued+--+-- See also 'listObjectsChunk' and 'listObjectsFold'+listObjects :: Connection+            -> Credentials+            -> BucketId+            -> ObjKey -- ^ prefix+            -> Maybe Char -- ^ delimiter+            -> IO ([ObjMetaInfo],[ObjKey]) -- ^ @(objects, prefixes)@+listObjects conn creds bid pfx delim = go nullObjKey [] []+  where+    go marker acc1 acc2 = do+      (marker', objs, pfxs) <- listObjectsChunk conn creds bid pfx delim marker 0+      let acc1' = acc1 <> objs+          acc2' = acc2 <> pfxs+      case () of+        _ | isNullObjKey marker' -> pure (acc1', acc2')+          | otherwise            -> go marker' acc1' acc2'++-- | Convenient 'foldM'-like object listing operation+--+-- Here's an usage example for iterating over the list of objects in+-- chunks of 100 objects and deleting those; and finally deleting the bucket:+--+-- > destroyBucket conn creds bid = do+-- >   listObjectsFold conn creds bid nullObjKey Nothing 100 () $ \() objs [] ->+-- >     forM_ objs $ \omi -> deleteObject conn creds bid (omiKey omi)+-- >   deleteBucket conn creds bid+--+listObjectsFold :: Connection+                -> Credentials+                -> BucketId+                -> ObjKey -- ^ prefix+                -> Maybe Char -- ^ delimiter+                -> Word16 -- ^ max number of keys per iteration+                -> a -- ^ initial value of accumulator argument to folding function+                -> (a -> [ObjMetaInfo] -> [ObjKey] -> IO a) -- ^ folding function+                -> IO a -- ^ returns final value of accumulator value+listObjectsFold conn creds bid pfx delim maxKeys acc0 lbody = go nullObjKey acc0+  where+    go marker acc = do+      (marker', objs, pfxs) <- listObjectsChunk conn creds bid pfx delim marker maxKeys+      acc' <- lbody acc objs pfxs+      case () of+        _ | isNullObjKey marker' -> pure acc'+          | otherwise            -> go marker' acc'++{-+listAllObjects conn creds bid pfx delim = listStreamAllObjects conn creds bid pfx delim >>= go 5 [] []+  where+    go :: Int -> [ObjMetaInfo] -> [ObjKey] -> S3ListStream -> IO ([ObjMetaInfo],[ObjKey])+    go !_         acc acc' S3ListDone = evaluate (acc,acc')+    go maxRetries acc acc' (S3ListEx ex retry)+      | maxRetries > 1 = retry >>= go (maxRetries-1) acc acc'+      | otherwise      = do+          _ <- throwProtoFail ("listAllObjects needed more than 5 retries (" <> show ex <> ")")+          throwIO ex++    go maxRetries acc acc' (S3ListFrag objs pfxs next _) =+        go maxRetries (acc <> objs) (acc' <> pfxs) =<< next++-}++-- -- |+-- --+-- -- TODO: currently supports only non-paginated top-level folder+-- listObjectsFolder :: S3Cfg -> S3Connection -> IO [ObjMetaInfo]+-- listObjectsFolder s3cfg c = do+--     (nextMarker, objs, pfxs) <- listObjectsChunk s3cfg c isNullObjKey isNullObjKey (Just '/')+--     unless (nextMarker == isNullObjKey) $ throwProtoFail "listObjectsFolder"+--     pure $! objs++{-++  <xsd:complexType name="ListBucketResult">+    <xsd:sequence>+      <xsd:element name="Metadata" type="tns:MetadataEntry" minOccurs="0" maxOccurs="unbounded"/>+      <xsd:element name="Name" type="xsd:string"/>+      <xsd:element name="Prefix" type="xsd:string"/>+      <xsd:element name="Marker" type="xsd:string"/>+      <xsd:element name="NextMarker" type="xsd:string" minOccurs="0"/>+      <xsd:element name="MaxKeys" type="xsd:int"/>+      <xsd:element name="Delimiter" type="xsd:string" minOccurs="0"/>+      <xsd:element name="IsTruncated" type="xsd:boolean"/>+      <xsd:element name="Contents" type="tns:ListEntry" minOccurs="0" maxOccurs="unbounded"/>+      <xsd:element name="CommonPrefixes" type="tns:PrefixEntry" minOccurs="0" maxOccurs="unbounded"/>+    </xsd:sequence>+  </xsd:complexType>+++-}++data MetadataEntry = MetadataEntry {-key-} ShortText {-value-} ShortText+  deriving Show++pMetadataEntry :: P MetadataEntry+pMetadataEntry = MetadataEntry <$> one (s3_xsd'string "Name") <*> one (s3_xsd'string "Value")++data ListBucketResult = LBR+  { lbrMetadata        :: [MetadataEntry]+  , lbrName            :: BucketId+  , lbrPrefix          :: ObjKey+  , lbrMarker          :: ObjKey+  , lbrNextMarker      :: Maybe ObjKey+  , lbrMaxKeys         :: Int32+  , lbrDelimiter       :: Maybe Char+  , lbrIsTruncated     :: Bool+  , lbrEncodingTypeUrl:: Bool+  , lbrContents        :: [ObjMetaInfo]+  , lbrCommonPrefixes  :: [ObjKey]+  } deriving Show++instance FromXML ListBucketResult where+  tagFromXML _   = s3qname "ListBucketResult"+  parseXML_ = withChildren $ do+      lbrMetadata       <- unbounded (parseXML' (s3qname "Metadata") (withChildren pMetadataEntry))+      lbrName           <- one (s3_xsd'string "Name")++      -- we need this information early on as it affects the decoding of+      -- ObjKey values; so let's read-ahead+      tmp               <- aheadMaybeOne ((== s3qname "EncodingType") . X.elName)+                                         (s3_xsd'string "EncodingType")++      lbrEncodingTypeUrl <- case tmp :: Maybe Text of+                              Just "url" -> pure True+                              Nothing    -> pure False+                              Just _     -> failP "unsupported <EncodingType> encoutered"++      lbrPrefix         <- one (s3'ObjKey "Prefix" lbrEncodingTypeUrl)+      lbrMarker         <- one (s3'ObjKey "Marker" lbrEncodingTypeUrl)+      lbrNextMarker     <- maybeOne (s3'ObjKey "NextMarker" lbrEncodingTypeUrl)+      lbrMaxKeys        <- one (s3_xsd'int "MaxKeys")+      lbrDelimiter      <- fmap T.head <$> maybeOne (s3_xsd'string "Delimiter")+      lbrIsTruncated    <- one (s3_xsd'boolean "IsTruncated")+      lbrContents       <- unbounded (parseXML' (s3qname "Contents") $+                                       withChildren (pObjMetaInfo lbrEncodingTypeUrl))+      lbrCommonPrefixes <- unbounded (parseXML' (s3qname "CommonPrefixes") $+                                       withChildren (pCommonPrefixes lbrEncodingTypeUrl))++      pure LBR{..}+    where+      pCommonPrefixes urlEnc = one (s3'ObjKey "Prefix" urlEnc)++-- | Primitive operation for list objects+--+-- This operation corresponds to a single HTTP service request+--+-- The 'listObjectsChunk' and 'listObjects' operations build on this primitive building block.+listObjectsChunk :: Connection+                 -> Credentials+                 -> BucketId+                 -> ObjKey     -- ^ prefix (use 'isNullObjKey' if none)+                 -> Maybe Char -- ^ delimiter+                 -> ObjKey     -- ^ marker (use 'isNullObjKey' if none)+                 -> Word16     -- ^ max-keys (set @0@ to use default which is usually @1000@)+                 -> IO (ObjKey,[ObjMetaInfo],[ObjKey]) -- ^ @(next-marker, objects, prefixes)@+listObjectsChunk conn creds bid pfx delim marker maxKeys = withAWSHeaders conn $ \awsh -> do+    let q = HC.buildRequest1 $+              setAWSRequest creds awsh+                { ahdrMethod        = HC.GET+                , ahdrUrlPath       = bucketUrlPath bid+                , ahdrUrlQuery      = urlq+                }++    (resp,mtmp) <- doHttpReqXml conn q HC.emptyBody++    case HC.getStatusCode resp of+      200 -> pure ()+      _   -> throwUnexpectedXmlResp resp mtmp++    LBR{..} <- case maybe (Left "empty body") parseXML mtmp of+      Right lbr -> pure (lbr :: ListBucketResult)+      Left err  -> throwProtoFail $ "ListObjects: " <> err++    let nextMarker' | lbrIsTruncated = fromMaybe nullObjKey (max (omiKey <$> last lbrContents) (last lbrCommonPrefixes))+                    | otherwise      = nullObjKey++        nextMarker  | lbrIsTruncated = fromMaybe nextMarker' lbrNextMarker+                    | otherwise      = nullObjKey++    unless (lbrIsTruncated /= isNullObjKey nextMarker) $+      throwProtoFail "NextMarker and isTruncated inconsistent"++    unless (nextMarker == nextMarker') $+      throwProtoFail "NextMarker inconsistent" -- should never happen++    evaluate (force (nextMarker,lbrContents,lbrCommonPrefixes))+  where+    -- we could use max-keys=, but unfortunately AWS S3 doesn't appear+    -- to support pureing more than 1000 entries (which is the+    -- default anyway)++    -- NB: keep this alphabetically sorted+    qryparms = mconcat+      [ [ "delimiter=" <> urlEncode True (BC8.singleton d) | Just d <- [delim] ]+      , [ "encoding-type=url" | s3cfgEncodingUrl (s3connCfg conn) ]+      , [ "marker="    <> urlEncodeObjKeyQry marker | not (isNullObjKey marker) ]+      , [ "max-keys="  <> BC8.pack (show maxKeys) | maxKeys > 0 ]+      , [ "prefix="    <> urlEncodeObjKeyQry pfx | not (isNullObjKey pfx) ]+      ]+    urlq | null qryparms = mempty+         | otherwise = "?" <> BC8.intercalate "&" qryparms++-- | Access permissions (aka /Canned ACLs/)+--+-- This has different meanings depending on whether it's set for buckets or objects+--+-- The owner of an entity has always full read & write access+--+-- For buckets, read access denotes the ability to list objects+data Acl = AclPrivate+         | AclPublicRead+         | AclPublicReadWrite+         | AclPublicAuthenticatedRead+         deriving (Show,Typeable,Generic)++instance NFData Acl++acl2str :: Acl -> ByteString+acl2str acl = case acl of+                AclPrivate                 -> "private"+                AclPublicRead              -> "public-read"+                AclPublicReadWrite         -> "public-read-write"+                AclPublicAuthenticatedRead -> "authenticated-read"+++data CopyObjectResult = CopyObjectResult+  { _corLastModified :: UTCTime+  , corETag          :: ETag+  } deriving Show+++instance FromXML CopyObjectResult where+  tagFromXML _ = s3qname "CopyObjectResult"+  parseXML_ = withChildren $+    CopyObjectResult <$> one (s3_xsd'dateTime "LastModified")+                     <*> (mkETag <$> one (s3_xsd'string "ETag"))++-- | Copy Object+copyObject :: Connection+           -> Credentials+           -> BucketId+           -> ObjKey+           -> (BucketId,ObjKey) -- ^ source object to copy+           -> Maybe Acl+           -> IO ETag+copyObject conn creds bid objkey (srcBid,srcObjKey) macl = withAWSHeaders conn $ \awsh -> do+    let q = HC.buildRequest1 $+              setAWSRequest creds awsh+                { ahdrMethod        = HC.PUT+                , ahdrUrlPath       = objUrlPath bid objkey+                , ahdrExtraHeaders  = hdrs+                }+              -- TODO: forM_ mcond setConditionHeader++    (resp, mtmp) <- doHttpReqXml conn q HC.emptyBody++    case (HC.getStatusCode resp,mtmp) of+      (200,Just x) | Right v <- parseXML x -> pure (corETag v)+      _ -> throwUnexpectedXmlResp resp mtmp+  where+    hdrs = ("x-amz-copy-source", objUrlPath srcBid srcObjKey)+           : case macl of+               Nothing  -> []+               Just acl -> [("x-amz-acl", acl2str acl)]+++-- | @PUT@ Object+putObject :: Connection+          -> Credentials+          -> BucketId+          -> ObjKey        -- ^ Object key+          -> BL.ByteString -- ^ Object payload data+          -> CType         -- ^ @content-type@ (e.g. @application/binary@); see also 'noCType'+          -> Maybe Acl+          -> IO ETag+putObject conn creds bid objkey objdata ctype macl+  = fromMaybe undefined <$> putObjectX conn creds bid objkey objdata ctype macl Nothing++putObjectCond :: Connection+              -> Credentials+              -> BucketId+              -> ObjKey        -- ^ Object key+              -> BL.ByteString -- ^ Object payload data+              -> CType         -- ^ @content-type@ (e.g. @application/binary@); see also 'noCType'+              -> Maybe Acl+              -> Condition+              -> IO (Maybe ETag)+putObjectCond conn creds bid objkey objdata ctype macl cond+  = putObjectX conn creds bid objkey objdata ctype macl (Just cond)++-- common codepath+putObjectX :: Connection+            -> Credentials+            -> BucketId+            -> ObjKey+            -> BL.ByteString+            -> CType+            -> Maybe Acl+            -> Maybe Condition+            -> IO (Maybe ETag)+putObjectX conn creds bid objkey objdata ctype macl mcond = withAWSHeaders conn $ \awsh -> do+    let q = HC.buildRequest1 $ do+              setAWSRequest creds awsh+                { ahdrMethod        = HC.PUT+                , ahdrUrlPath       = objUrlPath bid objkey+                , ahdrContentType   = ctype+                , ahdrContentHashes = Just (md5,sha256,BL.length objdata)+                , ahdrExtraHeaders  = hdrs+                }++              -- sadly, `setHeader "Last-Modified" ...` doesn't seem have any effect+              forM_ mcond setConditionHeader++    (resp, bs) <- doHttpReq True conn q (bsBody objdata)++    case HC.getStatusCode resp of+      200 -> case mkETag <$> HC.getHeader resp "ETag" of+               Just x  -> pure (Just x)+               Nothing -> throwProtoFail "ETag"+      412 | Just _ <- mcond -> pure Nothing+      _   -> throwUnexpectedResp resp bs+  where+    hdrs = case macl of+             Nothing  -> []+             Just acl -> [("x-amz-acl", acl2str acl)]++    md5    = md5hash    objdata+    sha256 = sha256hash objdata++    bsBody :: BL.ByteString -> Streams.OutputStream Builder.Builder -> IO ()+    bsBody bs = Streams.write (Just (Builder.lazyByteString bs))++-- | @GET@ Object+getObject :: Connection+          -> Credentials+          -> BucketId+          -> ObjKey        -- ^ Object key+          -> IO (ETag, CType, BL.ByteString)+getObject conn creds bid objkey = withAWSHeaders conn $ \awsh -> do+    let q = HC.buildRequest1 $+              setAWSRequest creds awsh+                { ahdrMethod        = HC.GET+                , ahdrUrlPath       = objUrlPath bid objkey+                }++    (resp, bs) <- doHttpReq False conn q HC.emptyBody++    case HC.getStatusCode resp of+      200 -> case mkETag <$> HC.getHeader resp "ETag" of+               Just x  -> pure (x, getCT resp, bs)+               Nothing -> throwProtoFail "ETag"+      _   -> throwUnexpectedResp resp bs++getObjectCond :: Connection+              -> Credentials+              -> BucketId+              -> ObjKey        -- ^ Object key+              -> Condition+              -> IO (Maybe (ETag, CType, BL.ByteString))+getObjectCond conn creds bid objkey cond = withAWSHeaders conn $ \awsh -> do+    let q = HC.buildRequest1 $ do+              setAWSRequest creds awsh+                { ahdrMethod        = HC.GET+                , ahdrUrlPath       = objUrlPath bid objkey+                }+              setConditionHeader cond++    (resp, bs) <- doHttpReq False conn q HC.emptyBody++    case HC.getStatusCode resp of+      200 -> case mkETag <$> HC.getHeader resp "ETag" of+               Just x  -> pure $ Just (x, getCT resp, bs)+               Nothing -> throwProtoFail "ETag"+      304 | IfNotMatch  _ <- cond -> pure Nothing+          | IfNotExists   <- cond -> pure Nothing+      412 | IfMatch     _ <- cond -> pure Nothing+          | IfExists      <- cond -> pure Nothing -- non-sensical+      _   -> throwUnexpectedResp resp bs++-- | @DELETE@ Object+deleteObject :: Connection -> Credentials -> BucketId -> ObjKey -> IO ()+deleteObject conn creds bid objkey = withAWSHeaders conn $ \awsh -> do+    let q = HC.buildRequest1 $+              setAWSRequest creds awsh+                { ahdrMethod        = HC.DELETE+                , ahdrUrlPath       = objUrlPath bid objkey+                }++    (resp, bs) <- doHttpReq True conn q HC.emptyBody++    case HC.getStatusCode resp of+      204 -> pure ()+      _   -> throwUnexpectedResp resp bs+++deleteObjectCond :: Connection -> Credentials -> BucketId -> ObjKey -> Condition -> IO Bool+deleteObjectCond conn creds bid objkey cond = withAWSHeaders conn $ \awsh -> do+    let q = HC.buildRequest1 $ do+              setAWSRequest creds awsh+                { ahdrMethod        = HC.DELETE+                , ahdrUrlPath       = objUrlPath bid objkey+                }+              setConditionHeader cond++    (resp, bs) <- doHttpReq True conn q HC.emptyBody++    case HC.getStatusCode resp of+      204 -> pure True+      412 -> pure False+      _   -> throwUnexpectedResp resp bs++-- | Bucket metadata reported by 'listBuckets'+data BucketInfo = BucketInfo !BucketId !UTCTime+                deriving (Show,Typeable,Generic)++instance NFData BucketInfo++instance FromXML BucketInfo where+  tagFromXML _   = s3qname "Bucket"+  parseXML_ = withChildren $+    BucketInfo <$> one (s3_xsd'string "Name")+               <*> one (s3_xsd'dateTime "CreationDate")+++pObjMetaInfo :: Bool -> P ObjMetaInfo+pObjMetaInfo urlEnc = do+    omiKey <- one (s3'ObjKey "Key" urlEnc)+    omiLastModified <- one (s3_xsd'dateTime "LastModified")++    omiEtag <- mkETag <$> one (s3_xsd'string "ETag")+    -- -- sometimes the reported MD5 is computed over chunks, in+    -- -- which case the etag has a "-<num>" suffix. For now, we just+    -- -- map those to the special zero MD5 as we can't do anything+    -- -- sensible with it anyway (but we may want to be able to+    -- -- detect that the MD5 reported was not a proper MD5)++    omiSize <- one (s3_xsd'long "Size")++    let sc = \case+          "DEEP_ARCHIVE"       -> Just ()+          "GLACIER"            -> Just ()+          "INTELLIGENT_TIERING"-> Just ()+          "ONEZONE_IA"         -> Just ()+          "REDUCED_REDUNDANCY" -> Just ()+          "STANDARD"           -> Just ()+          "STANDARD_IA"        -> Just ()+          "UNKNOWN"            -> Just ()+          _                    -> Nothing -- FIXME++    let s3_storageClass = s3_xsd'enum "StorageClass" sc -- StorageClass / TODO++    -- NB: some implementations have (optional) <Owner> and+    -- (mandatory) <StorageClass> swapped in their schema+    -- (i.e. <StorageClass> not being last); so we tolerate both+    -- orderings++    msc <- maybeOne s3_storageClass+    (own,()) <- case msc of+      Nothing  -> (,) <$> (Just <$> one parseXML) <*> one s3_storageClass+      Just sc' -> (,) <$> maybeOne parseXML <*> pure sc'++    let omiOwnerId = fmap ownerID own++    pure $! (OMI {..})+++----------------------------------------------------------------------------++data Owner = Owner { ownerID           :: ShortText+                   , _ownerDisplayName :: Maybe ShortText+                   } deriving Show++instance FromXML Owner where+  tagFromXML _ = s3qname "Owner"+  parseXML_ = withChildren $+    Owner <$> one (s3_xsd'string "ID")+          <*> maybeOne (s3_xsd'string "DisplayName")+++newtype ListAllMyBucketsResult = ListAllMyBucketsResult [BucketInfo]++instance FromXML ListAllMyBucketsResult where+  tagFromXML _ = s3qname "ListAllMyBucketsResult"++  parseXML_ = withChildren $ do+    _ <- one pure -- owner; todo+    ListAllMyBucketsResult <$> one (fmap unBuckets . parseXML)++newtype Buckets = Buckets { unBuckets :: [BucketInfo] }++instance FromXML Buckets where+  tagFromXML _ = s3qname "Buckets"+  parseXML_ = withChildren $ Buckets <$> unbounded parseXML++----------------------------------------------------------------------------++newtype Error = Error ShortText+              deriving Show++{- NB: The <Error> response element has no namespace and its schema is not openly documented; the first sub-element is always a <Code> text-element.++<Error>+  <Code>BucketNotEmpty</Code>+  <BucketName>hstest1</BucketName>+  <RequestId>tx000000000000002d08a23-005b80213f-5893fff-us-east-1-iad1</RequestId>+  <HostId>5893fff-us-east-1-iad1-us-east-1</HostId>+</Error>++-}++instance FromXML Error where+  tagFromXML _ = X.unqual "Error"++  parseXML_ = withChildren $ do+    code <- one (xsd'string (X.unqual "Code"))+    void unboundedAny -- skip the rest+    pure (Error code)

@@ -0,0 +1,230 @@+{-# LANGUAGE LambdaCase        #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards   #-}++{-++Copyright (c) 2016-2019  Herbert Valerio Riedel <hvr@gnu.org>++ This file is free software: you may copy, redistribute and/or modify it+ under the terms of the GNU General Public License as published by the+ Free Software Foundation, either version 3 of the License, or (at your+ option) any later version.++ This file 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 (see `LICENSE`).  If not, see+ <https://www.gnu.org/licenses/gpl-3.0.html>.++-}++-- |+-- Copyright: © Herbert Valerio Riedel 2016-2019+-- SPDX-License-Identifier: GPL-3.0-or-later+module Network.S3.Signature+    ( AWSHeaders(..)+    , setAWSRequest+    ) where++import           Internal+import           Network.S3.Types++import qualified Codec.Base16          as B16+import qualified Codec.Base64          as B64+import qualified Crypto.Hash.SHA1      as SHA1+import qualified Crypto.Hash.SHA256    as SHA256+import qualified Data.ByteString       as BS+import qualified Data.ByteString.Char8 as BC8+import qualified Data.List             as List+import qualified Data.Text.Short       as TS+import           Data.Time.Format      (defaultTimeLocale)+import qualified Data.Time.Format      as DT+import qualified Network.Http.Client   as HC+++data AWSHeaders = AWSHeaders+  { ahdrMethod        :: HC.Method+  , ahdrUrlPath       :: UrlPath -- always starting w/ a '/'+  , ahdrUrlQuery      :: ByteString -- always starting w/ the '?' separator+  , ahdrTimestamp     :: UTCTime+  , ahdrContentType   :: CType+  , ahdrContentHashes :: Maybe (MD5Val,SHA256Val,Int64)+  , ahdrExtraHeaders  :: [(ByteString,ByteString)]+  , ahdrSigType       :: SignatureVersion+  , ahdrHost          :: ByteString+  , ahdrRegion        :: ByteString+  }++-- | Sets up AWS headers and performs AWS signature+setAWSRequest :: Credentials -> AWSHeaders -> HC.RequestBuilder ()+setAWSRequest creds AWSHeaders{..} = do+    HC.http ahdrMethod (ahdrUrlPath <> ahdrUrlQuery)+    HC.setHeader "Date" dateRFC1123+    unless (BS.null ctype) $ HC.setContentType ctype+    forM_ clen HC.setContentLength+    forM_ ahdrExtraHeaders (uncurry HC.setHeader)++    unless (isAnonCredentials creds) $ case ahdrSigType of+      SignatureV2 -> do+        unless (BS.null cmd5)  $ HC.setHeader "Content-MD5" cmd5++        HC.setHeader "Authorization" $+          genSignatureV2 ahdrMethod ahdrUrlPath (cmd5,ctype,dateRFC1123) ahdrExtraHeaders creds++      SignatureV4 -> do+        let v4hdrs = [("host", ahdrHost)+                     ,("x-amz-date",dateAmz)+                     ,("x-amz-content-sha256",csha256)+                     ]++        HC.setHeader "x-amz-date" dateAmz+        HC.setHeader "x-amz-content-sha256" csha256++        HC.setHeader "Authorization" $+          genSignatureV4 ahdrMethod (ahdrUrlPath,ahdrUrlQuery) (csha256,dateAmz) (v4hdrs<>ahdrExtraHeaders) ahdrRegion creds++  where+    dateRFC1123 = formatRFC1123 ahdrTimestamp+    dateAmz     = formatAmzDate ahdrTimestamp++    ctype = let CType x = ahdrContentType in TS.toByteString x++    (cmd5,csha256,clen) = case ahdrContentHashes of+             Just (md5,sha256,l) -> (md5b64 md5,sha256hex sha256,Just l)+             Nothing | hasBody ahdrMethod -> (md5b64 (md5hash mempty), csha256Empty, Just 0)+                     | otherwise          -> (mempty,csha256Empty,Nothing)++    csha256Empty = sha256hex (sha256hash mempty)++formatRFC1123 :: UTCTime -> ByteString+formatRFC1123 = BC8.pack . DT.formatTime defaultTimeLocale "%a, %d %b %Y %X GMT"++formatAmzDate :: UTCTime -> ByteString+formatAmzDate = BC8.pack . DT.formatTime defaultTimeLocale "%Y%m%dT%H%M%SZ"+++{- | Compute AWS v2 signature+@+Authorization = "AWS" + " " + AWSAccessKeyId + ":" + Signature;++Signature = Base64( HMAC-SHA1( YourSecretAccessKeyID, UTF-8-Encoding-Of( StringToSign ) ) );++StringToSign = HTTP-Verb + "\n" ++	Content-MD5 + "\n" ++	Content-Type + "\n" ++	Date + "\n" ++	CanonicalizedAmzHeaders ++	CanonicalizedResource;++CanonicalizedResource = [ "/" + Bucket ] ++	<HTTP-Request-URI, from the protocol name up to the query string> ++	[ subresource, if present. For example "?acl", "?location", "?logging", or "?torrent"];++CanonicalizedAmzHeaders = ...+@++-}+genSignatureV2 :: HC.Method -> ByteString+               -> (ByteString,ByteString,ByteString)+               -> [(ByteString,ByteString)]+               -> Credentials+               -> ByteString+genSignatureV2 verb urlp (cmd5,ctype,date) amzhdrs (Credentials akey skey)+  = mconcat ["AWS ", akey, ":", B64.encode sig]+  where+    -- signature+    sig = SHA1.hmac skey msg+    -- string-to-sign+    msg = joinWithLF $+              [ meth2bs verb+              , cmd5+              , ctype+              , date+              ] <>+              [ k <> ":" <> v | (k,v) <- List.sort amzhdrs ] <>+              [ urlp ]++-- | Compute AWS v4 signature+genSignatureV4 :: HC.Method+               -> (ByteString,ByteString)+               -> (ByteString,ByteString)+               -> [(ByteString,ByteString)]+               -> ByteString+               -> Credentials+               -> ByteString+genSignatureV4 verb (urlp,urlq) (csha256,ts) amzhdrs region (Credentials akey skey0)+  = mconcat+    [ algoId+    , " Credential=", akey, "/", credScope+    , ", SignedHeaders=", signedHdrs+    , ", Signature=", B16.encode sig+    ]++  where+    algoId = "AWS4-HMAC-SHA256"+    hdrs' = List.sort amzhdrs++    -- signature+    sig = SHA256.hmac signKey msg++    -- signing-key+    signKey = ("AWS4"<>skey0) `SHA256.hmac` tsDate+                              `SHA256.hmac` region+                              `SHA256.hmac` "s3"+                              `SHA256.hmac` "aws4_request"++    -- string-to-sign+    msg = joinWithLF+      [ algoId+      , ts+      , credScope+      , B16.encode (SHA256.hash crq)+      ]++    -- canonical request+    crq = joinWithLF $+      [ meth2bs verb+      , urlp+      , BS.drop 1 urlq ] <>+      [ k <> ":" <> v | (k,v) <- hdrs' ] <>+      [ mempty+      , signedHdrs+      , csha256+      ]++    signedHdrs = BS.intercalate ";" (fst <$> hdrs')++    credScope = mconcat [ tsDate , "/", region, "/s3/aws4_request" ]++    -- i.e., the date-part of the timestamp+    tsDate = BC8.takeWhile (/='T') ts++-- NB: this does not add a trailing newline+joinWithLF :: [ByteString] -> ByteString+joinWithLF = BS.intercalate "\n"+++meth2bs :: HC.Method -> ByteString+meth2bs = \case+  HC.PUT      -> "PUT"+  HC.POST     -> "POST"+  HC.GET      -> "GET"+  HC.HEAD     -> "HEAD"+  HC.DELETE   -> "DELETE"+  HC.OPTIONS  -> "OPTIONS"+  HC.PATCH    -> "PATCH"+  HC.CONNECT  -> "CONNECT"+  HC.TRACE    -> "TRACE"+  HC.Method x -> x++hasBody :: HC.Method -> Bool+hasBody = \case+  HC.PUT      -> True+  HC.POST     -> True+  HC.PATCH    -> True+  HC.Method _ -> undefined -- TODO+  _           -> False

@@ -0,0 +1,213 @@+{-# LANGUAGE BangPatterns               #-}+{-# LANGUAGE DeriveDataTypeable         #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase                 #-}+{-# LANGUAGE OverloadedStrings          #-}++{-++Copyright (c) 2016-2019  Herbert Valerio Riedel <hvr@gnu.org>++ This file is free software: you may copy, redistribute and/or modify it+ under the terms of the GNU General Public License as published by the+ Free Software Foundation, either version 3 of the License, or (at your+ option) any later version.++ This file 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 (see `LICENSE`).  If not, see+ <https://www.gnu.org/licenses/gpl-3.0.html>.++-}++-- |+-- Copyright: © Herbert Valerio Riedel 2016-2019+-- SPDX-License-Identifier: GPL-3.0-or-later+module Network.S3.Types+    ( module Network.S3.Types+    ) where++import qualified Data.ByteString       as BS+import qualified Data.ByteString.Char8 as BC8+import qualified Data.ByteString.Short as BSS+import           Data.Char+import qualified Data.Text.Encoding    as T+import qualified Data.Text.Short       as TS+import           Internal+import qualified Network.Http.Client   as HC++class XsdString a where fromXsdString :: Text -> a+instance XsdString Text where fromXsdString = id+instance XsdString ShortText where fromXsdString = TS.fromText+instance XsdString ShortByteString where fromXsdString = TS.toShortByteString . TS.fromText+instance XsdString ByteString where fromXsdString = T.encodeUtf8++type UrlPath = ByteString++-- | Content-type+newtype CType = CType ShortText+              deriving (Eq,Show,Typeable,Generic,NFData,Hashable)++-- | Unspecified 'CType'+noCType :: CType+noCType = CType mempty++-- | Configure S3 endpoint+data S3Cfg = S3Cfg+    { s3cfgBaseUrl     :: !HC.URL -- ^ Service endpoint (i.e without 'BucketId'); Only scheme, host and port are used currently+--  , s3cfgPathStyle  :: !Bool -- ^ use path-style access mode (i.e. <http://s3.example.org/bucket-id> instead of virtual-hosted style <http://bucket-id.s3.example.org/>)+    , s3cfgRegion      :: !ByteString -- ^ E.g. @"us-east-1"@ this is currently only used for computing the signature when 's3cfgSigVersion' is set to 'SignatureV4'+    , s3cfgSigVersion  :: !SignatureVersion -- ^ Which signature algorithm to use for authentication; 'SignatureV4' is recommended unless there's reason to use the legacy 'SignatureV2' variant.+    , s3cfgEncodingUrl :: !Bool -- ^ Enable use of @encoding=url@ feature for some operations+                                --+                                -- This is only needed when object keys contain Unicode code-points not representable in XML 1.0; the XML 1.0 representable code-points are+                                --+                                -- > Char ::= #x9 | #xA | #xD | [#x20-#xD7FF] | [#xE000-#xFFFD] | [#x10000-#x10FFFF]+                                --+                                -- Note that some S3 server implementations exhibit bugs when using LF or CR characters in object keys.+                                --+                                -- Note also that some S3 implementation have been observed to incorrectly implement @encoding=url@ so it's generally advisable to disable this feature unless there's actual need and it's been confirmed that the S3 server implementatio implements it correctly.+    , s3cfgDebug       :: !Bool -- ^ Enable protocol debugging output to stdout+    } deriving (Show,Typeable,Generic)++instance NFData S3Cfg++-- | Default 'S3Cfg' value with recommended/default settings, i.e.+--+-- >>> defaultS3Cfg+-- S3Cfg {s3cfgBaseUrl = "", s3cfgRegion = "us-east-1", s3cfgSigVersion = SignatureV4, s3cfgEncodingUrl = False, s3cfgDebug = False}+--+-- __NOTE__: At the very least you have to override the 's3cfgBaseUrl' field.+defaultS3Cfg :: S3Cfg+defaultS3Cfg = S3Cfg+    { s3cfgBaseUrl     = ""+--  , s3cfgPathStyle   = True+    , s3cfgRegion      = "us-east-1"+    , s3cfgSigVersion  = SignatureV4+    , s3cfgEncodingUrl = False+    , s3cfgDebug       = False+    }++-- | Denotes version of the S3 request signing algorithm+data SignatureVersion = SignatureV2 -- ^ Legacy HMAC-SHA1/MD5 based signing algorithm+                      | SignatureV4 -- ^ Current HMAC-SHA256 based signing algorithm (recommended)+                      deriving (Eq,Show,Typeable,Generic)++instance NFData SignatureVersion++-- | S3 Credentials+--+-- We use memory pinned 'ByteString's because we don't want to have the credential data copied around more than necessary.+data Credentials = Credentials+    { s3AccessKey :: !ByteString -- ^ 'mempty' denotes anonymous access (see also 'noCredentials')+    , s3SecretKey :: !ByteString+    } deriving (Eq,Show,Typeable,Generic)++instance NFData Credentials++-- | Anonymous access+noCredentials :: Credentials+noCredentials = Credentials "" ""++isAnonCredentials :: Credentials -> Bool+isAnonCredentials (Credentials akey _) = BS.null akey++-- | S3 Bucket identifier+--+--+newtype BucketId = BucketId ShortByteString    -- ^ Must be valid as DNS name component; S3 server implementations may have additional restrictions (see e.g. AWS S3's <https://docs.aws.amazon.com/AmazonS3/latest/dev/BucketRestrictions.html#bucketnamingrules "Rules for Bucket Naming">)+                 deriving (Eq,Ord,Show,NFData,Generic,Typeable,XsdString,Hashable)++-- | The name for a key is a non-empty sequence of Unicode characters whose UTF-8 encoding is at most 1024 bytes long.+--+-- See also remarks in 's3cfgEncodingUrl' about permissible code-points.+--+-- See also AWS S3's documentation on <https://docs.aws.amazon.com/AmazonS3/latest/dev/UsingMetadata.html "Object Key and Metadata">+newtype ObjKey = ObjKey ShortText+               deriving (Show,Eq,Ord,Typeable,Generic,NFData,Hashable)++unObjKey :: ObjKey -> ShortText+unObjKey (ObjKey k) = k++-- | Represents the /null/ (or empty) 'ObjKey'+nullObjKey :: ObjKey+nullObjKey = ObjKey mempty++-- | Test whether 'ObjKey' is the 'nullObjKey'+isNullObjKey :: ObjKey -> Bool+isNullObjKey = TS.null . unObjKey+++----------------------------------------------------------------------------++-- | Denotes an <https://en.wikipedia.org/wiki/HTTP_ETag ETag>+data ETag = ETag !ShortByteString+          | ETagMD5 !MD5Val -- ^ This constructor will be used if the ETag looks like a proper MD5 based ETag+          deriving (Show,Eq,Ord,Typeable,Generic)++instance NFData ETag where+  rnf !_ = ()++instance Hashable ETag++{-++entity-tag = [ weak ] opaque-tag+     weak       = %x57.2F ; "W/", case-sensitive+     opaque-tag = DQUOTE *etagc DQUOTE+     etagc      = %x21 / %x23-7E / obs-text+                ; VCHAR except double quotes, plus obs-text+     obs-text   = %x80-FF+-}++etagToBS :: ETag -> ByteString+etagToBS (ETag etag)   = BSS.fromShort etag+etagToBS (ETagMD5 md5) = mconcat [ "\"", md5hex md5, "\"" ]++mkETag :: ByteString -> ETag+mkETag bs+  | BS.length bs == 34, BC8.head bs == '"', BC8.last bs == '"'+  , BC8.all (\c -> isHexDigit c && not (isUpper c)) (BS.init (BS.tail bs))+  , Just md5 <- md5unhex (BS.init (BS.tail bs)) = ETagMD5 md5++  | otherwise = ETag (BSS.toShort bs)++----------------------------------------------------------------------------++-- | Object Metadata+data ObjMetaInfo = OMI+    { omiKey          :: !ObjKey+    , omiEtag         :: !ETag+    , omiSize         :: !Int64+    , omiOwnerId      :: !(Maybe ShortText)+    , omiLastModified :: !UTCTime+    } deriving (Eq,Ord,Show,Typeable,Generic)++instance NFData ObjMetaInfo++----------------------------------------------------------------------------++-- | Conditional Request+--+-- Note that S3 server implementations vary in their support for+-- conditional requests+--+data Condition = IfExists         -- ^ @If-Match: *@+               | IfNotExists      -- ^ @If-None-Match: *@+               | IfMatch !ETag    -- ^ @If-Match: ...@+               | IfNotMatch !ETag -- ^ @If-None-Match: ...@+               deriving (Eq,Show,Typeable,Generic)++instance NFData Condition++setConditionHeader :: Condition -> HC.RequestBuilder ()+setConditionHeader = \case+  IfExists        -> HC.setHeader "If-Match" "*"+  IfNotExists     -> HC.setHeader "If-None-Match" "*"+  IfMatch  etag   -> HC.setHeader "If-Match" (etagToBS etag)+  IfNotMatch etag -> HC.setHeader "If-None-Match" (etagToBS etag)

@@ -0,0 +1,210 @@+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++{-++Copyright (c) 2016-2019  Herbert Valerio Riedel <hvr@gnu.org>++ This file is free software: you may copy, redistribute and/or modify it+ under the terms of the GNU General Public License as published by the+ Free Software Foundation, either version 3 of the License, or (at your+ option) any later version.++ This file 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 (see `LICENSE`).  If not, see+ <https://www.gnu.org/licenses/gpl-3.0.html>.++-}++-- | XML utilities+--+-- Copyright: © Herbert Valerio Riedel 2016-2019+-- SPDX-License-Identifier: GPL-3.0-or-later+module Network.S3.XML where++import           Internal+import           Network.S3.Types++import qualified Data.ByteString.Lazy    as BL+import           Data.Char+import qualified Data.Text               as T+import qualified Data.Text.Lazy.Encoding as TL+import qualified Data.Text.Short         as TS+import qualified Data.Time.Format        as DT+import           Text.Read               (readMaybe)+import qualified Text.XML                as X++----------------------------------------------------------------------------+-- XML parsing++s3qname :: X.LName -> X.QName+s3qname n = X.QName { X.qLName = n, X.qURI = s3xmlns, X.qPrefix = Nothing }+  where+    s3xmlns = "http://s3.amazonaws.com/doc/2006-03-01/"++showQN :: X.QName -> String+showQN (X.QName (X.LName ln) ns@(X.URI ns') _)+  | X.isNullURI ns = TS.unpack ln+  | otherwise      = mconcat [ "{", TS.unpack ns', "}", TS.unpack ln ]++xsd'string :: XsdString t => X.QName -> X.Element -> Either String t+xsd'string elNameExpected el+  | X.elName el /= elNameExpected+  = Left ("expected <" <> showQN elNameExpected <> "> but got <" <> showQN (X.elName el) <> "> instead")+  | not (null (X.elChildren el)) = Left ("<" <> showQN (X.elName el) <> "> schema violation")+  | otherwise = Right (fromXsdString $ X.strContent el)++xsd'dateTime :: X.QName -> X.Element -> Either String UTCTime+xsd'dateTime n el = do+  t <- xsd'string n el+  case DT.parseTime DT.defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ" (T.unpack t) of+    Nothing -> Left ("<" <> showQN (X.elName el) <> "> failed to decode xsd:dateTime")+    Just dt -> pure dt++xsd'long :: X.QName -> X.Element -> Either String Int64+xsd'long qn el = do+  t <- xsd'string qn el+  case readMaybe (T.unpack t) of+    Nothing -> Left ("<" <> showQN (X.elName el) <> "> failed to decode xsd:long")+    Just dt -> pure dt++xsd'int :: X.QName -> X.Element -> Either String Int32+xsd'int qn el = do+  t <- xsd'string qn el+  case readMaybe (T.unpack t) of+    Nothing -> Left ("<" <> showQN (X.elName el) <> "> failed to decode xsd:int")+    Just dt -> pure dt++xsd'enum :: X.QName -> (T.Text -> Maybe a) -> X.Element -> Either String a+xsd'enum ln f el = do+  t <- xsd'string ln el+  case f t of+    Nothing -> Left ("<" <> showQN (X.elName el) <> "> failed to decode xsd:string enumeration")+    Just dt -> pure dt++xsd'boolean :: X.QName -> X.Element -> Either String Bool+xsd'boolean ln el = do+  t <- xsd'string ln el+  case t :: T.Text of+    "true"  -> pure True+    "1"     -> pure True+    "false" -> pure False+    "0"     -> pure False+    _       -> Left ("<" <> showQN (X.elName el) <> "> failed to decode xsd:boolean enumeration")++s3_xsd'string :: XsdString t => X.LName -> X.Element -> Either String t+s3_xsd'string = xsd'string . s3qname++s3_xsd'dateTime :: X.LName -> X.Element -> Either String UTCTime+s3_xsd'dateTime = xsd'dateTime . s3qname++s3_xsd'long :: X.LName -> X.Element -> Either String Int64+s3_xsd'long = xsd'long . s3qname++s3_xsd'int :: X.LName -> X.Element -> Either String Int32+s3_xsd'int = xsd'int . s3qname++s3_xsd'boolean :: X.LName -> X.Element -> Either String Bool+s3_xsd'boolean = xsd'boolean . s3qname++s3_xsd'enum :: X.LName -> (T.Text -> Maybe a) -> X.Element -> Either String a+s3_xsd'enum ln = xsd'enum (s3qname ln)++class FromXML a where+    parseXML_  :: X.Element -> Either String a+    tagFromXML :: Proxy a -> X.QName++-- via 'FromXML' instance+parseXML :: forall a . FromXML a => X.Element -> Either String a+parseXML = parseXML' elNameExpected parseXML_+  where+    elNameExpected = tagFromXML (Proxy :: Proxy a)++-- direct parsing via inline parser+parseXML' :: X.QName -> (X.Element -> Either String a) -> X.Element -> Either String a+parseXML' elNameExpected p el = do+    unless (X.elName el == elNameExpected) $+      Left ("expected <" <> showQN elNameExpected <> "> but got <" <> showQN (X.elName el) <> "> instead")+    p el+++decodeXML :: forall a . FromXML a => BL.ByteString -> Either String a+decodeXML bs = case filterContent tag <$> (X.parseXML =<< decUtf8 bs) of+                 Right [x] -> parseXML x+                 _   -> Left ("decodeXML: failed to locate " <> show tag)+  where+    tag = tagFromXML (Proxy :: Proxy a)+    decUtf8 = either (\_ -> Left (0,"invalid UTF-8")) Right . TL.decodeUtf8'++filterContent :: X.QName -> [X.Content] -> [X.Element]+filterContent q = filter ((== q) . X.elName) . X.onlyElems++-- withChildren :: ([X.Element] -> Either String a) -> X.Element -> Either String a+-- withChildren h el+--   | not (T.all isSpace (X.strContent el)) = Left ("<" <> showQN (X.elName el) <> "> schema violation")+--   | otherwise = h (X.elChildren el)++withChildren :: P a -> X.Element -> Either String a+withChildren h el+  | not (T.all isSpace (X.strContent el)) = Left ("<" <> showQN (X.elName el) <> "> schema violation")+  | otherwise = go (X.elChildren el)+  where+    go els0 = do+      (els1,x) <- runP_ h els0+      case els1 of+        []   -> pure x+        e1:_ -> Left ("unexpected " <> showQN (X.elName e1))++one :: (X.Element -> Either String a) -> P a+one p = P $ \case+    []       -> Left "premature end-tag"+    el1:els  -> (,) els <$> p el1++aheadOne :: (X.Element -> Bool) -> (X.Element -> Either String a) -> P a+aheadOne c p = P $ \els0 -> case break c els0 of+    (_,[])               -> Left "premature end-tag"+    (preEls,el1:postEls) -> (,) (preEls<>postEls) <$> p el1++maybeOne :: (X.Element -> Either String a) -> P (Maybe a)+maybeOne p = (Just <$> one p) <|> pure Nothing++aheadMaybeOne :: (X.Element -> Bool) -> (X.Element -> Either String a) -> P (Maybe a)+aheadMaybeOne c p = (Just <$> aheadOne c p) <|> pure Nothing+++unbounded :: (X.Element -> Either String a) -> P [a]+unbounded p = many (one p)++-- | More efficient variant of @'unbounded' 'pure'@+unboundedAny :: P [X.Element]+unboundedAny = P $ \els -> pure ([],els)++-- unbounded1 :: (X.Element -> Either String a) -> P [a] -- NonEmpty+-- unbounded1 p = some (one p)++newtype P a = P { runP_ :: [X.Element] -> Either String ([X.Element], a) }++instance Functor P where+  fmap g (P m) = P (fmap (fmap (fmap g)) m)++instance Applicative P where+  pure x = P $ \cs -> Right (cs,x)+  (<*>) = ap++instance Monad P where+  return = pure+  p1 >>= p2 = P $ \cs0 -> do (cs1,a) <- runP_ p1 cs0+                             runP_ (p2 a) cs1++instance Alternative P where+  empty = failP "empty"+  p1 <|> p2 = P $ \cs0 -> either (\_ -> runP_ p2 cs0) pure (runP_ p1 cs0)++failP :: String -> P a+failP msg = P $ \_ -> Left msg