diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,675 @@ + GNU GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + 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. + + + Copyright (C) + + 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 . + +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: + + Copyright (C) + 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 +. + + 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 +. + diff --git a/S3.cabal b/S3.cabal new file mode 100644 --- /dev/null +++ b/S3.cabal @@ -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 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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Internal.hs b/src/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Internal.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} + +{- + +Copyright (c) 2016-2019 Herbert Valerio Riedel + + 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 + . + +-} + +-- | +-- 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 diff --git a/src/Network/S3.hs b/src/Network/S3.hs new file mode 100644 --- /dev/null +++ b/src/Network/S3.hs @@ -0,0 +1,979 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- + +Copyright (c) 2016-2019 Herbert Valerio Riedel + + 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 + . + +-} + +-- | +-- 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 + +{- + + + + + + + + + + + + + + + + + +-} + +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 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 "-" 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) and + -- (mandatory) swapped in their schema + -- (i.e. 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 response element has no namespace and its schema is not openly documented; the first sub-element is always a text-element. + + + BucketNotEmpty + hstest1 + tx000000000000002d08a23-005b80213f-5893fff-us-east-1-iad1 + 5893fff-us-east-1-iad1-us-east-1 + + +-} + +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) diff --git a/src/Network/S3/Signature.hs b/src/Network/S3/Signature.hs new file mode 100644 --- /dev/null +++ b/src/Network/S3/Signature.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +{- + +Copyright (c) 2016-2019 Herbert Valerio Riedel + + 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 + . + +-} + +-- | +-- 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 ] + + + + [ 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 diff --git a/src/Network/S3/Types.hs b/src/Network/S3/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/S3/Types.hs @@ -0,0 +1,213 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +{- + +Copyright (c) 2016-2019 Herbert Valerio Riedel + + 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 + . + +-} + +-- | +-- 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. instead of virtual-hosted style ) + , 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 ) + 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 +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 +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) diff --git a/src/Network/S3/XML.hs b/src/Network/S3/XML.hs new file mode 100644 --- /dev/null +++ b/src/Network/S3/XML.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +{- + +Copyright (c) 2016-2019 Herbert Valerio Riedel + + 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 + . + +-} + +-- | 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