packages feed

hs-hath (empty) → 1.1.1

raw patch · 63 files changed

+14323/−0 lines, 63 filesdep +aesondep +asyncdep +basesetup-changed

Dependencies added: aeson, async, base, base64, base64-bytestring, binary, bytestring, case-insensitive, co-log, co-log-core, co-log-polysemy, conduit, conduit-extra, containers, crypton, crypton-connection, crypton-x509, crypton-x509-store, cryptostore, data-default-class, dhall, digest, directory, exceptions, extra, filepath, ghc-prim, hex-text, hs-hath, hspec, http-client, http-client-tls, http-conduit, http-media, http-types, ini, lrucache, mason, memory, monad-control, monad-loops, mtl, network, network-uri, optparse-applicative, polysemy, polysemy-zoo, process, recv, relude, resourcet, retry, safe-exceptions, servant, servant-client, servant-client-core, servant-server, sqlite-simple, stm, streaming-commons, string-interpolate, suspend, template-haskell, temporary, text, time, time-units, timers, tls, tls-session-manager, transformers, unix, unliftio, unliftio-core, unordered-containers, wai, wai-extra, warp, xml-conduit

Files

+ CHANGELOG.md view
@@ -0,0 +1,118 @@+# Changelog for `hs-hath`++All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](https://keepachangelog.com/en/1.0.0/),+and this project adheres to the+[Haskell Package Versioning Policy](https://pvp.haskell.org/).++## [1.1.1] - 2026-01-26++### Added+- R2 Object Storage support with client-side caching+- Presigned URL generation for R2 redirects++### Changed+- Refactored time handling to use MonotonicTime for better precision+- Fix rate limiting logic+- Drop macOS support (removed logic-macos.hs)++## [1.0.3] - 2026-01-24++### Added+- Custom Prometheus metrics implementation with counters and gauges+- Metrics registry and snapshot mechanism for efficient metrics collection+- Non-blocking metrics retrieval endpoint with background worker+- stack-release.yaml for optimized release builds with LLVM support+- Aggressive optimization options for release builds++### Changed+- **Performance:** Improved rate limiting by removing TVar dependency and simplifying architecture+- **Performance:** Refactored to use monotonic time, avoiding complex UTCTime calculations+- Removed development logging statements+- Removed redundant imports+- Automated release process with GitHub Actions (separate build and release jobs)+- Removed dependency on `prometheus` and `binary` packages in favor of custom implementation++### Fixed+- Fixed config validation option to take effect properly++## [1.0.2] - 2026-01-23++### Added+- Gallery downloader task queue for better task management+- Filesystem cache backend as an alternative storage option+- Admin settings endpoint for runtime configuration+- Configuration validation and LRU cache tuning capabilities+- Enhanced logging for gallery downloader errors and failed tasks++### Changed+- **Performance:** Refactored hashing to use type classes for better abstraction+- **Performance:** Reduced intermediate ByteString allocations in hot paths+- **Performance:** Shared global HTTP manager across requests to reduce overhead+- **Performance:** Optimized buffer allocation strategies+- **Performance:** Improved hashing performance for security tokens+- Switched to monotonic clock for more accurate uptime tracking+- Refactored server loop for better code structure and maintainability+- Improved download retry logic with better error handling+- Improved gallery download resilience and error recovery+- Split middlewares into separate modules for better organization+- Enhanced CI workflow for Haskell projects++### Fixed+- Fixed keystamp rate limiting implementation+- Bypassed staticRanges check in Locate.hs to resolve compatibility issues+- Worked around encoding errors in gallery processing+- Added existence checks before processing to avoid redundant work++## [1.0.1] - 2026-01-20++### Added+- Statistics tracking with Prometheus metrics integration+- Prometheus package dependency for metrics collection+- Gallery downloader implementation+- Stats effect constructors for new metrics types+- Release workflow automation (release.yml)+- GHC build caching in CI++### Changed+- Refactored TrafficStats from TVar to Prometheus Registry+- Refactored settings handling for dynamic runtime updates+- Refactored signal handling and removed verification step+- DRY improvements for LRU cache implementation+- Refactored module structures for better organization+- Updated README with comprehensive documentation++### Fixed+- Fixed threaded speedtest issues++### Removed+- Removed Windows release targets++## [1.0.0] - 2026-01-19++### Added+- Initial release with keystamp-based rate limiting+- Core H@H (Hentai@Home) server functionality+- RPC client for H@H network communication+- SQLite and R2 storage backends with runtime switching+- File integrity verification with streaming to prevent space leaks+- In-memory LRU cache for R2 backend+- Docker support for containerized deployment+- Trust-proxy-headers option for real IP handling+- Migrate-to-R2 tool for backend migration+- Command-line interface with configuration options+- Traffic statistics tracking and reporting+- Graceful shutdown handling+- TLS support with certificate management+- Environment variable configuration (HATH_RPC_HOST, base URL)++### Changed+- Upgraded to GHC 9.6.7 and resolver lts-22.44+- SQLite journal mode changed to delete for better compatibility+- Switched from static linking to dynamic linking+- Widened aeson version bounds for better compatibility++### Fixed+- Resolved space leak in checkRate function+- Fixed space leak in file verification by using streaming approach
+ LICENSE view
@@ -0,0 +1,674 @@+                    GNU GENERAL PUBLIC LICENSE+                       Version 3, 29 June 2007++ Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>+ Everyone is permitted to copy and distribute verbatim copies+ of this license document, but changing it is not allowed.++                            Preamble++  The GNU General Public License is a free, copyleft license for+software and other kinds of works.++  The licenses for most software and other practical works are designed+to take away your freedom to share and change the works.  By contrast,+the GNU General Public License is intended to guarantee your freedom to+share and change all versions of a program--to make sure it remains free+software for all its users.  We, the Free Software Foundation, use the+GNU General Public License for most of our software; it applies also to+any other work released this way by its authors.  You can apply it to+your programs, too.++  When we speak of free software, we are referring to freedom, not+price.  Our General Public Licenses are designed to make sure that you+have the freedom to distribute copies of free software (and charge for+them if you wish), that you receive source code or can get it if you+want it, that you can change the software or use pieces of it in new+free programs, and that you know you can do these things.++  To protect your rights, we need to prevent others from denying you+these rights or asking you to surrender the rights.  Therefore, you have+certain responsibilities if you distribute copies of the software, or if+you modify it: responsibilities to respect the freedom of others.++  For example, if you distribute copies of such a program, whether+gratis or for a fee, you must pass on to the recipients the same+freedoms that you received.  You must make sure that they, too, receive+or can get the source code.  And you must show them these terms so they+know their rights.++  Developers that use the GNU GPL protect your rights with two steps:+(1) assert copyright on the software, and (2) offer you this License+giving you legal permission to copy, distribute and/or modify it.++  For the developers' and authors' protection, the GPL clearly explains+that there is no warranty for this free software.  For both users' and+authors' sake, the GPL requires that modified versions be marked as+changed, so that their problems will not be attributed erroneously to+authors of previous versions.++  Some devices are designed to deny users access to install or run+modified versions of the software inside them, although the manufacturer+can do so.  This is fundamentally incompatible with the aim of+protecting users' freedom to change the software.  The systematic+pattern of such abuse occurs in the area of products for individuals to+use, which is precisely where it is most unacceptable.  Therefore, we+have designed this version of the GPL to prohibit the practice for those+products.  If such problems arise substantially in other domains, we+stand ready to extend this provision to those domains in future versions+of the GPL, as needed to protect the freedom of users.++  Finally, every program is threatened constantly by software patents.+States should not allow patents to restrict development and use of+software on general-purpose computers, but in those that do, we wish to+avoid the special danger that patents applied to a free program could+make it effectively proprietary.  To prevent this, the GPL assures that+patents cannot be used to render the program non-free.++  The precise terms and conditions for copying, distribution and+modification follow.++                       TERMS AND CONDITIONS++  0. Definitions.++  "This License" refers to version 3 of the GNU General Public License.++  "Copyright" also means copyright-like laws that apply to other kinds of+works, such as semiconductor masks.++  "The Program" refers to any copyrightable work licensed under this+License.  Each licensee is addressed as "you".  "Licensees" and+"recipients" may be individuals or organizations.++  To "modify" a work means to copy from or adapt all or part of the work+in a fashion requiring copyright permission, other than the making of an+exact copy.  The resulting work is called a "modified version" of the+earlier work or a work "based on" the earlier work.++  A "covered work" means either the unmodified Program or a work based+on the Program.++  To "propagate" a work means to do anything with it that, without+permission, would make you directly or secondarily liable for+infringement under applicable copyright law, except executing it on a+computer or modifying a private copy.  Propagation includes copying,+distribution (with or without modification), making available to the+public, and in some countries other activities as well.++  To "convey" a work means any kind of propagation that enables other+parties to make or receive copies.  Mere interaction with a user through+a computer network, with no transfer of a copy, is not conveying.++  An interactive user interface displays "Appropriate Legal Notices"+to the extent that it includes a convenient and prominently visible+feature that (1) displays an appropriate copyright notice, and (2)+tells the user that there is no warranty for the work (except to the+extent that warranties are provided), that licensees may convey the+work under this License, and how to view a copy of this License.  If+the interface presents a list of user commands or options, such as a+menu, a prominent item in the list meets this criterion.++  1. Source Code.++  The "source code" for a work means the preferred form of the work+for making modifications to it.  "Object code" means any non-source+form of a work.++  A "Standard Interface" means an interface that either is an official+standard defined by a recognized standards body, or, in the case of+interfaces specified for a particular programming language, one that+is widely used among developers working in that language.++  The "System Libraries" of an executable work include anything, other+than the work as a whole, that (a) is included in the normal form of+packaging a Major Component, but which is not part of that Major+Component, and (b) serves only to enable use of the work with that+Major Component, or to implement a Standard Interface for which an+implementation is available to the public in source code form.  A+"Major Component", in this context, means a major essential component+(kernel, window system, and so on) of the specific operating system+(if any) on which the executable work runs, or a compiler used to+produce the work, or an object code interpreter used to run it.++  The "Corresponding Source" for a work in object code form means all+the source code needed to generate, install, and (for an executable+work) run the object code and to modify the work, including scripts to+control those activities.  However, it does not include the work's+System Libraries, or general-purpose tools or generally available free+programs which are used unmodified in performing those activities but+which are not part of the work.  For example, Corresponding Source+includes interface definition files associated with source files for+the work, and the source code for shared libraries and dynamically+linked subprograms that the work is specifically designed to require,+such as by intimate data communication or control flow between those+subprograms and other parts of the work.++  The Corresponding Source need not include anything that users+can regenerate automatically from other parts of the Corresponding+Source.++  The Corresponding Source for a work in source code form is that+same work.++  2. Basic Permissions.++  All rights granted under this License are granted for the term of+copyright on the Program, and are irrevocable provided the stated+conditions are met.  This License explicitly affirms your unlimited+permission to run the unmodified Program.  The output from running a+covered work is covered by this License only if the output, given its+content, constitutes a covered work.  This License acknowledges your+rights of fair use or other equivalent, as provided by copyright law.++  You may make, run and propagate covered works that you do not+convey, without conditions so long as your license otherwise remains+in force.  You may convey covered works to others for the sole purpose+of having them make modifications exclusively for you, or provide you+with facilities for running those works, provided that you comply with+the terms of this License in conveying all material for which you do+not control copyright.  Those thus making or running the covered works+for you must do so exclusively on your behalf, under your direction+and control, on terms that prohibit them from making any copies of+your copyrighted material outside their relationship with you.++  Conveying under any other circumstances is permitted solely under+the conditions stated below.  Sublicensing is not allowed; section 10+makes it unnecessary.++  3. Protecting Users' Legal Rights From Anti-Circumvention Law.++  No covered work shall be deemed part of an effective technological+measure under any applicable law fulfilling obligations under article+11 of the WIPO copyright treaty adopted on 20 December 1996, or+similar laws prohibiting or restricting circumvention of such+measures.++  When you convey a covered work, you waive any legal power to forbid+circumvention of technological measures to the extent such circumvention+is effected by exercising rights under this License with respect to+the covered work, and you disclaim any intention to limit operation or+modification of the work as a means of enforcing, against the work's+users, your or third parties' legal rights to forbid circumvention of+technological measures.++  4. Conveying Verbatim Copies.++  You may convey verbatim copies of the Program's source code as you+receive it, in any medium, provided that you conspicuously and+appropriately publish on each copy an appropriate copyright notice;+keep intact all notices stating that this License and any+non-permissive terms added in accord with section 7 apply to the code;+keep intact all notices of the absence of any warranty; and give all+recipients a copy of this License along with the Program.++  You may charge any price or no price for each copy that you convey,+and you may offer support or warranty protection for a fee.++  5. Conveying Modified Source Versions.++  You may convey a work based on the Program, or the modifications to+produce it from the Program, in the form of source code under the+terms of section 4, provided that you also meet all of these conditions:++    a) The work must carry prominent notices stating that you modified+    it, and giving a relevant date.++    b) The work must carry prominent notices stating that it is+    released under this License and any conditions added under section+    7.  This requirement modifies the requirement in section 4 to+    "keep intact all notices".++    c) You must license the entire work, as a whole, under this+    License to anyone who comes into possession of a copy.  This+    License will therefore apply, along with any applicable section 7+    additional terms, to the whole of the work, and all its parts,+    regardless of how they are packaged.  This License gives no+    permission to license the work in any other way, but it does not+    invalidate such permission if you have separately received it.++    d) If the work has interactive user interfaces, each must display+    Appropriate Legal Notices; however, if the Program has interactive+    interfaces that do not display Appropriate Legal Notices, your+    work need not make them do so.++  A compilation of a covered work with other separate and independent+works, which are not by their nature extensions of the covered work,+and which are not combined with it such as to form a larger program,+in or on a volume of a storage or distribution medium, is called an+"aggregate" if the compilation and its resulting copyright are not+used to limit the access or legal rights of the compilation's users+beyond what the individual works permit.  Inclusion of a covered work+in an aggregate does not cause this License to apply to the other+parts of the aggregate.++  6. Conveying Non-Source Forms.++  You may convey a covered work in object code form under the terms+of sections 4 and 5, provided that you also convey the+machine-readable Corresponding Source under the terms of this License,+in one of these ways:++    a) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by the+    Corresponding Source fixed on a durable physical medium+    customarily used for software interchange.++    b) Convey the object code in, or embodied in, a physical product+    (including a physical distribution medium), accompanied by a+    written offer, valid for at least three years and valid for as+    long as you offer spare parts or customer support for that product+    model, to give anyone who possesses the object code either (1) a+    copy of the Corresponding Source for all the software in the+    product that is covered by this License, on a durable physical+    medium customarily used for software interchange, for a price no+    more than your reasonable cost of physically performing this+    conveying of source, or (2) access to copy the+    Corresponding Source from a network server at no charge.++    c) Convey individual copies of the object code with a copy of the+    written offer to provide the Corresponding Source.  This+    alternative is allowed only occasionally and noncommercially, and+    only if you received the object code with such an offer, in accord+    with subsection 6b.++    d) Convey the object code by offering access from a designated+    place (gratis or for a charge), and offer equivalent access to the+    Corresponding Source in the same way through the same place at no+    further charge.  You need not require recipients to copy the+    Corresponding Source along with the object code.  If the place to+    copy the object code is a network server, the Corresponding Source+    may be on a different server (operated by you or a third party)+    that supports equivalent copying facilities, provided you maintain+    clear directions next to the object code saying where to find the+    Corresponding Source.  Regardless of what server hosts the+    Corresponding Source, you remain obligated to ensure that it is+    available for as long as needed to satisfy these requirements.++    e) Convey the object code using peer-to-peer transmission, provided+    you inform other peers where the object code and Corresponding+    Source of the work are being offered to the general public at no+    charge under subsection 6d.++  A separable portion of the object code, whose source code is excluded+from the Corresponding Source as a System Library, need not be+included in conveying the object code work.++  A "User Product" is either (1) a "consumer product", which means any+tangible personal property which is normally used for personal, family,+or household purposes, or (2) anything designed or sold for incorporation+into a dwelling.  In determining whether a product is a consumer product,+doubtful cases shall be resolved in favor of coverage.  For a particular+product received by a particular user, "normally used" refers to a+typical or common use of that class of product, regardless of the status+of the particular user or of the way in which the particular user+actually uses, or expects or is expected to use, the product.  A product+is a consumer product regardless of whether the product has substantial+commercial, industrial or non-consumer uses, unless such uses represent+the only significant mode of use of the product.++  "Installation Information" for a User Product means any methods,+procedures, authorization keys, or other information required to install+and execute modified versions of a covered work in that User Product from+a modified version of its Corresponding Source.  The information must+suffice to ensure that the continued functioning of the modified object+code is in no case prevented or interfered with solely because+modification has been made.++  If you convey an object code work under this section in, or with, or+specifically for use in, a User Product, and the conveying occurs as+part of a transaction in which the right of possession and use of the+User Product is transferred to the recipient in perpetuity or for a+fixed term (regardless of how the transaction is characterized), the+Corresponding Source conveyed under this section must be accompanied+by the Installation Information.  But this requirement does not apply+if neither you nor any third party retains the ability to install+modified object code on the User Product (for example, the work has+been installed in ROM).++  The requirement to provide Installation Information does not include a+requirement to continue to provide support service, warranty, or updates+for a work that has been modified or installed by the recipient, or for+the User Product in which it has been modified or installed.  Access to a+network may be denied when the modification itself materially and+adversely affects the operation of the network or violates the rules and+protocols for communication across the network.++  Corresponding Source conveyed, and Installation Information provided,+in accord with this section must be in a format that is publicly+documented (and with an implementation available to the public in+source code form), and must require no special password or key for+unpacking, reading or copying.++  7. Additional Terms.++  "Additional permissions" are terms that supplement the terms of this+License by making exceptions from one or more of its conditions.+Additional permissions that are applicable to the entire Program shall+be treated as though they were included in this License, to the extent+that they are valid under applicable law.  If additional permissions+apply only to part of the Program, that part may be used separately+under those permissions, but the entire Program remains governed by+this License without regard to the additional permissions.++  When you convey a copy of a covered work, you may at your option+remove any additional permissions from that copy, or from any part of+it.  (Additional permissions may be written to require their own+removal in certain cases when you modify the work.)  You may place+additional permissions on material, added by you to a covered work,+for which you have or can give appropriate copyright permission.++  Notwithstanding any other provision of this License, for material you+add to a covered work, you may (if authorized by the copyright holders of+that material) supplement the terms of this License with terms:++    a) Disclaiming warranty or limiting liability differently from the+    terms of sections 15 and 16 of this License; or++    b) Requiring preservation of specified reasonable legal notices or+    author attributions in that material or in the Appropriate Legal+    Notices displayed by works containing it; or++    c) Prohibiting misrepresentation of the origin of that material, or+    requiring that modified versions of such material be marked in+    reasonable ways as different from the original version; or++    d) Limiting the use for publicity purposes of names of licensors or+    authors of the material; or++    e) Declining to grant rights under trademark law for use of some+    trade names, trademarks, or service marks; or++    f) Requiring indemnification of licensors and authors of that+    material by anyone who conveys the material (or modified versions of+    it) with contractual assumptions of liability to the recipient, for+    any liability that these contractual assumptions directly impose on+    those licensors and authors.++  All other non-permissive additional terms are considered "further+restrictions" within the meaning of section 10.  If the Program as you+received it, or any part of it, contains a notice stating that it is+governed by this License along with a term that is a further+restriction, you may remove that term.  If a license document contains+a further restriction but permits relicensing or conveying under this+License, you may add to a covered work material governed by the terms+of that license document, provided that the further restriction does+not survive such relicensing or conveying.++  If you add terms to a covered work in accord with this section, you+must place, in the relevant source files, a statement of the+additional terms that apply to those files, or a notice indicating+where to find the applicable terms.++  Additional terms, permissive or non-permissive, may be stated in the+form of a separately written license, or stated as exceptions;+the above requirements apply either way.++  8. Termination.++  You may not propagate or modify a covered work except as expressly+provided under this License.  Any attempt otherwise to propagate or+modify it is void, and will automatically terminate your rights under+this License (including any patent licenses granted under the third+paragraph of section 11).++  However, if you cease all violation of this License, then your+license from a particular copyright holder is reinstated (a)+provisionally, unless and until the copyright holder explicitly and+finally terminates your license, and (b) permanently, if the copyright+holder fails to notify you of the violation by some reasonable means+prior to 60 days after the cessation.++  Moreover, your license from a particular copyright holder is+reinstated permanently if the copyright holder notifies you of the+violation by some reasonable means, this is the first time you have+received notice of violation of this License (for any work) from that+copyright holder, and you cure the violation prior to 30 days after+your receipt of the notice.++  Termination of your rights under this section does not terminate the+licenses of parties who have received copies or rights from you under+this License.  If your rights have been terminated and not permanently+reinstated, you do not qualify to receive new licenses for the same+material under section 10.++  9. Acceptance Not Required for Having Copies.++  You are not required to accept this License in order to receive or+run a copy of the Program.  Ancillary propagation of a covered work+occurring solely as a consequence of using peer-to-peer transmission+to receive a copy likewise does not require acceptance.  However,+nothing other than this License grants you permission to propagate or+modify any covered work.  These actions infringe copyright if you do+not accept this License.  Therefore, by modifying or propagating a+covered work, you indicate your acceptance of this License to do so.++  10. Automatic Licensing of Downstream Recipients.++  Each time you convey a covered work, the recipient automatically+receives a license from the original licensors, to run, modify and+propagate that work, subject to this License.  You are not responsible+for enforcing compliance by third parties with this License.++  An "entity transaction" is a transaction transferring control of an+organization, or substantially all assets of one, or subdividing an+organization, or merging organizations.  If propagation of a covered+work results from an entity transaction, each party to that+transaction who receives a copy of the work also receives whatever+licenses to the work the party's predecessor in interest had or could+give under the previous paragraph, plus a right to possession of the+Corresponding Source of the work from the predecessor in interest, if+the predecessor has it or can get it with reasonable efforts.++  You may not impose any further restrictions on the exercise of the+rights granted or affirmed under this License.  For example, you may+not impose a license fee, royalty, or other charge for exercise of+rights granted under this License, and you may not initiate litigation+(including a cross-claim or counterclaim in a lawsuit) alleging that+any patent claim is infringed by making, using, selling, offering for+sale, or importing the Program or any portion of it.++  11. Patents.++  A "contributor" is a copyright holder who authorizes use under this+License of the Program or a work on which the Program is based.  The+work thus licensed is called the contributor's "contributor version".++  A contributor's "essential patent claims" are all patent claims+owned or controlled by the contributor, whether already acquired or+hereafter acquired, that would be infringed by some manner, permitted+by this License, of making, using, or selling its contributor version,+but do not include claims that would be infringed only as a+consequence of further modification of the contributor version.  For+purposes of this definition, "control" includes the right to grant+patent sublicenses in a manner consistent with the requirements of+this License.++  Each contributor grants you a non-exclusive, worldwide, royalty-free+patent license under the contributor's essential patent claims, to+make, use, sell, offer for sale, import and otherwise run, modify and+propagate the contents of its contributor version.++  In the following three paragraphs, a "patent license" is any express+agreement or commitment, however denominated, not to enforce a patent+(such as an express permission to practice a patent or covenant not to+sue for patent infringement).  To "grant" such a patent license to a+party means to make such an agreement or commitment not to enforce a+patent against the party.++  If you convey a covered work, knowingly relying on a patent license,+and the Corresponding Source of the work is not available for anyone+to copy, free of charge and under the terms of this License, through a+publicly available network server or other readily accessible means,+then you must either (1) cause the Corresponding Source to be so+available, or (2) arrange to deprive yourself of the benefit of the+patent license for this particular work, or (3) arrange, in a manner+consistent with the requirements of this License, to extend the patent+license to downstream recipients.  "Knowingly relying" means you have+actual knowledge that, but for the patent license, your conveying the+covered work in a country, or your recipient's use of the covered work+in a country, would infringe one or more identifiable patents in that+country that you have reason to believe are valid.++  If, pursuant to or in connection with a single transaction or+arrangement, you convey, or propagate by procuring conveyance of, a+covered work, and grant a patent license to some of the parties+receiving the covered work authorizing them to use, propagate, modify+or convey a specific copy of the covered work, then the patent license+you grant is automatically extended to all recipients of the covered+work and works based on it.++  A patent license is "discriminatory" if it does not include within+the scope of its coverage, prohibits the exercise of, or is+conditioned on the non-exercise of one or more of the rights that are+specifically granted under this License.  You may not convey a covered+work if you are a party to an arrangement with a third party that is+in the business of distributing software, under which you make payment+to the third party based on the extent of your activity of conveying+the work, and under which the third party grants, to any of the+parties who would receive the covered work from you, a discriminatory+patent license (a) in connection with copies of the covered work+conveyed by you (or copies made from those copies), or (b) primarily+for and in connection with specific products or compilations that+contain the covered work, unless you entered into that arrangement,+or that patent license was granted, prior to 28 March 2007.++  Nothing in this License shall be construed as excluding or limiting+any implied license or other defenses to infringement that may+otherwise be available to you under applicable patent law.++  12. No Surrender of Others' Freedom.++  If conditions are imposed on you (whether by court order, agreement or+otherwise) that contradict the conditions of this License, they do not+excuse you from the conditions of this License.  If you cannot convey a+covered work so as to satisfy simultaneously your obligations under this+License and any other pertinent obligations, then as a consequence you may+not convey it at all.  For example, if you agree to terms that obligate you+to collect a royalty for further conveying from those to whom you convey+the Program, the only way you could satisfy both those terms and this+License would be to refrain entirely from conveying the Program.++  13. Use with the GNU Affero General Public License.++  Notwithstanding any other provision of this License, you have+permission to link or combine any covered work with a work licensed+under version 3 of the GNU Affero General Public License into a single+combined work, and to convey the resulting work.  The terms of this+License will continue to apply to the part which is the covered work,+but the special requirements of the GNU Affero General Public License,+section 13, concerning interaction through a network will apply to the+combination as such.++  14. Revised Versions of this License.++  The Free Software Foundation may publish revised and/or new versions of+the GNU General Public License from time to time.  Such new versions will+be similar in spirit to the present version, but may differ in detail to+address new problems or concerns.++  Each version is given a distinguishing version number.  If the+Program specifies that a certain numbered version of the GNU General+Public License "or any later version" applies to it, you have the+option of following the terms and conditions either of that numbered+version or of any later version published by the Free Software+Foundation.  If the Program does not specify a version number of the+GNU General Public License, you may choose any version ever published+by the Free Software Foundation.++  If the Program specifies that a proxy can decide which future+versions of the GNU General Public License can be used, that proxy's+public statement of acceptance of a version permanently authorizes you+to choose that version for the Program.++  Later license versions may give you additional or different+permissions.  However, no additional obligations are imposed on any+author or copyright holder as a result of your choosing to follow a+later version.++  15. Disclaimer of Warranty.++  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY+APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT+HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY+OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,+THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR+PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM+IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF+ALL NECESSARY SERVICING, REPAIR OR CORRECTION.++  16. Limitation of Liability.++  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING+WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS+THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY+GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE+USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF+DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD+PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),+EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF+SUCH DAMAGES.++  17. Interpretation of Sections 15 and 16.++  If the disclaimer of warranty and limitation of liability provided+above cannot be given local legal effect according to their terms,+reviewing courts shall apply local law that most closely approximates+an absolute waiver of all civil liability in connection with the+Program, unless a warranty or assumption of liability accompanies a+copy of the Program in return for a fee.++                     END OF TERMS AND CONDITIONS++            How to Apply These Terms to Your New Programs++  If you develop a new program, and you want it to be of the greatest+possible use to the public, the best way to achieve this is to make it+free software which everyone can redistribute and change under these terms.++  To do so, attach the following notices to the program.  It is safest+to attach them to the start of each source file to most effectively+state the exclusion of warranty; and each file should have at least+the "copyright" line and a pointer to where the full notice is found.++    <one line to give the program's name and a brief idea of what it does.>+    Copyright (C) <year>  <name of author>++    This program is free software: you can redistribute it and/or modify+    it under the terms of the GNU General Public License as published by+    the Free Software Foundation, either version 3 of the License, or+    (at your option) any later version.++    This program is distributed in the hope that it will be useful,+    but WITHOUT ANY WARRANTY; without even the implied warranty of+    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+    GNU General Public License for more details.++    You should have received a copy of the GNU General Public License+    along with this program.  If not, see <http://www.gnu.org/licenses/>.++Also add information on how to contact you by electronic and paper mail.++  If the program does terminal interaction, make it output a short+notice like this when it starts in an interactive mode:++    <program>  Copyright (C) <year>  <name of author>+    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'.+    This is free software, and you are welcome to redistribute it+    under certain conditions; type `show c' for details.++The hypothetical commands `show w' and `show c' should show the appropriate+parts of the General Public License.  Of course, your program's commands+might be different; for a GUI interface, you would use an "about box".++  You should also get your employer (if you work as a programmer) or school,+if any, to sign a "copyright disclaimer" for the program, if necessary.+For more information on this, and how to apply and follow the GNU GPL, see+<http://www.gnu.org/licenses/>.++  The GNU General Public License does not permit incorporating your program+into proprietary programs.  If your program is a subroutine library, you+may consider it more useful to permit linking proprietary applications with+the library.  If this is what you want to do, use the GNU Lesser General+Public License instead of this License.  But first, please read+<http://www.gnu.org/philosophy/why-not-lgpl.html>.
+ README.md view
@@ -0,0 +1,80 @@+# hs-hath - A Haskell Implementation of the Hentai@Home Client++[![License: GPL v3](https://img.shields.io/badge/License-GPLv3-blue.svg)](https://www.gnu.org/licenses/gpl-3.0)++A high-performance Haskell implementation of the Hentai@Home client. The client caches and serves gallery files, communicates with the H@H server via TLS-secured RPC, and supports S3-compatible storage backends including Cloudflare R2.++## Features++Resource caching uses an LRU cache with SQLite-backed or R2-backed storage. RPC communication to the H@H server uses TLS with automatic certificate refresh every 24 hours. Rate limiting includes both IP-based throttling and keystamp-based fallback for NAT environments. Gallery downloads support parallel file fetching. Prometheus metrics are available at the `/metrics` endpoint. The client tracks build information via the `--version` flag.++## Installation++### Prerequisites+- Stack (Haskell toolchain)+- SQLite 3+- OpenSSL libraries++### Building+```bash+git clone https://github.com/pe200012/hs-hath.git+cd hs-hath+stack build+```++## Configuration++Create a `client-login` file with your credentials:+```dhall+{ clientId = "your-client-id"+, key = "your-api-key" +, version = "1.0.0"+, proxy = None ClientProxy+, downloadDir = "./downloads"+, cachePath = "./cache.db"+}+```++## Usage++Start the client:+```bash+stack exec hs-hath+```++View version information:+```bash+stack exec hs-hath -- --version+```++The client responds to `SIGINT` and `SIGTERM` for graceful shutdown. Settings reload automatically via RPC command. The Prometheus metrics endpoint is available at `/metrics` for monitoring.++## Architecture++The RPC client handles communication with the H@H server, including certificate management and settings synchronization. The resource cache stores files using SQLite with LRU eviction. An HTTP server built on Warp serves cached resources. Rate limiting middleware provides both IP-based and keystamp-based request throttling. The storage backend supports local filesystem and S3-compatible services like Cloudflare R2.++## Metrics++The client exports Prometheus metrics in text format at the `/metrics` endpoint. Metrics include request counters, cache statistics, and operational counters for monitoring and alerting.++## Performance++Has not been optimized yet. Currently, it will take ~200MiB RAM on average.++## Troubleshooting++### Certificate errors+Verify system clock synchronization and certificate file permissions. Certificate refresh occurs automatically every 24 hours.++### Connection issues+Check proxy settings if configured. Ensure firewall allows outbound TLS connections on the required ports.++### Storage backend errors+For S3-compatible backends like Cloudflare R2, verify that the storage server returns required headers: `ETag`, `Content-Length`, and `Last-Modified`. Missing `ETag` headers cause write failures.++### Rate limiting+The client implements strict request throttling. Banned IPs and rate limit violations appear in console logs. Verify client configuration if legitimate requests are being rejected.++## License++This project is licensed under the GNU General Public License v3.0 - see the [LICENSE](LICENSE) file for details.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,86 @@+module Main ( main ) where++import           CLI                    ( Options(..), applyOptionsToConfig, parseOptions )++import qualified Data.Text              as T++import           Database.SQLite.Simple ( withConnection )++import           FileVerification       ( VerificationStats(..), verifyAllFiles )++import           HathNetwork.Genesis    ( fetchCertificate, runGenesisIO )+import           HathNetwork.RPC++import           Relude                 hiding ( runReader )++import           Server                 ( ServerAction(GracefulShutdown), startServer )++import           Storage.Database       ( initializeDB )++import           System.Posix           ( Handler(Catch), installHandler, sigINT, sigTERM )++import           Types++import           UnliftIO               ( newTChanIO, writeTChan )++import           Version                ( versionInfo )++main :: IO ()+main = do+  options <- parseOptions++  -- Handle --version flag+  when (optShowVersion options) $ do+    putStrLn $ T.unpack versionInfo+    exitSuccess++  baseConfig <- readClientConfig (toText $ optConfigPath options)+  let config = applyOptionsToConfig options baseConfig++  when (optValidateConfig options) $ do+    putStrLn "Configuration is valid."+    exitSuccess++  -- Initialize database and run startup verification unless skipped+  withConnection (T.unpack $ cachePath config) $ \conn -> do+    initializeDB conn++    -- Run full cache verification by default (skip with --skip-startup-verify)+    unless (optSkipStartupVerify options) $ do+      putStrLn "Verifying cache integrity (this may take a while)..."+      stats <- verifyAllFiles conn+      putStrLn $ "Verification complete:"+      putStrLn $ "  Files verified: " <> show (verifiedCount stats)+      putStrLn $ "  Corrupted files removed: " <> show (corruptedCount stats)+      putStrLn $ "  Time elapsed: " <> show (verificationTime stats)+      when (corruptedCount stats > 0)+        $ putStrLn+        $ "WARNING: " <> show (corruptedCount stats) <> " corrupted files were found and removed."++  chan <- newTChanIO+  void $ installHandler sigINT (Catch $ atomically $ writeTChan chan GracefulShutdown) Nothing+  void $ installHandler sigTERM (Catch $ atomically $ writeTChan chan GracefulShutdown) Nothing++  runRPCIO config serverStat >>= \case+    Right (Right True) -> runRPCIO config clientLogin >>= \case+      Right (Right settings) -> runGenesisIO config fetchCertificate >>= \case+        Right (Right certs) -> startServer+          config+          settings+          certs+          chan+          (optDisableRateLimit options)+          (optTrustProxyHeaders options)+        e -> do+          print e+          putStrLn "Unable to fetch certs, exiting..."+          exitFailure+      e -> do+        print e+        putStrLn "Unable to login, exiting..."+        exitFailure+    e -> do+      print e+      putStrLn "RPC is not available, exiting..."+      exitFailure+
+ app/Migrate.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Migrate ( main ) where++import           Colog                  ( LogAction(..), Message, Severity(..), richMessageAction )+import           Colog.Polysemy         ( Log, runLogAction )++import qualified Conduit                as C++import           Control.Exception      ( SomeException, try )+import           Control.Monad          ( when )++import qualified Data.ByteString        as BS+import qualified Data.Text              as T+import qualified Data.Text.IO           as TIO++import           Database.SQLite.Simple ( Connection, Only(..), Query, fold_, open, query_ )++import           Network.Minio          ( AccessKey(..)+                                        , CredentialValue(..)+                                        , SecretKey(..)+                                        , defaultPutObjectOptions+                                        , runMinio+                                        , setCreds+                                        , setRegion+                                        )+import qualified Network.Minio          as Minio++import           Options.Applicative++import           Polysemy+import           Polysemy.Error         ( Error, runError )+import           Polysemy.KVStore       ( updateKV )++import           Relude                 hiding ( Reader )++import           Storage.Database       ( FileRecord(..), initializeDB )+import           Storage.R2             ( R2Connection(..), mkR2Connection, runCacheR2 )++import           System.Directory       ( doesDirectoryExist, doesFileExist, listDirectory )+import           System.FilePath        ( (</>), takeFileName )++import           Types                  ( FileURI, R2Config(..), RPCError(..), parseFileURI )++-- | Command line options+data MigrateOptions+  = MigrateOptions+  { optSourceType :: !SourceType+  , optSourcePath :: !FilePath+  , optR2Endpoint :: !Text+  , optR2Bucket   :: !Text+  , optDryRun     :: !Bool+  , optBatchSize  :: !Int+  , optVerbose    :: !Bool+  }+  deriving ( Show )++data SourceType = SQLiteSource | FilesystemSource+  deriving ( Show, Eq )++-- | Parse command line options+parseOptions :: Parser MigrateOptions+parseOptions+  = MigrateOptions+  <$> option+    parseSourceType+    (long "source-type" <> short 't' <> metavar "TYPE" <> help "Source type: sqlite or filesystem")+  <*> strOption+    (long "source"+     <> short 's'+     <> metavar "PATH"+     <> help "Source path (SQLite db file or cache directory)")+  <*> strOption+    (long "endpoint"+     <> short 'e'+     <> metavar "URL"+     <> help "R2 endpoint URL (e.g., https://xxx.r2.cloudflarestorage.com)")+  <*> strOption (long "bucket" <> short 'b' <> metavar "NAME" <> help "R2 bucket name")+  <*> switch+    (long "dry-run" <> short 'n' <> help "Show what would be migrated without actually uploading")+  <*> option+    auto+    (long "batch-size"+     <> metavar "N"+     <> value 100+     <> showDefault+     <> help "Number of files to process per batch")+  <*> switch (long "verbose" <> short 'v' <> help "Enable verbose output")++parseSourceType :: ReadM SourceType+parseSourceType = eitherReader $ \case+  "sqlite"     -> Right SQLiteSource+  "filesystem" -> Right FilesystemSource+  "fs"         -> Right FilesystemSource+  other        -> Left $ "Unknown source type: " <> other <> ". Use 'sqlite' or 'filesystem'"++optsInfo :: ParserInfo MigrateOptions+optsInfo+  = info+    (parseOptions <**> helper)+    (fullDesc+     <> progDesc "Migrate cache files to Cloudflare R2"+     <> header "migrate-to-r2 - Cache migration tool for hs-hath")++main :: IO ()+main = do+  opts <- execParser optsInfo++  -- Check environment variables+  accessKeyMay <- lookupEnv "R2_ACCESS_KEY"+  secretKeyMay <- lookupEnv "R2_SECRET_KEY"++  when (isNothing accessKeyMay) $ do+    TIO.putStrLn "Error: R2_ACCESS_KEY environment variable not set"+    exitFailure++  when (isNothing secretKeyMay) $ do+    TIO.putStrLn "Error: R2_SECRET_KEY environment variable not set"+    exitFailure++  -- Create R2 connection+  let r2Cfg = R2Config { r2Endpoint = optR2Endpoint opts, r2Bucket = optR2Bucket opts }++  r2Result <- mkR2Connection r2Cfg+  case r2Result of+    Left err     -> do+      TIO.putStrLn $ "Error creating R2 connection: " <> err+      exitFailure+    Right r2Conn -> do+      TIO.putStrLn $ "Connected to R2: " <> optR2Endpoint opts <> "/" <> optR2Bucket opts++      case optSourceType opts of+        SQLiteSource     -> migrateSQLite opts r2Conn+        FilesystemSource -> migrateFilesystem opts r2Conn++-- | Migrate from SQLite database+migrateSQLite :: MigrateOptions -> R2Connection -> IO ()+migrateSQLite opts r2Conn = do+  TIO.putStrLn $ "Migrating from SQLite: " <> T.pack (optSourcePath opts)++  conn <- open (optSourcePath opts)++  -- Count total files+  [ Only totalCount ] <- query_ conn "SELECT COUNT(*) FROM files" :: IO [ Only Int ]+  TIO.putStrLn $ "Total files to migrate: " <> show totalCount++  when (optDryRun opts) $ do+    TIO.putStrLn "[DRY RUN] Would upload the following files:"++  -- Stream files from SQLite and upload to R2+  migratedCount <- newIORef (0 :: Int)+  errorCount <- newIORef (0 :: Int)++  void $ fold_ conn selectAllQuery ( (), 0 :: Int ) $ \( (), _idx ) record -> do+    let fileId = fileRecordFileId record+        uri    = parseFileURI (encodeUtf8 fileId)++    if optDryRun opts+      then do+        when (optVerbose opts) $ TIO.putStrLn $ "  Would upload: " <> fileId+      else do+        result <- uploadToR2 r2Conn uri record+        case result of+          Left err -> do+            atomicModifyIORef' errorCount (\c -> ( c + 1, () ))+            when (optVerbose opts)+              $ TIO.putStrLn+              $ "  Error uploading " <> fileId <> ": " <> show err+          Right () -> do+            atomicModifyIORef' migratedCount (\c -> ( c + 1, () ))+            when (optVerbose opts) $ TIO.putStrLn $ "  Uploaded: " <> fileId++    -- Progress update every batch+    let idx' = _idx + 1+    when (idx' `mod` optBatchSize opts == 0)+      $ TIO.putStrLn+      $ "  Progress: " <> show idx' <> "/" <> show totalCount++    pure ( (), idx' )++  finalMigrated <- readIORef migratedCount+  finalErrors <- readIORef errorCount++  TIO.putStrLn $ "\nMigration complete:"+  TIO.putStrLn $ "  Migrated: " <> show finalMigrated+  TIO.putStrLn $ "  Errors: " <> show finalErrors+  where+    selectAllQuery :: Query+    selectAllQuery = "SELECT lru_counter, s4, file_id, file_name, bytes FROM files"++-- | Migrate from filesystem cache+migrateFilesystem :: MigrateOptions -> R2Connection -> IO ()+migrateFilesystem opts r2Conn = do+  TIO.putStrLn $ "Migrating from filesystem: " <> T.pack (optSourcePath opts)++  exists <- doesDirectoryExist (optSourcePath opts)+  unless exists $ do+    TIO.putStrLn $ "Error: Directory does not exist: " <> T.pack (optSourcePath opts)+    exitFailure++  -- Filesystem cache structure: optSourcePath/s4/file_id+  -- Where s4 is first 4 chars of hash+  s4Dirs <- listDirectory (optSourcePath opts)++  when (optDryRun opts) $ TIO.putStrLn "[DRY RUN] Would upload the following files:"++  migratedCount <- newIORef (0 :: Int)+  errorCount <- newIORef (0 :: Int)++  forM_ s4Dirs $ \s4Dir -> do+    let s4Path = optSourcePath opts </> s4Dir+    isDir <- doesDirectoryExist s4Path+    when isDir $ do+      files <- listDirectory s4Path+      forM_ files $ \fileName -> do+        let filePath = s4Path </> fileName+            fileId   = T.pack fileName+            uri      = parseFileURI (encodeUtf8 fileId)++        isFile <- doesFileExist filePath+        when isFile $ do+          if optDryRun opts+            then do+              when (optVerbose opts) $ TIO.putStrLn $ "  Would upload: " <> fileId+            else do+              let bucket = r2ConnBucket r2Conn+                  key    = fileURIToKey uri+              result <- try @SomeException+                $ Minio.runMinioWith (r2MinioConn r2Conn)+                $ Minio.fPutObject bucket key filePath defaultPutObjectOptions+              case result of+                Left err          -> do+                  atomicModifyIORef' errorCount (\c -> ( c + 1, () ))+                  when (optVerbose opts)+                    $ TIO.putStrLn+                    $ "  Error uploading " <> fileId <> ": " <> show err+                Right (Left mErr) -> do+                  atomicModifyIORef' errorCount (\c -> ( c + 1, () ))+                  when (optVerbose opts)+                    $ TIO.putStrLn+                    $ "  Error uploading " <> fileId <> ": " <> show mErr+                Right (Right ())  -> do+                  atomicModifyIORef' migratedCount (\c -> ( c + 1, () ))+                  when (optVerbose opts) $ TIO.putStrLn $ "  Uploaded: " <> fileId++  finalMigrated <- readIORef migratedCount+  finalErrors <- readIORef errorCount++  TIO.putStrLn $ "\nMigration complete:"+  TIO.putStrLn $ "  Migrated: " <> show finalMigrated+  TIO.putStrLn $ "  Errors: " <> show finalErrors++-- | Upload a file record to R2+uploadToR2 :: R2Connection -> FileURI -> FileRecord -> IO (Either Text ())+uploadToR2 conn uri record = do+  let key     = fileURIToKey uri+      bucket  = r2ConnBucket conn+      content = fileRecordBytes record+      size    = fromIntegral (BS.length content) :: Int64+      src     = C.yield content++  result <- try @SomeException+    $ Minio.runMinioWith (r2MinioConn conn)+    $ Minio.putObject bucket key src (Just size) defaultPutObjectOptions++  case result of+    Left err          -> pure $ Left $ T.pack $ show err+    Right (Left mErr) -> pure $ Left $ T.pack $ show mErr+    Right (Right _)   -> pure $ Right ()++-- | Generate R2 object key from FileURI (same as in R2.hs)+fileURIToKey :: FileURI -> Text+fileURIToKey uri = s4 <> "/" <> fileId+  where+    fileId = show uri++    s4     = T.take 4 fileId
+ hs-hath.cabal view
@@ -0,0 +1,672 @@+cabal-version: 2.0++-- This file has been generated from package.yaml by hpack version 0.38.1.+--+-- see: https://github.com/sol/hpack++name:           hs-hath+version:        1.1.1+synopsis:       A Haskell implementation of the Hentai@Home client+description:    Please see the README on GitHub at <https://github.com/pe200012/hs-hath#readme>+category:       Web+homepage:       https://github.com/pe200012/hs-hath#readme+bug-reports:    https://github.com/pe200012/hs-hath/issues+author:         pe200012+maintainer:     1326263755@qq.com+copyright:      2024 pe200012+license:        GPL-3+license-file:   LICENSE+build-type:     Simple+tested-with:+    GHC == 9.6.6+extra-source-files:+    README.md+extra-doc-files:+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/pe200012/hs-hath++library+  exposed-modules:+      CLI+      FileVerification+      HathNetwork.Genesis+      HathNetwork.RPC+      Interface.API+      LegacyCiphers+      Metrics.Counter+      Metrics.Gauge+      Metrics.Prometheus+      Metrics.Registry+      Metrics.Snapshot+      Metrics.Types+      Middleware+      Server+      SettingM+      Stats+      Storage.Database+      Storage.Filesystem+      Storage.Locate+      Storage.R2+      Types+      Utils+      Version+  other-modules:+      Paths_hs_hath+  autogen-modules:+      Paths_hs_hath+  hs-source-dirs:+      src+  default-extensions:+      NoImplicitPrelude+      TypeApplications+      OverloadedStrings+      ScopedTypeVariables+      QuasiQuotes+      LambdaCase+      ViewPatterns+      MultiParamTypeClasses+      GADTs+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      aeson >=2.1 && <2.3+    , async ==2.2.*+    , base >=4.7 && <4.22+    , base64 ==1.0.*+    , bytestring >=0.11 && <0.13+    , co-log >=0.6 && <0.8+    , co-log-core ==0.3.*+    , co-log-polysemy >=0.0.1.5 && <0.0.2+    , conduit ==1.3.*+    , containers >=0.6 && <0.8+    , crypton ==1.0.*+    , crypton-connection ==0.4.*+    , crypton-x509 ==1.7.*+    , crypton-x509-store ==1.6.*+    , cryptostore ==0.3.*+    , dhall ==1.42.*+    , directory ==1.3.*+    , exceptions ==0.10.*+    , extra >=1.7 && <1.9+    , filepath >=1.4 && <1.6+    , hex-text ==0.1.*+    , hs-hath-minio+    , hs-hath-placeholder+    , hs-hath-warp-tls+    , http-client ==0.7.*+    , http-client-tls ==0.3.*+    , http-conduit ==2.3.*+    , http-media ==0.8.*+    , http-types ==0.12.*+    , lrucache ==1.2.*+    , mason >=0.2.6 && <0.3+    , memory ==0.18.*+    , monad-control ==1.0.*+    , monad-loops ==0.4.*+    , mtl ==2.3.*+    , network >=3.1 && <3.3+    , optparse-applicative ==0.18.*+    , polysemy ==1.9.*+    , polysemy-zoo ==0.8.*+    , process ==1.6.*+    , relude ==1.2.*+    , resourcet ==1.3.*+    , safe-exceptions ==0.1.*+    , servant >=0.20.2 && <0.21+    , servant-client >=0.20.2 && <0.21+    , servant-client-core >=0.20.2 && <0.21+    , servant-server >=0.20.2 && <0.21+    , sqlite-simple ==0.4.*+    , stm ==2.5.*+    , string-interpolate ==0.3.*+    , suspend ==0.2.*+    , template-haskell >=2.19 && <2.24+    , text >=2.0 && <2.2+    , time >=1.12 && <1.15+    , timers ==0.2.*+    , tls >=2.0 && <2.4+    , tls-session-manager >=0.0.5 && <0.1+    , transformers ==0.6.*+    , unix ==2.8.*+    , unliftio ==0.2.*+    , unordered-containers ==0.2.*+    , wai ==3.2.*+    , wai-extra ==3.1.*+    , warp ==3.4.*+  default-language: GHC2021++library hs-hath-minio+  exposed-modules:+      Lib.Prelude+      Network.Minio+      Network.Minio.AdminAPI+      Network.Minio.API+      Network.Minio.APICommon+      Network.Minio.CopyObject+      Network.Minio.Credentials+      Network.Minio.Credentials.AssumeRole+      Network.Minio.Credentials.Types+      Network.Minio.Data+      Network.Minio.Data.ByteString+      Network.Minio.Data.Crypto+      Network.Minio.Data.Time+      Network.Minio.Errors+      Network.Minio.JsonParser+      Network.Minio.ListOps+      Network.Minio.PresignedOperations+      Network.Minio.PutObject+      Network.Minio.S3API+      Network.Minio.SelectAPI+      Network.Minio.Sign.V4+      Network.Minio.Utils+      Network.Minio.XmlCommon+      Network.Minio.XmlGenerator+      Network.Minio.XmlParser+  other-modules:+      Paths_hs_hath+  autogen-modules:+      Paths_hs_hath+  hs-source-dirs:+      vendor/minio-hs-1.7.0/src+  default-extensions:+      BangPatterns+      DerivingStrategies+      FlexibleContexts+      FlexibleInstances+      LambdaCase+      MultiParamTypeClasses+      MultiWayIf+      OverloadedStrings+      RankNTypes+      ScopedTypeVariables+      TupleSections+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      aeson >=1 && <3+    , async ==2.2.*+    , base >=4.7 && <5+    , base64 >=0 && <2+    , base64-bytestring ==1.*+    , binary ==0.*+    , bytestring >=0.11 && <0.13+    , case-insensitive ==1.*+    , co-log >=0.6 && <0.8+    , co-log-core ==0.3.*+    , co-log-polysemy >=0.0.1.5 && <0.0.2+    , conduit ==1.*+    , conduit-extra ==1.*+    , containers >=0.6 && <0.8+    , crypton >=0 && <2+    , crypton-connection ==0.*+    , crypton-x509 ==1.7.*+    , crypton-x509-store ==1.6.*+    , cryptostore ==0.3.*+    , data-default-class ==0.*+    , dhall ==1.42.*+    , digest ==0.*+    , directory ==1.*+    , exceptions ==0.10.*+    , extra >=1.7 && <1.9+    , filepath >=1.4 && <1.6+    , hex-text ==0.1.*+    , http-client ==0.*+    , http-client-tls ==0.*+    , http-conduit ==2.*+    , http-media ==0.8.*+    , http-types ==0.*+    , ini ==0.*+    , lrucache ==1.2.*+    , mason >=0.2.6 && <0.3+    , memory ==0.*+    , monad-control ==1.0.*+    , monad-loops ==0.4.*+    , mtl ==2.3.*+    , network >=3.1 && <3.3+    , network-uri ==2.*+    , optparse-applicative ==0.18.*+    , polysemy ==1.9.*+    , polysemy-zoo ==0.8.*+    , process ==1.6.*+    , relude ==1.*+    , resourcet ==1.*+    , retry ==0.*+    , safe-exceptions ==0.1.*+    , servant >=0.20.2 && <0.21+    , servant-client >=0.20.2 && <0.21+    , servant-client-core >=0.20.2 && <0.21+    , servant-server >=0.20.2 && <0.21+    , sqlite-simple ==0.4.*+    , stm ==2.5.*+    , string-interpolate ==0.3.*+    , suspend ==0.2.*+    , template-haskell >=2.19 && <2.24+    , text >=1 && <3+    , time ==1.*+    , time-units ==1.*+    , timers ==0.2.*+    , tls >=2.0 && <2.4+    , tls-session-manager >=0.0.5 && <0.1+    , transformers ==0.*+    , unix ==2.8.*+    , unliftio ==0.*+    , unliftio-core ==0.*+    , unordered-containers ==0.*+    , wai ==3.2.*+    , wai-extra ==3.1.*+    , warp ==3.4.*+    , xml-conduit ==1.*+  mixins:+      base hiding (Prelude)+    , base64 hiding (Data.ByteString.Base64)+    , relude (Relude as Prelude)+    , relude +  default-language: GHC2021++library hs-hath-placeholder+  exposed-modules:+      Control.Placeholder+  other-modules:+      Paths_hs_hath+  autogen-modules:+      Paths_hs_hath+  hs-source-dirs:+      vendor/placeholder-0/src+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      aeson >=2.1 && <2.3+    , async ==2.2.*+    , base >=4.7 && <4.22+    , base64 ==1.0.*+    , bytestring >=0.11 && <0.13+    , co-log >=0.6 && <0.8+    , co-log-core ==0.3.*+    , co-log-polysemy >=0.0.1.5 && <0.0.2+    , conduit ==1.3.*+    , containers >=0.6 && <0.8+    , crypton ==1.0.*+    , crypton-connection ==0.4.*+    , crypton-x509 ==1.7.*+    , crypton-x509-store ==1.6.*+    , cryptostore ==0.3.*+    , dhall ==1.42.*+    , directory ==1.3.*+    , exceptions ==0.10.*+    , extra >=1.7 && <1.9+    , filepath >=1.4 && <1.6+    , ghc-prim >=0 && <10+    , hex-text ==0.1.*+    , http-client ==0.7.*+    , http-client-tls ==0.3.*+    , http-conduit ==2.3.*+    , http-media ==0.8.*+    , http-types ==0.12.*+    , lrucache ==1.2.*+    , mason >=0.2.6 && <0.3+    , memory ==0.18.*+    , monad-control ==1.0.*+    , monad-loops ==0.4.*+    , mtl ==2.3.*+    , network >=3.1 && <3.3+    , optparse-applicative ==0.18.*+    , polysemy ==1.9.*+    , polysemy-zoo ==0.8.*+    , process ==1.6.*+    , relude ==1.2.*+    , resourcet ==1.3.*+    , safe-exceptions ==0.1.*+    , servant >=0.20.2 && <0.21+    , servant-client >=0.20.2 && <0.21+    , servant-client-core >=0.20.2 && <0.21+    , servant-server >=0.20.2 && <0.21+    , sqlite-simple ==0.4.*+    , stm ==2.5.*+    , string-interpolate ==0.3.*+    , suspend ==0.2.*+    , template-haskell >=2.19 && <2.24+    , text >=2.0 && <2.2+    , time >=1.12 && <1.15+    , timers ==0.2.*+    , tls >=2.0 && <2.4+    , tls-session-manager >=0.0.5 && <0.1+    , transformers ==0.6.*+    , unix ==2.8.*+    , unliftio ==0.2.*+    , unordered-containers ==0.2.*+    , wai ==3.2.*+    , wai-extra ==3.1.*+    , warp ==3.4.*+  default-language: GHC2021++library hs-hath-warp-tls+  exposed-modules:+      Network.Wai.Handler.WarpTLS+      Network.Wai.Handler.WarpTLS.Internal+  other-modules:+      Paths_hs_hath+  autogen-modules:+      Paths_hs_hath+  hs-source-dirs:+      vendor/warp-tls-3.4.13+  default-extensions:+      Strict+      StrictData+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      aeson >=2.1 && <2.3+    , async ==2.2.*+    , base >=4.7 && <4.22+    , base64 ==1.0.*+    , bytestring ==0.*+    , co-log >=0.6 && <0.8+    , co-log-core ==0.3.*+    , co-log-polysemy >=0.0.1.5 && <0.0.2+    , conduit ==1.3.*+    , containers >=0.6 && <0.8+    , crypton ==1.0.*+    , crypton-connection ==0.4.*+    , crypton-x509 ==1.7.*+    , crypton-x509-store ==1.6.*+    , cryptostore ==0.3.*+    , dhall ==1.42.*+    , directory ==1.3.*+    , exceptions ==0.10.*+    , extra >=1.7 && <1.9+    , filepath >=1.4 && <1.6+    , hex-text ==0.1.*+    , http-client ==0.7.*+    , http-client-tls ==0.3.*+    , http-conduit ==2.3.*+    , http-media ==0.8.*+    , http-types ==0.12.*+    , lrucache ==1.2.*+    , mason >=0.2.6 && <0.3+    , memory ==0.18.*+    , monad-control ==1.0.*+    , monad-loops ==0.4.*+    , mtl ==2.3.*+    , network ==3.*+    , optparse-applicative ==0.18.*+    , polysemy ==1.9.*+    , polysemy-zoo ==0.8.*+    , process ==1.6.*+    , recv ==0.*+    , relude ==1.2.*+    , resourcet ==1.3.*+    , safe-exceptions ==0.1.*+    , servant >=0.20.2 && <0.21+    , servant-client >=0.20.2 && <0.21+    , servant-client-core >=0.20.2 && <0.21+    , servant-server >=0.20.2 && <0.21+    , sqlite-simple ==0.4.*+    , stm ==2.5.*+    , streaming-commons ==0.*+    , string-interpolate ==0.3.*+    , suspend ==0.2.*+    , template-haskell >=2.19 && <2.24+    , text >=1 && <3+    , time >=1.12 && <1.15+    , timers ==0.2.*+    , tls >=1 && <3+    , tls-session-manager ==0.*+    , transformers ==0.6.*+    , unix ==2.8.*+    , unliftio ==0.2.*+    , unordered-containers ==0.2.*+    , wai ==3.*+    , wai-extra ==3.1.*+    , warp ==3.*+  default-language: GHC2021++executable hs-hath+  main-is: Main.hs+  hs-source-dirs:+      app+  default-extensions:+      NoImplicitPrelude+      TypeApplications+      OverloadedStrings+      ScopedTypeVariables+      QuasiQuotes+      LambdaCase+      ViewPatterns+      MultiParamTypeClasses+      GADTs+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -fpedantic-bottoms+  build-depends:+      aeson >=2.1 && <2.3+    , async ==2.2.*+    , base >=4.7 && <4.22+    , base64 ==1.0.*+    , bytestring >=0.11 && <0.13+    , co-log >=0.6 && <0.8+    , co-log-core ==0.3.*+    , co-log-polysemy >=0.0.1.5 && <0.0.2+    , conduit ==1.3.*+    , containers >=0.6 && <0.8+    , crypton ==1.0.*+    , crypton-connection ==0.4.*+    , crypton-x509 ==1.7.*+    , crypton-x509-store ==1.6.*+    , cryptostore ==0.3.*+    , dhall ==1.42.*+    , directory ==1.3.*+    , exceptions ==0.10.*+    , extra >=1.7 && <1.9+    , filepath >=1.4 && <1.6+    , hex-text ==0.1.*+    , hs-hath+    , http-client ==0.7.*+    , http-client-tls ==0.3.*+    , http-conduit ==2.3.*+    , http-media ==0.8.*+    , http-types ==0.12.*+    , lrucache ==1.2.*+    , mason >=0.2.6 && <0.3+    , memory ==0.18.*+    , monad-control ==1.0.*+    , monad-loops ==0.4.*+    , mtl ==2.3.*+    , network >=3.1 && <3.3+    , optparse-applicative ==0.18.*+    , polysemy ==1.9.*+    , polysemy-zoo ==0.8.*+    , process ==1.6.*+    , relude ==1.2.*+    , resourcet ==1.3.*+    , safe-exceptions ==0.1.*+    , servant >=0.20.2 && <0.21+    , servant-client >=0.20.2 && <0.21+    , servant-client-core >=0.20.2 && <0.21+    , servant-server >=0.20.2 && <0.21+    , sqlite-simple ==0.4.*+    , stm ==2.5.*+    , string-interpolate ==0.3.*+    , suspend ==0.2.*+    , template-haskell >=2.19 && <2.24+    , text >=2.0 && <2.2+    , time >=1.12 && <1.15+    , timers ==0.2.*+    , tls >=2.0 && <2.4+    , tls-session-manager >=0.0.5 && <0.1+    , transformers ==0.6.*+    , unix ==2.8.*+    , unliftio ==0.2.*+    , unordered-containers ==0.2.*+    , wai ==3.2.*+    , wai-extra ==3.1.*+    , warp ==3.4.*+  default-language: GHC2021++executable migrate-to-r2+  main-is: Migrate.hs+  hs-source-dirs:+      app+  default-extensions:+      NoImplicitPrelude+      TypeApplications+      OverloadedStrings+      ScopedTypeVariables+      QuasiQuotes+      LambdaCase+      ViewPatterns+      MultiParamTypeClasses+      GADTs+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -main-is Migrate+  build-depends:+      aeson >=2.1 && <2.3+    , async ==2.2.*+    , base >=4.7 && <4.22+    , base64 ==1.0.*+    , bytestring >=0.11 && <0.13+    , co-log >=0.6 && <0.8+    , co-log-core ==0.3.*+    , co-log-polysemy >=0.0.1.5 && <0.0.2+    , conduit ==1.3.*+    , containers >=0.6 && <0.8+    , crypton ==1.0.*+    , crypton-connection ==0.4.*+    , crypton-x509 ==1.7.*+    , crypton-x509-store ==1.6.*+    , cryptostore ==0.3.*+    , dhall ==1.42.*+    , directory+    , exceptions ==0.10.*+    , extra >=1.7 && <1.9+    , filepath >=1.4 && <1.6+    , hex-text ==0.1.*+    , hs-hath+    , hs-hath-minio+    , http-client ==0.7.*+    , http-client-tls ==0.3.*+    , http-conduit ==2.3.*+    , http-media ==0.8.*+    , http-types ==0.12.*+    , lrucache ==1.2.*+    , mason >=0.2.6 && <0.3+    , memory ==0.18.*+    , monad-control ==1.0.*+    , monad-loops ==0.4.*+    , mtl ==2.3.*+    , network >=3.1 && <3.3+    , optparse-applicative+    , polysemy ==1.9.*+    , polysemy-zoo ==0.8.*+    , process ==1.6.*+    , relude ==1.2.*+    , resourcet ==1.3.*+    , safe-exceptions ==0.1.*+    , servant >=0.20.2 && <0.21+    , servant-client >=0.20.2 && <0.21+    , servant-client-core >=0.20.2 && <0.21+    , servant-server >=0.20.2 && <0.21+    , sqlite-simple ==0.4.*+    , stm ==2.5.*+    , string-interpolate ==0.3.*+    , suspend ==0.2.*+    , template-haskell >=2.19 && <2.24+    , text >=2.0 && <2.2+    , time >=1.12 && <1.15+    , timers ==0.2.*+    , tls >=2.0 && <2.4+    , tls-session-manager >=0.0.5 && <0.1+    , transformers ==0.6.*+    , unix ==2.8.*+    , unliftio ==0.2.*+    , unordered-containers ==0.2.*+    , wai ==3.2.*+    , wai-extra ==3.1.*+    , warp ==3.4.*+  default-language: GHC2021++test-suite hs-hath-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      FilesystemSpec+      Integration+      MockRPC+      R2Spec+      Paths_hs_hath+  autogen-modules:+      Paths_hs_hath+  hs-source-dirs:+      test+  default-extensions:+      NoImplicitPrelude+      TypeApplications+      OverloadedStrings+      ScopedTypeVariables+      QuasiQuotes+      LambdaCase+      ViewPatterns+      MultiParamTypeClasses+      GADTs+  ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      aeson >=2.1 && <2.3+    , async ==2.2.*+    , base >=4.7 && <4.22+    , base64 ==1.0.*+    , bytestring >=0.11 && <0.13+    , co-log >=0.6 && <0.8+    , co-log-core ==0.3.*+    , co-log-polysemy >=0.0.1.5 && <0.0.2+    , conduit ==1.3.*+    , containers >=0.6 && <0.8+    , crypton ==1.0.*+    , crypton-connection ==0.4.*+    , crypton-x509 ==1.7.*+    , crypton-x509-store ==1.6.*+    , cryptostore ==0.3.*+    , dhall ==1.42.*+    , directory+    , exceptions ==0.10.*+    , extra >=1.7 && <1.9+    , filepath+    , hex-text ==0.1.*+    , hs-hath+    , hspec ==2.11.*+    , http-client ==0.7.*+    , http-client-tls ==0.3.*+    , http-conduit ==2.3.*+    , http-media ==0.8.*+    , http-types ==0.12.*+    , lrucache ==1.2.*+    , mason >=0.2.6 && <0.3+    , memory ==0.18.*+    , monad-control ==1.0.*+    , monad-loops ==0.4.*+    , mtl ==2.3.*+    , network >=3.1 && <3.3+    , optparse-applicative ==0.18.*+    , polysemy ==1.9.*+    , polysemy-zoo ==0.8.*+    , process ==1.6.*+    , relude ==1.2.*+    , resourcet ==1.3.*+    , safe-exceptions ==0.1.*+    , servant >=0.20.2 && <0.21+    , servant-client >=0.20.2 && <0.21+    , servant-client-core >=0.20.2 && <0.21+    , servant-server >=0.20.2 && <0.21+    , sqlite-simple ==0.4.*+    , stm ==2.5.*+    , string-interpolate ==0.3.*+    , suspend ==0.2.*+    , template-haskell >=2.19 && <2.24+    , temporary+    , text >=2.0 && <2.2+    , time >=1.12 && <1.15+    , timers ==0.2.*+    , tls >=2.0 && <2.4+    , tls-session-manager >=0.0.5 && <0.1+    , transformers ==0.6.*+    , unix ==2.8.*+    , unliftio ==0.2.*+    , unordered-containers ==0.2.*+    , wai ==3.2.*+    , wai-extra ==3.1.*+    , warp ==3.4.*+  default-language: GHC2021
+ src/CLI.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE RecordWildCards #-}++module CLI ( Options(..), parseOptions, applyOptionsToConfig ) where++import           Options.Applicative++import           Relude++import           Types               ( ClientConfig(..) )++-- | Command line options+data Options+  = Options+  { optConfigPath        :: !FilePath      -- ^ Path to configuration file+  , optDownloadDir       :: !(Maybe Text)  -- ^ Override download directory+  , optCachePath         :: !(Maybe Text)  -- ^ Override cache path+  , optSkipStartupVerify :: !Bool         -- ^ Skip startup cache verification+  , optDisableRateLimit  :: !Bool          -- ^ Disable rate limiting (for NAT/proxy scenarios)+  , optTrustProxyHeaders :: !Bool         -- ^ Trust X-Forwarded-For header for real IP+  , optValidateConfig    :: !Bool          -- ^ Validate configuration and exit+  , optShowVersion       :: !Bool          -- ^ Show version information+  }+  deriving ( Show )++-- | Parse command line options+parseOptions :: IO Options+parseOptions = execParser opts+  where+    opts+      = info+        (optionsParser <**> helper)+        (fullDesc+         <> progDesc "Haskell implementation of the Hath client"+         <> header "hs-hath - A Hentai@Home client in Haskell")++-- | Options parser+optionsParser :: Parser Options+optionsParser+  = Options+  <$> strOption+    (long "config"+     <> short 'c'+     <> metavar "FILE"+     <> value "./client-login"+     <> help "Configuration file path (default: ./client-login)")+  <*> optional+    (strOption+       (long "download-dir"+        <> short 'd'+        <> metavar "DIR"+        <> help "Override download directory from config"))+  <*> optional+    (strOption (long "cache-path" <> metavar "PATH" <> help "Override cache path from config"))+  <*> switch (long "skip-startup-verify" <> help "Skip cache integrity verification at startup")+  <*> switch+    (long "disable-rate-limit"+     <> help "Disable rate limiting (use when behind NAT/proxy that doesn't forward real IP)")+  <*> switch+    (long "trust-proxy-headers"+     <> help "Trust X-Forwarded-For header for real client IP (use when behind trusted proxy)")+  <*> switch (long "validate-config" <> help "Validate configuration and exit")+  <*> switch (long "version" <> short 'v' <> help "Show version information and exit")++-- | Apply CLI options to client configuration+applyOptionsToConfig :: Options -> ClientConfig -> ClientConfig+applyOptionsToConfig Options { .. } config+  = config { downloadDir = fromMaybe (downloadDir config) optDownloadDir+           , cachePath   = fromMaybe (cachePath config) optCachePath+           }
+ src/FileVerification.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++module FileVerification+  ( -- * Types+    VerificationResult(..)+  , VerificationStats(..)+    -- * Verification Operations+  , verifyFile+  , verifyAllFiles+  , verifyRandomFile+  , shouldVerifyFile+    -- * Effect+  , FileVerification(..)+  , runFileVerification+  , runFileVerificationIO+    -- * Constants+  , verificationCooldownSeconds+  , minVerificationIntervalSeconds+  ) where++import           Data.Time.Clock        ( NominalDiffTime, UTCTime, diffUTCTime, getCurrentTime )++import           Database.SQLite.Simple++import           Polysemy+import           Polysemy.Operators++import           Relude++import           Storage.Database       ( FileRecord(..) )++import           Types                  ( FileURI(..), parseFileURI )++import           Utils                  ( hash )++-- | Result of verifying a single file+data VerificationResult+  = VerificationOK+  | VerificationCorrupted {-# UNPACK #-} !Text  -- ^ File ID of corrupted file+  | VerificationMissing {-# UNPACK #-} !Text    -- ^ File ID that should exist but doesn't+  deriving ( Show, Eq, Generic )++-- | Statistics from a verification run+data VerificationStats+  = VerificationStats { verifiedCount    :: {-# UNPACK #-} !Int+                      , corruptedCount   :: {-# UNPACK #-} !Int+                      , missingCount     :: {-# UNPACK #-} !Int+                      , deletedCount     :: {-# UNPACK #-} !Int+                      , verificationTime :: {-# UNPACK #-} !NominalDiffTime+                      }+  deriving ( Show, Eq, Generic )++instance Semigroup VerificationStats where+  a <> b+    = VerificationStats+    { verifiedCount    = verifiedCount a + verifiedCount b+    , corruptedCount   = corruptedCount a + corruptedCount b+    , missingCount     = missingCount a + missingCount b+    , deletedCount     = deletedCount a + deletedCount b+    , verificationTime = verificationTime a + verificationTime b+    }++instance Monoid VerificationStats where+  mempty = VerificationStats 0 0 0 0 0++-- | Cooldown between verifying the same file (1 week in seconds)+verificationCooldownSeconds :: Int64+verificationCooldownSeconds = 7 * 24 * 60 * 60++-- | Minimum interval between any verification checks (2 seconds)+minVerificationIntervalSeconds :: NominalDiffTime+minVerificationIntervalSeconds = 2++-- | Check if a file should be verified based on last verification time+shouldVerifyFile :: UTCTime -> UTCTime -> Bool+shouldVerifyFile lastVerified now+  = diffUTCTime now lastVerified > fromIntegral verificationCooldownSeconds++-- | Verify a single file's integrity by comparing stored hash with computed hash+verifyFile :: FileRecord -> VerificationResult+verifyFile record+  = let+      storedFileId = fileRecordFileId record+      content      = fileRecordBytes record+      uri          = parseFileURI (encodeUtf8 storedFileId)+      -- Extract expected hash from FileURI (already ByteString)+      -- FileURI format: hash-size-xres-yres-ext+      expectedHash = fileHash uri+      computedHash = hash @ByteString content+    in +      if expectedHash == computedHash+        then VerificationOK+        else VerificationCorrupted storedFileId++-- | Effect for file verification operations+data FileVerification m a where+  -- | Verify all files in the cache (for startup)+  VerifyAllFilesE :: FileVerification m VerificationStats+  -- | Verify a single random file (for periodic checks)+  VerifyRandomFileE :: FileVerification m (Maybe VerificationResult)+  -- | Get the last verification time+  GetLastVerificationTime :: FileVerification m (Maybe UTCTime)+  -- | Update the last verification time+  SetLastVerificationTime :: UTCTime -> FileVerification m ()++makeSem ''FileVerification++-- | Run file verification with SQLite connection+runFileVerification :: Member (Embed IO) r+                    => Connection+                    -> TVar (Maybe UTCTime)  -- ^ Last verification time+                    -> FileVerification : r @> a+                    -> r @> a+runFileVerification conn lastVerifVar = interpret $ \case+  VerifyAllFilesE           -> embed @IO $ verifyAllFiles conn++  VerifyRandomFileE         -> embed @IO $ verifyRandomFile conn lastVerifVar++  GetLastVerificationTime   -> embed @IO $ readTVarIO lastVerifVar++  SetLastVerificationTime t -> embed @IO $ atomically $ writeTVar lastVerifVar (Just t)++-- | Verify all files in the database using streaming to avoid loading all into memory+verifyAllFiles :: Connection -> IO VerificationStats+verifyAllFiles conn = do+  startTime <- getCurrentTime++  -- Use IORefs to accumulate results while streaming+  statsRef <- newIORef $! VerificationStats 0 0 0 0 0+  toDeleteRef <- newIORef ([] :: [ Text ])++  -- Stream files one at a time using fold_ to avoid loading all bytes into memory+  fold_+    conn+    "SELECT lru_counter, s4, file_id, file_name, bytes FROM files"+    ()+    (\() record -> do+       case verifyFile record of+         VerificationOK -> modifyIORef' statsRef $ \s -> let+             !v = verifiedCount s + 1+           in +             s { verifiedCount = v }+         VerificationCorrupted fileId -> do+           modifyIORef' statsRef $ \s -> let+               !c = corruptedCount s + 1+             in +               s { corruptedCount = c }+           modifyIORef' toDeleteRef (fileId :)+         VerificationMissing fileId -> do+           modifyIORef' statsRef $ \s -> let+               !m = missingCount s + 1+             in +               s { missingCount = m }+           modifyIORef' toDeleteRef (fileId :))++  -- Delete corrupted files+  toDelete <- readIORef toDeleteRef+  forM_ toDelete $ \fileId -> execute conn "DELETE FROM files WHERE file_id = ?" (Only fileId)++  endTime <- getCurrentTime+  let !elapsed = diffUTCTime endTime startTime++  stats <- readIORef statsRef+  pure $! stats { deletedCount = length toDelete, verificationTime = elapsed }++-- | Verify a random file from the cache+-- Returns Nothing if verification is on cooldown or no files exist+verifyRandomFile :: Connection -> TVar (Maybe UTCTime) -> IO (Maybe VerificationResult)+verifyRandomFile conn lastVerifVar = do+  now <- getCurrentTime+  lastVerif <- readTVarIO lastVerifVar++  -- Check cooldown+  case lastVerif of+    Just t+      | diffUTCTime now t < minVerificationIntervalSeconds -> pure Nothing  -- On cooldown+    _      -> do+      -- Get a random file that hasn't been verified recently+      -- We use RANDOM() for simplicity; production might want better randomization+      maybeRecord <- listToMaybe+        <$> query_+          conn+          "SELECT lru_counter, s4, file_id, file_name, bytes FROM files ORDER BY RANDOM() LIMIT 1"++      case maybeRecord of+        Nothing     -> pure Nothing  -- No files in cache+        Just record -> do+          -- Update last verification time+          atomically $ writeTVar lastVerifVar (Just now)++          -- Force evaluation of the result to ensure file bytes are processed+          -- before the record goes out of scope+          let !result = verifyFile record++          -- If corrupted, delete the file+          case result of+            VerificationCorrupted fileId -> do+              execute conn "DELETE FROM files WHERE file_id = ?" (Only fileId)+              pure $! Just result+            _ -> pure $! Just result++-- | Run file verification in IO+runFileVerificationIO+  :: Connection -> TVar (Maybe UTCTime) -> [ FileVerification, Embed IO, Final IO ] @> a -> IO a+runFileVerificationIO conn lastVerifVar+  = runFinal . embedToFinal . runFileVerification conn lastVerifVar
+ src/HathNetwork/Genesis.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}++module HathNetwork.Genesis+  ( Genesis(..)+  , fetchSettings+  , fetchCertificate+  , runGenesis+  , runGenesisIO+  ) where++import           Data.X509          ( CertificateChain, PrivKey )++import           Interface.API++import           Polysemy+import           Polysemy.Error     ( Error, errorToIOFinal )+import           Polysemy.Operators+import           Polysemy.Reader    ( Reader, runReader )++import           Relude             hiding ( Reader, runReader )++import           Servant.Client     ( ClientError )++import           Types++data Genesis m a where+  FetchSettings :: Genesis m HathSettings+  FetchCertificate :: Genesis m ( CertificateChain, PrivKey )++makeSem ''Genesis++{-# INLINE runGenesis #-}+runGenesis :: Members '[ Embed IO, Error RPCError, Reader ClientConfig, EHentaiAPI ] r+           => Genesis : r @> a+           -> Sem r a+runGenesis = interpret $ \case+  FetchSettings    -> getSettings+  FetchCertificate -> downloadCertificates++{-# INLINE runGenesisIO #-}+runGenesisIO+  :: ClientConfig+  -> [ Genesis+     , EHentaiAPI+     , Reader ClientConfig+     , Error ClientError+     , Error RPCError+     , Embed IO+     , Final IO+     ] @> a+  -> IO (Either RPCError (Either ClientError a))+runGenesisIO cfg+  = runFinal+  . embedToFinal @IO+  . errorToIOFinal @RPCError+  . errorToIOFinal @ClientError+  . runReader cfg+  . runEHentaiAPI+  . runGenesis
+ src/HathNetwork/RPC.hs view
@@ -0,0 +1,113 @@+{-# LANGUAGE DataKinds #-}++{-# LANGUAGE DeriveGeneric #-}++{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}++module HathNetwork.RPC+  ( RPCResponse(..)+  , parseRPCResponse+  , getPayload+  , RPC(..)+  , serverStat+  , stillAlive+  , clientStart+  , clientStop+  , clientLogin+  , checkGalleryTask+  , notifyGalleryCompletion+  , fetchGalleryFile+  , runRPC+  , runRPCIO+  ) where++import           Colog              ( Message, Severity(Info), richMessageAction )+import           Colog.Polysemy     ( Log, runLogAction )++import           Interface.API      hiding ( StillAlive )++import           Polysemy+import           Polysemy.Error     ( Error, errorToIOFinal )+import           Polysemy.Operators+import           Polysemy.Reader    ( Reader, runReader )++import           Relude             hiding ( Reader, ask, runReader )++import           Servant.Client     ( ClientError )++import           Types++import           Utils              ( log )++data RPC m a where+  -- | Test if remote server is running+  ServerStat :: RPC m Bool+  -- | Heartbeat+  StillAlive :: RPC m ()+  -- | Notify server that client is ready to start a session+  ClientStart :: RPC m Bool+  -- | Notify server that client is stopping a session+  ClientStop :: RPC m Bool+  -- | Login to remote server+  ClientLogin :: RPC m HathSettings+  -- | Check if there is a gallery task to download+  CheckGalleryTask :: RPC m (Maybe GalleryMetadata)+  -- | Notify server that a gallery task has been completed+  NotifyGalleryCompletion :: GalleryMetadata -> RPC m ()+  -- | Fetch gallery files+  FetchGalleryFile :: ( GalleryMetadata, [ GalleryFile ] )+    -> RPC m [ ( GalleryFile, ByteString ) ] -- ^ Successfully downloaded files++makeSem ''RPC++runRPC :: forall a r.+       Members '[ Embed IO, Error RPCError, Reader ClientConfig, EHentaiAPI, Log Message ] r+       => RPC : r @> a+       -> r @> a+runRPC = interpret $ \case+  ServerStat -> do+    b <- checkServerStatus+    log Info $ "Server availablity: " <> show b+    return b+  StillAlive -> heartbeat+  ClientStart -> log Info "Trying to start a session" >> startListening+  ClientStop -> log Info "Stopping a session" >> stopListening+  ClientLogin -> log Info "Logging in" >> login+  CheckGalleryTask -> log Info "Checking for a gallery task" >> nextGalleryTask+  NotifyGalleryCompletion+    metadata -> log Info "Notifying server that a gallery task has been completed"+    >> completeGalleryTask metadata+  FetchGalleryFile+    ( metadata, files ) -> log Info "Fetching gallery files" >> phi metadata [] files+  where+    phi _ acc [] = pure acc+    phi metadata acc (x : xs) = do+      maybeContent <- downloadGalleryFile metadata x+      case maybeContent of+        Just content -> phi metadata (( x, content ) : acc) xs+        Nothing      -> phi metadata acc xs++{-# INLINE runRPCIO #-}+runRPCIO :: ClientConfig+         -> [ RPC+            , EHentaiAPI+            , Log Message+            , Reader ClientConfig+            , Embed IO+            , Error ClientError+            , Error RPCError+            , Final IO+            ] @> a+         -> IO (Either RPCError (Either ClientError a))+runRPCIO cfg+  = runFinal+  . errorToIOFinal @RPCError+  . errorToIOFinal @ClientError+  . embedToFinal @IO+  . runReader cfg+  . runLogAction @IO richMessageAction+  . runEHentaiAPI+  . runRPC+
+ src/Interface/API.hs view
@@ -0,0 +1,474 @@+{-# LANGUAGE DataKinds #-}++{-# LANGUAGE RecordWildCards #-}++{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeOperators #-}++module Interface.API+  (   -- * H@H Client Exposed API+    API+  , api+  , ServerCommand(..)+  , DynCT+  , WithDynamicContentType(..)+    -- * EHentai RPC+  , EHentaiAPI(..)+  , ehRPC+  , RPCParams(..)+  , emptyRPCParams+  , runEHentaiAPI+  , checkServerStatus+  , heartbeat+  , startListening+  , stopListening+  , login+  , downloadCertificates+  , getSettings+  , nextGalleryTask+  , completeGalleryTask+  , downloadGalleryFile+  , reportFailures+  , fetchResource+  , fetchBlacklist+  , runEHentaiAPIIO+  ) where++import           Crypto.Store.PKCS12      ( readP12FileFromMemory+                                          , recover+                                          , recoverAuthenticated+                                          , toCredential+                                          , toProtectionPassword+                                          )++import qualified Data.ByteString.Char8    as BSC+import qualified Data.ByteString.Lazy     as LBS+import           Data.String.Interpolate  ( i )+import qualified Data.Text                as T+import           Data.Time.Clock.System   ( SystemTime(systemSeconds), getSystemTime )+import           Data.X509                ( CertificateChain, PrivKey )++import qualified Mason.Builder            as BD++import           Network.HTTP.Client      ( HttpException+                                          , Manager+                                          , Request(responseTimeout, host, requestHeaders)+                                          , Response(responseBody)+                                          , defaultManagerSettings+                                          , newManager+                                          , parseRequest+                                          , responseTimeoutMicro+                                          )+import           Network.HTTP.Media       ( (//), (/:) )+import           Network.HTTP.Simple      ( httpLbs )++import           Polysemy+import           Polysemy.Error           ( Error, errorToIOFinal, throw )+import           Polysemy.Operators+import           Polysemy.Reader          ( Reader, ask, runReader )+import           Polysemy.State           ( modify, runState )++import           Relude                   hiding ( Reader+                                                 , State+                                                 , ask+                                                 , modify+                                                 , runReader+                                                 , runState+                                                 )++import           Servant                  hiding ( addHeader )+import           Servant.API.ContentTypes ( AllCTRender(handleAcceptH) )+import           Servant.Client           ( BaseUrl(BaseUrl)+                                          , ClientEnv(makeClientRequest)+                                          , ClientError+                                          , ClientM+                                          , Scheme(Http)+                                          , client+                                          , defaultMakeClientRequest+                                          , mkClientEnv+                                          , runClientM+                                          )+import           Servant.Client.Core      ( addHeader )++import           System.IO.Unsafe         ( unsafePerformIO )++import           Types                    ( ClientConfig+                                          , ClientConfig(..)+                                          , FileURI(..)+                                          , GalleryFile(..)+                                          , GalleryMetadata(galleryMinXRes, galleryID)+                                          , HathSettings+                                          , RPCError(CertificateFailure)+                                          , RPCResponse(statusCode)+                                          , emptyMetadata+                                          , hentaiHeader+                                          , parseMetadata+                                          , parseRPCResponse+                                          , parseRPCResponse'+                                          , parseSettings+                                          )++import           UnliftIO                 ( try )++import           Utils                    ( hash )++-- | Available server commands+data ServerCommand+  = StillAlive        -- ^ Heartbeat request+  | ThreadedProxyTest -- ^ Multi-threaded speed test+  | SpeedTest        -- ^ Speed test+  | RefreshSettings  -- ^ Reloads hath configuration+  | StartDownloader  -- ^ Initiates gallery downloader+  | RefreshCerts     -- ^ Updates SSL certificates+  deriving ( Show, Eq )++-- Custom type conversion for ServerCommand+instance FromHttpApiData ServerCommand where+  {-# INLINE parseUrlPiece #-}+  parseUrlPiece = \case+    "still_alive" -> Right StillAlive+    "threaded_proxy_test" -> Right ThreadedProxyTest+    "speed_test" -> Right SpeedTest+    "refresh_settings" -> Right RefreshSettings+    "start_downloader" -> Right StartDownloader+    "refresh_certs" -> Right RefreshCerts+    cmd -> Left $ "Invalid command: " <> cmd++data DynCT+  deriving ( Typeable )++instance MimeRender DynCT ByteString where+  {-# INLINE mimeRender #-}+  mimeRender _ = LBS.fromStrict++instance Accept DynCT where+  {-# INLINE contentType #-}+  contentType _ = ""++data WithDynamicContentType+  = WithDynamicContentType+  { contentType :: {-# UNPACK #-} !ByteString, content :: {-# UNPACK #-} !ByteString }++instance MimeRender DynCT WithDynamicContentType where+  {-# INLINE mimeRender #-}+  mimeRender _ = LBS.fromStrict . content++instance AllCTRender '[ DynCT ] WithDynamicContentType where+  {-# INLINE handleAcceptH #-}+  handleAcceptH _ _ (WithDynamicContentType ct content)+    = Just ( LBS.fromStrict ct, LBS.fromStrict content )++data SpeedTest+  deriving ( Typeable )++instance MimeRender SpeedTest ByteString where+  {-# INLINE mimeRender #-}+  mimeRender _ = LBS.fromStrict++instance Accept SpeedTest where+  {-# INLINE contentTypes #-}+  contentTypes _+    = "text" // "html" /: ( "charset", "iso-8859-1" )+    :| [ "image" // "gif", "image" // "jpeg", "*" // "*" /: ( "q", ".2" ) ]++-- floskell-disable+-- API type definitions+type API+    =    "favicon.ico" :> Get '[PlainText] NoContent+    :<|> "robots.txt" :> Get '[PlainText] Text+    :<|> "h"+        :> Capture "info" Text+        :> Capture "opts" Text+        :> Capture "filename" Text+        :> Get '[DynCT] (Headers '[Header "Content-Length" Int] WithDynamicContentType)+    :<|> "metrics" :> Get '[PlainText] Text+    :<|> "servercmd"+        :> Capture "command" ServerCommand+        :> Capture "additional" Text+        :> Capture "time" Int+        :> Capture "key" Text+        :> StreamGet NoFraming OctetStream (Headers '[Header "Content-Length" Int] (SourceIO ByteString))+    :<|> "t"+        :> Capture "testsize" Int+        :> Capture "testtime" Int64+        :> Capture "testkey" Text+        :> Capture "nothing" Text+        :> StreamGet NoFraming SpeedTest (Headers '[Header "Content-Length" Int] (SourceIO ByteString))+    :<|> "admin"+        :> "settings"+        :> Get '[PlainText] Text+    :<|> Raw  -- This will catch all other routes including HEAD requests+-- floskell-enable++-- API specification+api :: Proxy API+api = Proxy++-- floskell-disable+type EHAPI =+       QueryParam "act" Text+  :>   QueryParam "cid" Text+  :>   QueryParam "add" Text+  :>   QueryParam "acttime" Text+  :>   QueryParam "actkey" Text+  :>   QueryParam "clientbuild" Text+  :>   Get '[PlainText,OctetStream] ByteString+-- floskell-enable++instance MimeUnrender PlainText ByteString where+  {-# INLINE mimeUnrender #-}+  mimeUnrender _ = mimeUnrender (Proxy @OctetStream)++data RPCParams+  = RPCParams { act         :: {-# UNPACK #-} !(Maybe Text)+              , cid         :: {-# UNPACK #-} !(Maybe Text)+              , add         :: {-# UNPACK #-} !(Maybe Text)+              , acttime     :: {-# UNPACK #-} !(Maybe Text)+              , actkey      :: {-# UNPACK #-} !(Maybe Text)+              , clientbuild :: {-# UNPACK #-} !(Maybe Text)+              }++emptyRPCParams :: RPCParams+emptyRPCParams+  = RPCParams { act         = Nothing+              , cid         = Nothing+              , add         = Nothing+              , acttime     = Nothing+              , actkey      = Nothing+              , clientbuild = Nothing+              }++ehAPI :: Proxy EHAPI+ehAPI = Proxy++ehAPIM :: RPCParams -> ClientM ByteString+ehAPIM RPCParams { .. } = client ehAPI act cid add acttime actkey clientbuild++data EHentaiAPI m a where+  EhRPC :: RPCParams -> EHentaiAPI m ByteString+  EhGallery :: RPCParams -> EHentaiAPI m ByteString++makeSem ''EHentaiAPI++{-# NOINLINE ehHttpManager #-}+ehHttpManager :: Manager+ehHttpManager = unsafePerformIO $ newManager defaultManagerSettings++{-# INLINE runEHentaiAPIIO #-}+runEHentaiAPIIO :: ClientConfig+                -> [ EHentaiAPI, Reader ClientConfig, Error ClientError, Embed IO, Final IO ] @> a+                -> IO (Either ClientError a)+runEHentaiAPIIO cfg+  = runFinal . embedToFinal . errorToIOFinal @ClientError . runReader cfg . runEHentaiAPI++{-# INLINE runEHentaiAPI #-}+runEHentaiAPI :: forall a r. Members [ Embed IO, Error ClientError, Reader ClientConfig ] r+              => EHentaiAPI : r @> a+              -> r @> a+runEHentaiAPI m = do+  cfg <- ask @ClientConfig+  currentTime <- embed (systemSeconds <$> getSystemTime)+  -- Internal: Override RPC host via HATH_RPC_HOST environment variable+  -- Format: "host" or "host:port" (default port: 80)+  rpcHostOverride <- embed (lookupEnv "HATH_RPC_HOST" :: IO (Maybe String))+  let ( rpcHostName, rpcPort ) = case rpcHostOverride of+        Nothing      -> ( "rpc.hentaiathome.net", 80 )+        Just hostStr -> case break (== ':') hostStr of+          ( h, ':' : p ) -> ( h, fromMaybe 80 (readMaybe p) )+          ( h, _ )       -> ( h, 80 )+  let k :: RPCParams -> String -> Sem r ByteString+      k params endpoint+        = either throw pure+        =<< embed+          (runClientM+             (ehAPIM+                params { acttime     = Just (show currentTime)+                       , clientbuild = Just (version cfg)+                       , actkey      = Just $ makeKey params cfg currentTime+                       , cid         = Just (clientId cfg)+                       })+             (mkClientEnv ehHttpManager (BaseUrl Http rpcHostName rpcPort endpoint))+             { makeClientRequest = \baseUrl req -> do+                 servantReq <- defaultMakeClientRequest+                   baseUrl+                   (foldr (uncurry (addHeader @Text)) req hentaiHeader)+                 pure servantReq { responseTimeout = responseTimeoutMicro rpcTimeout } })+      {-# INLINE k #-}+  interpret (\case+               EhRPC params     -> k params "/15/rpc"+               EhGallery params -> k params "/15/dl") m+  where+    rpcTimeout :: Int+    rpcTimeout = 60 * 1000000  -- 60 seconds in microseconds++    makeKey :: RPCParams -> ClientConfig -> Int64 -> Text+    makeKey params cfg time+      = let+          act'      = fromMaybe "" (act params)+          add'      = fromMaybe "" (add params)+          clientId' = clientId cfg+          key'      = key cfg+        in +          -- [i|hentai@home-#{act'}-#{add'}-#{clientId'}-#{time}-#{key'}|]+          hash+          $ BD.toStrictByteString+            ("hentai@home-"+             <> BD.textUtf8 act'+             <> "-"+             <> BD.textUtf8 add'+             <> "-"+             <> BD.textUtf8 clientId'+             <> "-"+             <> BD.int64Dec time+             <> "-"+             <> BD.textUtf8 key')++{-# INLINE checkServerStatus #-}+-- checkServerStatus :: Member EHentaiAPI r => Sem r Bool+checkServerStatus :: [ EHentaiAPI, Error RPCError ] >@> Bool+checkServerStatus = do+  res <- ehRPC emptyRPCParams { act = Just "server_stat" }+  case parseRPCResponse res of+    Left _  -> return False+    Right _ -> return True++{-# INLINE heartbeat #-}+heartbeat :: EHentaiAPI -@> ()+heartbeat = void $ ehRPC emptyRPCParams { act = Just "still_alive" }++{-# INLINE startListening #-}+startListening :: EHentaiAPI -@> Bool+startListening = do+  res <- ehRPC emptyRPCParams { act = Just "client_start" }+  case parseRPCResponse res of+    Left _  -> return False+    Right x -> return $ statusCode x == "OK"++{-# INLINE stopListening #-}+stopListening :: EHentaiAPI -@> Bool+stopListening = do+  res <- ehRPC emptyRPCParams { act = Just "client_stop" }+  case parseRPCResponse res of+    Left _  -> return False+    Right _ -> return True++{-# INLINE login #-}+login :: [ EHentaiAPI, Error RPCError ] >@> HathSettings+login = do+  x <- ehRPC emptyRPCParams { act = Just "client_login" }+  parseSettings <$> parseRPCResponse' x++downloadCertificates+  :: [ EHentaiAPI, Error RPCError, Reader ClientConfig ] >@> ( CertificateChain, PrivKey )+downloadCertificates = do+  bytes <- ehRPC emptyRPCParams { act = Just "get_cert" }+  cfg <- ask @ClientConfig+  fromPkcs12 cfg bytes+  where+    fromPkcs12 (encodeUtf8 . key -> passcode) bytes = case maybeCred of+      Left err       -> throw $ CertificateFailure $ show err+      Right Nothing  -> throw $ CertificateFailure "no credential"+      Right (Just c) -> pure c+      where+        maybeCred = do+          p12 <- readP12FileFromMemory bytes+          ( _, pkcs12 ) <- recoverAuthenticated passcode p12+          recover (toProtectionPassword passcode) (toCredential pkcs12)++{-# INLINE getSettings #-}+getSettings :: [ EHentaiAPI, Error RPCError ] >@> HathSettings+getSettings = do+  x <- ehRPC emptyRPCParams { act = Just "client_settings" }+  parseSettings <$> parseRPCResponse' x++{-# INLINE nextGalleryTask #-}+nextGalleryTask :: EHentaiAPI -@> Maybe GalleryMetadata+nextGalleryTask = do+  m <- parseMetadata <$> ehGallery emptyRPCParams { act = Just "fetchqueue" }+  if m == emptyMetadata+    then return Nothing+    else return $ Just m++{-# INLINE completeGalleryTask #-}+completeGalleryTask :: GalleryMetadata -> EHentaiAPI -@> ()+completeGalleryTask metadata+  = void+  $ ehGallery+    emptyRPCParams+    { act = Just "fetchqueue", add = Just [i|#{galleryID metadata};#{galleryMinXRes metadata}|] }++downloadGalleryFile+  :: GalleryMetadata+  -> GalleryFile+  -> [ EHentaiAPI, Reader ClientConfig, Error RPCError, Embed IO ] >@> Maybe ByteString+downloadGalleryFile metadata file = do+  ( failures, maybeContent ) <- runState @[ Text ] [] (operate 0)+  case maybeContent of+    Just content -> return $ Just content+    Nothing      -> do+      reportFailures failures+      return Nothing+  where+    download url = case parseRequest url of+      Nothing  -> pure Nothing+      Just req -> embed (try @IO @HttpException $ LBS.toStrict . responseBody <$> httpLbs @IO req)+        >>= \case+          Left _      -> pure Nothing+          Right bytes -> do+            if hash bytes /= galleryFileHash file+              then do+                modify+                  @[ Text ]+                  ([i|#{host req}-#{galleryFileIndex file}-#{galleryFileXRes file}|] :)+                pure Nothing+              else return $ Just bytes++    operate (retries :: Int)+      | retries > 3 = return Nothing+      | otherwise = do+        urls <- parseRPCResponse'+          =<< ehRPC+            emptyRPCParams+            { act = Just "dlfetch"+            , add = Just+                [i|#{galleryID metadata};#{galleryFilePage file};#{galleryFileIndex file};#{galleryFileXRes file};#{retries}|]+            }++        if null urls+          then operate (retries + 1) -- we did not get a valid URL, might be a network error+          else maybe (operate (retries + 1)) (pure . Just) . asum+            =<< traverse (download . BSC.unpack) urls++{-# INLINE reportFailures #-}+reportFailures :: [ Text ] -> EHentaiAPI -@> ()+reportFailures reports+  = void $ ehRPC emptyRPCParams { act = Just "dlfails", add = Just $ T.intercalate ";" reports }++fetchResource :: FileURI+              -> ( ByteString, ByteString )+              -> [ EHentaiAPI, Reader ClientConfig, Error RPCError, Embed IO ] >@> Maybe ByteString+fetchResource fileURI ( fileIndex, xres ) = do+  urls <- parseRPCResponse'+    =<< ehRPC+      emptyRPCParams { act = Just "srfetch", add = Just [i|#{fileIndex};#{xres};#{fileURI}|] }+  cfg <- ask @ClientConfig+  asum+    <$> traverse+      (download [i|#{clientId cfg}-#{hash @ByteString $ encodeUtf8 (key cfg) <> show fileURI}|]+       . BSC.unpack)+      urls+  where+    download token url = case parseRequest url of+      Nothing  -> pure Nothing+      Just req -> do+        bytes <- embed+          $ LBS.toStrict . responseBody+          <$> httpLbs @IO req { requestHeaders = ( "Hath-Request", token ) : hentaiHeader }+        if hash bytes /= fileHash fileURI+          then pure Nothing+          else return $ Just bytes++fetchBlacklist :: Int -> [ EHentaiAPI, Error RPCError ] >@> [ Text ]+fetchBlacklist deltaTime = do+  res <- ehRPC emptyRPCParams { act = Just "get_blacklist", add = Just $ show deltaTime }+  fmap decodeUtf8 <$> parseRPCResponse' res
+ src/LegacyCiphers.hs view
@@ -0,0 +1,172 @@+-- |+-- Module      : LegacyCiphers+-- License     : BSD-3-Clause+-- Maintainer  : Vincent Hanquez+-- Stability   : experimental+-- Portability : unknown+--+-- This module contains legacy cipher definitions borrowed from the+-- tls package (version 1.9.0) by Vincent Hanquez.+--+-- Original source: https://hackage.haskell.org/package/tls-1.9.0/docs/src/Network.TLS.Extra.Cipher.html+--+-- Copyright (c) Vincent Hanquez+--+-- Redistribution and use in source and binary forms, with or without+-- modification, are permitted provided that the following conditions are met:+--+-- 1. Redistributions of source code must retain the above copyright notice,+--    this list of conditions and the following disclaimer.+--+-- 2. Redistributions in binary form must reproduce the above copyright notice,+--    this list of conditions and the following disclaimer in the documentation+--    and/or other materials provided with the distribution.+--+-- 3. Neither the name of the copyright holder nor the names of its contributors+--    may be used to endorse or promote products derived from this software without+--    specific prior written permission.+--+-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+-- AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+-- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+-- ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE+-- LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR+-- CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF+-- SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS+-- INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN+-- CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)+-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+-- POSSIBILITY OF SUCH DAMAGE.+--+-- This file is part of the hs-hath project, which is licensed under GPL-3.0.+-- The BSD-3-Clause license applies to this specific file as noted above.+module LegacyCiphers+  ( cipher_ECDHE_ECDSA_AES128CBC_SHA+  , cipher_ECDHE_RSA_AES128CBC_SHA+  , cipher_ECDHE_RSA_AES256CBC_SHA+  ) where++import           Crypto.Cipher.AES   ( AES128, AES256 )+import           Crypto.Cipher.Types ( BlockCipher+                                     , IV+                                     , cbcDecrypt+                                     , cbcEncrypt+                                     , cipherInit+                                     , makeIV+                                     )+import           Crypto.Error        ( CryptoFailable, throwCryptoError )++import qualified Data.ByteString     as B++import           Network.TLS         ( Version(..) )+import           Network.TLS.Cipher  ( Bulk(..)+                                     , BulkBlock+                                     , BulkDirection(..)+                                     , BulkFunctions(..)+                                     , BulkKey+                                     , Cipher(..)+                                     , CipherKeyExchangeType(..)+                                     , Hash(..)+                                     )++import           Relude++cipher_ECDHE_ECDSA_AES128CBC_SHA :: Cipher+cipher_ECDHE_ECDSA_AES128CBC_SHA+  = Cipher { cipherID          = 0xC009+           , cipherName        = "ECDHE-ECDSA-AES128CBC-SHA"+           , cipherBulk        = bulk_aes128+           , cipherHash        = SHA1+           , cipherPRFHash     = Nothing+           , cipherKeyExchange = CipherKeyExchange_ECDHE_ECDSA+           , cipherMinVer      = Just TLS10+           }++cipher_ECDHE_RSA_AES128CBC_SHA :: Cipher+cipher_ECDHE_RSA_AES128CBC_SHA+  = Cipher { cipherID          = 0xC013+           , cipherName        = "ECDHE-RSA-AES128CBC-SHA"+           , cipherBulk        = bulk_aes128+           , cipherHash        = SHA1+           , cipherPRFHash     = Nothing+           , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+           , cipherMinVer      = Just TLS10+           }++cipher_ECDHE_RSA_AES256CBC_SHA :: Cipher+cipher_ECDHE_RSA_AES256CBC_SHA+  = Cipher { cipherID          = 0xC014+           , cipherName        = "ECDHE-RSA-AES256CBC-SHA"+           , cipherBulk        = bulk_aes256+           , cipherHash        = SHA1+           , cipherPRFHash     = Nothing+           , cipherKeyExchange = CipherKeyExchange_ECDHE_RSA+           , cipherMinVer      = Just TLS10+           }++bulk_aes128 :: Bulk+bulk_aes128+  = Bulk { bulkName       = "AES128"+         , bulkKeySize    = 16+         , bulkIVSize     = 16+         , bulkExplicitIV = 0+         , bulkAuthTagLen = 0+         , bulkBlockSize  = 16+         , bulkF          = BulkBlockF aes128cbc+         }++bulk_aes256 :: Bulk+bulk_aes256+  = Bulk { bulkName       = "AES256"+         , bulkKeySize    = 32+         , bulkIVSize     = 16+         , bulkExplicitIV = 0+         , bulkAuthTagLen = 0+         , bulkBlockSize  = 16+         , bulkF          = BulkBlockF aes256cbc+         }++noFail :: CryptoFailable a -> a+noFail = throwCryptoError++makeIV_ :: BlockCipher a => B.ByteString -> IV a+makeIV_ = fromMaybe (error "makeIV_") . makeIV++takelast :: Int -> B.ByteString -> B.ByteString+takelast i b = B.drop (B.length b - i) b++aes128cbc :: BulkDirection -> BulkKey -> BulkBlock+aes128cbc BulkEncrypt key+  = let+      ctx = noFail (cipherInit key) :: AES128+    in +      (\iv input -> let+           output = cbcEncrypt ctx (makeIV_ iv) input+         in +           ( output, takelast 16 output ))+aes128cbc BulkDecrypt key+  = let+      ctx = noFail (cipherInit key) :: AES128+    in +      (\iv input -> let+           output = cbcDecrypt ctx (makeIV_ iv) input+         in +           ( output, takelast 16 input ))++aes256cbc :: BulkDirection -> BulkKey -> BulkBlock+aes256cbc BulkEncrypt key+  = let+      ctx = noFail (cipherInit key) :: AES256+    in +      (\iv input -> let+           output = cbcEncrypt ctx (makeIV_ iv) input+         in +           ( output, takelast 16 output ))+aes256cbc BulkDecrypt key+  = let+      ctx = noFail (cipherInit key) :: AES256+    in +      (\iv input -> let+           output = cbcDecrypt ctx (makeIV_ iv) input+         in +           ( output, takelast 16 input ))
+ src/Metrics/Counter.hs view
@@ -0,0 +1,27 @@+module Metrics.Counter ( inc, add, read ) where++import           Metrics.Types++import           Relude++-- | Atomically increment counter by 1+inc :: Counter -> IO ()+inc = add 1++-- | Atomically add value to counter+add :: Int -> Counter -> IO ()+add n counter = atomicModifyIORef' (counterRef counter) $ \old -> ( old + fromIntegral n, () )++{-# INLINE add #-}++-- | Read current counter value+-- This is used for snapshot generation and should not be used in hot paths+read :: Counter -> IO Int64+read = readIORef . counterRef++{-# INLINE read #-}++-- Note: We use atomicModifyIORef' instead of modifyIORef' because:+-- 1. It's truly atomic (lock-free at CPU level)+-- 2. No MVar blocking+-- 3. Performance: ~50ns per operation vs ~500ns with MVar
+ src/Metrics/Gauge.hs view
@@ -0,0 +1,41 @@+module Metrics.Gauge ( inc, dec, set, add, sub, read ) where++import           Metrics.Types++import           Relude++-- | Atomically increment gauge by 1+inc :: Gauge -> IO ()+inc = add 1++{-# INLINE inc #-}++-- | Atomically decrement gauge by 1+dec :: Gauge -> IO ()+dec = sub 1++{-# INLINE dec #-}++-- | Set gauge to exact value (non-atomic write is sufficient for gauges)+set :: Int64 -> Gauge -> IO ()+set n gauge = writeIORef (gaugeRef gauge) n++{-# INLINE set #-}++-- | Atomically add value to gauge+add :: Int -> Gauge -> IO ()+add n gauge = atomicModifyIORef' (gaugeRef gauge) $ \old -> ( old + fromIntegral n, () )++{-# INLINE add #-}++-- | Atomically subtract value from gauge+sub :: Int -> Gauge -> IO ()+sub n = add (negate n)++{-# INLINE sub #-}++-- | Read current gauge value+read :: Gauge -> IO Int64+read = readIORef . gaugeRef++{-# INLINE read #-}
+ src/Metrics/Prometheus.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Metrics.Prometheus ( render ) where++import qualified Data.Map.Strict as Map+import qualified Data.Text       as Text++import           Mason.Builder   ( BuilderFor+                                 , StrictByteStringBackend+                                 , byteString+                                 , int64Dec+                                 , intersperse+                                 , textUtf8+                                 , toStrictByteString+                                 )++import           Metrics.Types++import           Relude          hiding ( intersperse )++type MBuilder = BuilderFor StrictByteStringBackend++-- | Render a list of metric snapshots to Prometheus text format+render :: [ MetricSnapshot ] -> ByteString+render = toStrictByteString . mconcat . map renderMetric++-- | Render a single metric snapshot+renderMetric :: MetricSnapshot -> MBuilder+renderMetric = \case+  CounterSnapshot metricId help val -> renderMetricLines "counter" metricId help val+  GaugeSnapshot metricId help val   -> renderMetricLines "gauge" metricId help val++-- | Render the complete metric output (HELP, TYPE, and value lines)+renderMetricLines :: ByteString -> MetricId -> Text -> Int64 -> MBuilder+renderMetricLines typ (MetricId name labels) help val+  = mconcat+    [ "# HELP "+    , textUtf8 name+    , " "+    , textUtf8 help+    , "\n"+    , "# TYPE "+    , textUtf8 name+    , " "+    , byteString typ+    , "\n"+    , textUtf8 name+    , if Map.null labels+        then mempty+        else renderLabels labels+    , " "+    , int64Dec val+    , "\n"+    ]++-- | Render label set: {label1="value1",label2="value2"}+renderLabels :: Labels -> MBuilder+renderLabels labels+  | Map.null labels = mempty+  | otherwise = mconcat [ "{", intersperse "," $ map renderLabel $ Map.toList labels, "}" ]++-- | Render a single label: key="value"+renderLabel :: ( Text, Text ) -> MBuilder+renderLabel ( k, v ) = textUtf8 k <> "=\"" <> textUtf8 (escapeValue v) <> "\""++-- | Escape special characters in label values according to Prometheus spec+-- See: https://prometheus.io/docs/instrumenting/exposition_formats/+escapeValue :: Text -> Text+escapeValue = Text.replace "\\" "\\\\" . Text.replace "\"" "\\\"" . Text.replace "\n" "\\n"++-- Example output:+--+-- # HELP hath_cache_sent_bytes_total Total bytes sent from cache+-- # TYPE hath_cache_sent_bytes_total counter+-- hath_cache_sent_bytes_total 1234567+--+-- # HELP hath_errors_total Total errors by type+-- # TYPE hath_errors_total counter+-- hath_errors_total{type="network"} 42+-- hath_errors_total{type="timeout"} 13+--+-- Note: Labels with the same metric name but different label values+-- are currently registered as separate Counter instances.
+ src/Metrics/Registry.hs view
@@ -0,0 +1,59 @@+module Metrics.Registry+  ( newRegistry+  , registerCounter+  , registerGauge+  , registerCounterWith+  , registerGaugeWith+  ) where++import           Metrics.Types++import           Relude++-- | Create a new empty registry+newRegistry :: IO Registry+newRegistry = do+  counters <- newIORef []+  gauges <- newIORef []+  cachedSnapshot <- newTVarIO ""+  pure $ Registry counters gauges cachedSnapshot++-- | Register a counter without labels+registerCounter :: Text -> Text -> Registry -> IO Counter+registerCounter name help = registerCounterWith name help mempty++-- | Register a counter with labels+registerCounterWith :: Text -> Text -> Labels -> Registry -> IO Counter+registerCounterWith name help labels reg = do+  ref <- newIORef 0+  let metricId = MetricId name labels+      counter  = Counter metricId help ref+  -- Atomically prepend to counter list+  atomicModifyIORef' (registryCounters reg) $ \cs -> ( counter : cs, () )+  pure counter++-- | Register a gauge without labels+registerGauge :: Text -> Text -> Registry -> IO Gauge+registerGauge name help = registerGaugeWith name help mempty++-- | Register a gauge with labels+registerGaugeWith :: Text -> Text -> Labels -> Registry -> IO Gauge+registerGaugeWith name help labels reg = do+  ref <- newIORef 0+  let metricId = MetricId name labels+      gauge    = Gauge metricId help ref+  -- Atomically prepend to gauge list+  atomicModifyIORef' (registryGauges reg) $ \gs -> ( gauge : gs, () )+  pure gauge++-- Note: Registration is typically done at startup, so performance is not critical.+-- Using atomicModifyIORef' ensures thread-safety if multiple threads register metrics.+--+-- Label usage example (for future):+--   errorCounter <- registerCounterWith+--     "hath_errors_total"+--     "Total errors by type"+--     (Map.fromList [("type", "network")])+--     registry+--+-- This creates a counter with fixed labels at registration time.
+ src/Metrics/Snapshot.hs view
@@ -0,0 +1,53 @@+module Metrics.Snapshot ( generateSnapshot, startSnapshotWorker, getCachedSnapshot ) where++import           Control.Concurrent ( forkIO, threadDelay )++import qualified Metrics.Counter    as Counter+import qualified Metrics.Gauge      as Gauge+import qualified Metrics.Prometheus as Prometheus+import           Metrics.Types++import           Relude++-- | Generate a snapshot of all metrics in the registry+-- This reads all counter and gauge values and renders them to Prometheus format+generateSnapshot :: Registry -> IO ByteString+generateSnapshot reg = do+  counters <- readIORef (registryCounters reg)+  gauges <- readIORef (registryGauges reg)++  -- Read all counter values+  counterSnapshots <- forM counters $ \c -> do+    val <- Counter.read c+    pure $ CounterSnapshot (counterMetricId c) (counterHelp c) val++  -- Read all gauge values+  gaugeSnapshots <- forM gauges $ \g -> do+    val <- Gauge.read g+    pure $ GaugeSnapshot (gaugeMetricId g) (gaugeHelp g) val++  -- Render to Prometheus text format+  pure $ Prometheus.render (counterSnapshots <> gaugeSnapshots)++-- | Start a background worker that periodically updates the cached snapshot+-- This decouples metrics reads from the /metrics endpoint, eliminating blocking+startSnapshotWorker :: Registry -> Int -> IO ()+startSnapshotWorker reg intervalMicros = void $ forkIO $ forever $ do+  snapshot <- generateSnapshot reg+  atomically $ writeTVar (registryCachedSnapshot reg) snapshot+  threadDelay intervalMicros++-- | Read the cached snapshot (zero-cost operation)+-- This is what the /metrics endpoint should call+getCachedSnapshot :: Registry -> IO ByteString+getCachedSnapshot = readTVarIO . registryCachedSnapshot++{-# INLINE getCachedSnapshot #-}++-- Performance notes:+-- - generateSnapshot: O(n) where n = number of metrics (~10-100 typically)+--   Takes ~1-10ms depending on metric count+-- - startSnapshotWorker: Runs in background, default 5s interval+--   CPU overhead: negligible (~0.02% with 10 metrics)+-- - getCachedSnapshot: O(1), ~100ns+--   This is what makes /metrics endpoint non-blocking
+ src/Metrics/Types.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StrictData #-}++module Metrics.Types+  ( Labels+  , MetricId(..)+  , Counter(..)+  , Gauge(..)+  , Registry(..)+  , MetricSnapshot(..)+  ) where++import           GHC.Generics++import           Relude++-- | Label support for metrics (key-value pairs)+type Labels = Map Text Text++-- | Metric identifier combining name and labels+data MetricId = MetricId { metricName :: !Text, metricLabels :: !Labels }+  deriving ( Eq, Ord, Show, Generic )++-- | Counter metric (monotonically increasing)+data Counter+  = Counter { counterMetricId :: !MetricId, counterHelp :: !Text, counterRef :: !(IORef Int64) }++-- | Gauge metric (can increase or decrease)+data Gauge = Gauge { gaugeMetricId :: !MetricId, gaugeHelp :: !Text, gaugeRef :: !(IORef Int64) }++-- | Registry holding all registered metrics+data Registry+  = Registry { registryCounters       :: !(IORef [ Counter ])+             , registryGauges         :: !(IORef [ Gauge ])+             , registryCachedSnapshot :: !(TVar ByteString)+             }++-- | Snapshot of a metric value (for rendering)+data MetricSnapshot = CounterSnapshot !MetricId !Text !Int64 | GaugeSnapshot !MetricId !Text !Int64+  deriving ( Show )
+ src/Middleware.hs view
@@ -0,0 +1,165 @@+module Middleware+  ( rateLimitMiddleware+  , tracingConnections+  , normalizeAcceptMiddleware+  , tracingTimeUsage+  , withHentaiHeaders+  , IPMap+  , KeystampMap+  , IP(..)+  , IPRecord(..)+  , timeWindow+  ) where++import           Control.Exception   ( finally )++import qualified Data.ByteString     as BS+import qualified Data.HashMap.Strict as HashMap++import           GHC.Clock           ( getMonotonicTime )++import qualified Metrics.Gauge       as Gauge++import           Network.HTTP.Types  ( hAccept )+import           Network.Socket      ( HostAddress, HostAddress6, SockAddr(..) )+import           Network.Wai         ( Middleware+                                     , mapResponseHeaders+                                     , rawPathInfo+                                     , remoteHost+                                     , requestHeaders+                                     )++import           Relude              hiding ( Reader, ask, get, runReader )++import           Stats               ( StatsEnv(..) )++import           System.IO.Unsafe    ( unsafePerformIO )++import           Types               ( hentaiHeader )++import           Utils               ( tooManyRequestsResponse )++timeWindow :: Double+timeWindow = 10 * 60 -- 10 minutes in seconds++maxRequests :: Int8+maxRequests = 5++-- Data types for tracking requests+-- Note: Lists cannot be unpacked, so we use strict spine with explicit strictness+data IPRecord+  = IPRecord { earlistRequestTime :: !Double   -- ^ Time of the first request+             , requestTimes       :: !Int8     -- ^ Number of requests in the time window+             , bannedUntil        :: !Double -- ^ When the ban expires+             }+  deriving ( Show )++-- Change the Map key from SockAddr to a custom IP type+data IP = IPv4 {-# UNPACK #-} !HostAddress | IPv6 {-# UNPACK #-} !HostAddress6+  deriving ( Eq, Ord, Show, Generic )++instance Hashable IP++type IPMap = HashMap IP IPRecord++{-# INLINE getIP #-}+-- Helper function to extract just the IP from a SockAddr+getIP :: SockAddr -> Maybe IP+getIP (SockAddrInet _ ha) = Just $ IPv4 ha+getIP (SockAddrInet6 _ _ ha _) = Just $ IPv6 ha+getIP _ = Nothing++{-# NOINLINE globalIPMap #-}+globalIPMap :: IORef IPMap+globalIPMap = unsafePerformIO $ newIORef HashMap.empty++{-# NOINLINE globalIPMapCounter #-}+globalIPMapCounter :: IORef Int+globalIPMapCounter = unsafePerformIO $ newIORef 0++-- Create a new rate limiting middleware+rateLimitMiddleware :: Middleware+rateLimitMiddleware app req k+  | "/h/" `BS.isPrefixOf` rawPathInfo req = do+    now <- getMonotonicTime+    let sockAddr = remoteHost req+    case getIP sockAddr of+      Nothing -> app req k  -- If we can't get IP, just allow the request+      Just ip -> do+        allowed <- checkRateLimit ip now+        if allowed+          then app req k+          else k tooManyRequestsResponse+  | otherwise = app req k  -- Skip rate limiting for non-resource paths++-- Check if request is allowed and update rate limit state+--+-- return False if the request should be blocked+checkRateLimit :: IP -> Double -> IO Bool+checkRateLimit ip now = do+  cnt <- readIORef globalIPMapCounter+  if cnt > 100+    then do+      writeIORef globalIPMapCounter 0+      writeIORef globalIPMap HashMap.empty+      pure True+    else do+      writeIORef globalIPMapCounter (cnt + 1)+      m <- readIORef globalIPMap+      maybe firstRequest existingRequest (HashMap.lookup ip m)+  where+    -- Handle first request from an IP by creating new record+    firstRequest = do+      modifyIORef' globalIPMap $ HashMap.insert ip (IPRecord now 1 0)+      return True++    -- Check if IP is banned, otherwise check request count+    existingRequest record+      | bannedUntil record > now = return False+      | otherwise = checkAndUpdateRequests record++    -- Check if requests are within rate limit window and update accordingly+    checkAndUpdateRequests record+      = if now - earlistRequestTime record <= timeWindow+        then if requestTimes record > maxRequests+          then do+            -- Ban the IP for 5 minutes+            modifyIORef' globalIPMap $ HashMap.insert ip (record { bannedUntil = now + 5 * 60 })+            return False+          else do+            modifyIORef' globalIPMap+              $ HashMap.insert ip (record { requestTimes = requestTimes record + 1 })+            return True+        else return True++type KeystampMap = HashMap ByteString ( Int, Double )++-- | Track active connections+tracingConnections :: StatsEnv -> Middleware+tracingConnections statsEnv app req k = do+  Gauge.inc (statsActiveConnectionsGauge statsEnv)+  finally (app req k) (Gauge.dec (statsActiveConnectionsGauge statsEnv))++normalizeAcceptMiddleware :: Middleware+normalizeAcceptMiddleware app req = app req { requestHeaders = normalizedHeaders }+  where+    normalizedHeaders = map normalizeHeader (requestHeaders req)++    normalizeHeader ( name, value )+      | name == hAccept = ( name, "*/*" )+      | otherwise = ( name, value )++tracingTimeUsage :: StatsEnv -> Middleware+tracingTimeUsage statsEnv app req k = do+  startTime <- getMonotonicTime+  finally (app req k) (do+                         endTime <- getMonotonicTime+                         let latency = endTime - startTime+                         Gauge.set (round (latency * 1000000)) (statsLatency statsEnv))++withHentaiHeaders :: Middleware+withHentaiHeaders app req k = app req (k . mapResponseHeaders addHeaders)+  where+    addHeaders headers@(map fst -> names)+      = filter ((`notElem` names) . fst) hentaiHeader ++ headers+
+ src/Server.hs view
@@ -0,0 +1,775 @@+{-# LANGUAGE DataKinds #-}++{-# LANGUAGE PartialTypeSignatures #-}+{-# LANGUAGE TypeOperators #-}++module Server+  ( startServer+  , ServerAction(..)+  , makeApplication+  , CacheRunner(..)+  , IPMap+  , KeystampMap+  , GalleryTask(..)+  ) where++import           Colog                                ( Message+                                                      , Severity(Info, Warning)+                                                      , richMessageAction+                                                      )+import           Colog.Polysemy                       ( Log, runLogAction )++import           Control.Concurrent                   ( forkIO, threadDelay )+import           Control.Concurrent.Suspend           ( mDelay )+import           Control.Concurrent.Timer             ( repeatedTimer, stopTimer )+import           Control.Exception                    ( finally, try )++import qualified Data.ByteString                      as BS+import qualified Data.ByteString.Char8                as BSC+import qualified Data.ByteString.Lazy                 as LBS+import qualified Data.ByteString.Lazy.Char8           as LBS8+import qualified Data.HashMap.Strict                  as HashMap+import qualified Data.Map.Strict                      as Map+import           Data.String.Interpolate              ( i )+import qualified Data.Text                            as Text+import           Data.Time.Clock.POSIX                ( POSIXTime, getPOSIXTime )+import           Data.Time.Clock.System               ( SystemTime(systemSeconds), getSystemTime )+import           Data.X509                            ( CertificateChain, PrivKey )++import           Database.SQLite.Simple               ( withConnection )++import           HathNetwork.Genesis+import           HathNetwork.RPC                      ( RPC+                                                      , notifyGalleryCompletion+                                                      , runRPC+                                                      , runRPCIO+                                                      , stillAlive+                                                      )++import           Interface.API                        ( API+                                                      , EHentaiAPI+                                                      , ServerCommand(..)+                                                      , WithDynamicContentType(WithDynamicContentType)+                                                      , api+                                                      , downloadGalleryFile+                                                      , fetchBlacklist+                                                      , nextGalleryTask+                                                      , runEHentaiAPI+                                                      , runEHentaiAPIIO+                                                      , startListening+                                                      , stopListening+                                                      )++import           LegacyCiphers++import qualified Mason.Builder                        as BD++import           Middleware++import           Network.HTTP.Client                  ( brReadSome+                                                      , newManager+                                                      , parseRequest+                                                      , withResponse+                                                      )+import           Network.HTTP.Client.TLS              ( tlsManagerSettings )+import           Network.HTTP.Simple                  ( getResponseBody )+import           Network.HTTP.Types                   ( status200, status404 )+import           Network.TLS                          ( Credentials(Credentials), Version(..) )+import           Network.TLS.Extra                    ( ciphersuite_all )+import           Network.Wai                          ( Middleware+                                                      , Request(requestMethod)+                                                      , responseLBS+                                                      )+import           Network.Wai.Handler.Warp             ( defaultSettings, setPort )+import           Network.Wai.Handler.WarpTLS          ( OnInsecure(AllowInsecure)+                                                      , TLSSettings(..)+                                                      , defaultTlsSettings+                                                      , runTLS+                                                      )+import           Network.Wai.Middleware.RealIp        ( realIpHeader )+import           Network.Wai.Middleware.RequestLogger ( logStdout )++import           Polysemy                             ( Embed+                                                      , Members+                                                      , Sem+                                                      , embed+                                                      , embedToFinal+                                                      , runFinal+                                                      )+import           Polysemy.Async                       ( Async, asyncToIOFinal )+import           Polysemy.Error                       ( Error, errorToIOFinal, mapError, throw )+import           Polysemy.KVStore                     ( KVStore )+import           Polysemy.Reader                      ( Reader, ask, runReader )++import           Relude                               hiding ( Reader, ask, get, runReader )++import           Servant+import           Servant.Client                       ( ClientError )+import qualified Servant.Types.SourceT                as Source++import           SettingM                             ( SettingM(..)+                                                      , getSettings+                                                      , runSettingM+                                                      , updateSettings+                                                      )++import           Stats                                ( Stats+                                                      , StatsEnv(..)+                                                      , addDlBytes+                                                      , addDownload+                                                      , addUpload+                                                      , incDlFile+                                                      , incDlTask+                                                      , incServed+                                                      , newStatsEnv+                                                      , readPrometheus+                                                      , runStats+                                                      )++import           Storage.Database                     ( FileRecord(fileRecordBytes)+                                                      , initializeDB+                                                      , runCache+                                                      )+import           Storage.Filesystem                   ( runCacheFilesystem )+import           Storage.Locate+import           Storage.R2                           ( mkR2Connection, runCacheR2 )++import           System.Directory                     ( createDirectoryIfMissing, doesFileExist )+import           System.FilePath                      ( takeDirectory )+import           System.IO                            ( hPutStrLn )+import           System.IO.Unsafe                     ( unsafePerformIO )++import           Types                                ( CacheBackend(..)+                                                      , ClientConfig+                                                      , ClientConfig(..)+                                                      , FileURI(fileExt)+                                                      , GalleryFile(..)+                                                      , GalleryMetadata(..)+                                                      , HathSettings(..)+                                                      , RPCError+                                                      , StorageResult(..)+                                                      , hentaiHeader+                                                      , parseFileURI+                                                      )++import           UnliftIO                             ( TChan+                                                      , getMonotonicTime+                                                      , newTChanIO+                                                      , race+                                                      , readTChan+                                                      , replicateConcurrently+                                                      , withAsync+                                                      , writeTChan+                                                      )++import           Utils                                ( bufferSending+                                                      , hash+                                                      , log+                                                      , lookupParam+                                                      , parseURLParams+                                                      )++maxTimeDrift :: Int64+maxTimeDrift = 600++{-# NOINLINE globalKeystampMap #-}+globalKeystampMap :: IORef KeystampMap+globalKeystampMap = unsafePerformIO $ newIORef HashMap.empty++{-# NOINLINE globalKeystampMapCounter #-}+globalKeystampMapCounter :: IORef Int+globalKeystampMapCounter = unsafePerformIO $ newIORef 0++maxSameKeystampRequests :: Int+maxSameKeystampRequests = 10++data ServerAction = Reload | Cert | GracefulShutdown++data GalleryTask = GalleryTask++-- | Server runtime environment containing all channels for inter-thread communication.+-- This bundles channels used by the server loop to coordinate actions and tasks.+data ServerChannels+  = ServerChannels+  { serverActionChan :: !(TChan ServerAction)+    -- ^ Channel for receiving server control commands (reload, cert refresh, shutdown)+  , galleryTaskChan  :: !(TChan GalleryTask)+    -- ^ Channel for coordinating gallery download tasks+  }++-- | Server runtime state containing all mutable variables.+-- These TVars are shared across threads and updated during server operation.+data ServerState+  = ServerState { serverSettings :: !(TVar HathSettings)+                  -- ^ Dynamic server settings that can be updated via RPC+                , serverStatsEnv :: !StatsEnv+                  -- ^ Prometheus metrics environment (gauges, counters, histograms)+                }++-- | Server configuration flags controlling middleware behavior.+data ServerFlags+  = ServerFlags { disableRateLimit  :: !Bool+                  -- ^ If True, bypass IP-based rate limiting middleware+                , trustProxyHeaders :: !Bool+                  -- ^ If True, trust X-Forwarded-For headers for real client IP+                }++-- | Server loop context bundling all runtime dependencies.+-- This groups all parameters needed by the server loop to reduce parameter count+-- and improve code clarity.+data ServerLoopContext+  = ServerLoopContext+  { loopConfig      :: !ClientConfig+    -- ^ Static client configuration (client ID, key, cache backend, etc.)+  , loopChannels    :: !ServerChannels+    -- ^ Communication channels for server actions and gallery tasks+  , loopState       :: !ServerState+    -- ^ Mutable server state (settings, rate limits, metrics)+  , loopFlags       :: !ServerFlags+    -- ^ Configuration flags controlling middleware behavior+  , loopCacheRunner :: !CacheRunner+    -- ^ Cache backend interpreter (SQLite, R2, or Filesystem)+  }++-- Server implementation+server :: Members+         '[ Embed IO+          , Error ServerError+          , Error RPCError+          , EHentaiAPI+          , Reader ClientConfig+          , RPC+          , Locate+          , Reader (TChan ServerAction)+          , Reader (TChan GalleryTask)+          , Stats+          , Log Message+          , Genesis+          , SettingM+          , Async+          ]+         r+       => ServerT API (Sem r)+server+  = faviconHandler+  :<|> robotsHandler+  :<|> resourceHandler+  :<|> statsHandler+  :<|> serverCmdHandler+  :<|> testHandler+  :<|> adminSettingsHandler+  :<|> Tagged rawHandler+  where+    faviconHandler+      = throw $ err301 { errHeaders = [ ( "Location", "https://e-hentai.org/favicon.ico" ) ] }++    robotsHandler = return "User-agent: *\nDisallow: /"++    resourceHandler+      (encodeUtf8 -> fileid)+      (parseURLParams . encodeUtf8 -> opts)+      (encodeUtf8 -> filename) = do+      currentTime <- embed getSystemTime+      cfg <- ask @ClientConfig+      when (abs (timestamp - systemSeconds currentTime) > maxTimeDrift)+        $ throw err403 { errBody = "Your time is out of sync. Please update your system time." }+      when (answer /= challange cfg) $ throw err403 { errBody = "Invalid key." }+      isSimpleLimited <- checkKeystampRateLimit+      if isSimpleLimited+        then throw $ err429 { errBody = "Too Many Requests" }+        else locateResource+          LocateURI { locateURIFilename = filename, locateURI = uri, locateURIOptions = opts }+          >>= \case+            Nothing -> throw err404+            Just (Redirect url) -> throw+              $ err302+              { errHeaders = [ ( "Location", url ), ( "Cache-Control", "public, max-age=600" ) ] }+            Just (Record (fileRecordBytes -> bs)) -> do+              incServed+              addUpload (BS.length bs)+              return+                $ addHeader @"Content-Length" (BS.length bs)+                $ WithDynamicContentType mimeType bs+      where+        mimeType = case fileExt uri of+          "jpg" -> "image/jpeg"+          "png" -> "image/png"+          "gif" -> "image/gif"+          "mp4" -> "video/mp4"+          "wbm" -> "video/webm"+          "wbp" -> "video/webp"+          "avf" -> "video/avif"+          "jxl" -> "image/jxl"+          _     -> "application/octet-stream"++        uri = parseFileURI fileid++        ( timestamp :: Int64, answer )+          = let+              rs        = fromMaybe "" (Map.lookup "keystamp" opts)+              ( t, rk ) = BSC.span (/= '-') rs+            in+              ( fromIntegral $ maybe 0 fst $ BSC.readInteger t, BS.tail rk )++        {-# INLINE challange #-}+        -- [i|#{timestamp}-#{fileid}-#{key cfg}-hotlinkthis|]+        challange :: ClientConfig -> ByteString+        challange cfg+          = BS.take 10+          $ hash+          $ BD.toStrictByteString+            (BD.int64Dec timestamp+             <> "-"+             <> BD.byteString fileid+             <> "-"+             <> BD.textUtf8 (key cfg)+             <> "-hotlinkthis")++        -- return True if over limit+        checkKeystampRateLimit = embed @IO $ do+          cnt <- readIORef globalKeystampMapCounter+          if cnt > 100+            then do+              writeIORef globalKeystampMapCounter 0+              writeIORef globalKeystampMap HashMap.empty+              pure False+            else do+              writeIORef globalKeystampMapCounter (cnt + 1)+              now <- getMonotonicTime+              m <- readIORef globalKeystampMap+              let checkKey = fileid <> show timestamp+              case HashMap.lookup checkKey m of+                Nothing -> modifyIORef' globalKeystampMap (HashMap.insert checkKey ( 1, now ))+                  >> pure False+                Just ( times, stamp ) -> if now - stamp > timeWindow+                  then modifyIORef' globalKeystampMap (HashMap.delete checkKey) >> pure False+                  else if times >= maxSameKeystampRequests+                    then pure True+                    else modifyIORef'+                      globalKeystampMap+                      (HashMap.insert checkKey ( times + 1, stamp ))+                      >> pure False++    serverCmdHandler command (parseURLParams . encodeUtf8 -> additional) _time _key+      = case command of+        StillAlive        -> plainText "I feel FANTASTIC and I'm still alive"+        ThreadedProxyTest -> let+            args = do+              hostname <- lookupParam "hostname" additional+              protocol <- lookupParam "protocol" additional <|> return "http"+              port <- lookupParam "port" additional+              testSize <- readInt @Int64 =<< lookupParam "testsize" additional+              testCount <- readInt =<< lookupParam "testcount" additional+              testTime <- readInt @Int64 =<< lookupParam "testtime" additional+              testKey <- lookupParam "testkey" additional+              return+                ( testCount+                , testSize+                  -- [i|#{protocol}://#{hostname}:#{port}/t/#{testSize}/#{testTime}/#{testKey}/randomkeyhere|]+                , LBS8.unpack+                  $ BD.toLazyByteString+                    (BD.byteString protocol+                     <> "://"+                     <> BD.byteString hostname+                     <> ":"+                     <> BD.byteString port+                     <> "/t/"+                     <> BD.int64Dec testSize+                     <> "/"+                     <> BD.int64Dec testTime+                     <> "/"+                     <> BD.byteString testKey+                     <> "/0")+                )+          in+            case args of+              Nothing -> throw err403+              Just ( testCount, testSize, url ) -> do+                mgr <- embed $ newManager tlsManagerSettings+                case parseRequest url of+                  Nothing  -> throw err403+                  Just req -> do+                    results <- embed $ replicateConcurrently testCount $ runTest testSize req mgr+                    let ( failed :: Int, millis :: Int64 )+                          = foldl' (\( f, t ) r -> case r of+                                      Nothing -> ( f + 1, t )+                                      Just v  -> ( f, t + v )) ( 0, 0 ) results+                    addUpload (testCount * fromIntegral testSize)+                    plainText [i|OK:#{failed}-#{millis}|]+        SpeedTest         -> let+            testSize+              = maybe+                1000000+                (fromIntegral . fst)+                (BSC.readInteger =<< lookupParam "testsize" additional)+          in+            do+              addDownload testSize+              return+                $ addHeader @"Content-Length" testSize+                $ Source.fromStepT+                $ bufferSending testSize+        RefreshSettings   -> do+          log Info "Refreshing settings"+          updateSettings =<< fetchSettings+          plainText ""+        StartDownloader   -> do+          chan <- ask @(TChan GalleryTask)+          log Info "Starting gallery downloader"+          void $ embed $ forkIO $ do+            atomically $ writeTChan chan GalleryTask+          plainText ""+        RefreshCerts      -> do+          log Info "Refreshing certificates"+          chan <- ask @(TChan ServerAction)+          void $ embed $ forkIO $ do+            threadDelay (1000000 * 2)+            atomically $ writeTChan chan Cert+          plainText ""+      where+        runTest testSize req mgr = do+          start <- getPOSIXTime+          let phi 0 _  = do+                end <- getPOSIXTime+                return $ truncate $ realToFrac @POSIXTime @Double $ 1000 * (end - start)+              phi n br = do+                s <- LBS.length <$> brReadSome br 1024+                phi (max 0 (n - s)) br+          try @SomeException (withResponse req mgr (phi testSize . getResponseBody)) >>= \case+            Left _  -> return Nothing+            Right v -> return $ Just v++        {-# INLINE readInt #-}+        {-# SPECIALISE readInt :: ByteString -> Maybe Int #-}+        {-# SPECIALISE readInt :: ByteString -> Maybe Int64 #-}+        readInt :: Num a => ByteString -> Maybe a+        readInt = fmap (fromIntegral . fst) . BSC.readInteger++        {-# INLINE plainText #-}+        plainText t+          = pure+          $ addHeader @"Content-Length" (BS.length t)+          $ Source.fromStepT+          $ Source.Yield t Source.Stop++    statsHandler = readPrometheus++    testHandler testSize testTime (encodeUtf8 @_ @ByteString -> testKey) _ = do+      currentTime <- embed getSystemTime+      cfg <- ask @ClientConfig+      when (abs (testTime - systemSeconds currentTime) > maxTimeDrift) $ throw err403+      when (testKey /= challange cfg) $ throw err403+      addUpload testSize+      return $ addHeader @"Content-Length" testSize $ Source.fromStepT $ bufferSending testSize+      where+        {-# INLINE challange #-}+        -- [i|hentai@home-speedtest-#{testSize}-#{testTime}-#{clientId cfg}-#{key cfg}|]+        challange :: ClientConfig -> ByteString+        challange cfg+          = hash+          $ BD.toStrictByteString+            ("hentai@home-speedtest-"+             <> BD.intDec testSize+             <> "-"+             <> BD.int64Dec testTime+             <> "-"+             <> BD.textUtf8 (clientId cfg)+             <> "-"+             <> BD.textUtf8 (key cfg))++    adminSettingsHandler = show <$> getSettings++    rawHandler req k = case requestMethod req of+      -- Handle HEAD requests with 200 OK and empty body+      "HEAD" -> k $ responseLBS status200 hentaiHeader ""++      _      -> k $ responseLBS status404 [] ""++-- | Set up periodic timers for various housekeeping tasks+tictok :: ClientConfig -> IO (IO ())+tictok config = do+  -- heartbeat+  heartbeatHandle <- repeatedTimer (void $ runRPCIO config stillAlive) (mDelay 1)++  -- resource blacklist+  blacklistHandle <- repeatedTimer (do+                                      res <- runRPCIO config (fetchBlacklist 43200)+                                      print res) (mDelay 36)++  return $ do+    stopTimer heartbeatHandle+    stopTimer blacklistHandle++notifyStart :: ClientConfig -> IO ()+notifyStart config = psi+  where+    psi = runRPCIO config startListening >>= \case+      Right (Right True) -> return ()+      _ -> threadDelay 1000000 >> psi++-- | Abstract cache runner - wraps the cache effect interpreter+-- This allows us to switch between SQLite and R2 backends at runtime+newtype CacheRunner+  = CacheRunner+  { runCacheWith+      :: forall r a. Members '[ Embed IO, Log Message, Reader ClientConfig, Error RPCError ] r+      => Sem (KVStore FileURI StorageResult : r) a+      -> Sem r a+  }++-- Create the WAI application with rate limiting+makeApplication :: ServerLoopContext -> Application+makeApplication serverCxt+  = finalMiddleware+  $ normalizeAcceptMiddleware+  $ tracingConnections statsEnv+  $ tracingTimeUsage statsEnv+  $ withHentaiHeaders+  $ serve api (hoistServer api interpretServer server)+  where+    ServerLoopContext+      { loopConfig = cfg+      , loopChannels = ServerChannels { serverActionChan = action, galleryTaskChan = gallery }+      , loopState = ServerState { serverSettings = settings, serverStatsEnv = statsEnv }+      , loopFlags = ServerFlags { disableRateLimit = disableRL, trustProxyHeaders = trustProxy }+      , loopCacheRunner = cacheRunner+      } = serverCxt++    applyRealIp :: Middleware+    applyRealIp+      = if trustProxy+        then realIpHeader "X-Forwarded-For"+        else id++    applyRateLimit :: Middleware+    applyRateLimit+      = if disableRL+        then id+        else rateLimitMiddleware++    finalMiddleware :: Middleware+    finalMiddleware = applyRealIp . applyRateLimit++    interpretServer :: Sem _ a -> Handler a+    interpretServer+      = Handler+      . ExceptT+      . runFinal+      . asyncToIOFinal+      . embedToFinal @IO+      . errorToIOFinal @ServerError+      . mapError @RPCError (const err500)+      . mapError @ClientError (const err500)+      . mapError @SomeException (const err500)+      . runSettingM settings+      . runReader cfg+      . runReader action+      . runReader statsEnv+      . runReader gallery+      . runLogAction @IO @Message richMessageAction+      . runEHentaiAPI+      . runCacheWith cacheRunner+      . runStats+      . runLocate+      . runGenesis+      . runRPC++-- | Core server loop implementing the main request-response cycle.+--+-- This function encapsulates the common logic for running the TLS server,+-- handling server actions (reload, cert refresh, shutdown), and coordinating+-- graceful shutdown. The loop is parameterized by a recursion continuation+-- to support different cache backends that may need different state (e.g.,+-- SQLite connection handle).+--+-- The server loop:+-- 1. Creates a WAI application with all configured middleware+-- 2. Notifies the RPC server that we're ready to serve+-- 3. Races between:+--    - Receiving control commands on the action channel+--    - Running the TLS server to handle HTTP requests+-- 4. Handles control commands:+--    - 'GracefulShutdown': Stops listening and exits cleanly+--    - 'Reload': Exits to allow systemd/supervisor to restart+--    - 'Cert': Refreshes TLS certificates and recurses with new certs+--+--+serverLoop :: ServerLoopContext+           -- ^ Server runtime context (config, channels, state, flags, cache)+           -> ( CertificateChain, PrivKey )+           -- ^ Current TLS certificates+           -> IO ( CertificateChain, PrivKey )+serverLoop ctx certs = do+  let ServerLoopContext { loopConfig = cfg+                        , loopChannels = ServerChannels { serverActionChan = chan }+                        , loopState = ServerState { serverSettings = settings }+                        } = ctx++  let app = makeApplication ctx++  st <- readTVarIO settings+  result <- withAsync (notifyStart cfg) $ \_ -> race (atomically $ readTChan chan)+    $ runTLS+      (defaultTlsSettings+       { tlsCredentials     = Just (Credentials [ certs ])+       , onInsecure         = AllowInsecure+       , tlsCiphers         = ciphersuite_all+           ++ [ cipher_ECDHE_ECDSA_AES128CBC_SHA+              , cipher_ECDHE_RSA_AES128CBC_SHA+              , cipher_ECDHE_RSA_AES256CBC_SHA+              ]+       , tlsAllowedVersions = [ TLS10, TLS11, TLS12, TLS13 ]+       })+      (setPort (clientPort st) defaultSettings)+    $ logStdout app++  case result of+    Left GracefulShutdown -> gracefulShutdown cfg+    Left Reload -> exitSuccess+    Left Cert -> refreshCerts cfg+    Right _ -> error "Server terminated unexpectedly"++-- | Perform graceful shutdown by notifying RPC server and exiting.+--+-- This function repeatedly calls 'stopListening' until the RPC server+-- acknowledges the shutdown request, then exits the process cleanly.+gracefulShutdown :: ClientConfig -> IO a+gracefulShutdown cfg = go+  where+    go = runEHentaiAPIIO cfg stopListening >>= \case+      Right _ -> exitSuccess+      Left _  -> go++-- | Refresh TLS certificates with exponential backoff retry logic.+--+-- Attempts to fetch new certificates from the Genesis RPC endpoint.+-- On failure, retries up to 3 times with exponential backoff (2^n seconds).+-- After 3 failures, triggers graceful shutdown.+--+-- This is called when the server receives a 'Cert' action, typically+-- triggered by the periodic certificate refresh timer or manual server command.+refreshCerts :: ClientConfig -> IO ( CertificateChain, PrivKey )+refreshCerts cfg = retry 0+  where+    retry :: Int -> IO ( CertificateChain, PrivKey )+    retry retries = runGenesisIO cfg fetchCertificate >>= \case+      Right (Right newCerts) -> return newCerts+      e -> do+        putStrLn $ "Failed to refresh certs: " <> show e+        if retries >= 3+          then do+            putStrLn "Giving up after 3 retries"+            gracefulShutdown cfg+          else do+            let delaySeconds = 2 ^ retries :: Int+            putStrLn+              $ "Retrying in "+              <> show delaySeconds+              <> " seconds (attempt "+              <> show (retries + 1)+              <> "/3)"+            threadDelay (1000000 * delaySeconds)+            retry (retries + 1)++startServer :: ClientConfig+            -> HathSettings+            -> ( CertificateChain, PrivKey )+            -> TChan ServerAction+            -> Bool+            -> Bool+            -> IO ()+startServer config settings certs chan disableRateLimit trustProxyHeaders = do+  ssVar <- newTVarIO settings+  galleryHandler <- newTChanIO+  statsEnv <- newStatsEnv+  void $ forkIO $ forever $ do+    GalleryTask <- atomically $ readTChan galleryHandler+    result <- try @SomeException+      $ runFinal+      $ embedToFinal @IO+      $ errorToIOFinal @ClientError+      $ errorToIOFinal @RPCError+      $ runReader config+      $ runReader statsEnv+      $ runStats+      $ runLogAction @IO @Message richMessageAction+      $ runEHentaiAPI+      $ runRPC startsDownloader+    case result of+      Left e  -> hPutStrLn stderr $ "Gallery downloader error: " <> show e+      Right _ -> return ()+  print =<< runRPCIO config (fetchBlacklist 259200)+  let ctx runner+        = ServerLoopContext+        { loopConfig      = config+        , loopChannels    = ServerChannels+            { serverActionChan = chan, galleryTaskChan = galleryHandler }+        , loopState       = ServerState { serverSettings = ssVar, serverStatsEnv = statsEnv }+        , loopFlags       = ServerFlags+            { disableRateLimit = disableRateLimit, trustProxyHeaders = trustProxyHeaders }+        , loopCacheRunner = runner+        }+  case cacheBackend config of+    CacheBackendSQLite     -> do+      withConnection (Text.unpack $ cachePath config) $ \conn -> do+        initializeDB conn+        let cacheRunner = CacheRunner { runCacheWith = runCache conn }+        stopTictok <- tictok config+        finally (serverLoopMain (ctx cacheRunner) certs) stopTictok+    CacheBackendR2         -> do+      case r2Config config of+        Nothing    -> error "cacheBackend=r2 but r2Config is missing"+        Just r2Cfg -> do+          r2ConnResult <- mkR2Connection r2Cfg+          case r2ConnResult of+            Left err     -> error $ "Failed to initialize R2: " <> err+            Right r2Conn -> do+              let cacheRunner = CacheRunner { runCacheWith = runCacheR2 r2Conn }+              stopTictok <- tictok config+              finally (serverLoopMain (ctx cacheRunner) certs) stopTictok+    CacheBackendFilesystem -> do+      let root = Text.unpack $ cachePath config+      -- Ensure cache root exists+      createDirectoryIfMissing True root+      let cacheRunner = CacheRunner { runCacheWith = runCacheFilesystem root }+      stopTictok <- tictok config+      finally (serverLoopMain (ctx cacheRunner) certs) stopTictok+  where+    startsDownloader = do+      metadata <- nextGalleryTask+      incDlTask+      case metadata of+        Nothing -> log Info "No gallery task available"+        Just md -> do+          log Info [i|Starting download for gallery #{galleryID md}|]+          complete <- mapM (verifyAndDownload md) (galleryFileList md)+          when (and complete) (notifyGalleryCompletion md)++    verifyAndDownload md f = do+      let filePath :: FilePath+            = [i|download/#{galleryID md}/#{galleryFileName f}.#{galleryFileExt f}|]+      embed $ createDirectoryIfMissing True (takeDirectory filePath)+      existingBytes <- embed $ do+        existing <- doesFileExist filePath+        if existing+          then BS.readFile filePath+          else return BS.empty+      if galleryFileHash f == hash existingBytes+        then log Info [i|#{galleryFileName f}.#{galleryFileExt f} already verified, skipping|]+          >> pure True+        else downloadGalleryFile md f >>= \case+          Nothing    -> do+            log Warning [i|Failed to download #{galleryFileName f}.#{galleryFileExt f}|]+            pure False+          Just bytes -> do+            log Info [i|Downloaded #{galleryFileName f}.#{galleryFileExt f}|]+            incDlFile+            addDlBytes (BS.length bytes)+            embed $ BS.writeFile filePath bytes+            pure True++    serverLoopMain :: ServerLoopContext -> ( CertificateChain, PrivKey ) -> IO ()+    serverLoopMain ctx cert = do+      newCert <- serverLoop ctx cert+      serverLoopMain ctx newCert+
+ src/SettingM.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}++module SettingM ( SettingM(..), getSettings, updateSettings, runSettingM ) where++import           Polysemy+import           Polysemy.Operators++import           Relude             hiding ( Reader )++import           Types              ( HathSettings )++data SettingM m a where+  -- | Get current H@H settings+  GetSettings :: SettingM m HathSettings+  -- | Update H@H settings (hot update without restart)+  UpdateSettings :: HathSettings -> SettingM m ()++makeSem ''SettingM++{-# INLINE runSettingM #-}+-- | Run the Settings effect with a TVar storing the current settings+runSettingM :: Member (Embed IO) r => TVar HathSettings -> SettingM : r @> a -> r @> a+runSettingM tvar = interpret $ \case+  GetSettings        -> embed $ readTVarIO @IO tvar+  UpdateSettings new -> embed $ atomically @IO $ writeTVar tvar new
+ src/Stats.hs view
@@ -0,0 +1,174 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE TemplateHaskell #-}++module Stats+  ( StatsEnv(..)+  , newStatsEnv+  , Stats(..)+  , addUpload+  , addDownload+  , incServed+  , incFetched+  , updateUptime+  , incActiveConnections+  , decActiveConnections+  , incDlTask+  , incDlFile+  , addDlBytes+  , readPrometheus+  , runStats+  ) where++import           GHC.Clock          ( getMonotonicTime )++import qualified Metrics.Counter    as Counter+import qualified Metrics.Gauge      as Gauge+import           Metrics.Registry   ( newRegistry, registerCounter, registerGauge )+import           Metrics.Snapshot   ( getCachedSnapshot, startSnapshotWorker )+-- Custom metrics implementation (replaces prometheus library)+import           Metrics.Types      ( Counter, Gauge, Registry )++import           Polysemy+import           Polysemy.Operators+import           Polysemy.Reader    ( Reader, ask )++import           Relude             hiding ( Reader, ask )++data StatsEnv+  = StatsEnv+  { statsStart :: !Double+  , statsRegistry :: !Registry+  , statsUploadBytesCounter :: !Counter+  , statsDownloadBytesCounter :: !Counter+  , statsServedCounter :: !Counter+  , statsFetchedCounter :: !Counter+  , statsActiveConnectionsGauge :: !Gauge+  , statsUptimeGauge :: !Gauge+  , statsDlTaskCounter :: !Counter+  , statsDlFileCounter :: !Counter+  , statsDlBytesCounter :: !Counter+  , statsErrorCounter :: !Counter+  , statsLatency :: !Gauge+  }++newStatsEnv :: IO StatsEnv+newStatsEnv = do+  t0 <- getMonotonicTime+  registry <- newRegistry+  uploadBytesCounter+    <- registerCounter "hath_cache_sent_bytes_total" "Total bytes sent from cache" registry+  downloadBytesCounter+    <- registerCounter "hath_cache_received_bytes_total" "Total bytes received into cache" registry+  servedCounter <- registerCounter "hath_cache_sent_total" "Total number of cache hits" registry+  fetchedCounter+    <- registerCounter "hath_cache_received_total" "Total number of cache misses" registry+  activeConnectionsGauge+    <- registerGauge "hath_active_connections" "Number of active connections" registry+  uptimeGauge <- registerGauge "hath_uptime_seconds" "Server uptime in seconds" registry+  dlTaskCounter+    <- registerCounter "hath_download_task_count_total" "Total gallery download tasks" registry+  dlFileCounter+    <- registerCounter "hath_download_file_count_total" "Total gallery files downloaded" registry+  dlBytesCounter <- registerCounter+    "hath_download_size_bytes_total"+    "Total bytes downloaded from galleries"+    registry+  errorCounter <- registerCounter "hath_errors_total" "Total errors" registry+  latencyGauge <- registerGauge "hath_latency_seconds" "Request latency in seconds" registry++  -- Start background snapshot worker (updates every 5 seconds)+  startSnapshotWorker registry (5 * 1000000)++  pure+    $ StatsEnv+      t0+      registry+      uploadBytesCounter+      downloadBytesCounter+      servedCounter+      fetchedCounter+      activeConnectionsGauge+      uptimeGauge+      dlTaskCounter+      dlFileCounter+      dlBytesCounter+      errorCounter+      latencyGauge++data Stats m a where+  AddUpload :: Int -> Stats m ()+  AddDownload :: Int -> Stats m ()+  IncServed :: Stats m ()+  IncFetched :: Stats m ()+  ReadPrometheus :: Stats m Text++  -- New uptime metric+  UpdateUptime :: Stats m ()++  -- Active connections+  IncActiveConnections :: Stats m ()+  DecActiveConnections :: Stats m ()++  -- Gallery Downloader metrics+  IncDlTask :: Stats m ()+  IncDlFile :: Stats m ()+  AddDlBytes :: Int -> Stats m ()++  -- Error metrics with labels+  IncError :: Text -> Stats m ()  -- error type label++makeSem ''Stats++runStats :: Members '[ Embed IO, Reader StatsEnv ] r => Stats : r @> a -> r @> a+runStats = interpret $ \case+  AddUpload n -> do+    env <- ask+    embed $ Counter.add n (statsUploadBytesCounter env)+  AddDownload n -> do+    env <- ask+    embed $ Counter.add n (statsDownloadBytesCounter env)+  IncServed -> do+    env <- ask+    embed $ Counter.inc (statsServedCounter env)+  IncFetched -> do+    env <- ask+    embed $ Counter.inc (statsFetchedCounter env)++  -- New uptime metric+  UpdateUptime -> do+    env <- ask+    now <- embed getMonotonicTime+    let elapsed = now - statsStart env+    embed $ Gauge.set (round elapsed) (statsUptimeGauge env)++  -- Active connections+  IncActiveConnections -> do+    env <- ask+    embed $ Gauge.inc (statsActiveConnectionsGauge env)++  DecActiveConnections -> do+    env <- ask+    embed $ Gauge.dec (statsActiveConnectionsGauge env)++  -- Gallery Downloader metrics+  IncDlTask -> do+    env <- ask+    embed $ Counter.inc (statsDlTaskCounter env)+  IncDlFile -> do+    env <- ask+    embed $ Counter.inc (statsDlFileCounter env)+  AddDlBytes n -> do+    env <- ask+    embed $ Counter.add n (statsDlBytesCounter env)++  -- Error metrics with labels+  IncError _errorType -> do+    env <- ask+    embed $ Counter.inc (statsErrorCounter env)++  ReadPrometheus -> do+    env <- ask+    snapshot <- embed $ getCachedSnapshot (statsRegistry env)+    pure $ decodeUtf8 snapshot+
+ src/Storage/Database.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TypeOperators #-}++module Storage.Database ( FileRecord(..), initializeDB, runCache, runCachePure ) where++import           Data.String.Interpolate ( i )++import           Database.SQLite.Simple++import           Polysemy+import           Polysemy.KVStore        ( KVStore(..), runKVStorePurely )+import           Polysemy.Operators++import           Relude                  hiding ( Reader, State, ask, evalState, get, modify, put )++import           Types                   ( FileRecord(..), FileURI, StorageResult(..) )++{-# INLINE initializeDB #-}+-- | Initialize database with required schema+initializeDB :: Connection -> IO ()+initializeDB conn = do+  execute_+    conn+    [i|CREATE TABLE IF NOT EXISTS files (+        lru_counter INTEGER NOT NULL DEFAULT 0,+        s4 TEXT NOT NULL,+        file_id TEXT PRIMARY KEY,+        file_name TEXT,+        bytes BLOB NOT NULL+    ) strict|]+  execute_ conn "pragma journal_mode=delete"+  execute_ conn "pragma synchronous=normal"+  execute_ conn "pragma temp_store=memory"++    -- execute_ conn "pragma cache_size=100000"+    -- execute_ conn "pragma mmap_size=65536"+-- | Run the cache with SQLite+runCache+  :: Members '[ Embed IO ] r => Connection -> KVStore FileURI StorageResult : r @> a -> r @> a+runCache conn = interpret $ \case+  LookupKV uri -> do+    let fid = show @Text uri+    embed+      $ execute conn "UPDATE files SET lru_counter = lru_counter + 1 WHERE file_id = ?" (Only fid)+    results <- embed+      $ query+        conn+        "SELECT lru_counter, s4, file_id, file_name, bytes FROM files WHERE file_id = ?"+        (Only fid)+    case listToMaybe results of+      Just record -> return $ Just (Record record)+      Nothing     -> return Nothing++  UpdateKV _uri (Just (Redirect _url))+    -> error "impossible: cannot store Redirect in Database backend"++  UpdateKV _ (Just (Record record)) -> do+    embed+      $ execute+        conn+        [i|INSERT OR REPLACE INTO files+                    (lru_counter, s4, file_id, file_name, bytes)+                    VALUES (?, ?, ?, ?, ?)|]+        record++  UpdateKV uri Nothing -> let+      fid = show @ByteString uri+    in +      embed $ execute conn "DELETE FROM files WHERE file_id = ?" (Only fid)++{-# INLINE runCachePure #-}+runCachePure :: Map FileURI FileRecord -> KVStore FileURI FileRecord : r @> a -> r @> a+runCachePure initial = fmap snd . runKVStorePurely initial
+ src/Storage/Filesystem.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Storage.Filesystem ( runCacheFilesystem ) where++import           Colog              ( Message, Severity(Error) )+import           Colog.Polysemy     ( Log )++import           Control.Exception  ( try )++import qualified Data.ByteString    as BS+import           Data.Cache.LRU.IO+import qualified Data.Cache.LRU.IO  as LRU+import qualified Data.Text          as T++import           Polysemy+import           Polysemy.Error     ( Error, throw )+import           Polysemy.KVStore   ( KVStore(..) )+import           Polysemy.Operators+import           Polysemy.Reader    ( Reader, asks )++import           Relude             hiding ( Reader, ask, asks )++import           Storage.Database   ( FileRecord(..) )++import           System.Directory   ( createDirectoryIfMissing, doesFileExist, removeFile )+import           System.FilePath    ( (</>), takeDirectory, takeFileName )++import           Types              ( ClientConfig, FileURI(..), RPCError(..), StorageResult(..) )+import qualified Types              as Ty++import           Utils              ( log )++-- | Generate filesystem path from root and FileURI+-- Format: root/s4/fileid+fileURIToPath :: FilePath -> FileURI -> FilePath+fileURIToPath root uri = root </> s4 </> fileId+  where+    -- Sanitize to prevent directory traversal+    fileId = takeFileName (show uri)++    s4     = T.unpack $ T.take 4 (T.pack fileId)++-- | Run the cache with Filesystem backend+runCacheFilesystem :: Members '[ Embed IO, Log Message, Reader ClientConfig, Error RPCError ] r+                   => FilePath -- ^ Cache root directory+                   -> KVStore FileURI StorageResult : r @> a+                   -> r @> a+runCacheFilesystem root m = do+  lruSize <- asks Ty.lruCacheSize+  let entries = Just (fromIntegral (lruSize `div` 300000)) -- Approximate number of entries based on avg file size ~300 KiB+  memCache <- embed $ newAtomicLRU entries+  interpret (phi memCache) m+  where+    phi :: forall r r1 x. Members '[ Embed IO, Log Message, Error RPCError ] r1+        => AtomicLRU FileURI FileRecord+        -> KVStore FileURI StorageResult (Sem r) x+        -> Sem r1 x+    phi cache (LookupKV uri) = do+      let path = fileURIToPath root uri+      embed (LRU.lookup uri cache) >>= \case+        Just res -> pure $ Just $ Record res+        Nothing  -> do+          result <- embed $ try @SomeException $ BS.readFile path+          case result of+            Left _      -> pure Nothing -- File not found or read error+            Right bytes -> do+              let recd = Ty.reconstructRecord uri bytes+              embed $ LRU.insert uri recd cache+              pure $ Just $ Record recd++    phi _cache (UpdateKV _uri (Just (Redirect _url)))+      = error "impossible: cannot store Redirect in Filesystem backend"++    phi cache (UpdateKV uri (Just (Record record))) = do+      let path    = fileURIToPath root uri+          content = fileRecordBytes record+      result <- embed $ try @SomeException $ do+        createDirectoryIfMissing True (takeDirectory path)+        BS.writeFile path content+      case result of+        Left err -> do+          log Error ("Filesystem write failed for " <> T.pack path <> ": " <> T.pack (show err))+          throw $ Ty.StorageError (T.pack $ show err)+        Right _  -> embed $ LRU.insert uri record cache++    phi cache (UpdateKV uri Nothing) = do+      let path = fileURIToPath root uri+      result <- embed $ try @SomeException $ do+        exists <- doesFileExist path+        when exists $ removeFile path+      case result of+        Left err -> do+          log Error ("Filesystem delete failed for " <> T.pack path <> ": " <> T.pack (show err))+          throw $ Ty.StorageError (T.pack $ show err)+        Right _  -> embed $ void $ LRU.delete uri cache
+ src/Storage/Locate.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TemplateHaskell #-}++module Storage.Locate ( LocateURI(..), Locate(..), locateResource, runLocate ) where++import           Colog                   ( Message, Severity(Info, Warning) )+import           Colog.Polysemy          ( Log )++import qualified Data.ByteString         as BS+import qualified Data.ByteString.Short   as SBS+import qualified Data.Map                as Map+import           Data.String.Interpolate ( i )++import           Interface.API           ( EHentaiAPI, fetchResource )++import           Polysemy+import           Polysemy.Error          ( Error )+import           Polysemy.KVStore        ( KVStore, lookupKV, updateKV )+import           Polysemy.Operators+import           Polysemy.Reader         ( Reader )++import           Relude                  hiding ( Reader, ask )++import           SettingM                ( SettingM, getSettings )++import           Stats                   ( Stats, addDownload, incFetched )++import           Types++import           Utils                   ( log )++data LocateURI+  = LocateURI { locateURIFilename :: !ByteString+              , locateURI         :: !FileURI+              , locateURIOptions  :: !(Map ByteString ByteString)+              }++data Locate m a where+  -- | Fetch a specific resource from the server+  LocateResource :: LocateURI -> Locate m (Maybe StorageResult)++makeSem ''Locate++runLocate+  :: Members+    '[ KVStore FileURI StorageResult+     , SettingM+     , Error RPCError+     , Reader ClientConfig+     , EHentaiAPI+     , Embed IO+     , Stats+     , Log Message+     ]+    r+  => Locate : r @> a+  -> r @> a+runLocate = interpret $ \case+  LocateResource uri -> do+    settings <- getSettings+    let fileURI = locateURI uri+        s4      = SBS.take 4 . show $ fileURI+    -- if HashSet.member s4 (staticRanges settings) <-- we have a bug in setting parsing. wait for fix+    if True+      then lookupKV fileURI >>= \case+        Just x@Redirect {} -> return $ Just x+        Just x@Record {} -> return $ Just x+        Nothing -> case ( Map.lookup "fileindex" (locateURIOptions uri)+                        , Map.lookup "xres" (locateURIOptions uri)+                        ) of+          ( Just fileIndex, Just xres ) -> log Info [i|Fetching resource: #{fileURI}|]+            >> fetchResource fileURI ( fileIndex, xres )+            >>= \case+              Just content -> do+                incFetched+                addDownload (BS.length content)+                let record+                      = Record+                        FileRecord+                        { fileRecordLRUCounter = 1+                        , fileRecordS4         = decodeUtf8 s4+                        , fileRecordFileId     = show fileURI+                        , fileRecordFileName   = Just $ decodeUtf8 $ locateURIFilename uri+                        , fileRecordBytes      = content+                        }+                updateKV fileURI $ Just record+                pure $ Just record+              Nothing      -> do+                log Warning [i|Failed to fetch resource, sorry for you|]+                pure Nothing+          _ -> do+            log Info [i|Not enough information to fetch resource: #{fileURI}|]+            pure Nothing+      else do+        log Info [i|Resource not in our ranges, rejecting: #{s4}|]+        pure Nothing
+ src/Storage/R2.hs view
@@ -0,0 +1,173 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Storage.R2 ( R2Connection(..), mkR2Connection, runCacheR2 ) where++import           Colog                   ( Message, Severity(Error, Warning) )+import           Colog.Polysemy          ( Log )++import qualified Conduit                 as C++import           Control.Exception       ( try )++import qualified Data.ByteArray          as BA+import qualified Data.ByteString         as BS+import           Data.Cache.LRU.IO+import qualified Data.Cache.LRU.IO       as LRU+import qualified Data.Text               as T++import           GHC.Clock               ( getMonotonicTime )++import           Network.HTTP.Client     ( newManager )+import           Network.HTTP.Client.TLS ( tlsManagerSettings )+import           Network.Minio           ( AccessKey(..)+                                         , CredentialValue(..)+                                         , SecretKey(..)+                                         , defaultPutObjectOptions+                                         , presignedGetObjectUrl+                                         , removeObject+                                         , setCreds+                                         , setRegion+                                         )+import qualified Network.Minio           as Minio+import           Network.Minio.S3API     ( headObject )++import           Polysemy+import           Polysemy.Error          ( Error, throw )+import           Polysemy.KVStore        ( KVStore(..) )+import           Polysemy.Operators+import           Polysemy.Reader         ( Reader, asks )++import           Relude                  hiding ( Reader, ask, asks )++import           Storage.Database        ( FileRecord(..) )++import           Types                   ( ClientConfig+                                         , FileURI(..)+                                         , RPCError(..)+                                         , StorageResult(..)+                                         )+import qualified Types                   as Ty++import           Utils                   ( log )++-- | R2 connection configuration built at runtime+data R2Connection = R2Connection { r2MinioConn :: !Minio.MinioConn, r2ConnBucket :: !Text }++-- | Build R2 connection from config + environment variables+-- Reads R2_ACCESS_KEY and R2_SECRET_KEY from environment+mkR2Connection :: Ty.R2Config -> IO (Either Text R2Connection)+mkR2Connection cfg = do+  accessKeyMay <- lookupEnv "R2_ACCESS_KEY"+  secretKeyMay <- lookupEnv "R2_SECRET_KEY"+  case ( accessKeyMay, secretKeyMay ) of+    ( Nothing, _ ) -> pure $ Left "R2_ACCESS_KEY environment variable not set"+    ( _, Nothing ) -> pure $ Left "R2_SECRET_KEY environment variable not set"+    ( Just accessKey, Just secretKey ) -> do+      let creds+            = CredentialValue+            { cvAccessKey    = AccessKey $ T.pack accessKey+            , cvSecretKey    = SecretKey $ BA.convert (encodeUtf8 @String @ByteString secretKey)+            , cvSessionToken = Nothing+            }+          -- Use IsString instance to parse endpoint URL+          baseConnInfo = fromString $ T.unpack $ Ty.r2Endpoint cfg+      -- Set credentials and region+      minioConn <- liftIO $ do+        manager <- newManager tlsManagerSettings+        Minio.mkMinioConn (setCreds creds $ setRegion "auto" baseConnInfo) manager+      pure $ Right R2Connection { r2MinioConn = minioConn, r2ConnBucket = Ty.r2Bucket cfg }++-- | Generate R2 object key from FileURI+-- Format: s4/hash-size-xres-yres-ext+fileURIToKey :: FileURI -> Text+fileURIToKey uri = s4 <> "/" <> fileId+  where+    fileId = show uri++    s4     = T.take 4 fileId++-- | Run the cache with Cloudflare R2+-- Read operations silently degrade to Nothing on failure (with warning log)+-- Write/delete operations propagate errors+runCacheR2 :: Members '[ Embed IO, Log Message, Reader ClientConfig, Error RPCError ] r+           => R2Connection+           -> KVStore FileURI StorageResult : r @> a+           -> r @> a+runCacheR2 conn m = do+  lruSize <- asks Ty.lruCacheSize+  let entries = Just (fromIntegral (lruSize `div` 300)) -- Approximate number of entries based on avg url link size ~300 bytes+  memCache <- embed $ newAtomicLRU entries+  interpret (phi memCache) m+  where+    bucket = r2ConnBucket conn++    phi :: forall r r1 x. Members '[ Embed IO, Log Message, Error RPCError ] r1+        => AtomicLRU FileURI ( Double, ByteString )+        -> KVStore FileURI StorageResult (Sem r) x+        -> Sem r1 x+    phi cache (LookupKV uri@(fileURIToKey -> key))         = do+      now <- embed getMonotonicTime+      embed (LRU.lookup uri cache) >>= \case+        Just ( expireTime, link )+          | now < expireTime -> pure $ Just $ Redirect link+        _ -> do+          -- First, check if object exists using HEAD request+          headResult <- embed+            $ try @SomeException+            $ Minio.runMinioWith (r2MinioConn conn)+            $ headObject bucket key []+          case headResult of+            Right (Right _info) -> do+              -- Object exists, try to generate presigned URL (1200 seconds expiry = 20 mins)+              maybeLink <- embed+                (Minio.runMinioWith+                   (r2MinioConn conn)+                   (presignedGetObjectUrl bucket key 1200 [] []))+              case maybeLink of+                Left _minioErr -> pure Nothing+                Right link     -> do+                  let expireTime = now + 600 -- 10 minutes cache TTL to ensure fresh links+                  embed $ LRU.insert uri ( expireTime, link ) cache+                  pure $ Just $ Redirect link+            _ -> do+              -- Object does not exist in R2 storage+              log Warning ("Object not found in R2 storage: " <> key)+              pure Nothing++    phi _cache (UpdateKV _uri (Just (Redirect _url)))+      = error "impossible: cannot store Redirect in R2 backend"++    phi _cache (UpdateKV uri (Just (Record record)))       = do+      let key     = fileURIToKey uri+          content = fileRecordBytes record+          siz     = fromIntegral (BS.length content) :: Int64+          src     = C.yield content+      result <- embed+        $ try @SomeException+        $ Minio.runMinioWith (r2MinioConn conn)+        $ Minio.putObject bucket key src (Just siz) defaultPutObjectOptions+      case result of+        Left err -> do+          log Error ("R2 write failed for " <> key <> ": " <> T.pack (show err))+          throw $ Ty.StorageError (T.pack $ show err)+        Right (Left minioErr) -> do+          log Error ("R2 write failed for " <> key <> ": " <> T.pack (show minioErr))+          throw $ Ty.StorageError (T.pack $ show minioErr)+        Right (Right _) -> pure ()++    phi cache (UpdateKV uri@(fileURIToKey -> key) Nothing) = do+      result <- embed+        $ try @SomeException+        $ Minio.runMinioWith (r2MinioConn conn)+        $ removeObject bucket key+      case result of+        Left err -> do+          log Error ("R2 delete failed for " <> key <> ": " <> T.pack (show err))+          throw $ Ty.StorageError (T.pack $ show err)+        Right (Left minioErr) -> do+          log Error ("R2 delete failed for " <> key <> ": " <> T.pack (show minioErr))+          throw $ Ty.StorageError (T.pack $ show minioErr)+        Right (Right _) -> embed $ void $ LRU.delete uri cache
+ src/Types.hs view
@@ -0,0 +1,353 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE Strict #-}++module Types+  (  -- * Types+    ClientProxy(..)+  , ClientConfig(..)+  , GalleryMetadata(..)+  , HathSettings(..)+  , GalleryFile(..)+  , RPCError(..)+  , FileURI(..)+  , RPCResponse(..)+  , CacheBackend(..)+  , R2Config(..)+  , FileRecord(..)+  , StorageResult(..)+    -- * Globals+  , hentaiHeader+    -- * Default values+  , defaultHathSettings+  , defaultClientConfig+  , emptyFileURI+  , emptyMetadata+    -- * Parsing+  , parseSettings+  , parseMetadata+  , readClientConfig+  , parseFileURI+  , parseRPCResponse+  , parseRPCResponse'+  , reconstructRecord+    -- * Selectors+  , getPayload+  ) where++import qualified Data.ByteString.Char8  as BS+import qualified Data.ByteString.Short  as SBS+import qualified Data.HashSet           as HashSet+import qualified Data.Text              as T++import           Database.SQLite.Simple ( FromRow, ToRow )++import           Dhall                  ( FromDhall(..), ToDhall(..), auto, input )++import           Network.HTTP.Types     ( HeaderName )++import           Polysemy               ( Member, Sem )+import           Polysemy.Error         ( Error )+import qualified Polysemy.Error         as Error++import           Prelude                ( Show(show) )++import           Relude                 hiding ( show )++import           Text.Printf            ( printf )++{-# SPECIALISE hentaiHeader :: [ ( HeaderName, Text ) ] #-}+{-# SPECIALISE hentaiHeader :: [ ( HeaderName, ByteString ) ] #-}+hentaiHeader :: IsString a => [ ( HeaderName, a ) ]+hentaiHeader+  = [ ( "Connection", "close" )+    , ( "User-Agent", "Hentai@Home 176" )+    , ( "Cache-Control", "public, max-age=31536000" )+    , ( "Server", "Genetic Lifeform and Distributed Open Server 1.6.4" )+    , ( "X-Content-Type-Options", "nosniff" )+    ]++data ClientProxy+  = ClientProxy { host :: {-# UNPACK #-} !Text+                , port :: {-# UNPACK #-} !Integer+                , auth :: {-# UNPACK #-} !(Maybe ( Text, Text ))+                }+  deriving ( Show, Generic )++instance FromDhall ClientProxy++instance ToDhall ClientProxy++-- | Cache backend selection+data CacheBackend = CacheBackendSQLite | CacheBackendR2 | CacheBackendFilesystem+  deriving ( Show, Eq, Generic )++instance FromDhall CacheBackend++instance ToDhall CacheBackend++-- | R2 configuration (endpoint and bucket from config, secrets from env)+data R2Config = R2Config { r2Endpoint :: {-# UNPACK #-} !Text, r2Bucket :: {-# UNPACK #-} !Text }+  deriving ( Show, Generic )++instance FromDhall R2Config++instance ToDhall R2Config++data ClientConfig+  = ClientConfig+  { clientId     :: {-# UNPACK #-} !Text+  , key          :: {-# UNPACK #-} !Text+  , version      :: {-# UNPACK #-} !Text+  , proxy        :: {-# UNPACK #-} !(Maybe ClientProxy)+  , downloadDir  :: {-# UNPACK #-} !Text+  , cachePath    :: {-# UNPACK #-} !Text+  , cacheBackend :: !CacheBackend+  , r2Config     :: !(Maybe R2Config)+  , lruCacheSize :: {-# UNPACK #-} !Int64+  }+  deriving ( Show, Generic )++instance FromDhall ClientConfig++instance ToDhall ClientConfig++defaultClientConfig :: ClientConfig+defaultClientConfig+  = ClientConfig+  { clientId     = ""+  , key          = ""+  , version      = ""+  , proxy        = Nothing+  , downloadDir  = ""+  , cachePath    = ""+  , cacheBackend = CacheBackendSQLite+  , r2Config     = Nothing+  , lruCacheSize = 100 * 1024 * 1024 -- 100 MiB, roughly 100 MiB / 300 KiB per file = 341 entries+  }++readClientConfig :: Text -> IO ClientConfig+readClientConfig = input auto++data HathSettings+  = HathSettings+  { rpcBaseURL         :: {-# UNPACK #-} !ShortByteString+  , clientHost         :: {-# UNPACK #-} !ShortByteString+  , clientPort         :: {-# UNPACK #-} !Int+  , throttleBytes      :: {-# UNPACK #-} !Int64+  , diskLimitBytes     :: {-# UNPACK #-} !Int64+  , diskRemainingBytes :: {-# UNPACK #-} !Int64+  , cacheNeedsRescan   :: {-# UNPACK #-} !Bool+  , cacheNeedsVerify   :: {-# UNPACK #-} !Bool+  , useLessMemory      :: {-# UNPACK #-} !Bool+  , checkIPOrigin      :: {-# UNPACK #-} !Bool+  , floodControl       :: {-# UNPACK #-} !Bool+  , staticRanges       :: {-# UNPACK #-} !(HashSet ShortByteString)+  }+  deriving ( Show )++defaultHathSettings :: HathSettings+defaultHathSettings+  = HathSettings+  { rpcBaseURL         = "/15/rpc"+  , clientHost         = ""+  , clientPort         = 0+  , throttleBytes      = 0+  , diskLimitBytes     = 0+  , diskRemainingBytes = 0+  , cacheNeedsRescan   = False+  , cacheNeedsVerify   = False+  , useLessMemory      = False+  , checkIPOrigin      = True+  , floodControl       = True+  , staticRanges       = mempty+  }++parseSettings :: [ ByteString ] -> HathSettings+parseSettings+  = foldl' (\s kv -> let+                ( k, rest ) = BS.span (/= '=') kv+                v           = BS.drop 1 rest+              in +                case ( k, readMaybe @Int64 (BS.unpack v) ) of+                  ( "host", _ ) -> s { clientHost = SBS.toShort v }+                  ( "port", Just p ) -> s { clientPort = fromIntegral p }+                  ( "throttle_bytes", Just bytes ) -> s { throttleBytes = bytes }+                  ( "disklimit_bytes", Just bytes ) -> s { diskLimitBytes = bytes }+                  ( "diskremaining_bytes", Just bytes ) -> s { diskRemainingBytes = bytes }+                  ( "static_ranges", _ ) -> s+                    { staticRanges = HashSet.fromList (SBS.toShort <$> BS.split ';' v) }+                  _ -> s) defaultHathSettings++data GalleryFile+  = GalleryFile { galleryFilePage  :: {-# UNPACK #-} !Int+                , galleryFileIndex :: {-# UNPACK #-} !Int+                , galleryFileName  :: {-# UNPACK #-} !ByteString+                , galleryFileXRes  :: {-# UNPACK #-} !ByteString+                , galleryFileHash  :: {-# UNPACK #-} !ByteString+                , galleryFileExt   :: {-# UNPACK #-} !ByteString+                }+  deriving ( Eq )++data GalleryMetadata+  = GalleryMetadata { galleryID        :: {-# UNPACK #-} !Int+                    , galleryFileCount :: {-# UNPACK #-} !Int+                    , galleryMinXRes   :: {-# UNPACK #-} !ByteString+                    , galleryTitle     :: {-# UNPACK #-} !ByteString+                    , galleryFileList  :: {-# UNPACK #-} ![ GalleryFile ]+                    }+  deriving ( Eq )++emptyMetadata :: GalleryMetadata+emptyMetadata+  = GalleryMetadata+  { galleryID        = 0+  , galleryFileCount = 0+  , galleryMinXRes   = ""+  , galleryTitle     = ""+  , galleryFileList  = []+  }++{-# NOINLINE emptyMetadata #-}++parseMetadata :: ByteString -> GalleryMetadata+parseMetadata bytes = foldl' go emptyMetadata (BS.lines bytes)+  where+    go metadata line = case BS.words line of+      [] -> metadata+      [ "GID", maybeGid ]+        -> maybe metadata (\( gid, _ ) -> metadata { galleryID = gid }) (BS.readInt maybeGid)+      [ "FILECOUNT", maybeCount ] -> maybe+        metadata+        (\( count, _ ) -> metadata { galleryFileCount = count })+        (BS.readInt maybeCount)+      [ "MINXRES", xres ] -> metadata { galleryMinXRes = xres }+      ("TITLE" : rest) -> metadata { galleryTitle = BS.unwords rest }+      [ maybePage, maybeFid, mxres, hash, ext, basename ]+        -> case ( BS.readInt maybePage, BS.readInt maybeFid ) of+          ( Just ( page, _ ), Just ( fid, _ ) ) -> metadata+            { galleryFileList = GalleryFile+                { galleryFilePage  = page+                , galleryFileIndex = fid+                , galleryFileName  = basename+                , galleryFileXRes  = mxres+                , galleryFileHash  = hash+                , galleryFileExt   = ext+                }+                : galleryFileList metadata+            }+          _ -> metadata+      _ -> metadata++    {-# INLINE go #-}++data FileURI+  = FileURI { fileHash :: {-# UNPACK #-} !ByteString+            , fileSize :: {-# UNPACK #-} !Int+            , fileXRes :: {-# UNPACK #-} !Int+            , fileYRes :: {-# UNPACK #-} !Int+            , fileExt  :: {-# UNPACK #-} !ByteString+            }+  deriving ( Ord, Eq )++instance Show FileURI where+  show (FileURI { fileHash, fileSize, fileXRes, fileYRes, fileExt })+    = printf "%s-%d-%d-%d-%s" (BS.unpack fileHash) fileSize fileXRes fileYRes (BS.unpack fileExt)++emptyFileURI :: FileURI+emptyFileURI = FileURI { fileHash = "", fileSize = 0, fileXRes = 0, fileYRes = 0, fileExt = "" }++parseFileURI :: ByteString -> FileURI+parseFileURI bytes = loop 0 0 0 0 0 0+  where+    !len = BS.length bytes++    loop !idx !cnt !i1 !i2 !i3 !i4+      | idx >= len+        = if cnt == (4 :: Int)+          then mkURI i1 i2 i3 i4+          else emptyFileURI+      | BS.index bytes idx == '-' = case cnt of+        0 -> loop (idx + 1) 1 idx 0 0 0+        1 -> loop (idx + 1) 2 i1 idx 0 0+        2 -> loop (idx + 1) 3 i1 i2 idx 0+        3 -> loop (idx + 1) 4 i1 i2 i3 idx+        _ -> emptyFileURI+      | otherwise = loop (idx + 1) cnt i1 i2 i3 i4++    mkURI i1 i2 i3 i4+      = let+          hash = BS.take i1 bytes+          size = BS.take (i2 - i1 - 1) (BS.drop (i1 + 1) bytes)+          xres = BS.take (i3 - i2 - 1) (BS.drop (i2 + 1) bytes)+          yres = BS.take (i4 - i3 - 1) (BS.drop (i3 + 1) bytes)+          ext  = BS.drop (i4 + 1) bytes+        in +          FileURI { fileHash = hash+                  , fileSize = conv size+                  , fileXRes = conv xres+                  , fileYRes = conv yres+                  , fileExt  = ext+                  }++    conv = maybe 0 fst . BS.readInt++data RPCResponse+  = RPCResponse { statusCode :: {-# UNPACK #-} !ByteString, payload :: ![ ByteString ] }+  deriving ( Show, Eq, Generic )++data RPCError+  = EmptyResponse+  | RequestFailure {-# UNPACK #-} !Text  -- Contains the error status code+  | CertificateFailure {-# UNPACK #-} !Text+  | StorageError {-# UNPACK #-} !Text    -- Storage write/delete failure+  deriving ( Show, Eq, Generic )++instance Exception RPCError++{-# INLINE parseRPCResponse #-}+-- | Parse an RPC response from a lazy ByteString+-- The first line is the status code, followed by the payload lines+parseRPCResponse :: ByteString -> Either RPCError RPCResponse+parseRPCResponse bytes = case BS.lines bytes of+  [] -> Left EmptyResponse+  status : rest -> Right $ RPCResponse { statusCode = status, payload = rest }++{-# INLINE getPayload #-}+-- | Get the payload if the response was successful+getPayload :: RPCResponse -> Either RPCError [ ByteString ]+getPayload response+  | statusCode response == "OK" = Right $ payload response+  | otherwise = Left $ RequestFailure $ decodeUtf8 $ statusCode response++{-# INLINE parseRPCResponse' #-}+-- | Parse RPC responses effectfully+parseRPCResponse' :: Member (Error RPCError) r => ByteString -> Sem r [ ByteString ]+parseRPCResponse' bytes = Error.fromEither (getPayload =<< parseRPCResponse bytes)++data FileRecord+  = FileRecord { fileRecordLRUCounter :: {-# UNPACK #-} !Int64+               , fileRecordS4         :: {-# UNPACK #-} !Text+               , fileRecordFileId     :: {-# UNPACK #-} !Text+               , fileRecordFileName   :: {-# UNPACK #-} !(Maybe Text)+               , fileRecordBytes      :: !BS.ByteString+               }+  deriving ( Show, Generic, Eq )++instance FromRow FileRecord++instance ToRow FileRecord++-- | Reconstruct FileRecord from FileURI and bytes+reconstructRecord :: FileURI -> ByteString -> FileRecord+reconstructRecord uri bytes+  = FileRecord { fileRecordLRUCounter = 0+               , fileRecordS4         = T.take 4 fileId+               , fileRecordFileId     = fileId+               , fileRecordFileName   = Nothing+               , fileRecordBytes      = bytes+               }+  where+    fileId = T.pack $ show uri++data StorageResult = Record FileRecord | Redirect ByteString
+ src/Utils.hs view
@@ -0,0 +1,88 @@++module Utils ( module Utils ) where++import           Colog                   ( Message, Msg(..), Severity )+import           Colog.Polysemy          ( Log )+import qualified Colog.Polysemy          as Co++import           Crypto.Hash             ( SHA1 )+import qualified Crypto.Hash             as Crypto++import           Data.ByteArray.Encoding ( Base(Base16), convertToBase )+import qualified Data.ByteString         as BS+import qualified Data.ByteString.Char8   as BS8+import qualified Data.Map.Strict         as Map++import           Network.HTTP.Types      ( mkStatus )+import           Network.Wai             ( Response, responseLBS )++import           Polysemy.Operators++import           Relude++import qualified Servant.Types.SourceT   as Source+import           Servant.Types.SourceT   ( StepT )++type URLParams = Map.Map ByteString ByteString++{-# INLINE parseURLParams #-}+-- | Parse URL parameters in the format "key1=value1;key2=value2;key3;key4"+--+-- >>> parseURLParams "key1=value1;key2=value2;key3;key4"+parseURLParams :: ByteString -> URLParams+parseURLParams = foldl' insertPair Map.empty . BS8.split ';'+  where+    insertPair acc pair = case BS8.split '=' pair of+      []           -> acc+      [ key ]      -> Map.insert key mempty acc  -- Parameter without value becomes empty string+      [ key, val ] -> Map.insert key val acc+      key : val    -> error $ "Invalid URL parameter: " <> show key <> "=" <> show val++{-# INLINE lookupParam #-}+-- | Lookup a parameter value+lookupParam :: ByteString -> URLParams -> Maybe ByteString+lookupParam = Map.lookup++{-# INLINE hasParam #-}+-- | Check if a parameter exists+hasParam :: ByteString -> URLParams -> Bool+hasParam = Map.member++bufferSending :: Int -> StepT m ByteString+bufferSending 0 = Source.Stop+bufferSending n+  | n >= tcpBufferSize = Source.Yield preallocated (bufferSending (n - tcpBufferSize))+  | otherwise = Source.Yield (BS.take n preallocated) Source.Stop+  where+    tcpBufferSize :: Int+    tcpBufferSize = 1460++    preallocated :: ByteString+    preallocated = BS.replicate tcpBufferSize 54++-- msg :: sev -> Text -> Msg sev+-- msg sev m = withFrozenCallStack (Msg { msgSeverity = sev, msgStack = callStack, msgText = m })+{-# INLINE log #-}+log :: Severity -> Text -> Log Message -@> ()+log sev msg+  = withFrozenCallStack (Co.log Msg { msgSeverity = sev, msgStack = callStack, msgText = msg })++class HathHash a where+  hash :: ByteString -> a++instance HathHash Text where+  {-# INLINABLE hash #-}+  hash = decodeUtf8 @Text @ByteString . convertToBase Base16 . Crypto.hash @ByteString @SHA1++instance HathHash ByteString where+  {-# INLINABLE hash #-}+  hash = convertToBase Base16 . Crypto.hash @ByteString @SHA1++{-# INLINE tooManyRequestsResponse #-}+-- Standard 429 response+tooManyRequestsResponse :: Response+tooManyRequestsResponse+  = responseLBS+    (mkStatus 429 "Too Many Requests")+    [ ( "Content-Type", "text/plain" ) ]+    "Too Many Requests"
+ src/Version.hs view
@@ -0,0 +1,39 @@+{-# LANGUAGE TemplateHaskell #-}++module Version ( versionInfo ) where++import           Control.Exception   ( catch )++import qualified Data.Text           as T+import           Data.Time.Clock     ( getCurrentTime )+import           Data.Time.Format    ( defaultTimeLocale, formatTime )++import           Language.Haskell.TH ( runIO, stringE )++import           Relude++import           System.Process      ( readProcess )++-- | Version information string+versionInfo :: T.Text+versionInfo+  = T.unlines+    [ "hs-hath " <> commitStr <> " (" <> dateStr <> ")"+    , "Build Commit: " <> commitStr+    , "Build Date:   " <> dateStr+    ]+  where+    commitStr :: T.Text+    commitStr+      = T.strip $ T.pack $( runIO (do+                                     c <- catch+                                       (readProcess "git" [ "rev-parse", "--short=7", "HEAD" ] "")+                                       (\(_ :: SomeException) -> return "unknown")+                                     stringE c) )++    dateStr :: T.Text+    dateStr+      = T.strip $ T.pack $( runIO (do+                                     t <- getCurrentTime+                                     let d = formatTime defaultTimeLocale "%Y-%m-%d %H:%M:%S UTC" t+                                     stringE d) )
+ test/FilesystemSpec.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module FilesystemSpec ( filesystemSpecs ) where++import           Colog                ( LogAction(..), Message )+import           Colog.Polysemy       ( Log, runLogAction )++import           Storage.Database     ( FileRecord(..) )++import           Polysemy+import           Polysemy.Error       ( Error, runError )+import           Polysemy.KVStore     ( KVStore, lookupKV, updateKV )++import           Storage.Filesystem   ( runCacheFilesystem )++import           Relude               hiding ( Reader )++import           System.Directory     ( doesFileExist )+import           System.FilePath      ( (</>) )+import           System.IO.Temp       ( withSystemTempDirectory )++import           Test.Hspec++import           Types                ( FileURI, RPCError, parseFileURI )++-- | Sample file record for testing+sampleRecord :: FileRecord+sampleRecord = FileRecord+  {+    fileRecordLRUCounter = 0+  ,+    fileRecordS4         = "test"+  ,+    fileRecordFileId     = "testhash1234-1024-800-600-jpg"+  ,+    fileRecordFileName   = Just "test.jpg"+  ,+    fileRecordBytes      = "test content for Filesystem storage"+  }++-- | Parse a file URI from the sample record+sampleURI :: FileURI+sampleURI = parseFileURI "testhash1234-1024-800-600-jpg"++-- | Silence logs for cleaner test output+silentLogAction :: LogAction IO Message+silentLogAction = LogAction $ \_ -> pure ()++-- | Run a program with Filesystem cache effect (silent logging)+runWithFilesystemSilent :: FilePath+                        -> Sem '[KVStore FileURI FileRecord, Log Message, Error RPCError, Embed IO] a +                        -> IO (Either RPCError a)+runWithFilesystemSilent root program = +  runM+  . runError @RPCError+  . runLogAction @IO @Message silentLogAction+  . runCacheFilesystem root+  $ program++-- | Lookup with explicit type+lookupFile :: Member (KVStore FileURI FileRecord) r => FileURI -> Sem r (Maybe FileRecord)+lookupFile = lookupKV++-- | Update with explicit type+updateFile :: Member (KVStore FileURI FileRecord) r => FileURI -> Maybe FileRecord -> Sem r ()+updateFile = updateKV++filesystemSpecs :: Spec+filesystemSpecs = describe "Filesystem Cache Effect" $ do+  +  it "should store and retrieve a file record" $ do+    withSystemTempDirectory "hath-test" $ \tempDir -> do+      let root = tempDir </> "cache"+      +      -- Store+      storeResult <- runWithFilesystemSilent root $ updateFile sampleURI (Just sampleRecord)+      storeResult `shouldBe` Right ()+      +      -- Verify file exists on disk (impl detail check)+      -- Path: root/s4/fileid+      -- s4 for sampleURI: "test" (first 4 of hash? No, show uri)+      -- show uri: testhash1234-1024-800-600-jpg+      -- s4: test+      let expectedPath = root </> "test" </> "testhash1234-1024-800-600-jpg"+      exists <- doesFileExist expectedPath+      exists `shouldBe` True++      -- Retrieve+      retrieveResult <- runWithFilesystemSilent root $ lookupFile sampleURI+      case retrieveResult of+        Left err -> expectationFailure $ "Error: " <> show err+        Right Nothing -> expectationFailure "Expected file record but got Nothing"+        Right (Just record) -> do+          fileRecordBytes record `shouldBe` fileRecordBytes sampleRecord++  it "should return Nothing for non-existent file" $ do+    withSystemTempDirectory "hath-test" $ \tempDir -> do+      let root = tempDir </> "cache"+      let nonExistentURI = parseFileURI "nonexistent999-1024-800-600-jpg"+      +      result <- runWithFilesystemSilent root $ lookupFile nonExistentURI+      case result of+        Left err -> expectationFailure $ "Error: " <> show err+        Right Nothing -> pure ()+        Right (Just _) -> expectationFailure "Expected Nothing but got a record"++  it "should delete a file record" $ do+    withSystemTempDirectory "hath-test" $ \tempDir -> do+      let root = tempDir </> "cache"+      +      -- Store first+      _ <- runWithFilesystemSilent root $ updateFile sampleURI (Just sampleRecord)+      +      -- Delete+      deleteResult <- runWithFilesystemSilent root $ updateFile sampleURI Nothing+      deleteResult `shouldBe` Right ()+      +      -- Verify deleted on disk+      let expectedPath = root </> "test" </> "testhash1234-1024-800-600-jpg"+      exists <- doesFileExist expectedPath+      exists `shouldBe` False+      +      -- Verify lookup returns Nothing+      lookupResult <- runWithFilesystemSilent root $ lookupFile sampleURI+      lookupResult `shouldBe` Right Nothing
+ test/Integration.hs view
@@ -0,0 +1,858 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++-- | Integration tests for hs-hath full lifecycle+module Integration ( integrationSpecs ) where++import           Control.Concurrent       ( ThreadId, forkIO, killThread, threadDelay )+import           Control.Concurrent.MVar  ( MVar, newEmptyMVar, putMVar, tryTakeMVar )+import           Control.Concurrent.STM   ( TVar, newTVarIO )+import           Control.Exception        ( bracket, catch, SomeException )++import qualified Data.Aeson               as A+import qualified Data.Aeson               as A+import qualified Data.ByteString          as BS+import qualified Data.ByteString.Char8    as BSC+import qualified Data.ByteString.Lazy     as LBS+import qualified Data.HashMap.Strict      as HM+import qualified Data.Map.Strict          as Map+import           Data.String.Interpolate  ( i )+import qualified Data.Text                as T+import           Data.Text.Encoding       ( decodeUtf8, encodeUtf8 )+import           Data.Time.Clock.System   ( SystemTime(systemSeconds), getSystemTime )+import           Data.X509                ( CertificateChain(..), PrivKey )+import           Data.X509.File           ( readSignedObject, readKeyFile )++import           Storage.Database         ( initializeDB )+import           Database.SQLite.Simple   ( withConnection )++import           Utils                    ( hash )++import           MockRPC++import           Network.HTTP.Client      ( defaultManagerSettings+                                          , httpLbs+                                          , method+                                          , newManager+                                          , parseRequest+                                          , redirectCount+                                          , responseBody+                                          , responseStatus+                                          )+import           Network.HTTP.Types       ( status200, status301, status403, status404, status429 )+import qualified Network.Wai.Handler.Warp as Warp++import           Relude                   hiding ( Reader+                                                 , decodeUtf8+                                                 , encodeUtf8+                                                 , newEmptyMVar+                                                 , newTVarIO+                                                 , runReader+                                                 )++import           Server                   ( CacheRunner(..)++                                          , ServerAction(..)++                                          , makeApplication++                                          , startServer++                                          , IPMap++                                          , KeystampMap++                                          , GalleryTask(..)++                                          )++++import           Storage.Database         ( runCache )++++import           Stats                    ( newStatsEnv )++++import           System.Environment       ( setEnv )++++import           Test.Hspec++++import           UnliftIO                 ( TChan++++                                          , newTChanIO++++                                          , tryReadTChan++++                                          , writeTChan++++                                          )++++++++import           Types                    ( CacheBackend(..)+++                                          , ClientConfig(..)+                                          , HathSettings(..)+                                          , defaultHathSettings+                                          )++-- | Test configuration+testConfig :: Int -> ClientConfig+testConfig port+  = ClientConfig+  { clientId     = "test-client-001"+  , key          = "test-secret-key-12345"+  , version      = "1.0.0-test"+  , proxy        = Nothing+  , downloadDir  = "/tmp/hs-hath-test"+  , cachePath    = "/tmp/hs-hath-test-" <> show port <> ".db"+  , cacheBackend = CacheBackendSQLite+  , r2Config     = Nothing+  }++withTestServer+  :: MockRPCConfig+  -> ClientConfig+  -> HathSettings+  -> (Int -> IO a)+  -> IO a+withTestServer mockCfg clientCfg settings action = withMockRPC mockCfg $ do+  setEnv "HATH_RPC_HOST" ("localhost:" <> show (mockPort mockCfg))+  serverChan <- newTChanIO+  ipMap <- newTVarIO HM.empty+  ksVar <- newTVarIO HM.empty+  galleryHandler <- newTChanIO+  ssVar <- newTVarIO settings+  statsEnv <- newStatsEnv+  withConnection ":memory:" $ \conn -> do+    initializeDB conn+    let cacheRunner = CacheRunner { runCacheWith = runCache conn }+        app = makeApplication clientCfg ssVar serverChan galleryHandler ipMap ksVar False False cacheRunner statsEnv+    Warp.testWithApplication (pure app) action++-- | Helper to load test certificates+loadTestCertificates :: IO (CertificateChain, [PrivKey])+loadTestCertificates = do+  certs <- readSignedObject "test-cert.pem"+  keys <- readKeyFile "test-key.pem"+  return (CertificateChain certs, keys)++-- | Test with startServer (includes full initialization)+withStartServer+  :: MockRPCConfig+  -> ClientConfig+  -> HathSettings+  -> (Int -> TChan ServerAction -> IO a)+  -> IO a+withStartServer mockCfg clientCfg settings action = withMockRPC mockCfg $ do+  setEnv "HATH_RPC_HOST" ("localhost:" <> show (mockPort mockCfg))+  (certChain, keys) <- loadTestCertificates+  case keys of+    [] -> error "No private key found in test-key.pem"+    (privKey:_) -> do+      serverChan <- newTChanIO+      let certs = (certChain, privKey)+          port = clientPort settings+      +      -- Start server in background thread (skipVerify = True for tests)+      bracket+        (forkIO $ startServer clientCfg settings certs serverChan True False)+        killThread+        (\_ -> do+          -- Wait a bit for server to initialize+          threadDelay 1000000  -- 1 second+          -- Run the test action+          result <- action port serverChan+          -- Shutdown server gracefully+          atomically $ writeTChan serverChan GracefulShutdown+          threadDelay 500000  -- Wait for shutdown+          return result+        )++-- | Integration specs+integrationSpecs :: Spec+integrationSpecs = do+  describe "Full Server Lifecycle" $ do+    it "serves requested file by fetching from upstream (MockRPC)" $ do+      let mockPortNum = 19801+          mockContent = "TEST_FILE_CONTENT_123"+          mockConfig  = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent }+          clientCfg   = testConfig 0+          fileURIStr  = hash @Text mockContent <> "-123-1024-768-txt"++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        currentTime <- getSystemTime+        let ts = systemSeconds currentTime+            k  = key clientCfg+            challengeInput = encodeUtf8 [i|#{ts}-#{fileURIStr}-#{k}-hotlinkthis|]+            challenge = BS.take 10 (hash @ByteString challengeInput)+            keystampText = [i|#{ts}-#{decodeUtf8 challenge}|] :: Text+            opts = [i|keystamp=#{keystampText};fileindex=1;xres=1024|] :: Text+            url = [i|http://localhost:#{serverPort}/h/#{fileURIStr}/#{opts}/testfile.txt|]++        manager <- newManager defaultManagerSettings+        request <- parseRequest url+        response <- httpLbs request manager++        responseStatus response `shouldBe` status200+        LBS.toStrict (responseBody response) `shouldBe` mockContent+        let parsedOpts = Map.fromList $ do+              t <- T.splitOn ";" opts+              let (optKey, v) = T.breakOn "=" t+              pure (encodeUtf8 optKey, encodeUtf8 (T.drop 1 v))+        Map.lookup "keystamp" parsedOpts `shouldSatisfy` isJust++    it "rejects requests with invalid keystamp" $ do+      let mockPortNum = 19802+          mockContent = "TEST_FILE_CONTENT_123"+          mockConfig  = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent }+          clientCfg   = testConfig 1+          fileURIStr  = hash @Text mockContent <> "-123-1024-768-txt"++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        currentTime <- getSystemTime+        let ts = systemSeconds currentTime+            invalidKeystampText = "invalid" :: Text+            opts = [i|keystamp=#{invalidKeystampText};fileindex=1;xres=1024|] :: Text+            url = [i|http://localhost:#{serverPort}/h/#{fileURIStr}/#{opts}/testfile.txt|]++        manager <- newManager defaultManagerSettings+        request <- parseRequest url+        response <- httpLbs request manager++        responseStatus response `shouldBe` status403+        responseBody response `shouldSatisfy` const True++    it "applies rate limiting with 429 after bursts" $ do+      let mockPortNum = 19803+          mockContent = "RL_TEST_CONTENT"+          mockConfig  = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent }+          clientCfg   = testConfig 2+          fileURIStr  = hash @Text mockContent <> "-123-1024-768-txt"++      withTestServer mockConfig clientCfg defaultHathSettings { throttleBytes = 1 } $ \serverPort -> do+        now <- getSystemTime+        let ts = systemSeconds now+            k  = key clientCfg+            goodKeystamp =+              let inner = encodeUtf8 [i|#{ts}-#{fileURIStr}-#{k}-hotlinkthis|]+              in [i|#{ts}-#{decodeUtf8 (BS.take 10 (hash @ByteString inner))}|] :: Text+            opts = [i|keystamp=#{goodKeystamp};fileindex=1;xres=1024|] :: Text+            url = [i|http://localhost:#{serverPort}/h/#{fileURIStr}/#{opts}/testfile.txt|]++        manager <- newManager defaultManagerSettings+        req0 <- parseRequest url+        let burstRequests = replicate 7 req0++        responses <- forM burstRequests $ \req -> httpLbs req manager+        let statuses = responseStatus <$> responses+        length (filter (== status429) statuses) `shouldSatisfy` (>= 2)++    it "returns stats snapshot with non-negative counters" $ do+      let mockPortNum = 19804+          mockConfig  = defaultMockConfig { mockPort = mockPortNum }+          clientCfg   = testConfig 3++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        manager <- newManager defaultManagerSettings+        req <- parseRequest [i|http://localhost:#{serverPort}/metrics|]+        resp <- httpLbs req manager+        responseStatus resp `shouldBe` status200+        LBS.toStrict (responseBody resp) `shouldSatisfy` (\body -> "hath_cache_sent_total" `BS.isInfixOf` body)++    it "returns 404 for unknown raw routes" $ do+      let mockPortNum = 19805+          mockConfig  = defaultMockConfig { mockPort = mockPortNum }+          clientCfg   = testConfig 4++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        manager <- newManager defaultManagerSettings+        req <- parseRequest [i|http://localhost:#{serverPort}/unknown-path|]+        responseStatus <$> httpLbs req manager `shouldReturn` status404++    it "serves /robots.txt with disallow all" $ do+      let mockPortNum = 19806+          mockConfig  = defaultMockConfig { mockPort = mockPortNum }+          clientCfg   = testConfig 5++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        manager <- newManager defaultManagerSettings+        req <- parseRequest [i|http://localhost:#{serverPort}/robots.txt|]+        resp <- httpLbs req manager+        responseStatus resp `shouldBe` status200+        LBS.toStrict (responseBody resp) `shouldSatisfy` (\body -> "Disallow" `BS.isInfixOf` body)++    it "redirects /favicon.ico to e-hentai.org" $ do+      let mockPortNum = 19807+          mockConfig  = defaultMockConfig { mockPort = mockPortNum }+          clientCfg   = testConfig 6++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        manager <- newManager defaultManagerSettings+        req0 <- parseRequest [i|http://localhost:#{serverPort}/favicon.ico|]+        let req = req0 { redirectCount = 0 }+        resp <- httpLbs req manager+        responseStatus resp `shouldBe` status301++    it "handles /servercmd/still_alive" $ do+      let mockPortNum = 19808+          mockConfig  = defaultMockConfig { mockPort = mockPortNum }+          clientCfg   = testConfig 7++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        now <- getSystemTime+        let ts = systemSeconds now+        manager <- newManager defaultManagerSettings+        req <- parseRequest [i|http://localhost:#{serverPort}/servercmd/still_alive/additional/#{ts}/key|]+        resp <- httpLbs req manager+        responseStatus resp `shouldBe` status200+        LBS.toStrict (responseBody resp) `shouldSatisfy` (\body -> "FANTASTIC" `BS.isInfixOf` body)++    it "handles /servercmd/speed_test" $ do+      let mockPortNum = 19809+          mockConfig  = defaultMockConfig { mockPort = mockPortNum }+          clientCfg   = testConfig 8++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        now <- getSystemTime+        let ts = systemSeconds now+        manager <- newManager defaultManagerSettings+        req <- parseRequest [i|http://localhost:#{serverPort}/servercmd/speed_test/testsize=1000/#{ts}/key|]+        resp <- httpLbs req manager+        responseStatus resp `shouldBe` status200++    it "handles /t speed test endpoint with valid key" $ do+      let mockPortNum = 19810+          mockConfig  = defaultMockConfig { mockPort = mockPortNum }+          clientCfg   = testConfig 9+          testSize = 1000 :: Int++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        now <- getSystemTime+        let ts = systemSeconds now+            cid = clientId clientCfg+            k = key clientCfg+            challengeBS = encodeUtf8 $ T.pack $ "hentai@home-speedtest-" <> show testSize <> "-" <> show ts <> "-" <> T.unpack cid <> "-" <> T.unpack k+            testKeyText = hash @Text challengeBS+            urlStr = "http://localhost:" <> show serverPort <> "/t/" <> show testSize <> "/" <> show ts <> "/" <> T.unpack testKeyText <> "/nothing"+        manager <- newManager defaultManagerSettings+        req <- parseRequest urlStr+        resp <- httpLbs req manager+        responseStatus resp `shouldBe` status200++    it "rejects /t speed test with invalid time drift" $ do+      let mockPortNum = 19811+          mockConfig  = defaultMockConfig { mockPort = mockPortNum }+          clientCfg   = testConfig 10+          testSize = 1000 :: Int++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        let ts = 1000000 :: Int64+            testKeyStr = "invalid-key" :: String+            url = [i|http://localhost:#{serverPort}/t/#{testSize}/#{ts}/#{testKeyStr}/nothing|] :: String+        manager <- newManager defaultManagerSettings+        req <- parseRequest url+        resp <- httpLbs req manager+        responseStatus resp `shouldBe` status403++    it "handles HEAD request with 200" $ do+      let mockPortNum = 19812+          mockConfig  = defaultMockConfig { mockPort = mockPortNum }+          clientCfg   = testConfig 11++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        manager <- newManager defaultManagerSettings+        req0 <- parseRequest [i|http://localhost:#{serverPort}/anything|]+        let req = req0 { method = "HEAD" }+        resp <- httpLbs req manager+        responseStatus resp `shouldBe` status200+        responseBody resp `shouldBe` ""++    it "handles /servercmd/refresh_settings" $ do+      let mockPortNum = 19813+          mockConfig  = defaultMockConfig { mockPort = mockPortNum }+          clientCfg   = testConfig 12++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        now <- getSystemTime+        let ts = systemSeconds now+        manager <- newManager defaultManagerSettings+        req <- parseRequest [i|http://localhost:#{serverPort}/servercmd/refresh_settings/additional/#{ts}/key|]+        resp <- httpLbs req manager+        responseStatus resp `shouldBe` status200++    it "handles /servercmd/refresh_certs" $ do+      let mockPortNum = 19814+          mockConfig  = defaultMockConfig { mockPort = mockPortNum }+          clientCfg   = testConfig 13++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        now <- getSystemTime+        let ts = systemSeconds now+        manager <- newManager defaultManagerSettings+        req <- parseRequest [i|http://localhost:#{serverPort}/servercmd/refresh_certs/additional/#{ts}/key|]+        resp <- httpLbs req manager+        responseStatus resp `shouldBe` status200++    it "handles /servercmd/threaded_proxy_test with missing params" $ do+      let mockPortNum = 19815+          mockConfig  = defaultMockConfig { mockPort = mockPortNum }+          clientCfg   = testConfig 14++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        now <- getSystemTime+        let ts = systemSeconds now+        manager <- newManager defaultManagerSettings+        req <- parseRequest [i|http://localhost:#{serverPort}/servercmd/threaded_proxy_test/additional/#{ts}/key|]+        resp <- httpLbs req manager+        responseStatus resp `shouldBe` status403++    it "serves file with jpg extension and correct mime type" $ do+      let mockPortNum = 19816+          mockContent = "FAKE_JPG_CONTENT"+          mockConfig  = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent }+          clientCfg   = testConfig 15+          fileURIStr  = hash @Text mockContent <> "-123-1024-768-jpg"++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        currentTime <- getSystemTime+        let ts = systemSeconds currentTime+            k  = key clientCfg+            challengeInput = encodeUtf8 [i|#{ts}-#{fileURIStr}-#{k}-hotlinkthis|]+            challenge = BS.take 10 (hash @ByteString challengeInput)+            keystampText = [i|#{ts}-#{decodeUtf8 challenge}|] :: Text+            opts = [i|keystamp=#{keystampText};fileindex=1;xres=1024|] :: Text+            url = [i|http://localhost:#{serverPort}/h/#{fileURIStr}/#{opts}/test.jpg|]++        manager <- newManager defaultManagerSettings+        request <- parseRequest url+        response <- httpLbs request manager++        responseStatus response `shouldBe` status200+        LBS.toStrict (responseBody response) `shouldBe` mockContent++    it "serves file with png extension" $ do+      let mockPortNum = 19817+          mockContent = "FAKE_PNG_CONTENT"+          mockConfig  = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent }+          clientCfg   = testConfig 16+          fileURIStr  = hash @Text mockContent <> "-123-1024-768-png"++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        currentTime <- getSystemTime+        let ts = systemSeconds currentTime+            k  = key clientCfg+            challengeInput = encodeUtf8 [i|#{ts}-#{fileURIStr}-#{k}-hotlinkthis|]+            challenge = BS.take 10 (hash @ByteString challengeInput)+            keystampText = [i|#{ts}-#{decodeUtf8 challenge}|] :: Text+            opts = [i|keystamp=#{keystampText};fileindex=1;xres=1024|] :: Text+            url = [i|http://localhost:#{serverPort}/h/#{fileURIStr}/#{opts}/test.png|]++        manager <- newManager defaultManagerSettings+        request <- parseRequest url+        response <- httpLbs request manager++        responseStatus response `shouldBe` status200++    it "serves file with gif extension" $ do+      let mockPortNum = 19818+          mockContent = "FAKE_GIF_CONTENT"+          mockConfig  = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent }+          clientCfg   = testConfig 17+          fileURIStr  = hash @Text mockContent <> "-123-1024-768-gif"++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        currentTime <- getSystemTime+        let ts = systemSeconds currentTime+            k  = key clientCfg+            challengeInput = encodeUtf8 [i|#{ts}-#{fileURIStr}-#{k}-hotlinkthis|]+            challenge = BS.take 10 (hash @ByteString challengeInput)+            keystampText = [i|#{ts}-#{decodeUtf8 challenge}|] :: Text+            opts = [i|keystamp=#{keystampText};fileindex=1;xres=1024|] :: Text+            url = [i|http://localhost:#{serverPort}/h/#{fileURIStr}/#{opts}/test.gif|]++        manager <- newManager defaultManagerSettings+        request <- parseRequest url+        response <- httpLbs request manager++        responseStatus response `shouldBe` status200++    it "serves file with mp4 extension" $ do+      let mockPortNum = 19819+          mockContent = "FAKE_MP4_CONTENT"+          mockConfig  = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent }+          clientCfg   = testConfig 18+          fileURIStr  = hash @Text mockContent <> "-123-1024-768-mp4"++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        currentTime <- getSystemTime+        let ts = systemSeconds currentTime+            k  = key clientCfg+            challengeInput = encodeUtf8 [i|#{ts}-#{fileURIStr}-#{k}-hotlinkthis|]+            challenge = BS.take 10 (hash @ByteString challengeInput)+            keystampText = [i|#{ts}-#{decodeUtf8 challenge}|] :: Text+            opts = [i|keystamp=#{keystampText};fileindex=1;xres=1024|] :: Text+            url = [i|http://localhost:#{serverPort}/h/#{fileURIStr}/#{opts}/test.mp4|]++        manager <- newManager defaultManagerSettings+        request <- parseRequest url+        response <- httpLbs request manager++        responseStatus response `shouldBe` status200++    it "handles /servercmd/start_downloader" $ do+      let mockPortNum = 19820+          mockConfig  = defaultMockConfig { mockPort = mockPortNum }+          clientCfg   = testConfig 19++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        now <- getSystemTime+        let ts = systemSeconds now+        manager <- newManager defaultManagerSettings+        req <- parseRequest [i|http://localhost:#{serverPort}/servercmd/start_downloader/additional/#{ts}/key|]+        resp <- httpLbs req manager+        responseStatus resp `shouldBe` status200++    it "serves file with webm extension" $ do+      let mockPortNum = 19821+          mockContent = "FAKE_WEBM_CONTENT"+          mockConfig  = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent }+          clientCfg   = testConfig 20+          fileURIStr  = hash @Text mockContent <> "-123-1024-768-wbm"++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        currentTime <- getSystemTime+        let ts = systemSeconds currentTime+            k  = key clientCfg+            challengeInput = encodeUtf8 [i|#{ts}-#{fileURIStr}-#{k}-hotlinkthis|]+            challenge = BS.take 10 (hash @ByteString challengeInput)+            keystampText = [i|#{ts}-#{decodeUtf8 challenge}|] :: Text+            opts = [i|keystamp=#{keystampText};fileindex=1;xres=1024|] :: Text+            url = [i|http://localhost:#{serverPort}/h/#{fileURIStr}/#{opts}/test.webm|]++        manager <- newManager defaultManagerSettings+        request <- parseRequest url+        response <- httpLbs request manager++        responseStatus response `shouldBe` status200++    it "serves file with webp extension" $ do+      let mockPortNum = 19822+          mockContent = "FAKE_WEBP_CONTENT"+          mockConfig  = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent }+          clientCfg   = testConfig 21+          fileURIStr  = hash @Text mockContent <> "-123-1024-768-wbp"++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        currentTime <- getSystemTime+        let ts = systemSeconds currentTime+            k  = key clientCfg+            challengeInput = encodeUtf8 [i|#{ts}-#{fileURIStr}-#{k}-hotlinkthis|]+            challenge = BS.take 10 (hash @ByteString challengeInput)+            keystampText = [i|#{ts}-#{decodeUtf8 challenge}|] :: Text+            opts = [i|keystamp=#{keystampText};fileindex=1;xres=1024|] :: Text+            url = [i|http://localhost:#{serverPort}/h/#{fileURIStr}/#{opts}/test.webp|]++        manager <- newManager defaultManagerSettings+        request <- parseRequest url+        response <- httpLbs request manager++        responseStatus response `shouldBe` status200++    it "serves file with avif extension" $ do+      let mockPortNum = 19823+          mockContent = "FAKE_AVIF_CONTENT"+          mockConfig  = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent }+          clientCfg   = testConfig 22+          fileURIStr  = hash @Text mockContent <> "-123-1024-768-avf"++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        currentTime <- getSystemTime+        let ts = systemSeconds currentTime+            k  = key clientCfg+            challengeInput = encodeUtf8 [i|#{ts}-#{fileURIStr}-#{k}-hotlinkthis|]+            challenge = BS.take 10 (hash @ByteString challengeInput)+            keystampText = [i|#{ts}-#{decodeUtf8 challenge}|] :: Text+            opts = [i|keystamp=#{keystampText};fileindex=1;xres=1024|] :: Text+            url = [i|http://localhost:#{serverPort}/h/#{fileURIStr}/#{opts}/test.avif|]++        manager <- newManager defaultManagerSettings+        request <- parseRequest url+        response <- httpLbs request manager++        responseStatus response `shouldBe` status200++    it "serves file with jxl extension" $ do+      let mockPortNum = 19824+          mockContent = "FAKE_JXL_CONTENT"+          mockConfig  = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent }+          clientCfg   = testConfig 23+          fileURIStr  = hash @Text mockContent <> "-123-1024-768-jxl"++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        currentTime <- getSystemTime+        let ts = systemSeconds currentTime+            k  = key clientCfg+            challengeInput = encodeUtf8 [i|#{ts}-#{fileURIStr}-#{k}-hotlinkthis|]+            challenge = BS.take 10 (hash @ByteString challengeInput)+            keystampText = [i|#{ts}-#{decodeUtf8 challenge}|] :: Text+            opts = [i|keystamp=#{keystampText};fileindex=1;xres=1024|] :: Text+            url = [i|http://localhost:#{serverPort}/h/#{fileURIStr}/#{opts}/test.jxl|]++        manager <- newManager defaultManagerSettings+        request <- parseRequest url+        response <- httpLbs request manager++        responseStatus response `shouldBe` status200++    it "rejects resource request with time drift at boundary (601 seconds)" $ do+      let mockPortNum = 19825+          mockContent = "TIMEDRIFT_TEST"+          mockConfig  = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent }+          clientCfg   = testConfig 24+          fileURIStr  = hash @Text mockContent <> "-123-1024-768-txt"++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        currentTime <- getSystemTime+        let ts = systemSeconds currentTime - 601+            k  = key clientCfg+            challengeInput = encodeUtf8 [i|#{ts}-#{fileURIStr}-#{k}-hotlinkthis|]+            challenge = BS.take 10 (hash @ByteString challengeInput)+            keystampText = [i|#{ts}-#{decodeUtf8 challenge}|] :: Text+            opts = [i|keystamp=#{keystampText};fileindex=1;xres=1024|] :: Text+            url = [i|http://localhost:#{serverPort}/h/#{fileURIStr}/#{opts}/testfile.txt|]++        manager <- newManager defaultManagerSettings+        request <- parseRequest url+        response <- httpLbs request manager++        responseStatus response `shouldBe` status403+        LBS.toStrict (responseBody response) `shouldSatisfy` (\body -> "time" `BS.isInfixOf` body)++    it "serves resource from cache when already stored" $ do+      let mockPortNum = 19826+          mockContent = "CACHED_CONTENT_TEST"+          mockConfig  = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent }+          clientCfg   = testConfig 25+          fileURIStr  = hash @Text mockContent <> "-123-1024-768-txt"++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        currentTime <- getSystemTime+        let ts = systemSeconds currentTime+            k  = key clientCfg+            challengeInput = encodeUtf8 [i|#{ts}-#{fileURIStr}-#{k}-hotlinkthis|]+            challenge = BS.take 10 (hash @ByteString challengeInput)+            keystampText = [i|#{ts}-#{decodeUtf8 challenge}|] :: Text+            opts = [i|keystamp=#{keystampText};fileindex=1;xres=1024|] :: Text+            url = [i|http://localhost:#{serverPort}/h/#{fileURIStr}/#{opts}/testfile.txt|]++        manager <- newManager defaultManagerSettings+        request <- parseRequest url+        +        -- First request fetches from upstream+        response1 <- httpLbs request manager+        responseStatus response1 `shouldBe` status200+        +        -- Second request should hit cache+        response2 <- httpLbs request manager+        responseStatus response2 `shouldBe` status200+        LBS.toStrict (responseBody response2) `shouldBe` mockContent++    it "rejects resource request with missing fileindex option" $ do+      let mockPortNum = 19827+          mockContent = "MISSING_PARAM_TEST"+          mockConfig  = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent }+          clientCfg   = testConfig 26+          fileURIStr  = hash @Text mockContent <> "-123-1024-768-txt"++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        currentTime <- getSystemTime+        let ts = systemSeconds currentTime+            k  = key clientCfg+            challengeInput = encodeUtf8 [i|#{ts}-#{fileURIStr}-#{k}-hotlinkthis|]+            challenge = BS.take 10 (hash @ByteString challengeInput)+            keystampText = [i|#{ts}-#{decodeUtf8 challenge}|] :: Text+            opts = [i|keystamp=#{keystampText};xres=1024|] :: Text+            url = [i|http://localhost:#{serverPort}/h/#{fileURIStr}/#{opts}/testfile.txt|]++        manager <- newManager defaultManagerSettings+        request <- parseRequest url+        response <- httpLbs request manager++        responseStatus response `shouldBe` status404++    it "returns 404 when resource not found in cache and no params" $ do+      let mockPortNum = 19828+          mockContent = "NOT_FOUND_TEST"+          mockConfig  = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent }+          clientCfg   = testConfig 27+          fileURIStr  = hash @Text mockContent <> "-123-1024-768-txt"++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        currentTime <- getSystemTime+        let ts = systemSeconds currentTime+            k  = key clientCfg+            challengeInput = encodeUtf8 [i|#{ts}-#{fileURIStr}-#{k}-hotlinkthis|]+            challenge = BS.take 10 (hash @ByteString challengeInput)+            keystampText = [i|#{ts}-#{decodeUtf8 challenge}|] :: Text+            opts = [i|keystamp=#{keystampText}|] :: Text+            url = [i|http://localhost:#{serverPort}/h/#{fileURIStr}/#{opts}/testfile.txt|]++        manager <- newManager defaultManagerSettings+        request <- parseRequest url+        response <- httpLbs request manager++        responseStatus response `shouldBe` status404++    it "serves resource with default octet-stream mime type for unknown extension" $ do+      let mockPortNum = 19829+          mockContent = "UNKNOWN_EXT_CONTENT"+          mockConfig  = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent }+          clientCfg   = testConfig 28+          fileURIStr  = hash @Text mockContent <> "-123-1024-768-xyz"++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        currentTime <- getSystemTime+        let ts = systemSeconds currentTime+            k  = key clientCfg+            challengeInput = encodeUtf8 [i|#{ts}-#{fileURIStr}-#{k}-hotlinkthis|]+            challenge = BS.take 10 (hash @ByteString challengeInput)+            keystampText = [i|#{ts}-#{decodeUtf8 challenge}|] :: Text+            opts = [i|keystamp=#{keystampText};fileindex=1;xres=1024|] :: Text+            url = [i|http://localhost:#{serverPort}/h/#{fileURIStr}/#{opts}/test.unknown|]++        manager <- newManager defaultManagerSettings+        request <- parseRequest url+        response <- httpLbs request manager++        responseStatus response `shouldBe` status200+        LBS.toStrict (responseBody response) `shouldBe` mockContent++    it "accepts resource request with future timestamp within drift limit" $ do+      let mockPortNum = 19830+          mockContent = "FUTURE_TIME_TEST"+          mockConfig  = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent }+          clientCfg   = testConfig 29+          fileURIStr  = hash @Text mockContent <> "-123-1024-768-txt"++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        currentTime <- getSystemTime+        let ts = systemSeconds currentTime + 500+            k  = key clientCfg+            challengeInput = encodeUtf8 [i|#{ts}-#{fileURIStr}-#{k}-hotlinkthis|]+            challenge = BS.take 10 (hash @ByteString challengeInput)+            keystampText = [i|#{ts}-#{decodeUtf8 challenge}|] :: Text+            opts = [i|keystamp=#{keystampText};fileindex=1;xres=1024|] :: Text+            url = [i|http://localhost:#{serverPort}/h/#{fileURIStr}/#{opts}/testfile.txt|]++        manager <- newManager defaultManagerSettings+        request <- parseRequest url+        response <- httpLbs request manager++        responseStatus response `shouldBe` status200++    it "handles POST request to unknown route with 404" $ do+      let mockPortNum = 19831+          mockConfig  = defaultMockConfig { mockPort = mockPortNum }+          clientCfg   = testConfig 30++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        manager <- newManager defaultManagerSettings+        req0 <- parseRequest [i|http://localhost:#{serverPort}/unknown-post|]+        let req = req0 { method = "POST" }+        resp <- httpLbs req manager+        responseStatus resp `shouldBe` status404++    it "handles GET request to unknown route with 404" $ do+      let mockPortNum = 19832+          mockConfig  = defaultMockConfig { mockPort = mockPortNum }+          clientCfg   = testConfig 31++      withTestServer mockConfig clientCfg defaultHathSettings $ \serverPort -> do+        manager <- newManager defaultManagerSettings+        req <- parseRequest [i|http://localhost:#{serverPort}/random/path/here|]+        resp <- httpLbs req manager+        responseStatus resp `shouldBe` status404++  -- Tests using startServer to cover initialization code+  describe "Server Initialization with startServer" $ do+    it "starts server successfully and serves requests" $ do+      let mockPortNum = 19900+          mockContent = "INIT_TEST_CONTENT"+          mockConfig  = defaultMockConfig { mockPort = mockPortNum, mockFileContent = mockContent }+          clientCfg   = testConfig 100+          settings = defaultHathSettings { clientPort = 9900 }+          fileURIStr  = hash @Text mockContent <> "-123-1024-768-txt"++      withStartServer mockConfig clientCfg settings $ \serverPort _chan -> do+        currentTime <- getSystemTime+        let ts = systemSeconds currentTime+            k  = key clientCfg+            challengeInput = encodeUtf8 [i|#{ts}-#{fileURIStr}-#{k}-hotlinkthis|]+            challenge = BS.take 10 (hash @ByteString challengeInput)+            keystampText = [i|#{ts}-#{decodeUtf8 challenge}|] :: Text+            opts = [i|keystamp=#{keystampText};fileindex=1;xres=1024|] :: Text++        -- Use TLS-aware manager to connect to HTTPS server+        manager <- newManager defaultManagerSettings+        -- Try HTTP first (onInsecure = AllowInsecure means HTTP should work)+        request <- parseRequest $ [i|http://localhost:#{serverPort}/h/#{fileURIStr}/#{opts}/testfile.txt|]+        response <- httpLbs request manager++        responseStatus response `shouldBe` status200++    it "initializes database and fetches blacklist on startup" $ do+      let mockPortNum = 19901+          mockConfig  = defaultMockConfig { mockPort = mockPortNum }+          clientCfg   = testConfig 101+          settings = defaultHathSettings { clientPort = 9901 }++      withStartServer mockConfig clientCfg settings $ \_serverPort _chan -> do+        -- The test passes if startServer successfully:+        -- 1. Calls fetchBlacklist (line 477 in Server.hs)+        -- 2. Initializes database (line 479)+        -- 3. Sets up tictok timers (line 480)+        -- 4. Starts the server loop+        threadDelay 2000000  -- Wait 2 seconds for initialization+        -- If we got here without exceptions, initialization succeeded+        return ()++    it "fetches blacklist via tictok timer" $ do+      let mockPortNum = 19903+          mockConfig  = defaultMockConfig { mockPort = mockPortNum }+          clientCfg   = testConfig 103+          settings = defaultHathSettings { clientPort = 9903 }++      withStartServer mockConfig clientCfg settings $ \_serverPort _chan -> do+        -- tictok sets up three timers:+        -- 1. IP map cleanup (every 1 minute)+        -- 2. Heartbeat stillAlive (every 1 minute)+        -- 3. Blacklist fetch (every 36 minutes)+        -- Wait a bit to ensure timers are set up+        threadDelay 3000000  -- 3 seconds+        -- The RPC mock will receive heartbeat calls+        return ()
+ test/MockRPC.hs view
@@ -0,0 +1,151 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++-- | Mock RPC server for testing hs-hath client without connecting to real H@H network.+--+-- Usage:+--   1. Start the mock server with 'withMockRPC'+--   2. Set HATH_RPC_HOST environment variable to "localhost"+--   3. Run client code against the mock server+module MockRPC+  ( withMockRPC+  , MockRPCConfig(..)+  , defaultMockConfig+  , startMockRPC+  , stopMockRPC+  ) where++import           Control.Concurrent       ( ThreadId, forkIO, killThread )+import           Control.Concurrent.MVar  ( MVar, newEmptyMVar, putMVar, takeMVar )+import           Control.Exception        ( SomeException, catch, throwIO )++import qualified Data.ByteString.Char8    as BS+import qualified Data.ByteString.Lazy     as LBS+import           Data.Text                ( Text )+import qualified Data.Text                as T++import qualified Network.HTTP.Types       as HTTP+import qualified Network.Wai              as Wai+import qualified Network.Wai.Handler.Warp as Warp++import           Relude                   hiding ( newEmptyMVar, putMVar, takeMVar )++-- | Configuration for mock RPC server behavior+data MockRPCConfig+  = MockRPCConfig+  { mockServerStatResponse :: ByteString  -- ^ Response for server_stat+  , mockClientLoginResponse :: ByteString  -- ^ Response for client_login+  , mockStillAliveResponse :: ByteString  -- ^ Response for still_alive+  , mockClientStartResponse :: ByteString  -- ^ Response for client_start+  , mockClientStopResponse :: ByteString  -- ^ Response for client_stop+  , mockGetCertResponse :: ByteString  -- ^ Response for get_cert (or error)+  , mockClientSettingsResponse :: ByteString -- ^ Response for client_settings+  , mockFileContent :: ByteString -- ^ Content for file downloads+  , mockPort :: Int         -- ^ Port to run mock server on+  }++-- | Default mock configuration with valid responses+defaultMockConfig :: MockRPCConfig+defaultMockConfig+  = MockRPCConfig+  { mockServerStatResponse = "OK"+  , mockClientLoginResponse = BS.unlines+      [ "OK"+      , "host=127.0.0.1"+      , "port=8080"+      , "throttle_bytes=0"+      , "disklimit_bytes=107374182400"+      , "diskremaining_bytes=107374182400"+      ]+  , mockStillAliveResponse = "OK"+  , mockClientStartResponse = "OK"+  , mockClientStopResponse = "OK"+  , mockGetCertResponse = "FAIL\nNo test certificate available"+  , mockClientSettingsResponse = BS.unlines [ "OK", "host=127.0.0.1", "port=8080" ]+  , mockFileContent = "TEST_FILE_CONTENT"+  , mockPort = 19800+  }++-- | Mock RPC application+mockRPCApp :: MockRPCConfig -> Wai.Application+mockRPCApp config req respond = do+  let path  = Wai.rawPathInfo req+      query = Wai.queryString req+      act   = join $ snd <$> find ((== "act") . fst) query  -- Extract "act" parameter++  case ( path, act ) of+    -- RPC endpoint+    ( "/15/rpc", Just action ) -> handleRPCAction config action respond+    ( "/15/dl", _ ) -> handleDownload config respond+    _ -> respond $ notFoundResponse++-- | Handle RPC actions based on the 'act' parameter+handleRPCAction :: MockRPCConfig+                -> ByteString+                -> (Wai.Response -> IO Wai.ResponseReceived)+                -> IO Wai.ResponseReceived+handleRPCAction config action respond = case action of+  "server_stat" -> respond $ okResponse $ mockServerStatResponse config+  "client_login" -> respond $ okResponse $ mockClientLoginResponse config+  "still_alive" -> respond $ okResponse $ mockStillAliveResponse config+  "client_start" -> respond $ okResponse $ mockClientStartResponse config+  "client_stop" -> respond $ okResponse $ mockClientStopResponse config+  "get_cert" -> respond $ okResponse $ mockGetCertResponse config+  "client_settings" -> respond $ okResponse $ mockClientSettingsResponse config+  "get_blacklist" -> respond $ okResponse "OK"  -- Empty blacklist+  "dlfetch" -> respond $ okResponse "OK"  -- No download URLs+  "dlfails" -> respond $ okResponse "OK"  -- Acknowledge failures+  "srfetch" -> respond+    $ okResponse+    $ "OK\nhttp://localhost:" <> encodeUtf8 (show (mockPort config) :: Text) <> "/15/dl"+  _ -> respond $ okResponse $ "FAIL\nUnknown action: " <> action++-- | Handle download endpoint+handleDownload+  :: MockRPCConfig -> (Wai.Response -> IO Wai.ResponseReceived) -> IO Wai.ResponseReceived+handleDownload config respond = respond $ okResponse (mockFileContent config)++-- | Create a 200 OK response with given body+okResponse :: ByteString -> Wai.Response+okResponse body+  = Wai.responseLBS+    HTTP.status200+    [ ( "Content-Type", "text/plain; charset=utf-8" ) ]+    (LBS.fromStrict body)++-- | Create a 404 Not Found response+notFoundResponse :: Wai.Response+notFoundResponse = Wai.responseLBS HTTP.status404 [ ( "Content-Type", "text/plain" ) ] "Not Found"++-- | Start mock RPC server in background thread+startMockRPC :: MockRPCConfig -> IO ( ThreadId, MVar () )+startMockRPC config = do+  ready <- newEmptyMVar+  tid <- forkIO $ do+    let settings+          = Warp.setPort (mockPort config)+          $ Warp.setBeforeMainLoop (putMVar ready ())+          $ Warp.defaultSettings+    Warp.runSettings settings (mockRPCApp config)+  takeMVar ready  -- Wait for server to be ready+  return ( tid, ready )++-- | Stop mock RPC server+stopMockRPC :: ThreadId -> IO ()+stopMockRPC = killThread++-- | Run an action with a mock RPC server+-- The server is started before the action and stopped after.+withMockRPC :: MockRPCConfig -> IO a -> IO a+withMockRPC config action = do+  ( tid, _ ) <- startMockRPC config+  result <- action `finally'` stopMockRPC tid+  return result+  where+    finally' :: IO a -> IO () -> IO a+    finally' io cleanup = do+      result <- io `catch` (\(e :: SomeException) -> cleanup >> throwIO e)+      cleanup+      return result+
+ test/R2Spec.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++module R2Spec ( r2Specs ) where++import           Colog                ( LogAction(..), richMessageAction, Message )+import           Colog.Polysemy       ( Log, runLogAction )++import           Storage.Database     ( FileRecord(..) )++import           Polysemy+import           Polysemy.Error       ( Error, runError )+import           Polysemy.KVStore     ( KVStore, lookupKV, updateKV )++import           Storage.R2           ( R2Connection(..), mkR2Connection, runCacheR2 )++import           Relude               hiding ( Reader )++import           System.Environment   ( setEnv )++import           Test.Hspec++import           Types                ( FileURI, R2Config(..), RPCError, parseFileURI )++-- | R2 test configuration+testR2Config :: R2Config+testR2Config = R2Config+  { r2Endpoint = "https://111e2d89a4500e36dcda4853060fe725.r2.cloudflarestorage.com"+  , r2Bucket   = "hath"+  }++-- | Sample file record for testing+sampleRecord :: FileRecord+sampleRecord = FileRecord+  { fileRecordLRUCounter = 0+  , fileRecordS4         = "test"+  , fileRecordFileId     = "testhash1234-1024-800-600-jpg"+  , fileRecordFileName   = Just "test.jpg"+  , fileRecordBytes      = "test content for R2 storage"+  }++-- | Parse a file URI from the sample record+sampleURI :: FileURI+sampleURI = parseFileURI "testhash1234-1024-800-600-jpg"++-- | Silence logs for cleaner test output+silentLogAction :: LogAction IO Message+silentLogAction = LogAction $ \_ -> pure ()++-- | Run a program with R2 cache effect (silent logging)+runWithR2Silent :: R2Connection +                -> Sem '[KVStore FileURI FileRecord, Log Message, Error RPCError, Embed IO] a +                -> IO (Either RPCError a)+runWithR2Silent conn program = +  runM+  . runError @RPCError+  . runLogAction @IO @Message silentLogAction+  . runCacheR2 conn+  $ program++-- | Lookup with explicit type+lookupFile :: Member (KVStore FileURI FileRecord) r => FileURI -> Sem r (Maybe FileRecord)+lookupFile = lookupKV++-- | Update with explicit type+updateFile :: Member (KVStore FileURI FileRecord) r => FileURI -> Maybe FileRecord -> Sem r ()+updateFile = updateKV++r2Specs :: Spec+r2Specs = describe "R2 Cache Effect" $ do+  +  -- Setup: ensure env vars are set+  beforeAll setupEnv $ do+    +    describe "mkR2Connection" $ do+      it "should create connection with valid env vars" $ \_ -> do+        result <- mkR2Connection testR2Config+        case result of+          Left err -> expectationFailure $ "Connection failed: " <> toString err+          Right _  -> pure ()+      +      it "should fail without R2_ACCESS_KEY" $ \_ -> do+        -- Temporarily unset+        setEnv "R2_ACCESS_KEY" ""+        result <- mkR2Connection testR2Config+        -- Restore+        setEnv "R2_ACCESS_KEY" "cbb541929f87b599e8831ee1917a57fd"+        case result of+          Left _  -> pure ()  -- Expected+          Right _ -> expectationFailure "Should have failed without R2_ACCESS_KEY"++    describe "runCacheR2" $ do+      xit "should store a file record (PUT)" $ \conn -> do+        result <- runWithR2Silent conn $ updateFile sampleURI (Just sampleRecord)+        result `shouldBe` Right ()++      xit "should retrieve a stored file record (GET)" $ \conn -> do+        -- First store+        _ <- runWithR2Silent conn $ updateFile sampleURI (Just sampleRecord)+        -- Then retrieve+        result <- runWithR2Silent conn $ lookupFile sampleURI+        case result of+          Left err -> expectationFailure $ "R2 error: " <> show err+          Right Nothing -> expectationFailure "Expected file record but got Nothing"+          Right (Just record) -> do+            fileRecordBytes record `shouldBe` fileRecordBytes sampleRecord++      it "should return Nothing for non-existent file" $ \conn -> do+        let nonExistentURI = parseFileURI "nonexistent999-1024-800-600-jpg"+        result <- runWithR2Silent conn $ lookupFile nonExistentURI+        case result of+          Left _ -> pure ()  -- Error is acceptable (404 from R2)+          Right Nothing -> pure ()  -- Expected+          Right (Just _) -> expectationFailure "Expected Nothing but got a record"++      xit "should delete a file record (DELETE)" $ \conn -> do+        -- Store first+        _ <- runWithR2Silent conn $ updateFile sampleURI (Just sampleRecord)+        -- Delete+        deleteResult <- runWithR2Silent conn $ updateFile sampleURI Nothing+        deleteResult `shouldBe` Right ()+        -- Verify deleted+        lookupResult <- runWithR2Silent conn $ lookupFile sampleURI+        case lookupResult of+          Left _ -> pure ()  -- Error acceptable+          Right Nothing -> pure ()  -- Expected+          Right (Just _) -> expectationFailure "File should have been deleted"++-- | Setup environment variables and create connection+setupEnv :: IO R2Connection+setupEnv = do+  -- Set env vars (in real tests, these would come from .env)+  setEnv "R2_ACCESS_KEY" "12345678901234567890123456789012" -- 32 chars+  setEnv "R2_SECRET_KEY" "1234567890123456789012345678901234567890" -- 40 chars+  +  result <- mkR2Connection testR2Config+  case result of+    Left err -> error $ "Failed to create R2 connection: " <> err+    Right conn -> pure conn
+ test/Spec.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++import qualified Data.Map.Strict  as Map+import           Data.Text        ( Text )++import           Storage.Database ( FileRecord(..), runCachePure )++import           FilesystemSpec   ( filesystemSpecs )+import           Integration      ( integrationSpecs )++import           R2Spec           ( r2Specs )++import           Polysemy+import           Polysemy.KVStore ( KVStore, lookupKV, updateKV )++import           Relude           hiding ( Reader )++import           Test.Hspec++import           Types            ( FileURI, parseFileURI )++main :: IO ()+main = hspec $ do+  cacheSpecs+  integrationSpecs+  r2Specs+  filesystemSpecs++-- | Helper to store a file record+storeFile :: Member (KVStore FileURI FileRecord) r => FileRecord -> Sem r ()+storeFile record = updateKV (parseFileURI $ encodeUtf8 $ fileRecordFileId record) (Just record)++-- | Helper to lookup a file by id+lookupFile :: Member (KVStore FileURI FileRecord) r => Text -> Sem r (Maybe FileRecord)+lookupFile fid = lookupKV (parseFileURI $ encodeUtf8 fid)++cacheSpecs :: Spec+cacheSpecs = describe "Cache effect" $ do+  let sampleRecord+        = FileRecord { fileRecordLRUCounter = 1+                     , fileRecordS4         = "s4-value"+                     , fileRecordFileId     = "test-id"+                     , fileRecordFileName   = Just "test.txt"+                     , fileRecordBytes      = "test content"+                     }++  describe "runCachePure" $ do+    it "should store and retrieve a file record" $ do+      let program = do+            storeFile sampleRecord+            lookupFile "test-id"+          result  = run $ runCachePure Map.empty program++      result `shouldBe` Just sampleRecord++    it "should return Nothing for non-existent file" $ do+      let program = lookupFile "non-existent"+          result  = run $ runCachePure Map.empty program++      result `shouldBe` Nothing++    it "should update existing record" $ do+      let updatedRecord = sampleRecord { fileRecordBytes = "new content" }+          program       = do+            storeFile sampleRecord+            storeFile updatedRecord+            lookupFile "test-id"+          result        = run $ runCachePure Map.empty program++      result `shouldBe` Just updatedRecord++
+ vendor/minio-hs-1.7.0/src/Lib/Prelude.hs view
@@ -0,0 +1,55 @@+--+-- MinIO Haskell SDK, (C) 2017 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Lib.Prelude+  ( module Exports,+    both,+    showBS,+    toStrictBS,+    fromStrictBS,+    lastMay,+  )+where++import Control.Monad.Trans.Maybe as Exports (MaybeT (..), runMaybeT)+import qualified Data.ByteString.Lazy as LB+import Data.Time as Exports+  ( UTCTime (..),+    diffUTCTime,+  )+import UnliftIO as Exports+  ( Handler,+    catch,+    catches,+    throwIO,+    try,+  )++-- | Apply a function on both elements of a pair+both :: (a -> b) -> (a, a) -> (b, b)+both f (a, b) = (f a, f b)++showBS :: (Show a) => a -> ByteString+showBS a = encodeUtf8 (show a :: Text)++toStrictBS :: LByteString -> ByteString+toStrictBS = LB.toStrict++fromStrictBS :: ByteString -> LByteString+fromStrictBS = LB.fromStrict++lastMay :: [a] -> Maybe a+lastMay a = last <$> nonEmpty a
+ vendor/minio-hs-1.7.0/src/Network/Minio.hs view
@@ -0,0 +1,345 @@+--+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++-- |+-- Module:      Network.Minio+-- Copyright:   (c) 2017-2023 MinIO Dev Team+-- License:     Apache 2.0+-- Maintainer:  MinIO Dev Team <dev@min.io>+--+-- Types and functions to conveniently access S3 compatible object+-- storage servers like MinIO.+module Network.Minio+  ( -- * Credentials+    CredentialValue (..),+    credentialValueText,+    AccessKey (..),+    SecretKey (..),+    SessionToken (..),++    -- ** Credential Loaders++    -- | Run actions that retrieve 'CredentialValue's from the environment or+    -- files or other custom sources.+    CredentialLoader,+    fromAWSConfigFile,+    fromAWSEnv,+    fromMinioEnv,+    findFirst,++    -- * Connecting to object storage+    ConnectInfo,+    setRegion,+    setCreds,+    setCredsFrom,+    isConnectInfoSecure,+    disableTLSCertValidation,+    MinioConn,+    mkMinioConn,++    -- ** Connection helpers++    -- | These are helpers to construct 'ConnectInfo' values for common+    -- cases.+    minioPlayCI,+    awsCI,+    gcsCI,++    -- ** STS Credential types+    STSAssumeRole (..),+    STSAssumeRoleOptions (..),+    defaultSTSAssumeRoleOptions,+    requestSTSCredential,+    setSTSCredential,+    ExpiryTime (..),+    STSCredentialProvider,++    -- * Minio Monad++    ----------------++    -- | The Minio Monad provides connection-reuse, bucket-location+    -- caching, resource management and simpler error handling+    -- functionality. All actions on object storage are performed within+    -- this Monad.+    Minio,+    runMinioWith,+    runMinio,+    runMinioResWith,+    runMinioRes,++    -- * Bucket Operations++    -- ** Creation, removal and querying+    Bucket,+    makeBucket,+    removeBucket,+    bucketExists,+    Region,+    getLocation,++    -- ** Listing buckets+    BucketInfo (..),+    listBuckets,++    -- ** Listing objects+    listObjects,+    listObjectsV1,+    ListItem (..),+    ObjectInfo,+    oiObject,+    oiModTime,+    oiETag,+    oiSize,+    oiUserMetadata,+    oiMetadata,++    -- ** Listing incomplete uploads+    listIncompleteUploads,+    UploadId,+    UploadInfo (..),+    listIncompleteParts,+    ObjectPartInfo (..),++    -- ** Bucket Notifications+    getBucketNotification,+    putBucketNotification,+    removeAllBucketNotification,+    Notification (..),+    defaultNotification,+    NotificationConfig (..),+    Arn,+    Event (..),+    Filter (..),+    defaultFilter,+    FilterKey (..),+    defaultFilterKey,+    FilterRules (..),+    defaultFilterRules,+    FilterRule (..),++    -- * Object Operations+    Object,++    -- ** File-based operations+    fGetObject,+    fPutObject,++    -- ** Conduit-based streaming operations+    putObject,+    PutObjectOptions,+    defaultPutObjectOptions,+    pooContentType,+    pooContentEncoding,+    pooContentDisposition,+    pooContentLanguage,+    pooCacheControl,+    pooStorageClass,+    pooUserMetadata,+    pooNumThreads,+    pooSSE,+    getObject,+    GetObjectOptions,+    defaultGetObjectOptions,+    gooRange,+    gooIfMatch,+    gooIfNoneMatch,+    gooIfModifiedSince,+    gooIfUnmodifiedSince,+    gooSSECKey,+    GetObjectResponse,+    gorObjectInfo,+    gorObjectStream,++    -- ** Server-side object copying+    copyObject,+    SourceInfo,+    defaultSourceInfo,+    srcBucket,+    srcObject,+    srcRange,+    srcIfMatch,+    srcIfNoneMatch,+    srcIfModifiedSince,+    srcIfUnmodifiedSince,+    DestinationInfo,+    defaultDestinationInfo,+    dstBucket,+    dstObject,++    -- ** Querying object info+    statObject,++    -- ** Object removal operations+    removeObject,+    removeIncompleteUpload,++    -- ** Select Object Content with SQL+    module Network.Minio.SelectAPI,++    -- * Server-Side Encryption Helpers+    mkSSECKey,+    SSECKey,+    SSE (..),++    -- * Presigned Operations+    presignedPutObjectUrl,+    presignedGetObjectUrl,+    presignedHeadObjectUrl,+    UrlExpiry,++    -- ** POST (browser) upload helpers++    -- | Please see+    -- https://docs.aws.amazon.com/AmazonS3/latest/API/sigv4-HTTPPOSTConstructPolicy.html+    -- for detailed information.+    newPostPolicy,+    presignedPostPolicy,+    showPostPolicy,+    PostPolicy,+    PostPolicyError (..),++    -- *** Post Policy condition helpers+    PostPolicyCondition,+    ppCondBucket,+    ppCondContentLengthRange,+    ppCondContentType,+    ppCondKey,+    ppCondKeyStartsWith,+    ppCondSuccessActionStatus,++    -- * Error handling++    -- | Data types representing various errors that may occur while+    -- working with an object storage service.+    MinioErr (..),+    MErrV (..),+    ServiceErr (..),+  )+where++{-+This module exports the high-level MinIO API for object storage.+-}++import qualified Data.Conduit as C+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.Combinators as CC+import Network.Minio.API+import Network.Minio.CopyObject+import Network.Minio.Credentials+import Network.Minio.Data+import Network.Minio.Errors+import Network.Minio.ListOps+import Network.Minio.PutObject+import Network.Minio.S3API+import Network.Minio.SelectAPI++-- | Lists buckets.+listBuckets :: Minio [BucketInfo]+listBuckets = getService++-- | Fetch the object and write it to the given file safely. The+-- object is first written to a temporary file in the same directory+-- and then moved to the given path.+fGetObject :: Bucket -> Object -> FilePath -> GetObjectOptions -> Minio ()+fGetObject bucket object fp opts = do+  src <- getObject bucket object opts+  C.connect (gorObjectStream src) $ CB.sinkFileCautious fp++-- | Upload the given file to the given object.+fPutObject ::+  Bucket ->+  Object ->+  FilePath ->+  PutObjectOptions ->+  Minio ()+fPutObject bucket object f opts =+  void $ putObjectInternal bucket object opts $ ODFile f Nothing++-- | Put an object from a conduit source. The size can be provided if+-- known; this helps the library select optimal part sizes to perform+-- a multipart upload. If not specified, it is assumed that the object+-- can be potentially 5TiB and selects multipart sizes appropriately.+putObject ::+  Bucket ->+  Object ->+  C.ConduitM () ByteString Minio () ->+  Maybe Int64 ->+  PutObjectOptions ->+  Minio ()+putObject bucket object src sizeMay opts =+  void $ putObjectInternal bucket object opts $ ODStream src sizeMay++-- | Perform a server-side copy operation to create an object based on+-- the destination specification in DestinationInfo from the source+-- specification in SourceInfo. This function performs a multipart+-- copy operation if the new object is to be greater than 5GiB in+-- size.+copyObject :: DestinationInfo -> SourceInfo -> Minio ()+copyObject dstInfo srcInfo =+  void $+    copyObjectInternal+      (dstBucket dstInfo)+      (dstObject dstInfo)+      srcInfo++-- | Remove an object from the object store.+removeObject :: Bucket -> Object -> Minio ()+removeObject = deleteObject++-- | Get an object from the object store.+getObject ::+  Bucket ->+  Object ->+  GetObjectOptions ->+  Minio GetObjectResponse+getObject bucket object opts =+  getObject' bucket object [] $ gooToHeaders opts++-- | Get an object's metadata from the object store. It accepts the+-- same options as GetObject.+statObject :: Bucket -> Object -> GetObjectOptions -> Minio ObjectInfo+statObject b o opts = headObject b o $ gooToHeaders opts++-- | Creates a new bucket in the object store. The Region can be+-- optionally specified. If not specified, it will use the region+-- configured in ConnectInfo, which is by default, the US Standard+-- Region.+makeBucket :: Bucket -> Maybe Region -> Minio ()+makeBucket bucket regionMay = do+  region <- maybe (asks $ connectRegion . mcConnInfo) return regionMay+  putBucket bucket region+  addToRegionCache bucket region++-- | Removes a bucket from the object store.+removeBucket :: Bucket -> Minio ()+removeBucket bucket = do+  deleteBucket bucket+  deleteFromRegionCache bucket++-- | Query the object store if a given bucket is present.+bucketExists :: Bucket -> Minio Bool+bucketExists = headBucket++-- | Removes an ongoing multipart upload of an object.+removeIncompleteUpload :: Bucket -> Object -> Minio ()+removeIncompleteUpload bucket object = do+  uploads <-+    C.runConduit $+      listIncompleteUploads bucket (Just object) False+        C..| CC.sinkList+  mapM_ (abortMultipartUpload bucket object) (uiUploadId <$> uploads)
+ vendor/minio-hs-1.7.0/src/Network/Minio/API.hs view
@@ -0,0 +1,354 @@+--+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.API+  ( connect,+    S3ReqInfo (..),+    runMinio,+    executeRequest,+    buildRequest,+    mkStreamRequest,+    getLocation,+    isValidBucketName,+    checkBucketNameValidity,+    isValidObjectName,+    checkObjectNameValidity,+    requestSTSCredential,+  )+where++import Control.Retry+  ( fullJitterBackoff,+    limitRetriesByCumulativeDelay,+    retrying,+  )+import qualified Data.ByteString as B+import qualified Data.Char as C+import qualified Data.Conduit as C+import qualified Data.HashMap.Strict as H+import qualified Data.Text as T+import qualified Data.Time.Clock as Time+import Lib.Prelude+import Network.HTTP.Client (defaultManagerSettings)+import qualified Network.HTTP.Client as NClient+import Network.HTTP.Conduit (Response)+import qualified Network.HTTP.Conduit as NC+import Network.HTTP.Types (simpleQueryToQuery)+import qualified Network.HTTP.Types as HT+import Network.HTTP.Types.Header (hHost)+import Network.Minio.APICommon+import Network.Minio.Credentials+import Network.Minio.Data+import Network.Minio.Errors+import Network.Minio.Sign.V4+import Network.Minio.Utils+import Network.Minio.XmlParser++-- | Fetch bucket location (region)+getLocation :: Bucket -> Minio Region+getLocation bucket = do+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riBucket = Just bucket,+          riQueryParams = [("location", Nothing)],+          riNeedsLocation = False+        }+  parseLocation $ NC.responseBody resp++-- | Looks for region in RegionMap and updates it using getLocation if+-- absent.+discoverRegion :: S3ReqInfo -> Minio (Maybe Region)+discoverRegion ri = runMaybeT $ do+  bucket <- MaybeT $ return $ riBucket ri+  regionMay <- lift $ lookupRegionCache bucket+  maybe+    ( do+        l <- lift $ getLocation bucket+        lift $ addToRegionCache bucket l+        return l+    )+    return+    regionMay++-- | Returns the region to be used for the request.+getRegion :: S3ReqInfo -> Minio (Maybe Region)+getRegion ri = do+  ci <- asks mcConnInfo++  -- getService/makeBucket/getLocation -- don't need location+  if+      | not $ riNeedsLocation ri ->+          return $ Just $ connectRegion ci+      -- if autodiscovery of location is disabled by user+      | not $ connectAutoDiscoverRegion ci ->+          return $ Just $ connectRegion ci+      -- discover the region for the request+      | otherwise -> discoverRegion ri++getRegionHost :: Region -> Minio Text+getRegionHost r = do+  ci <- asks mcConnInfo++  if "amazonaws.com" `T.isSuffixOf` connectHost ci+    then+      maybe+        (throwIO $ MErrVRegionNotSupported r)+        return+        (H.lookup r awsRegionMap)+    else return $ connectHost ci++-- | Computes the appropriate host, path and region for the request.+--+-- For AWS, always use virtual bucket style, unless bucket has periods. For+-- MinIO and other non-AWS, default to path style.+getHostPathRegion :: S3ReqInfo -> Minio (Text, ByteString, Maybe Region)+getHostPathRegion ri = do+  ci <- asks mcConnInfo+  regionMay <- getRegion ri+  case riBucket ri of+    Nothing ->+      -- Implies a ListBuckets request.+      return (connectHost ci, "/", regionMay)+    Just bucket -> do+      regionHost <- case regionMay of+        Nothing -> return $ connectHost ci+        Just "" -> return $ connectHost ci+        Just r -> getRegionHost r+      let pathStyle =+            ( regionHost,+              getS3Path (riBucket ri) (riObject ri),+              regionMay+            )+          virtualStyle =+            ( bucket <> "." <> regionHost,+              encodeUtf8 $ "/" <> fromMaybe "" (riObject ri),+              regionMay+            )+      ( if isAWSConnectInfo ci+          then+            return $+              if bucketHasPeriods bucket+                then pathStyle+                else virtualStyle+          else return pathStyle+        )++-- | requestSTSCredential requests temporary credentials using the Security Token+-- Service API. The returned credential will include a populated 'SessionToken'+-- and an 'ExpiryTime'.+requestSTSCredential :: (STSCredentialProvider p) => p -> IO (CredentialValue, ExpiryTime)+requestSTSCredential p = do+  endpoint <- maybe (throwIO $ MErrValidation MErrVSTSEndpointNotFound) return $ getSTSEndpoint p+  let endPt = NC.parseRequest_ $ toString endpoint+      settings+        | NC.secure endPt = NC.tlsManagerSettings+        | otherwise = defaultManagerSettings++  mgr <- NC.newManager settings+  liftIO $ retrieveSTSCredentials p ("", 0, False) mgr++buildRequest :: S3ReqInfo -> Minio NC.Request+buildRequest ri = do+  maybe (return ()) checkBucketNameValidity $ riBucket ri+  maybe (return ()) checkObjectNameValidity $ riObject ri++  ci <- asks mcConnInfo++  (host, path, regionMay) <- getHostPathRegion ri++  let ci' = ci {connectHost = host}+      hostHeader = (hHost, getHostAddr ci')+      ri' =+        ri+          { riHeaders = hostHeader : riHeaders ri,+            riRegion = regionMay+          }+      -- Does not contain body and auth info.+      baseRequest =+        NC.defaultRequest+          { NC.method = riMethod ri',+            NC.secure = connectIsSecure ci',+            NC.host = encodeUtf8 $ connectHost ci',+            NC.port = connectPort ci',+            NC.path = path,+            NC.requestHeaders = riHeaders ri',+            NC.queryString = HT.renderQuery False $ riQueryParams ri'+          }++  timeStamp <- liftIO Time.getCurrentTime++  mgr <- asks mcConnManager+  cv <- liftIO $ getCredential (connectCreds ci') (getEndpoint ci') mgr++  let sp =+        SignParams+          (coerce $ cvAccessKey cv)+          (coerce $ cvSecretKey cv)+          (coerce $ cvSessionToken cv)+          ServiceS3+          timeStamp+          (riRegion ri')+          (riPresignExpirySecs ri')+          Nothing++  -- Cases to handle:+  --+  -- 0. Handle presign URL case.+  --+  -- 1. Connection is secure: use unsigned payload+  --+  -- 2. Insecure connection, streaming signature is enabled via use of+  --    conduit payload: use streaming signature for request.+  --+  -- 3. Insecure connection, non-conduit payload: compute payload+  -- sha256hash, buffer request in memory and perform request.++  if+      | isJust (riPresignExpirySecs ri') ->+          -- case 0 from above.+          do+            let signPairs = signV4QueryParams sp baseRequest+                qpToAdd = simpleQueryToQuery signPairs+                existingQueryParams = HT.parseQuery (NC.queryString baseRequest)+                updatedQueryParams = existingQueryParams ++ qpToAdd+            return $ NClient.setQueryString updatedQueryParams baseRequest+      | isStreamingPayload (riPayload ri') && not (connectIsSecure ci') ->+          -- case 2 from above.+          do+            (pLen, pSrc) <- case riPayload ri of+              PayloadC l src -> return (l, src)+              _ -> throwIO MErrVUnexpectedPayload+            let reqFn = signV4Stream pLen sp baseRequest+            return $ reqFn pSrc+      | otherwise ->+          do+            sp' <-+              ( if connectIsSecure ci'+                  then -- case 1 described above.+                    return sp+                  else+                    ( -- case 3 described above.+                      do+                        pHash <- getPayloadSHA256Hash $ riPayload ri'+                        return $ sp {spPayloadHash = Just pHash}+                    )+                )++            let signHeaders = signV4 sp' baseRequest+            return $+              baseRequest+                { NC.requestHeaders =+                    NC.requestHeaders baseRequest ++ signHeaders,+                  NC.requestBody = getRequestBody (riPayload ri')+                }++retryAPIRequest :: Minio a -> Minio a+retryAPIRequest apiCall = do+  resE <-+    retrying retryPolicy (const shouldRetry) $+      const $+        try apiCall+  either throwIO return resE+  where+    -- Retry using the full-jitter backoff method for up to 10 mins+    -- total+    retryPolicy =+      limitRetriesByCumulativeDelay tenMins $+        fullJitterBackoff oneMilliSecond+    oneMilliSecond = 1000 -- in microseconds+    tenMins = 10 * 60 * 1000000 -- in microseconds+    -- retry on connection related failure+    shouldRetry :: Either NC.HttpException a -> Minio Bool+    shouldRetry resE =+      case resE of+        -- API request returned successfully+        Right _ -> return False+        -- API request failed with a retryable exception+        Left httpExn@(NC.HttpExceptionRequest _ exn) ->+          case (exn :: NC.HttpExceptionContent) of+            NC.ResponseTimeout -> return True+            NC.ConnectionTimeout -> return True+            NC.ConnectionFailure _ -> return True+            -- We received an unexpected exception+            _ -> throwIO httpExn+        -- We received an unexpected exception+        Left someOtherExn -> throwIO someOtherExn++executeRequest :: S3ReqInfo -> Minio (Response LByteString)+executeRequest ri = do+  req <- buildRequest ri+  mgr <- asks mcConnManager+  retryAPIRequest $ httpLbs req mgr++mkStreamRequest ::+  S3ReqInfo ->+  Minio (Response (C.ConduitM () ByteString Minio ()))+mkStreamRequest ri = do+  req <- buildRequest ri+  mgr <- asks mcConnManager+  retryAPIRequest $ http req mgr++-- Bucket name validity check according to AWS rules.+isValidBucketName :: Bucket -> Bool+isValidBucketName bucket =+  not+    ( or+        [ len < 3 || len > 63,+          any labelCheck labels,+          any labelCharsCheck labels,+          isIPCheck+        ]+    )+  where+    len = T.length bucket+    labels = T.splitOn "." bucket+    -- does label `l` fail basic checks of length and start/end?+    labelCheck l = T.length l == 0 || T.head l == '-' || T.last l == '-'+    -- does label `l` have non-allowed characters?+    labelCharsCheck l =+      isJust $+        T.find+          ( \x ->+              not+                ( C.isAsciiLower x+                    || x == '-'+                    || C.isDigit x+                )+          )+          l+    -- does label `l` have non-digit characters?+    labelNonDigits l = isJust $ T.find (not . C.isDigit) l+    labelAsNums = map (not . labelNonDigits) labels+    -- check if bucket name looks like an IP+    isIPCheck = and labelAsNums && length labelAsNums == 4++-- Throws exception iff bucket name is invalid according to AWS rules.+checkBucketNameValidity :: (MonadIO m) => Bucket -> m ()+checkBucketNameValidity bucket =+  unless (isValidBucketName bucket) $+    throwIO $+      MErrVInvalidBucketName bucket++isValidObjectName :: Object -> Bool+isValidObjectName object =+  T.length object > 0 && B.length (encodeUtf8 object) <= 1024++checkObjectNameValidity :: (MonadIO m) => Object -> m ()+checkObjectNameValidity object =+  unless (isValidObjectName object) $+    throwIO $+      MErrVInvalidObjectName object
+ vendor/minio-hs-1.7.0/src/Network/Minio/APICommon.hs view
@@ -0,0 +1,80 @@+--+-- MinIO Haskell SDK, (C) 2018 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.APICommon where++import qualified Conduit as C+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LB+import Data.Conduit.Binary (sourceHandleRange)+import qualified Data.Text as T+import Lib.Prelude+import qualified Network.HTTP.Conduit as NC+import qualified Network.HTTP.Types as HT+import Network.Minio.Data+import Network.Minio.Data.Crypto+import Network.Minio.Errors++sha256Header :: ByteString -> HT.Header+sha256Header = ("x-amz-content-sha256",)++-- | This function throws an error if the payload is a conduit (as it+-- will not be possible to re-read the conduit after it is consumed).+getPayloadSHA256Hash :: Payload -> Minio ByteString+getPayloadSHA256Hash (PayloadBS bs) = return $ hashSHA256 bs+getPayloadSHA256Hash (PayloadH h off size) =+  hashSHA256FromSource $+    sourceHandleRange+      h+      (return . fromIntegral $ off)+      (return . fromIntegral $ size)+getPayloadSHA256Hash (PayloadC _ _) = throwIO MErrVUnexpectedPayload++getRequestBody :: Payload -> NC.RequestBody+getRequestBody (PayloadBS bs) = NC.RequestBodyBS bs+getRequestBody (PayloadH h off size) =+  NC.requestBodySource size $+    sourceHandleRange+      h+      (return . fromIntegral $ off)+      (return . fromIntegral $ size)+getRequestBody (PayloadC n src) = NC.requestBodySource n src++mkStreamingPayload :: Payload -> Payload+mkStreamingPayload payload =+  case payload of+    PayloadBS bs ->+      PayloadC+        (fromIntegral $ BS.length bs)+        (C.sourceLazy $ LB.fromStrict bs)+    PayloadH h off len ->+      PayloadC len $+        sourceHandleRange+          h+          (return . fromIntegral $ off)+          (return . fromIntegral $ len)+    _ -> payload++isStreamingPayload :: Payload -> Bool+isStreamingPayload (PayloadC _ _) = True+isStreamingPayload _ = False++-- | Checks if the connect info is for Amazon S3.+isAWSConnectInfo :: ConnectInfo -> Bool+isAWSConnectInfo ci = ".amazonaws.com" `T.isSuffixOf` connectHost ci++bucketHasPeriods :: Bucket -> Bool+bucketHasPeriods b = isJust $ T.find (== '.') b
+ vendor/minio-hs-1.7.0/src/Network/Minio/AdminAPI.hs view
@@ -0,0 +1,711 @@+--+-- MinIO Haskell SDK, (C) 2018-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.AdminAPI+  ( -- * MinIO Admin API++    --------------------++    -- | Provides MinIO admin API and related types. It is in+    -- experimental state.+    DriveInfo (..),+    ErasureInfo (..),+    Backend (..),+    ConnStats (..),+    HttpStats (..),+    ServerProps (..),+    CountNAvgTime (..),+    StorageClass (..),+    StorageInfo (..),+    SIData (..),+    ServerInfo (..),+    getServerInfo,+    HealOpts (..),+    HealResultItem (..),+    HealStatus (..),+    HealStartResp (..),+    startHeal,+    forceStartHeal,+    getHealStatus,+    SetConfigResult (..),+    NodeSummary (..),+    setConfig,+    getConfig,+    ServerVersion (..),+    ServiceStatus (..),+    serviceStatus,+    ServiceAction (..),+    serviceSendAction,+  )+where++import Data.Aeson+  ( FromJSON,+    ToJSON,+    Value (Object),+    eitherDecode,+    object,+    pairs,+    parseJSON,+    toEncoding,+    toJSON,+    withObject,+    withText,+    (.:),+    (.:?),+    (.=),+  )+import qualified Data.Aeson as A+import Data.Aeson.Types (typeMismatch)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as T+import Data.Time (NominalDiffTime, getCurrentTime)+import Lib.Prelude+import Network.HTTP.Conduit (Response)+import qualified Network.HTTP.Conduit as NC+import qualified Network.HTTP.Types as HT+import Network.HTTP.Types.Header (hHost)+import Network.Minio.APICommon+import Network.Minio.Credentials+import Network.Minio.Data+import Network.Minio.Errors+import Network.Minio.Sign.V4+import Network.Minio.Utils++data DriveInfo = DriveInfo+  { diUuid :: Text,+    diEndpoint :: Text,+    diState :: Text+  }+  deriving stock (Show, Eq)++instance FromJSON DriveInfo where+  parseJSON = withObject "DriveInfo" $ \v ->+    DriveInfo+      <$> v+        .: "uuid"+      <*> v+        .: "endpoint"+      <*> v+        .: "state"++data StorageClass = StorageClass+  { scParity :: Int,+    scData :: Int+  }+  deriving stock (Show, Eq)++data ErasureInfo = ErasureInfo+  { eiOnlineDisks :: Int,+    eiOfflineDisks :: Int,+    eiStandard :: StorageClass,+    eiReducedRedundancy :: StorageClass,+    eiSets :: [[DriveInfo]]+  }+  deriving stock (Show, Eq)++instance FromJSON ErasureInfo where+  parseJSON = withObject "ErasureInfo" $ \v -> do+    onlineDisks <- v .: "OnlineDisks"+    offlineDisks <- v .: "OfflineDisks"+    stdClass <-+      StorageClass+        <$> v+          .: "StandardSCData"+        <*> v+          .: "StandardSCParity"+    rrClass <-+      StorageClass+        <$> v+          .: "RRSCData"+        <*> v+          .: "RRSCParity"+    sets <- v .: "Sets"+    return $ ErasureInfo onlineDisks offlineDisks stdClass rrClass sets++data Backend+  = BackendFS+  | BackendErasure ErasureInfo+  deriving stock (Show, Eq)++instance FromJSON Backend where+  parseJSON = withObject "Backend" $ \v -> do+    typ <- v .: "Type"+    case typ :: Int of+      1 -> return BackendFS+      2 -> BackendErasure <$> parseJSON (Object v)+      _ -> typeMismatch "BackendType" (Object v)++data ConnStats = ConnStats+  { csTransferred :: Int64,+    csReceived :: Int64+  }+  deriving stock (Show, Eq)++instance FromJSON ConnStats where+  parseJSON = withObject "ConnStats" $ \v ->+    ConnStats+      <$> v+        .: "transferred"+      <*> v+        .: "received"++data ServerProps = ServerProps+  { spUptime :: NominalDiffTime,+    spVersion :: Text,+    spCommitId :: Text,+    spRegion :: Text,+    spSqsArns :: [Text]+  }+  deriving stock (Show, Eq)++instance FromJSON ServerProps where+  parseJSON = withObject "SIServer" $ \v -> do+    uptimeNs <- v .: "uptime"+    let uptime = uptimeNs / 1e9+    ver <- v .: "version"+    commitId <- v .: "commitID"+    region <- v .: "region"+    arn <- v .: "sqsARN"+    return $ ServerProps uptime ver commitId region arn++data StorageInfo = StorageInfo+  { siUsed :: Int64,+    siBackend :: Backend+  }+  deriving stock (Show, Eq)++instance FromJSON StorageInfo where+  parseJSON = withObject "StorageInfo" $ \v ->+    StorageInfo+      <$> v+        .: "Used"+      <*> v+        .: "Backend"++data CountNAvgTime = CountNAvgTime+  { caCount :: Int64,+    caAvgDuration :: Text+  }+  deriving stock (Show, Eq)++instance FromJSON CountNAvgTime where+  parseJSON = withObject "CountNAvgTime" $ \v ->+    CountNAvgTime+      <$> v+        .: "count"+      <*> v+        .: "avgDuration"++data HttpStats = HttpStats+  { hsTotalHeads :: CountNAvgTime,+    hsSuccessHeads :: CountNAvgTime,+    hsTotalGets :: CountNAvgTime,+    hsSuccessGets :: CountNAvgTime,+    hsTotalPuts :: CountNAvgTime,+    hsSuccessPuts :: CountNAvgTime,+    hsTotalPosts :: CountNAvgTime,+    hsSuccessPosts :: CountNAvgTime,+    hsTotalDeletes :: CountNAvgTime,+    hsSuccessDeletes :: CountNAvgTime+  }+  deriving stock (Show, Eq)++instance FromJSON HttpStats where+  parseJSON = withObject "HttpStats" $ \v ->+    HttpStats+      <$> v+        .: "totalHEADs"+      <*> v+        .: "successHEADs"+      <*> v+        .: "totalGETs"+      <*> v+        .: "successGETs"+      <*> v+        .: "totalPUTs"+      <*> v+        .: "successPUTs"+      <*> v+        .: "totalPOSTs"+      <*> v+        .: "successPOSTs"+      <*> v+        .: "totalDELETEs"+      <*> v+        .: "successDELETEs"++data SIData = SIData+  { sdStorage :: StorageInfo,+    sdConnStats :: ConnStats,+    sdHttpStats :: HttpStats,+    sdProps :: ServerProps+  }+  deriving stock (Show, Eq)++instance FromJSON SIData where+  parseJSON = withObject "SIData" $ \v ->+    SIData+      <$> v+        .: "storage"+      <*> v+        .: "network"+      <*> v+        .: "http"+      <*> v+        .: "server"++data ServerInfo = ServerInfo+  { siError :: Text,+    siAddr :: Text,+    siData :: SIData+  }+  deriving stock (Show, Eq)++instance FromJSON ServerInfo where+  parseJSON = withObject "ServerInfo" $ \v ->+    ServerInfo+      <$> v+        .: "error"+      <*> v+        .: "addr"+      <*> v+        .: "data"++data ServerVersion = ServerVersion+  { svVersion :: Text,+    svCommitId :: Text+  }+  deriving stock (Show, Eq)++instance FromJSON ServerVersion where+  parseJSON = withObject "ServerVersion" $ \v ->+    ServerVersion+      <$> v+        .: "version"+      <*> v+        .: "commitID"++data ServiceStatus = ServiceStatus+  { ssVersion :: ServerVersion,+    ssUptime :: NominalDiffTime+  }+  deriving stock (Show, Eq)++instance FromJSON ServiceStatus where+  parseJSON = withObject "ServiceStatus" $ \v -> do+    serverVersion <- v .: "serverVersion"+    uptimeNs <- v .: "uptime"+    let uptime = uptimeNs / 1e9+    return $ ServiceStatus serverVersion uptime++data ServiceAction+  = ServiceActionRestart+  | ServiceActionStop+  deriving stock (Show, Eq)++instance ToJSON ServiceAction where+  toJSON a = object ["action" .= serviceActionToText a]++serviceActionToText :: ServiceAction -> Text+serviceActionToText a = case a of+  ServiceActionRestart -> "restart"+  ServiceActionStop -> "stop"++adminPath :: ByteString+adminPath = "/minio/admin"++data HealStartResp = HealStartResp+  { hsrClientToken :: Text,+    hsrClientAddr :: Text,+    hsrStartTime :: UTCTime+  }+  deriving stock (Show, Eq)++instance FromJSON HealStartResp where+  parseJSON = withObject "HealStartResp" $ \v ->+    HealStartResp+      <$> v+        .: "clientToken"+      <*> v+        .: "clientAddress"+      <*> v+        .: "startTime"++data HealOpts = HealOpts+  { hoRecursive :: Bool,+    hoDryRun :: Bool+  }+  deriving stock (Show, Eq)++instance ToJSON HealOpts where+  toJSON (HealOpts r d) =+    object ["recursive" .= r, "dryRun" .= d]+  toEncoding (HealOpts r d) =+    pairs ("recursive" .= r <> "dryRun" .= d)++instance FromJSON HealOpts where+  parseJSON = withObject "HealOpts" $ \v ->+    HealOpts+      <$> v+        .: "recursive"+      <*> v+        .: "dryRun"++data HealItemType+  = HealItemMetadata+  | HealItemBucket+  | HealItemBucketMetadata+  | HealItemObject+  deriving stock (Show, Eq)++instance FromJSON HealItemType where+  parseJSON = withText "HealItemType" $ \v -> case v of+    "metadata" -> return HealItemMetadata+    "bucket" -> return HealItemBucket+    "object" -> return HealItemObject+    "bucket-metadata" -> return HealItemBucketMetadata+    _ -> typeMismatch "HealItemType" (A.String v)++data NodeSummary = NodeSummary+  { nsName :: Text,+    nsErrSet :: Bool,+    nsErrMessage :: Text+  }+  deriving stock (Show, Eq)++instance FromJSON NodeSummary where+  parseJSON = withObject "NodeSummary" $ \v ->+    NodeSummary+      <$> v+        .: "name"+      <*> v+        .: "errSet"+      <*> v+        .: "errMsg"++data SetConfigResult = SetConfigResult+  { scrStatus :: Bool,+    scrNodeSummary :: [NodeSummary]+  }+  deriving stock (Show, Eq)++instance FromJSON SetConfigResult where+  parseJSON = withObject "SetConfigResult" $ \v ->+    SetConfigResult+      <$> v+        .: "status"+      <*> v+        .: "nodeResults"++data HealResultItem = HealResultItem+  { hriResultIdx :: Int,+    hriType :: HealItemType,+    hriBucket :: Bucket,+    hriObject :: Object,+    hriDetail :: Text,+    hriParityBlocks :: Maybe Int,+    hriDataBlocks :: Maybe Int,+    hriDiskCount :: Int,+    hriSetCount :: Int,+    hriObjectSize :: Int,+    hriBefore :: [DriveInfo],+    hriAfter :: [DriveInfo]+  }+  deriving stock (Show, Eq)++instance FromJSON HealResultItem where+  parseJSON = withObject "HealResultItem" $ \v ->+    HealResultItem+      <$> v+        .: "resultId"+      <*> v+        .: "type"+      <*> v+        .: "bucket"+      <*> v+        .: "object"+      <*> v+        .: "detail"+      <*> v+        .:? "parityBlocks"+      <*> v+        .:? "dataBlocks"+      <*> v+        .: "diskCount"+      <*> v+        .: "setCount"+      <*> v+        .: "objectSize"+      <*> ( do+              before <- v .: "before"+              before .: "drives"+          )+      <*> ( do+              after <- v .: "after"+              after .: "drives"+          )++data HealStatus = HealStatus+  { hsSummary :: Text,+    hsStartTime :: UTCTime,+    hsSettings :: HealOpts,+    hsNumDisks :: Int,+    hsFailureDetail :: Maybe Text,+    hsItems :: Maybe [HealResultItem]+  }+  deriving stock (Show, Eq)++instance FromJSON HealStatus where+  parseJSON = withObject "HealStatus" $ \v ->+    HealStatus+      <$> v+        .: "Summary"+      <*> v+        .: "StartTime"+      <*> v+        .: "Settings"+      <*> v+        .: "NumDisks"+      <*> v+        .:? "Detail"+      <*> v+        .: "Items"++healPath :: Maybe Bucket -> Maybe Text -> ByteString+healPath bucket prefix = do+  if isJust bucket+    then+      encodeUtf8 $+        "v1/heal/"+          <> fromMaybe "" bucket+          <> "/"+          <> fromMaybe "" prefix+    else encodeUtf8 ("v1/heal/" :: Text)++-- | Get server version and uptime.+serviceStatus :: Minio ServiceStatus+serviceStatus = do+  rsp <-+    executeAdminRequest+      AdminReqInfo+        { ariMethod = HT.methodGet,+          ariPayload = PayloadBS B.empty,+          ariPayloadHash = Nothing,+          ariPath = "v1/service",+          ariHeaders = [],+          ariQueryParams = []+        }++  let rspBS = NC.responseBody rsp+  case eitherDecode rspBS of+    Right ss -> return ss+    Left err -> throwIO $ MErrVJsonParse $ T.pack err++-- | Send service restart or stop action to MinIO server.+serviceSendAction :: ServiceAction -> Minio ()+serviceSendAction action = do+  let payload = PayloadBS $ LBS.toStrict $ A.encode action+  void $+    executeAdminRequest+      AdminReqInfo+        { ariMethod = HT.methodPost,+          ariPayload = payload,+          ariPayloadHash = Nothing,+          ariPath = "v1/service",+          ariHeaders = [],+          ariQueryParams = []+        }++-- | Get the current config file from server.+getConfig :: Minio ByteString+getConfig = do+  rsp <-+    executeAdminRequest+      AdminReqInfo+        { ariMethod = HT.methodGet,+          ariPayload = PayloadBS B.empty,+          ariPayloadHash = Nothing,+          ariPath = "v1/config",+          ariHeaders = [],+          ariQueryParams = []+        }+  return $ LBS.toStrict $ NC.responseBody rsp++-- | Set a new config to the server.+setConfig :: ByteString -> Minio SetConfigResult+setConfig config = do+  rsp <-+    executeAdminRequest+      AdminReqInfo+        { ariMethod = HT.methodPut,+          ariPayload = PayloadBS config,+          ariPayloadHash = Nothing,+          ariPath = "v1/config",+          ariHeaders = [],+          ariQueryParams = []+        }++  let rspBS = NC.responseBody rsp+  case eitherDecode rspBS of+    Right scr -> return scr+    Left err -> throwIO $ MErrVJsonParse $ T.pack err++-- | Get the progress of currently running heal task, this API should be+-- invoked right after `startHeal`. `token` is obtained after `startHeal`+-- which should be used to get the heal status.+getHealStatus :: Maybe Bucket -> Maybe Text -> Text -> Minio HealStatus+getHealStatus bucket prefix token = do+  when (isNothing bucket && isJust prefix) $ throwIO MErrVInvalidHealPath+  let qparams = HT.queryTextToQuery [("clientToken", Just token)]+  rsp <-+    executeAdminRequest+      AdminReqInfo+        { ariMethod = HT.methodPost,+          ariPayload = PayloadBS B.empty,+          ariPayloadHash = Nothing,+          ariPath = healPath bucket prefix,+          ariHeaders = [],+          ariQueryParams = qparams+        }+  let rspBS = NC.responseBody rsp+  case eitherDecode rspBS of+    Right hs -> return hs+    Left err -> throwIO $ MErrVJsonParse $ T.pack err++doHeal :: Maybe Bucket -> Maybe Text -> HealOpts -> Bool -> Minio HealStartResp+doHeal bucket prefix opts forceStart = do+  when (isNothing bucket && isJust prefix) $ throwIO MErrVInvalidHealPath+  let payload = PayloadBS $ LBS.toStrict $ A.encode opts+  let qparams =+        bool+          []+          (HT.queryTextToQuery [("forceStart", Just "true")])+          forceStart++  rsp <-+    executeAdminRequest+      AdminReqInfo+        { ariMethod = HT.methodPost,+          ariPayload = payload,+          ariPayloadHash = Nothing,+          ariPath = healPath bucket prefix,+          ariHeaders = [],+          ariQueryParams = qparams+        }++  let rspBS = NC.responseBody rsp+  case eitherDecode rspBS of+    Right hsr -> return hsr+    Left err -> throwIO $ MErrVJsonParse $ T.pack err++-- | Start a heal sequence that scans data under given (possible empty)+-- `bucket` and `prefix`. The `recursive` bool turns on recursive+-- traversal under the given path. `dryRun` does not mutate on-disk data,+-- but performs data validation. Two heal sequences on overlapping paths+-- may not be initiated. The progress of a heal should be followed using+-- the `HealStatus` API. The server accumulates results of the heal+-- traversal and waits for the client to receive and acknowledge+-- them using the status API+startHeal :: Maybe Bucket -> Maybe Text -> HealOpts -> Minio HealStartResp+startHeal bucket prefix opts = doHeal bucket prefix opts False++-- | Similar to start a heal sequence, but force start a new heal sequence+-- even if an active heal is under progress.+forceStartHeal :: Maybe Bucket -> Maybe Text -> HealOpts -> Minio HealStartResp+forceStartHeal bucket prefix opts = doHeal bucket prefix opts True++-- | Fetches information for all cluster nodes, such as server+-- properties, storage information, network statistics, etc.+getServerInfo :: Minio [ServerInfo]+getServerInfo = do+  rsp <-+    executeAdminRequest+      AdminReqInfo+        { ariMethod = HT.methodGet,+          ariPayload = PayloadBS B.empty,+          ariPayloadHash = Nothing,+          ariPath = "v1/info",+          ariHeaders = [],+          ariQueryParams = []+        }+  let rspBS = NC.responseBody rsp+  case eitherDecode rspBS of+    Right si -> return si+    Left err -> throwIO $ MErrVJsonParse $ T.pack err++executeAdminRequest :: AdminReqInfo -> Minio (Response LByteString)+executeAdminRequest ari = do+  req <- buildAdminRequest ari+  mgr <- asks mcConnManager+  httpLbs req mgr++buildAdminRequest :: AdminReqInfo -> Minio NC.Request+buildAdminRequest areq = do+  ci <- asks mcConnInfo+  sha256Hash <-+    if connectIsSecure ci+      then -- if secure connection+        return "UNSIGNED-PAYLOAD"+      else -- otherwise compute sha256+        getPayloadSHA256Hash (ariPayload areq)++  timeStamp <- liftIO getCurrentTime++  mgr <- asks mcConnManager+  cv <- liftIO $ getCredential (connectCreds ci) (getEndpoint ci) mgr++  let hostHeader = (hHost, getHostAddr ci)+      newAreq =+        areq+          { ariPayloadHash = Just sha256Hash,+            ariHeaders =+              hostHeader+                : sha256Header sha256Hash+                : ariHeaders areq+          }+      signReq = toRequest ci newAreq+      sp =+        SignParams+          (coerce $ cvAccessKey cv)+          (coerce $ cvSecretKey cv)+          (coerce $ cvSessionToken cv)+          ServiceS3+          timeStamp+          Nothing+          Nothing+          (ariPayloadHash newAreq)+      signHeaders = signV4 sp signReq++  -- Update signReq with Authorization header containing v4 signature+  return+    signReq+      { NC.requestHeaders = ariHeaders newAreq ++ signHeaders+      }+  where+    toRequest :: ConnectInfo -> AdminReqInfo -> NC.Request+    toRequest ci aReq =+      NC.defaultRequest+        { NC.method = ariMethod aReq,+          NC.secure = connectIsSecure ci,+          NC.host = encodeUtf8 $ connectHost ci,+          NC.port = connectPort ci,+          NC.path = B.intercalate "/" [adminPath, ariPath aReq],+          NC.requestHeaders = ariHeaders aReq,+          NC.queryString = HT.renderQuery False $ ariQueryParams aReq,+          NC.requestBody = getRequestBody (ariPayload aReq)+        }
+ vendor/minio-hs-1.7.0/src/Network/Minio/CopyObject.hs view
@@ -0,0 +1,106 @@+--+-- MinIO Haskell SDK, (C) 2017 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.CopyObject where++import qualified Data.List as List+import Lib.Prelude+import Network.Minio.Data+import Network.Minio.Errors+import Network.Minio.S3API+import Network.Minio.Utils++-- | Copy an object using single or multipart copy strategy.+copyObjectInternal ::+  Bucket ->+  Object ->+  SourceInfo ->+  Minio ETag+copyObjectInternal b' o srcInfo = do+  let sBucket = srcBucket srcInfo+      sObject = srcObject srcInfo++  -- get source object size with a head request+  oi <- headObject sBucket sObject []+  let srcSize = oiSize oi++  -- check that byte offsets are valid if specified in cps+  let rangeMay = srcRange srcInfo+      range = maybe (0, srcSize) identity rangeMay+      startOffset = fst range+      endOffset = snd range++  when+    ( isJust rangeMay+        && ( (startOffset < 0)+               || (endOffset < startOffset)+               || (endOffset >= srcSize)+           )+    )+    $ throwIO+    $ MErrVInvalidSrcObjByteRange range++  -- 1. If sz > 64MiB (minPartSize) use multipart copy, OR+  -- 2. If startOffset /= 0 use multipart copy+  let destSize =+        (\(a, b) -> b - a + 1) $+          maybe (0, srcSize - 1) identity rangeMay++  if destSize > minPartSize || (endOffset - startOffset + 1 /= srcSize)+    then multiPartCopyObject b' o srcInfo srcSize+    else fst <$> copyObjectSingle b' o srcInfo {srcRange = Nothing} []++-- | Given the input byte range of the source object, compute the+-- splits for a multipart copy object procedure. Minimum part size+-- used is minPartSize.+selectCopyRanges :: (Int64, Int64) -> [(PartNumber, (Int64, Int64))]+selectCopyRanges (st, end) =+  zip pns $+    zipWith (\x y -> (st + x, st + x + y - 1)) startOffsets partSizes+  where+    size = end - st + 1+    (pns, startOffsets, partSizes) = List.unzip3 $ selectPartSizes size++-- | Perform a multipart copy object action. Since we cannot verify+-- existing parts based on the source object, there is no resuming+-- copy action support.+multiPartCopyObject ::+  Bucket ->+  Object ->+  SourceInfo ->+  Int64 ->+  Minio ETag+multiPartCopyObject b o cps srcSize = do+  uid <- newMultipartUpload b o []++  let byteRange = maybe (0, srcSize - 1) identity $ srcRange cps+      partRanges = selectCopyRanges byteRange+      partSources =+        map+          (\(x, (start, end)) -> (x, cps {srcRange = Just (start, end)}))+          partRanges+      dstInfo = defaultDestinationInfo {dstBucket = b, dstObject = o}++  copiedParts <-+    limitedMapConcurrently+      10+      ( \(pn, cps') -> do+          (etag, _) <- copyObjectPart dstInfo cps' uid pn []+          return (pn, etag)+      )+      partSources++  completeMultipartUpload b o uid copiedParts
+ vendor/minio-hs-1.7.0/src/Network/Minio/Credentials.hs view
@@ -0,0 +1,77 @@+--+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.Credentials+  ( CredentialValue (..),+    credentialValueText,+    STSCredentialProvider (..),+    AccessKey (..),+    SecretKey (..),+    SessionToken (..),+    ExpiryTime (..),+    STSCredentialStore,+    initSTSCredential,+    getSTSCredential,+    Creds (..),+    getCredential,+    Endpoint,++    -- * STS Assume Role+    defaultSTSAssumeRoleOptions,+    STSAssumeRole (..),+    STSAssumeRoleOptions (..),+  )+where++import Data.Time (diffUTCTime, getCurrentTime)+import qualified Network.HTTP.Client as NC+import Network.Minio.Credentials.AssumeRole+import Network.Minio.Credentials.Types+import qualified UnliftIO.MVar as M++data STSCredentialStore = STSCredentialStore+  { cachedCredentials :: M.MVar (CredentialValue, ExpiryTime),+    refreshAction :: Endpoint -> NC.Manager -> IO (CredentialValue, ExpiryTime)+  }++initSTSCredential :: (STSCredentialProvider p) => p -> IO STSCredentialStore+initSTSCredential p = do+  let action = retrieveSTSCredentials p+  -- start with dummy credential, so that refresh happens for first request.+  now <- getCurrentTime+  mvar <- M.newMVar (CredentialValue mempty mempty mempty, coerce now)+  return $+    STSCredentialStore+      { cachedCredentials = mvar,+        refreshAction = action+      }++getSTSCredential :: STSCredentialStore -> Endpoint -> NC.Manager -> IO (CredentialValue, Bool)+getSTSCredential store ep mgr = M.modifyMVar (cachedCredentials store) $ \cc@(v, expiry) -> do+  now <- getCurrentTime+  if diffUTCTime now (coerce expiry) > 0+    then do+      res <- refreshAction store ep mgr+      return (res, (fst res, True))+    else return (cc, (v, False))++data Creds+  = CredsStatic CredentialValue+  | CredsSTS STSCredentialStore++getCredential :: Creds -> Endpoint -> NC.Manager -> IO CredentialValue+getCredential (CredsStatic v) _ _ = return v+getCredential (CredsSTS s) ep mgr = fst <$> getSTSCredential s ep mgr
+ vendor/minio-hs-1.7.0/src/Network/Minio/Credentials/AssumeRole.hs view
@@ -0,0 +1,266 @@+--+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.Credentials.AssumeRole where++import qualified Data.ByteArray as BA+import qualified Data.ByteString.Lazy as LB+import qualified Data.Text as T+import qualified Data.Time as Time+import Data.Time.Units (Second)+import Lib.Prelude (UTCTime, throwIO)+import Network.HTTP.Client (RequestBody (RequestBodyBS))+import qualified Network.HTTP.Client as NC+import Network.HTTP.Types (hContentType, methodPost, renderSimpleQuery)+import Network.HTTP.Types.Header (hHost)+import Network.Minio.Credentials.Types+import Network.Minio.Data.Crypto (hashSHA256)+import Network.Minio.Errors (MErrV (..))+import Network.Minio.Sign.V4+import Network.Minio.Utils (getHostHeader, httpLbs)+import Network.Minio.XmlCommon+import Text.XML.Cursor hiding (bool)++stsVersion :: ByteString+stsVersion = "2011-06-15"++defaultDurationSeconds :: Second+defaultDurationSeconds = 3600++-- | Assume Role API argument.+--+-- @since 1.7.0+data STSAssumeRole = STSAssumeRole+  { -- | Credentials to use in the AssumeRole STS API.+    sarCredentials :: CredentialValue,+    -- | Optional settings.+    sarOptions :: STSAssumeRoleOptions+  }++-- | Options for STS Assume Role API.+data STSAssumeRoleOptions = STSAssumeRoleOptions+  { -- | STS endpoint to which the request will be made. For MinIO, this is the+    -- same as the server endpoint. For AWS, this has to be the Security Token+    -- Service endpoint. If using with 'setSTSCredential', this option can be+    -- left as 'Nothing' and the endpoint in 'ConnectInfo' will be used.+    saroEndpoint :: Maybe Text,+    -- | Desired validity for the generated credentials.+    saroDurationSeconds :: Maybe Second,+    -- | IAM policy to apply for the generated credentials.+    saroPolicyJSON :: Maybe ByteString,+    -- | Location is usually required for AWS.+    saroLocation :: Maybe Text,+    saroRoleARN :: Maybe Text,+    saroRoleSessionName :: Maybe Text+  }++-- | Default STS Assume Role options - all options are Nothing, except for+-- duration which is set to 1 hour.+defaultSTSAssumeRoleOptions :: STSAssumeRoleOptions+defaultSTSAssumeRoleOptions =+  STSAssumeRoleOptions+    { saroEndpoint = Nothing,+      saroDurationSeconds = Just 3600,+      saroPolicyJSON = Nothing,+      saroLocation = Nothing,+      saroRoleARN = Nothing,+      saroRoleSessionName = Nothing+    }++data AssumeRoleCredentials = AssumeRoleCredentials+  { arcCredentials :: CredentialValue,+    arcExpiration :: UTCTime+  }+  deriving stock (Show, Eq)++data AssumeRoleResult = AssumeRoleResult+  { arrSourceIdentity :: Text,+    arrAssumedRoleArn :: Text,+    arrAssumedRoleId :: Text,+    arrRoleCredentials :: AssumeRoleCredentials+  }+  deriving stock (Show, Eq)++-- | parseSTSAssumeRoleResult parses an XML response of the following form:+--+-- <AssumeRoleResponse xmlns="https://sts.amazonaws.com/doc/2011-06-15/">+--   <AssumeRoleResult>+--   <SourceIdentity>Alice</SourceIdentity>+--     <AssumedRoleUser>+--       <Arn>arn:aws:sts::123456789012:assumed-role/demo/TestAR</Arn>+--       <AssumedRoleId>ARO123EXAMPLE123:TestAR</AssumedRoleId>+--     </AssumedRoleUser>+--     <Credentials>+--       <AccessKeyId>ASIAIOSFODNN7EXAMPLE</AccessKeyId>+--       <SecretAccessKey>wJalrXUtnFEMI/K7MDENG/bPxRfiCYzEXAMPLEKEY</SecretAccessKey>+--       <SessionToken>+--        AQoDYXdzEPT//////////wEXAMPLEtc764bNrC9SAPBSM22wDOk4x4HIZ8j4FZTwdQW+--        LWsKWHGBuFqwAeMicRXmxfpSPfIeoIYRqTflfKD8YUuwthAx7mSEI/qkPpKPi/kMcGd+--        QrmGdeehM4IC1NtBmUpp2wUE8phUZampKsburEDy0KPkyQDYwT7WZ0wq5VSXDvp75YU+--        9HFvlRd8Tx6q6fE8YQcHNVXAkiY9q6d+xo0rKwT38xVqr7ZD0u0iPPkUL64lIZbqBAz+--        +scqKmlzm8FDrypNC9Yjc8fPOLn9FX9KSYvKTr4rvx3iSIlTJabIQwj2ICCR/oLxBA==+--       </SessionToken>+--       <Expiration>2019-11-09T13:34:41Z</Expiration>+--     </Credentials>+--     <PackedPolicySize>6</PackedPolicySize>+--   </AssumeRoleResult>+--   <ResponseMetadata>+--     <RequestId>c6104cbe-af31-11e0-8154-cbc7ccf896c7</RequestId>+--   </ResponseMetadata>+-- </AssumeRoleResponse>+parseSTSAssumeRoleResult :: (MonadIO m) => ByteString -> Text -> m AssumeRoleResult+parseSTSAssumeRoleResult xmldata namespace = do+  r <- parseRoot $ LB.fromStrict xmldata+  let s3Elem' = s3Elem namespace+      sourceIdentity =+        T.concat $+          r+            $/ s3Elem' "AssumeRoleResult"+            &/ s3Elem' "SourceIdentity"+            &/ content+      roleArn =+        T.concat $+          r+            $/ s3Elem' "AssumeRoleResult"+            &/ s3Elem' "AssumedRoleUser"+            &/ s3Elem' "Arn"+            &/ content+      roleId =+        T.concat $+          r+            $/ s3Elem' "AssumeRoleResult"+            &/ s3Elem' "AssumedRoleUser"+            &/ s3Elem' "AssumedRoleId"+            &/ content++      convSB :: Text -> BA.ScrubbedBytes+      convSB = BA.convert . (encodeUtf8 :: Text -> ByteString)++      credsInfo = do+        cr <-+          maybe (Left $ MErrVXmlParse "No Credentials Element found") Right $+            listToMaybe $+              r $/ s3Elem' "AssumeRoleResult" &/ s3Elem' "Credentials"+        let cur = fromNode $ node cr+        return+          ( CredentialValue+              { cvAccessKey =+                  coerce $+                    T.concat $+                      cur $/ s3Elem' "AccessKeyId" &/ content,+                cvSecretKey =+                  coerce $+                    convSB $+                      T.concat $+                        cur+                          $/ s3Elem' "SecretAccessKey"+                          &/ content,+                cvSessionToken =+                  Just $+                    coerce $+                      convSB $+                        T.concat $+                          cur+                            $/ s3Elem' "SessionToken"+                            &/ content+              },+            T.concat $ cur $/ s3Elem' "Expiration" &/ content+          )+  creds <- either throwIO pure credsInfo+  expiry <- parseS3XMLTime $ snd creds+  let roleCredentials =+        AssumeRoleCredentials+          { arcCredentials = fst creds,+            arcExpiration = expiry+          }+  return+    AssumeRoleResult+      { arrSourceIdentity = sourceIdentity,+        arrAssumedRoleArn = roleArn,+        arrAssumedRoleId = roleId,+        arrRoleCredentials = roleCredentials+      }++instance STSCredentialProvider STSAssumeRole where+  getSTSEndpoint = saroEndpoint . sarOptions+  retrieveSTSCredentials sar (host', port', isSecure') mgr = do+    -- Assemble STS request+    let requiredParams =+          [ ("Action", "AssumeRole"),+            ("Version", stsVersion)+          ]+        opts = sarOptions sar++        durSecs :: Int =+          fromIntegral $+            fromMaybe defaultDurationSeconds $+              saroDurationSeconds opts+        otherParams =+          [ ("RoleArn",) . encodeUtf8 <$> saroRoleARN opts,+            ("RoleSessionName",) . encodeUtf8 <$> saroRoleSessionName opts,+            Just ("DurationSeconds", show durSecs),+            ("Policy",) <$> saroPolicyJSON opts+          ]+        parameters = requiredParams ++ catMaybes otherParams+        (host, port, isSecure) =+          case getSTSEndpoint sar of+            Just ep ->+              let endPt = NC.parseRequest_ $ toString ep+               in (NC.host endPt, NC.port endPt, NC.secure endPt)+            Nothing -> (host', port', isSecure')+        reqBody = renderSimpleQuery False parameters+        req =+          NC.defaultRequest+            { NC.host = host,+              NC.port = port,+              NC.secure = isSecure,+              NC.method = methodPost,+              NC.requestHeaders =+                [ (hHost, getHostHeader (host, port)),+                  (hContentType, "application/x-www-form-urlencoded")+                ],+              NC.requestBody = RequestBodyBS reqBody+            }++    -- Sign the STS request.+    timeStamp <- liftIO Time.getCurrentTime+    let sp =+          SignParams+            { spAccessKey = coerce $ cvAccessKey $ sarCredentials sar,+              spSecretKey = coerce $ cvSecretKey $ sarCredentials sar,+              spSessionToken = coerce $ cvSessionToken $ sarCredentials sar,+              spService = ServiceSTS,+              spTimeStamp = timeStamp,+              spRegion = saroLocation opts,+              spExpirySecs = Nothing,+              spPayloadHash = Just $ hashSHA256 reqBody+            }+        signHeaders = signV4 sp req+        signedReq =+          req+            { NC.requestHeaders = NC.requestHeaders req ++ signHeaders+            }++    -- Make the STS request+    resp <- httpLbs signedReq mgr+    result <-+      parseSTSAssumeRoleResult+        (toStrict $ NC.responseBody resp)+        "https://sts.amazonaws.com/doc/2011-06-15/"+    return+      ( arcCredentials $ arrRoleCredentials result,+        coerce $ arcExpiration $ arrRoleCredentials result+      )
+ vendor/minio-hs-1.7.0/src/Network/Minio/Credentials/Types.hs view
@@ -0,0 +1,90 @@+--+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StrictData #-}++module Network.Minio.Credentials.Types where++import qualified Data.ByteArray as BA+import Lib.Prelude (UTCTime)+import qualified Network.HTTP.Client as NC++-- | Access Key type.+newtype AccessKey = AccessKey {unAccessKey :: Text}+  deriving stock (Show)+  deriving newtype (Eq, IsString, Semigroup, Monoid)++-- | Secret Key type - has a show instance that does not print the value.+newtype SecretKey = SecretKey {unSecretKey :: BA.ScrubbedBytes}+  deriving stock (Show)+  deriving newtype (Eq, IsString, Semigroup, Monoid)++-- | Session Token type - has a show instance that does not print the value.+newtype SessionToken = SessionToken {unSessionToken :: BA.ScrubbedBytes}+  deriving stock (Show)+  deriving newtype (Eq, IsString, Semigroup, Monoid)++-- | Object storage credential data type. It has support for the optional+-- [SessionToken](https://docs.aws.amazon.com/IAM/latest/UserGuide/id_credentials_temp_use-resources.html)+-- for using temporary credentials requested via STS.+--+-- The show instance for this type does not print the value of secrets for+-- security.+--+-- @since 1.7.0+data CredentialValue = CredentialValue+  { cvAccessKey :: AccessKey,+    cvSecretKey :: SecretKey,+    cvSessionToken :: Maybe SessionToken+  }+  deriving stock (Eq, Show)++scrubbedToText :: BA.ScrubbedBytes -> Text+scrubbedToText =+  let b2t :: ByteString -> Text+      b2t = decodeUtf8+      s2b :: BA.ScrubbedBytes -> ByteString+      s2b = BA.convert+   in b2t . s2b++-- | Convert a 'CredentialValue' to a text tuple. Use this to output the+-- credential to files or other programs.+credentialValueText :: CredentialValue -> (Text, Text, Maybe Text)+credentialValueText cv =+  ( coerce $ cvAccessKey cv,+    (scrubbedToText . coerce) $ cvSecretKey cv,+    scrubbedToText . coerce <$> cvSessionToken cv+  )++-- | Endpoint represented by host, port and TLS enabled flag.+type Endpoint = (ByteString, Int, Bool)++-- | Typeclass for STS credential providers.+--+-- @since 1.7.0+class STSCredentialProvider p where+  retrieveSTSCredentials ::+    p ->+    -- | STS Endpoint (host, port, isSecure)+    Endpoint ->+    NC.Manager ->+    IO (CredentialValue, ExpiryTime)+  getSTSEndpoint :: p -> Maybe Text++-- | 'ExpiryTime' represents a time at which a credential expires.+newtype ExpiryTime = ExpiryTime {unExpiryTime :: UTCTime}+  deriving stock (Show)+  deriving newtype (Eq)
+ vendor/minio-hs-1.7.0/src/Network/Minio/Data.hs view
@@ -0,0 +1,1192 @@+--+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TypeFamilies #-}++module Network.Minio.Data where++import qualified Conduit as C+import qualified Control.Concurrent.MVar as M+import Control.Monad.Trans.Except (throwE)+import Control.Monad.Trans.Resource+  ( MonadResource,+    MonadThrow (..),+    MonadUnliftIO,+    ResourceT,+    runResourceT,+  )+import qualified Data.Aeson as A+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import Data.Default.Class (def)+import qualified Data.HashMap.Strict as H+import qualified Data.Ini as Ini+import qualified Data.List as List+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Time (defaultTimeLocale, formatTime)+import Lib.Prelude (UTCTime, throwIO)+import qualified Network.Connection as Conn+import Network.HTTP.Client (defaultManagerSettings)+import qualified Network.HTTP.Client.TLS as TLS+import qualified Network.HTTP.Conduit as NC+import Network.HTTP.Types+  ( ByteRange,+    Header,+    Method,+    Query,+    hRange,+  )+import qualified Network.HTTP.Types as HT+import Network.Minio.Credentials+import Network.Minio.Data.Crypto+  ( encodeToBase64,+    hashMD5ToBase64,+  )+import Network.Minio.Data.Time (UrlExpiry)+import Network.Minio.Errors+  ( MErrV (MErrVInvalidEncryptionKeyLength, MErrVMissingCredentials),+    MinioErr (..),+  )+import Network.Minio.Utils+import System.Directory (doesFileExist, getHomeDirectory)+import qualified System.Environment as Env+import System.FilePath.Posix (combine)+import qualified UnliftIO as U+import qualified UnliftIO.MVar as UM++-- | max obj size is 5TiB+maxObjectSize :: Int64+maxObjectSize = 5 * 1024 * 1024 * oneMiB++-- | minimum size of parts used in multipart operations.+minPartSize :: Int64+minPartSize = 64 * oneMiB++oneMiB :: Int64+oneMiB = 1024 * 1024++-- | maximum number of parts that can be uploaded for a single object.+maxMultipartParts :: Int64+maxMultipartParts = 10000++-- TODO: Add a type which provides typed constants for region.  this+-- type should have a IsString instance to infer the appropriate+-- constant.++-- | awsRegionMap - library constant+awsRegionMap :: H.HashMap Text Text+awsRegionMap =+  H.fromList+    [ ("us-east-1", "s3.us-east-1.amazonaws.com"),+      ("us-east-2", "s3.us-east-2.amazonaws.com"),+      ("us-west-1", "s3.us-west-1.amazonaws.com"),+      ("us-west-2", "s3.us-west-2.amazonaws.com"),+      ("ca-central-1", "s3.ca-central-1.amazonaws.com"),+      ("ap-south-1", "s3.ap-south-1.amazonaws.com"),+      ("ap-south-2", "s3.ap-south-2.amazonaws.com"),+      ("ap-northeast-1", "s3.ap-northeast-1.amazonaws.com"),+      ("ap-northeast-2", "s3.ap-northeast-2.amazonaws.com"),+      ("ap-northeast-3", "s3.ap-northeast-3.amazonaws.com"),+      ("ap-southeast-1", "s3.ap-southeast-1.amazonaws.com"),+      ("ap-southeast-2", "s3.ap-southeast-2.amazonaws.com"),+      ("ap-southeast-3", "s3.ap-southeast-3.amazonaws.com"),+      ("eu-west-1", "s3.eu-west-1.amazonaws.com"),+      ("eu-west-2", "s3.eu-west-2.amazonaws.com"),+      ("eu-west-3", "s3.eu-west-3.amazonaws.com"),+      ("eu-central-1", "s3.eu-central-1.amazonaws.com"),+      ("eu-central-2", "s3.eu-central-2.amazonaws.com"),+      ("eu-south-1", "s3.eu-south-1.amazonaws.com"),+      ("eu-south-2", "s3.eu-south-2.amazonaws.com"),+      ("af-south-1", "s3.af-south-1.amazonaws.com"),+      ("ap-east-1", "s3.ap-east-1.amazonaws.com"),+      ("cn-north-1", "s3.cn-north-1.amazonaws.com.cn"),+      ("cn-northwest-1", "s3.cn-northwest-1.amazonaws.com.cn"),+      ("eu-north-1", "s3.eu-north-1.amazonaws.com"),+      ("me-south-1", "s3.me-south-1.amazonaws.com"),+      ("me-central-1", "s3.me-central-1.amazonaws.com"),+      ("us-gov-east-1", "s3.us-gov-east-1.amazonaws.com"),+      ("us-gov-west-1", "s3.us-gov-west-1.amazonaws.com"),+      ("sa-east-1", "s3.sa-east-1.amazonaws.com")+    ]++-- | Connection Info data type. To create a 'ConnectInfo' value,+-- enable the @OverloadedStrings@ language extension and use the+-- `IsString` instance to provide a URL, for example:+--+-- > let c :: ConnectInfo = "https://play.min.io"+data ConnectInfo = ConnectInfo+  { connectHost :: Text,+    connectPort :: Int,+    connectCreds :: Creds,+    connectIsSecure :: Bool,+    connectRegion :: Region,+    connectAutoDiscoverRegion :: Bool,+    connectDisableTLSCertValidation :: Bool+  }++getEndpoint :: ConnectInfo -> Endpoint+getEndpoint ci = (encodeUtf8 $ connectHost ci, connectPort ci, connectIsSecure ci)++instance IsString ConnectInfo where+  fromString str =+    let req = NC.parseRequest_ str+     in ConnectInfo+          { connectHost = TE.decodeUtf8 $ NC.host req,+            connectPort = NC.port req,+            connectCreds = CredsStatic $ CredentialValue mempty mempty mempty,+            connectIsSecure = NC.secure req,+            connectRegion = "",+            connectAutoDiscoverRegion = True,+            connectDisableTLSCertValidation = False+          }++-- | A 'CredentialLoader' is an action that may return a 'CredentialValue'.+-- Loaders may be chained together using 'findFirst'.+--+-- @since 1.7.0+type CredentialLoader = IO (Maybe CredentialValue)++-- | Combines the given list of loaders, by calling each one in+-- order until a 'CredentialValue' is returned.+findFirst :: [CredentialLoader] -> IO (Maybe CredentialValue)+findFirst [] = return Nothing+findFirst (f : fs) = do+  c <- f+  maybe (findFirst fs) (return . Just) c++-- | This action returns a 'CredentialValue' populated from+-- @~\/.aws\/credentials@+fromAWSConfigFile :: CredentialLoader+fromAWSConfigFile = do+  credsE <- runExceptT $ do+    homeDir <- lift getHomeDirectory+    let awsCredsFile = homeDir `combine` ".aws" `combine` "credentials"+    fileExists <- lift $ doesFileExist awsCredsFile+    bool (throwE "FileNotFound") (return ()) fileExists+    ini <- ExceptT $ Ini.readIniFile awsCredsFile+    akey <-+      ExceptT $+        return $+          Ini.lookupValue "default" "aws_access_key_id" ini+    skey <-+      ExceptT $+        return $+          Ini.lookupValue "default" "aws_secret_access_key" ini+    return $ CredentialValue (coerce akey) (fromString $ T.unpack skey) Nothing+  return $ either (const Nothing) Just credsE++-- | This action returns a 'CredentialValue` populated from @AWS_ACCESS_KEY_ID@+-- and @AWS_SECRET_ACCESS_KEY@ environment variables.+fromAWSEnv :: CredentialLoader+fromAWSEnv = runMaybeT $ do+  akey <- MaybeT $ Env.lookupEnv "AWS_ACCESS_KEY_ID"+  skey <- MaybeT $ Env.lookupEnv "AWS_SECRET_ACCESS_KEY"+  return $ CredentialValue (fromString akey) (fromString skey) Nothing++-- | This action returns a 'CredentialValue' populated from @MINIO_ACCESS_KEY@+-- and @MINIO_SECRET_KEY@ environment variables.+fromMinioEnv :: CredentialLoader+fromMinioEnv = runMaybeT $ do+  akey <- MaybeT $ Env.lookupEnv "MINIO_ACCESS_KEY"+  skey <- MaybeT $ Env.lookupEnv "MINIO_SECRET_KEY"+  return $ CredentialValue (fromString akey) (fromString skey) Nothing++-- | setCredsFrom retrieves access credentials from the first action in the+-- given list that succeeds and sets it in the 'ConnectInfo'.+setCredsFrom :: [CredentialLoader] -> ConnectInfo -> IO ConnectInfo+setCredsFrom ps ci = do+  pMay <- findFirst ps+  maybe+    (throwIO MErrVMissingCredentials)+    (return . (`setCreds` ci))+    pMay++-- | setCreds sets the given `CredentialValue` in the `ConnectInfo`.+setCreds :: CredentialValue -> ConnectInfo -> ConnectInfo+setCreds cv connInfo =+  connInfo+    { connectCreds = CredsStatic cv+    }++-- | 'setSTSCredential' configures `ConnectInfo` to retrieve temporary+-- credentials via the STS API on demand. It is automatically refreshed on+-- expiry.+setSTSCredential :: (STSCredentialProvider p) => p -> ConnectInfo -> IO ConnectInfo+setSTSCredential p ci = do+  store <- initSTSCredential p+  return ci {connectCreds = CredsSTS store}++-- | Set the S3 region parameter in the `ConnectInfo`+setRegion :: Region -> ConnectInfo -> ConnectInfo+setRegion r connInfo =+  connInfo+    { connectRegion = r,+      connectAutoDiscoverRegion = False+    }++-- | Check if the connection to object storage server is secure+-- (i.e. uses TLS)+isConnectInfoSecure :: ConnectInfo -> Bool+isConnectInfoSecure = connectIsSecure++-- | Disable TLS certificate validation completely! This makes TLS+-- insecure! Use only for testing with self-signed or temporary+-- certificates. Note that this option has no effect, if you provide+-- your own Manager in `mkMinioConn`.+disableTLSCertValidation :: ConnectInfo -> ConnectInfo+disableTLSCertValidation c = c {connectDisableTLSCertValidation = True}++getHostAddr :: ConnectInfo -> ByteString+getHostAddr ci = getHostHeader (encodeUtf8 $ connectHost ci, connectPort ci)++-- | Default Google Compute Storage ConnectInfo. Works only for+-- "Simple Migration" use-case with interoperability mode enabled on+-- GCP console. For more information -+-- https://cloud.google.com/storage/docs/migrating+--+-- Credentials should be supplied before use.+gcsCI :: ConnectInfo+gcsCI =+  setRegion+    "us"+    "https://storage.googleapis.com"++-- | Default AWS S3 ConnectInfo. Connects to "us-east-1". Credentials+-- should be supplied before use.+awsCI :: ConnectInfo+awsCI = "https://s3.amazonaws.com"++-- | <https://play.min.io MinIO Play Server>+-- ConnectInfo. Credentials are already filled in.+minioPlayCI :: ConnectInfo+minioPlayCI =+  let playCreds = CredentialValue "Q3AM3UQ867SPQQA43P2F" "zuf+tfteSlswRu7BJ86wekitnifILbZam1KYY3TG" Nothing+   in setCreds playCreds $+        setRegion+          "us-east-1"+          "https://play.min.io"++-- |+-- Represents a bucket in the object store+type Bucket = Text++-- |+-- Represents an object name+type Object = Text++-- | Represents a region+type Region = Text++-- | A type alias to represent an Entity-Tag returned by S3-compatible APIs.+type ETag = Text++-- | Data type to represent an object encryption key. Create one using+-- the `mkSSECKey` function.+newtype SSECKey = SSECKey BA.ScrubbedBytes+  deriving stock (Eq, Show)++-- | Validates that the given ByteString is 32 bytes long and creates+-- an encryption key.+mkSSECKey :: (MonadThrow m) => ByteString -> m SSECKey+mkSSECKey keyBytes+  | B.length keyBytes /= 32 =+      throwM MErrVInvalidEncryptionKeyLength+  | otherwise =+      return $ SSECKey $ BA.convert keyBytes++-- | Data type to represent Server-Side-Encryption settings+data SSE where+  -- | Specifies SSE S3 encryption - server manages encryption keys+  SSE :: SSE+  -- | Specifies that KMS service should be used. The first argument+  -- to the constructor is the Key Id to be used by the server (if+  -- not specified, the default KMS key id is used). The second+  -- argument is the optional KMS context that must have a+  -- `A.ToJSON` instance - please refer to the AWS S3 documentation+  -- for detailed information.+  SSEKMS :: (A.ToJSON a) => Maybe ByteString -> Maybe a -> SSE+  -- | Specifies server-side encryption with customer provided+  -- key. The argument is the encryption key to be used.+  SSEC :: SSECKey -> SSE++toPutObjectHeaders :: SSE -> [HT.Header]+toPutObjectHeaders sseArg =+  let sseHeader = "x-amz-server-side-encryption"+      sseKmsIdHeader = sseHeader <> "-aws-kms-key-id"+      sseKmsContextHeader = sseHeader <> "-context"+      ssecAlgo = sseHeader <> "-customer-algorithm"+      ssecKey = sseHeader <> "-customer-key"+      ssecKeyMD5 = ssecKey <> "-MD5"+   in case sseArg of+        SSE -> [(sseHeader, "AES256")]+        SSEKMS keyIdMay ctxMay ->+          [(sseHeader, "aws:kms")]+            ++ maybe [] (\k -> [(sseKmsIdHeader, k)]) keyIdMay+            ++ maybe [] (\k -> [(sseKmsContextHeader, LB.toStrict $ A.encode k)]) ctxMay+        SSEC (SSECKey sb) ->+          [ (ssecAlgo, "AES256"),+            (ssecKey, encodeToBase64 sb),+            (ssecKeyMD5, hashMD5ToBase64 sb)+          ]++-- | Data type for options in PutObject call.  Start with the empty+-- `defaultPutObjectOptions` and use various the various poo*+-- accessors.+data PutObjectOptions = PutObjectOptions+  { -- | Set a standard MIME type describing the format of the object.+    pooContentType :: Maybe Text,+    -- | Set what content encodings have been applied to the object and thus+    -- what decoding mechanisms must be applied to obtain the media-type+    -- referenced by the Content-Type header field.+    pooContentEncoding :: Maybe Text,+    -- | Set presentational information for the object.+    pooContentDisposition :: Maybe Text,+    -- | Set to specify caching behavior for the object along the+    -- request/reply chain.+    pooCacheControl :: Maybe Text,+    -- | Set to describe the language(s) intended for the audience.+    pooContentLanguage :: Maybe Text,+    -- | Set to @STANDARD@ or @REDUCED_REDUNDANCY@ depending on your+    -- performance needs, storage class is @STANDARD@ by default (i.e+    -- when Nothing is passed).+    pooStorageClass :: Maybe Text,+    -- | Set user defined metadata to store with the object.+    pooUserMetadata :: [(Text, Text)],+    -- | Set number of worker threads used to upload an object.+    pooNumThreads :: Maybe Word,+    -- | Set object encryption parameters for the request.+    pooSSE :: Maybe SSE+  }++-- | Provide default `PutObjectOptions`.+defaultPutObjectOptions :: PutObjectOptions+defaultPutObjectOptions = PutObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing [] Nothing Nothing++pooToHeaders :: PutObjectOptions -> [HT.Header]+pooToHeaders poo =+  userMetadata+    ++ mapMaybe tupToMaybe (zip names values)+    ++ maybe [] toPutObjectHeaders (pooSSE poo)+  where+    tupToMaybe (k, Just v) = Just (k, v)+    tupToMaybe (_, Nothing) = Nothing+    userMetadata = mkHeaderFromMetadata $ pooUserMetadata poo+    names =+      [ "content-type",+        "content-encoding",+        "content-disposition",+        "content-language",+        "cache-control",+        "x-amz-storage-class"+      ]+    values =+      map+        (fmap encodeUtf8 . (poo &))+        [ pooContentType,+          pooContentEncoding,+          pooContentDisposition,+          pooContentLanguage,+          pooCacheControl,+          pooStorageClass+        ]++-- |+-- BucketInfo returned for list buckets call+data BucketInfo = BucketInfo+  { biName :: Bucket,+    biCreationDate :: UTCTime+  }+  deriving stock (Show, Eq)++-- | A type alias to represent a part-number for multipart upload+type PartNumber = Int16++-- | Select part sizes - the logic is that the minimum part-size will+-- be 64MiB.+selectPartSizes :: Int64 -> [(PartNumber, Int64, Int64)]+selectPartSizes size =+  uncurry (List.zip3 [1 ..]) $+    List.unzip $+      loop 0 size+  where+    ceil :: Double -> Int64+    ceil = ceiling+    partSize =+      max+        minPartSize+        ( ceil $+            fromIntegral size+              / fromIntegral maxMultipartParts+        )+    m = partSize+    loop st sz+      | st > sz = []+      | st + m >= sz = [(st, sz - st)]+      | otherwise = (st, m) : loop (st + m) sz++-- | A type alias to represent an upload-id for multipart upload+type UploadId = Text++-- | A type to represent a part-number and etag.+type PartTuple = (PartNumber, ETag)++-- | Represents result from a listing of object parts of an ongoing+-- multipart upload.+data ListPartsResult = ListPartsResult+  { lprHasMore :: Bool,+    lprNextPart :: Maybe Int,+    lprParts :: [ObjectPartInfo]+  }+  deriving stock (Show, Eq)++-- | Represents information about an object part in an ongoing+-- multipart upload.+data ObjectPartInfo = ObjectPartInfo+  { opiNumber :: PartNumber,+    opiETag :: ETag,+    opiSize :: Int64,+    opiModTime :: UTCTime+  }+  deriving stock (Show, Eq)++-- | Represents result from a listing of incomplete uploads to a+-- bucket.+data ListUploadsResult = ListUploadsResult+  { lurHasMore :: Bool,+    lurNextKey :: Maybe Text,+    lurNextUpload :: Maybe Text,+    lurUploads :: [(Object, UploadId, UTCTime)],+    lurCPrefixes :: [Text]+  }+  deriving stock (Show, Eq)++-- | Represents information about a multipart upload.+data UploadInfo = UploadInfo+  { uiKey :: Object,+    uiUploadId :: UploadId,+    uiInitTime :: UTCTime,+    uiSize :: Int64+  }+  deriving stock (Show, Eq)++-- | Represents result from a listing of objects in a bucket.+data ListObjectsResult = ListObjectsResult+  { lorHasMore :: Bool,+    lorNextToken :: Maybe Text,+    lorObjects :: [ObjectInfo],+    lorCPrefixes :: [Text]+  }+  deriving stock (Show, Eq)++-- | Represents result from a listing of objects version 1 in a bucket.+data ListObjectsV1Result = ListObjectsV1Result+  { lorHasMore' :: Bool,+    lorNextMarker :: Maybe Text,+    lorObjects' :: [ObjectInfo],+    lorCPrefixes' :: [Text]+  }+  deriving stock (Show, Eq)++-- | Represents information about an object.+data ObjectInfo = ObjectInfo+  { -- | Object key+    oiObject :: Object,+    -- | Modification time of the object+    oiModTime :: UTCTime,+    -- | ETag of the object+    oiETag :: ETag,+    -- | Size of the object in bytes+    oiSize :: Int64,+    -- | A map of user-metadata+    -- pairs stored with an+    -- object (keys will not+    -- have the @X-Amz-Meta-@+    -- prefix).+    oiUserMetadata :: H.HashMap Text Text,+    -- | A map of metadata+    -- key-value pairs (not+    -- including the+    -- user-metadata pairs)+    oiMetadata :: H.HashMap Text Text+  }+  deriving stock (Show, Eq)++-- | Represents source object in server-side copy object+data SourceInfo = SourceInfo+  { -- | Bucket containing the source object+    srcBucket :: Text,+    -- | Source object key+    srcObject :: Text,+    -- | Source object+    -- byte-range+    -- (inclusive)+    srcRange :: Maybe (Int64, Int64),+    -- | ETag condition on source -+    -- object is copied only if the+    -- source object's ETag matches+    -- this value.+    srcIfMatch :: Maybe Text,+    -- | ETag not match condition+    -- on source - object is copied+    -- if ETag does not match this+    -- value.+    srcIfNoneMatch :: Maybe Text,+    -- | Copy source object only+    -- if the source has been+    -- modified since this time.+    srcIfModifiedSince :: Maybe UTCTime,+    -- | Copy source object only+    -- if the source has been+    -- un-modified since this+    -- given time.+    srcIfUnmodifiedSince :: Maybe UTCTime+  }+  deriving stock (Show, Eq)++-- | Provide a default for `SourceInfo`+defaultSourceInfo :: SourceInfo+defaultSourceInfo = SourceInfo "" "" Nothing Nothing Nothing Nothing Nothing++-- | Represents destination object in server-side copy object+data DestinationInfo = DestinationInfo+  { -- | Destination bucket+    dstBucket :: Text,+    -- | Destination object key+    dstObject :: Text+  }+  deriving stock (Show, Eq)++-- | Provide a default for `DestinationInfo`+defaultDestinationInfo :: DestinationInfo+defaultDestinationInfo = DestinationInfo "" ""++-- | Data type for options when getting an object from the+-- service. Start with the empty `defaultGetObjectOptions` and modify+-- it using the goo* functions.+data GetObjectOptions = GetObjectOptions+  { -- | Set object's data of given offset begin and end,+    -- [ByteRangeFromTo 0 9] means first ten bytes of the source object.+    gooRange :: Maybe ByteRange,+    -- | Set matching ETag condition, GetObject which matches the following+    -- ETag.+    gooIfMatch :: Maybe ETag,+    -- | Set matching ETag none condition, GetObject which does not match+    -- the following ETag.+    gooIfNoneMatch :: Maybe ETag,+    -- | Set object unmodified condition, GetObject unmodified since given time.+    gooIfUnmodifiedSince :: Maybe UTCTime,+    -- | Set object modified condition, GetObject modified since given time.+    gooIfModifiedSince :: Maybe UTCTime,+    -- | Specify SSE-C key+    gooSSECKey :: Maybe SSECKey+  }++-- | Provide default  `GetObjectOptions`.+defaultGetObjectOptions :: GetObjectOptions+defaultGetObjectOptions =+  GetObjectOptions Nothing Nothing Nothing Nothing Nothing Nothing++gooToHeaders :: GetObjectOptions -> [HT.Header]+gooToHeaders goo =+  rangeHdr+    ++ zip names values+    ++ maybe [] (toPutObjectHeaders . SSEC) (gooSSECKey goo)+  where+    names =+      [ "If-Match",+        "If-None-Match",+        "If-Unmodified-Since",+        "If-Modified-Since"+      ]+    values =+      mapMaybe+        (fmap encodeUtf8 . (goo &))+        [ gooIfMatch,+          gooIfNoneMatch,+          fmap formatRFC1123 . gooIfUnmodifiedSince,+          fmap formatRFC1123 . gooIfModifiedSince+        ]+    rangeHdr =+      maybe [] (\a -> [(hRange, HT.renderByteRanges [a])]) $+        gooRange goo++-- | Data type returned by 'getObject' representing the object being+-- retrieved. Use the @gor*@ functions to access its contents.+data GetObjectResponse = GetObjectResponse+  { -- | ObjectInfo of the object being retrieved.+    gorObjectInfo :: ObjectInfo,+    -- | A conduit of the bytes of the object.+    gorObjectStream :: C.ConduitM () ByteString Minio ()+  }++-- | A data-type for events that can occur in the object storage+-- server. Reference:+-- https://docs.aws.amazon.com/AmazonS3/latest/dev/NotificationHowTo.html#supported-notification-event-types+data Event+  = ObjectCreated+  | ObjectCreatedPut+  | ObjectCreatedPost+  | ObjectCreatedCopy+  | ObjectCreatedMultipartUpload+  | ObjectRemoved+  | ObjectRemovedDelete+  | ObjectRemovedDeleteMarkerCreated+  | ReducedRedundancyLostObject+  deriving stock (Eq, Show)++instance ToText Event where+  toText ObjectCreated = "s3:ObjectCreated:*"+  toText ObjectCreatedPut = "s3:ObjectCreated:Put"+  toText ObjectCreatedPost = "s3:ObjectCreated:Post"+  toText ObjectCreatedCopy = "s3:ObjectCreated:Copy"+  toText ObjectCreatedMultipartUpload = "s3:ObjectCreated:MultipartUpload"+  toText ObjectRemoved = "s3:ObjectRemoved:*"+  toText ObjectRemovedDelete = "s3:ObjectRemoved:Delete"+  toText ObjectRemovedDeleteMarkerCreated = "s3:ObjectRemoved:DeleteMarkerCreated"+  toText ReducedRedundancyLostObject = "s3:ReducedRedundancyLostObject"++textToEvent :: Text -> Maybe Event+textToEvent t = case t of+  "s3:ObjectCreated:*" -> Just ObjectCreated+  "s3:ObjectCreated:Put" -> Just ObjectCreatedPut+  "s3:ObjectCreated:Post" -> Just ObjectCreatedPost+  "s3:ObjectCreated:Copy" -> Just ObjectCreatedCopy+  "s3:ObjectCreated:MultipartUpload" -> Just ObjectCreatedMultipartUpload+  "s3:ObjectRemoved:*" -> Just ObjectRemoved+  "s3:ObjectRemoved:Delete" -> Just ObjectRemovedDelete+  "s3:ObjectRemoved:DeleteMarkerCreated" -> Just ObjectRemovedDeleteMarkerCreated+  "s3:ReducedRedundancyLostObject" -> Just ReducedRedundancyLostObject+  _ -> Nothing++-- | Filter data type - part of notification configuration+newtype Filter = Filter+  { fFilter :: FilterKey+  }+  deriving stock (Show, Eq)++-- | defaultFilter is empty, used to create a notification+-- configuration.+defaultFilter :: Filter+defaultFilter = Filter defaultFilterKey++-- | FilterKey contains FilterRules, and is part of a Filter.+newtype FilterKey = FilterKey+  { fkKey :: FilterRules+  }+  deriving stock (Show, Eq)++-- | defaultFilterKey is empty, used to create notification+-- configuration.+defaultFilterKey :: FilterKey+defaultFilterKey = FilterKey defaultFilterRules++-- | FilterRules represents a collection of `FilterRule`s.+newtype FilterRules = FilterRules+  { frFilterRules :: [FilterRule]+  }+  deriving stock (Show, Eq)++-- | defaultFilterRules is empty, used to create notification+-- configuration.+defaultFilterRules :: FilterRules+defaultFilterRules = FilterRules []++-- | A filter rule that can act based on the suffix or prefix of an+-- object. As an example, let's create two filter rules:+--+--    > let suffixRule = FilterRule "suffix" ".jpg"+--    > let prefixRule = FilterRule "prefix" "images/"+--+-- The @suffixRule@ restricts the notification to be triggered only+-- for objects having a suffix of ".jpg", and the @prefixRule@+-- restricts it to objects having a prefix of "images/".+data FilterRule = FilterRule+  { frName :: Text,+    frValue :: Text+  }+  deriving stock (Show, Eq)++-- | Arn is an alias of Text+type Arn = Text++-- | A data-type representing the configuration for a particular+-- notification system. It could represent a Queue, Topic or Lambda+-- Function configuration.+data NotificationConfig = NotificationConfig+  { ncId :: Text,+    ncArn :: Arn,+    ncEvents :: [Event],+    ncFilter :: Filter+  }+  deriving stock (Show, Eq)++-- | A data-type to represent bucket notification configuration. It is+-- a collection of queue, topic or lambda function configurations. The+-- structure of the types follow closely the XML representation+-- described at+-- <https://docs.aws.amazon.com/AmazonS3/latest/API/RESTBucketPUTnotification.html>+data Notification = Notification+  { nQueueConfigurations :: [NotificationConfig],+    nTopicConfigurations :: [NotificationConfig],+    nCloudFunctionConfigurations :: [NotificationConfig]+  }+  deriving stock (Show, Eq)++-- | The default notification configuration is empty.+defaultNotification :: Notification+defaultNotification = Notification [] [] []++--------------------------------------------------------------------------+-- Select API Related Types+--------------------------------------------------------------------------++-- | SelectRequest represents the Select API call. Use the+-- `selectRequest` function to create a value of this type.+data SelectRequest = SelectRequest+  { srExpression :: Text,+    srExpressionType :: ExpressionType,+    srInputSerialization :: InputSerialization,+    srOutputSerialization :: OutputSerialization,+    srRequestProgressEnabled :: Maybe Bool+  }+  deriving stock (Show, Eq)++data ExpressionType = SQL+  deriving stock (Show, Eq)++-- | InputSerialization represents format information of the input+-- object being queried. Use one of the smart constructors such as+-- `defaultCsvInput` as a starting value, and add compression info+-- using `setInputCompressionType`+data InputSerialization = InputSerialization+  { isCompressionType :: Maybe CompressionType,+    isFormatInfo :: InputFormatInfo+  }+  deriving stock (Show, Eq)++-- | Data type representing the compression setting in a Select+-- request.+data CompressionType+  = CompressionTypeNone+  | CompressionTypeGzip+  | CompressionTypeBzip2+  deriving stock (Show, Eq)++-- | Data type representing input object format information in a+-- Select request.+data InputFormatInfo+  = InputFormatCSV CSVInputProp+  | InputFormatJSON JSONInputProp+  | InputFormatParquet+  deriving stock (Show, Eq)++-- | defaultCsvInput returns InputSerialization with default CSV+-- format, and without any compression setting.+defaultCsvInput :: InputSerialization+defaultCsvInput = InputSerialization Nothing (InputFormatCSV defaultCSVProp)++-- | linesJsonInput returns InputSerialization with JSON line based+-- format with no compression setting.+linesJsonInput :: InputSerialization+linesJsonInput =+  InputSerialization+    Nothing+    (InputFormatJSON $ JSONInputProp JSONTypeLines)++-- | documentJsonInput returns InputSerialization with JSON document+-- based format with no compression setting.+documentJsonInput :: InputSerialization+documentJsonInput =+  InputSerialization+    Nothing+    (InputFormatJSON $ JSONInputProp JSONTypeDocument)++-- | defaultParquetInput returns InputSerialization with Parquet+-- format, and no compression setting.+defaultParquetInput :: InputSerialization+defaultParquetInput = InputSerialization Nothing InputFormatParquet++-- | setInputCompressionType sets the compression type for the input+-- of the SelectRequest+setInputCompressionType ::+  CompressionType ->+  SelectRequest ->+  SelectRequest+setInputCompressionType c i =+  let is = srInputSerialization i+      is' = is {isCompressionType = Just c}+   in i {srInputSerialization = is'}++-- | defaultCsvOutput returns OutputSerialization with default CSV+-- format.+defaultCsvOutput :: OutputSerialization+defaultCsvOutput = OutputSerializationCSV defaultCSVProp++-- | defaultJsonInput returns OutputSerialization with default JSON+-- format.+defaultJsonOutput :: OutputSerialization+defaultJsonOutput = OutputSerializationJSON (JSONOutputProp Nothing)++-- | selectRequest is used to build a `SelectRequest`+-- value. @selectRequest query inputSer outputSer@ represents a+-- SelectRequest with the SQL query text given by @query@, the input+-- serialization settings (compression format and format information)+-- @inputSer@ and the output serialization settings @outputSer@.+selectRequest ::+  Text ->+  InputSerialization ->+  OutputSerialization ->+  SelectRequest+selectRequest sqlQuery inputSer outputSer =+  SelectRequest+    { srExpression = sqlQuery,+      srExpressionType = SQL,+      srInputSerialization = inputSer,+      srOutputSerialization = outputSer,+      srRequestProgressEnabled = Nothing+    }++-- | setRequestProgressEnabled sets the flag for turning on progress+-- messages when the Select response is being streamed back to the+-- client.+setRequestProgressEnabled :: Bool -> SelectRequest -> SelectRequest+setRequestProgressEnabled enabled sr =+  sr {srRequestProgressEnabled = Just enabled}++type CSVInputProp = CSVProp++-- | CSVProp represents CSV format properties. It is built up using+-- the Monoid instance.+newtype CSVProp = CSVProp (H.HashMap Text Text)+  deriving stock (Show, Eq)++instance Semigroup CSVProp where+  (CSVProp a) <> (CSVProp b) = CSVProp (b <> a)++instance Monoid CSVProp where+  mempty = CSVProp mempty++csvPropsList :: CSVProp -> [(Text, Text)]+csvPropsList (CSVProp h) = sort $ H.toList h++defaultCSVProp :: CSVProp+defaultCSVProp = mempty++-- | Specify the CSV record delimiter property.+recordDelimiter :: Text -> CSVProp+recordDelimiter = CSVProp . H.singleton "RecordDelimiter"++-- | Specify the CSV field delimiter property.+fieldDelimiter :: Text -> CSVProp+fieldDelimiter = CSVProp . H.singleton "FieldDelimiter"++-- | Specify the CSV quote character property.+quoteCharacter :: Text -> CSVProp+quoteCharacter = CSVProp . H.singleton "QuoteCharacter"++-- | Specify the CSV quote-escape character property.+quoteEscapeCharacter :: Text -> CSVProp+quoteEscapeCharacter = CSVProp . H.singleton "QuoteEscapeCharacter"++-- | FileHeaderInfo specifies information about column headers for CSV+-- format.+data FileHeaderInfo+  = -- | No column headers are present+    FileHeaderNone+  | -- | Headers are present and they should be used+    FileHeaderUse+  | -- | Header are present, but should be ignored+    FileHeaderIgnore+  deriving stock (Show, Eq)++-- | Specify the CSV file header info property.+fileHeaderInfo :: FileHeaderInfo -> CSVProp+fileHeaderInfo = CSVProp . H.singleton "FileHeaderInfo" . toStr+  where+    toStr FileHeaderNone = "NONE"+    toStr FileHeaderUse = "USE"+    toStr FileHeaderIgnore = "IGNORE"++-- | Specify the CSV comment character property. Lines starting with+-- this character are ignored by the server.+commentCharacter :: Text -> CSVProp+commentCharacter = CSVProp . H.singleton "Comments"++-- | Allow quoted record delimiters inside a row using this property.+allowQuotedRecordDelimiter :: CSVProp+allowQuotedRecordDelimiter = CSVProp $ H.singleton "AllowQuotedRecordDelimiter" "TRUE"++-- | Set the CSV format properties in the InputSerialization.+setInputCSVProps :: CSVProp -> InputSerialization -> InputSerialization+setInputCSVProps p is = is {isFormatInfo = InputFormatCSV p}++-- | Set the CSV format properties in the OutputSerialization.+outputCSVFromProps :: CSVProp -> OutputSerialization+outputCSVFromProps = OutputSerializationCSV++newtype JSONInputProp = JSONInputProp {jsonipType :: JSONType}+  deriving stock (Show, Eq)++data JSONType = JSONTypeDocument | JSONTypeLines+  deriving stock (Show, Eq)++-- | OutputSerialization represents output serialization settings for+-- the SelectRequest. Use `defaultCsvOutput` or `defaultJsonOutput` as+-- a starting point.+data OutputSerialization+  = OutputSerializationJSON JSONOutputProp+  | OutputSerializationCSV CSVOutputProp+  deriving stock (Show, Eq)++type CSVOutputProp = CSVProp++-- | quoteFields is an output serialization parameter+quoteFields :: QuoteFields -> CSVProp+quoteFields q = CSVProp $+  H.singleton "QuoteFields" $+    case q of+      QuoteFieldsAsNeeded -> "ASNEEDED"+      QuoteFieldsAlways -> "ALWAYS"++-- | Represent the QuoteField setting.+data QuoteFields = QuoteFieldsAsNeeded | QuoteFieldsAlways+  deriving stock (Show, Eq)++newtype JSONOutputProp = JSONOutputProp {jsonopRecordDelimiter :: Maybe Text}+  deriving stock (Show, Eq)++-- | Set the output record delimiter for JSON format+outputJSONFromRecordDelimiter :: Text -> OutputSerialization+outputJSONFromRecordDelimiter t =+  OutputSerializationJSON (JSONOutputProp $ Just t)++-- Response related types++-- | An EventMessage represents each kind of message received from the server.+data EventMessage+  = ProgressEventMessage Progress+  | StatsEventMessage Stats+  | RequestLevelErrorMessage+      Text+      -- ^ Error code+      Text+      -- ^ Error message+  | RecordPayloadEventMessage ByteString+  deriving stock (Show, Eq)++data MsgHeaderName+  = MessageType+  | EventType+  | ContentType+  | ErrorCode+  | ErrorMessage+  deriving stock (Show, Eq)++msgHeaderValueType :: Word8+msgHeaderValueType = 7++type MessageHeader = (MsgHeaderName, Text)++-- | Represent the progress event returned in the Select response.+data Progress = Progress+  { pBytesScanned :: Int64,+    pBytesProcessed :: Int64,+    pBytesReturned :: Int64+  }+  deriving stock (Show, Eq)++-- | Represent the stats event returned at the end of the Select+-- response.+type Stats = Progress++--------------------------------------------------------------------------+-- Select API Related Types End+--------------------------------------------------------------------------++-- | Represents different kinds of payload that are used with S3 API+-- requests.+data Payload+  = PayloadBS ByteString+  | PayloadH Handle Int64 Int64 -- file handle, offset and length+  | PayloadC Int64 (C.ConduitT () ByteString (ResourceT IO) ()) -- length and byte source++defaultPayload :: Payload+defaultPayload = PayloadBS ""++data AdminReqInfo = AdminReqInfo+  { ariMethod :: Method,+    ariPayloadHash :: Maybe ByteString,+    ariPayload :: Payload,+    ariPath :: ByteString,+    ariHeaders :: [Header],+    ariQueryParams :: Query+  }++data S3ReqInfo = S3ReqInfo+  { riMethod :: Method,+    riBucket :: Maybe Bucket,+    riObject :: Maybe Object,+    riQueryParams :: Query,+    riHeaders :: [Header],+    riPayload :: Payload,+    riPayloadHash :: Maybe ByteString,+    riRegion :: Maybe Region,+    riNeedsLocation :: Bool,+    riPresignExpirySecs :: Maybe UrlExpiry+  }++defaultS3ReqInfo :: S3ReqInfo+defaultS3ReqInfo =+  S3ReqInfo+    HT.methodGet+    Nothing+    Nothing+    []+    []+    defaultPayload+    Nothing+    Nothing+    True+    Nothing++getS3Path :: Maybe Bucket -> Maybe Object -> ByteString+getS3Path b o =+  let segments = map encodeUtf8 $ catMaybes $ b : bool [] [o] (isJust b)+   in B.concat ["/", B.intercalate "/" segments]++type RegionMap = H.HashMap Bucket Region++-- | The Minio Monad - all computations accessing object storage+-- happens in it.+newtype Minio a = Minio+  { unMinio :: ReaderT MinioConn (ResourceT IO) a+  }+  deriving newtype+    ( Functor,+      Applicative,+      Monad,+      MonadIO,+      MonadReader MinioConn,+      MonadResource,+      MonadUnliftIO+    )++-- | MinioConn holds connection info and a connection pool to allow+-- for efficient resource re-use.+data MinioConn = MinioConn+  { mcConnInfo :: ConnectInfo,+    mcConnManager :: NC.Manager,+    mcRegionMap :: MVar RegionMap+  }++class HasSvcNamespace env where+  getSvcNamespace :: env -> Text++instance HasSvcNamespace MinioConn where+  getSvcNamespace env =+    let host = connectHost $ mcConnInfo env+     in ( if host == "storage.googleapis.com"+            then "http://doc.s3.amazonaws.com/2006-03-01"+            else "http://s3.amazonaws.com/doc/2006-03-01/"+        )++-- | Takes connection information and returns a connection object to+-- be passed to 'runMinio'. The returned value can be kept in the+-- application environment and passed to `runMinioWith` whenever+-- object storage is accessed.+connect :: ConnectInfo -> IO MinioConn+connect ci = do+  let settings+        | connectIsSecure ci && connectDisableTLSCertValidation ci =+            let badTlsSettings = Conn.TLSSettingsSimple+                  { Conn.settingDisableCertificateValidation = True+                  , Conn.settingDisableSession = False+                  , Conn.settingUseServerName = False+                  , Conn.settingClientSupported = def+                  }+             in TLS.mkManagerSettings badTlsSettings Nothing+        | connectIsSecure ci = NC.tlsManagerSettings+        | otherwise = defaultManagerSettings+  mgr <- NC.newManager settings+  mkMinioConn ci mgr++-- | Run the computation accessing object storage using the given+-- `MinioConn`. This reuses connections, but otherwise it is similar+-- to `runMinio`.+runMinioWith :: MinioConn -> Minio a -> IO (Either MinioErr a)+runMinioWith conn m = runResourceT $ runMinioResWith conn m++-- | Given `ConnectInfo` and a HTTP connection manager, create a+-- `MinioConn`.+mkMinioConn :: ConnectInfo -> NC.Manager -> IO MinioConn+mkMinioConn ci mgr = do+  rMapMVar <- M.newMVar H.empty+  return $ MinioConn ci mgr rMapMVar++-- | Run the Minio action and return the result or an error.+runMinio :: ConnectInfo -> Minio a -> IO (Either MinioErr a)+runMinio ci m = do+  conn <- connect ci+  runResourceT $ runMinioResWith conn m++-- | Similar to 'runMinioWith'. Allows applications to allocate/release+-- its resources along side MinIO's internal resources.+runMinioResWith :: MinioConn -> Minio a -> ResourceT IO (Either MinioErr a)+runMinioResWith conn m =+  flip runReaderT conn . unMinio $+    fmap Right m+      `U.catches` [ U.Handler handlerServiceErr,+                    U.Handler handlerHE,+                    U.Handler handlerFE,+                    U.Handler handlerValidation+                  ]+  where+    handlerServiceErr = return . Left . MErrService+    handlerHE = return . Left . MErrHTTP+    handlerFE = return . Left . MErrIO+    handlerValidation = return . Left . MErrValidation++-- | Similar to 'runMinio'. Allows applications to allocate/release+-- its resources along side MinIO's internal resources.+runMinioRes :: ConnectInfo -> Minio a -> ResourceT IO (Either MinioErr a)+runMinioRes ci m = do+  conn <- liftIO $ connect ci+  runMinioResWith conn m++-- | Format as per RFC 1123.+formatRFC1123 :: UTCTime -> T.Text+formatRFC1123 = T.pack . formatTime defaultTimeLocale "%a, %d %b %Y %X %Z"++lookupRegionCache :: Bucket -> Minio (Maybe Region)+lookupRegionCache b = do+  rMVar <- asks mcRegionMap+  rMap <- UM.readMVar rMVar+  return $ H.lookup b rMap++addToRegionCache :: Bucket -> Region -> Minio ()+addToRegionCache b region = do+  rMVar <- asks mcRegionMap+  UM.modifyMVar_ rMVar $ return . H.insert b region++deleteFromRegionCache :: Bucket -> Minio ()+deleteFromRegionCache b = do+  rMVar <- asks mcRegionMap+  UM.modifyMVar_ rMVar $ return . H.delete b
+ vendor/minio-hs-1.7.0/src/Network/Minio/Data/ByteString.hs view
@@ -0,0 +1,75 @@+--+-- MinIO Haskell SDK, (C) 2017 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+{-# LANGUAGE FlexibleInstances #-}++module Network.Minio.Data.ByteString+  ( stripBS,+    UriEncodable (..),+  )+where++import qualified Data.ByteString as B+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Char8 as BC8+import qualified Data.ByteString.Lazy as LB+import Data.Char (isAsciiLower, isAsciiUpper, isDigit, isSpace, toUpper)+import qualified Data.Text as T+import Numeric (showHex)++stripBS :: ByteString -> ByteString+stripBS = BC8.dropWhile isSpace . fst . BC8.spanEnd isSpace++class UriEncodable s where+  uriEncode :: Bool -> s -> ByteString++instance UriEncodable [Char] where+  uriEncode encodeSlash payload =+    LB.toStrict $+      BB.toLazyByteString $+        mconcat $+          map (`uriEncodeChar` encodeSlash) payload++instance UriEncodable ByteString where+  -- assumes that uriEncode is passed ASCII encoded strings.+  uriEncode encodeSlash bs =+    uriEncode encodeSlash $ BC8.unpack bs++instance UriEncodable Text where+  uriEncode encodeSlash txt =+    uriEncode encodeSlash $ T.unpack txt++-- | URI encode a char according to AWS S3 signing rules - see+-- UriEncode() at+-- https://docs.aws.amazon.com/AmazonS3/latest/API/sig-v4-header-based-auth.html+uriEncodeChar :: Char -> Bool -> BB.Builder+uriEncodeChar '/' True = BB.byteString "%2F"+uriEncodeChar '/' False = BB.char7 '/'+uriEncodeChar ch _+  | isAsciiUpper ch+      || isAsciiLower ch+      || isDigit ch+      || (ch == '_')+      || (ch == '-')+      || (ch == '.')+      || (ch == '~') =+      BB.char7 ch+  | otherwise = mconcat $ map f $ B.unpack $ encodeUtf8 $ T.singleton ch+  where+    f :: Word8 -> BB.Builder+    f n = BB.char7 '%' <> BB.string7 hexStr+      where+        hexStr = map toUpper $ showHex q $ showHex r ""+        (q, r) = divMod n (16 :: Word8)
+ vendor/minio-hs-1.7.0/src/Network/Minio/Data/Crypto.hs view
@@ -0,0 +1,99 @@+--+-- MinIO Haskell SDK, (C) 2017 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.Data.Crypto+  ( hashSHA256,+    hashSHA256FromSource,+    hashMD5,+    hashMD5ToBase64,+    hashMD5FromSource,+    hmacSHA256,+    hmacSHA256RawBS,+    digestToBS,+    digestToBase16,+    encodeToBase64,+  )+where++import Crypto.Hash+  ( Digest,+    MD5 (..),+    SHA256 (..),+    hashWith,+    HashAlgorithm,+    hashInit,+    hashUpdate,+    hashFinalize,+  )+import Crypto.MAC.HMAC (HMAC, hmac)+import Data.ByteArray (ByteArrayAccess, convert)+import Data.ByteArray.Encoding (Base (Base16, Base64), convertToBase)+import qualified Data.Conduit as C++-- | Replacement for Crypto.Hash.Conduit.sinkHash+-- This avoids dependency on cryptonite-conduit+sinkHash :: (Monad m, HashAlgorithm hash) => C.ConduitT ByteString o m (Digest hash)+sinkHash = go hashInit+  where+    go ctx = do+      mbs <- C.await+      case mbs of+        Nothing -> return $! hashFinalize ctx+        Just bs -> go $! hashUpdate ctx bs++hashSHA256 :: ByteString -> ByteString+hashSHA256 = digestToBase16 . hashWith SHA256++hashSHA256FromSource :: (Monad m) => C.ConduitM () ByteString m () -> m ByteString+hashSHA256FromSource src = do+  digest <- C.connect src sinkSHA256Hash+  return $ digestToBase16 digest+  where+    -- To help with type inference+    sinkSHA256Hash :: (Monad m) => C.ConduitM ByteString Void m (Digest SHA256)+    sinkSHA256Hash = sinkHash++-- Returns MD5 hash hex encoded.+hashMD5 :: ByteString -> ByteString+hashMD5 = digestToBase16 . hashWith MD5++hashMD5FromSource :: (Monad m) => C.ConduitM () ByteString m () -> m ByteString+hashMD5FromSource src = do+  digest <- C.connect src sinkMD5Hash+  return $ digestToBase16 digest+  where+    -- To help with type inference+    sinkMD5Hash :: (Monad m) => C.ConduitM ByteString Void m (Digest MD5)+    sinkMD5Hash = sinkHash++hmacSHA256 :: ByteString -> ByteString -> HMAC SHA256+hmacSHA256 message key = hmac key message++hmacSHA256RawBS :: ByteString -> ByteString -> ByteString+hmacSHA256RawBS message key = convert $ hmacSHA256 message key++digestToBS :: (ByteArrayAccess a) => a -> ByteString+digestToBS = convert++digestToBase16 :: (ByteArrayAccess a) => a -> ByteString+digestToBase16 = convertToBase Base16++-- Returns MD5 hash base 64 encoded.+hashMD5ToBase64 :: (ByteArrayAccess a) => a -> ByteString+hashMD5ToBase64 = convertToBase Base64 . hashWith MD5++encodeToBase64 :: (ByteArrayAccess a) => a -> ByteString+encodeToBase64 = convertToBase Base64
+ vendor/minio-hs-1.7.0/src/Network/Minio/Data/Time.hs view
@@ -0,0 +1,53 @@+--+-- MinIO Haskell SDK, (C) 2017 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.Data.Time+  ( awsTimeFormat,+    awsTimeFormatBS,+    awsDateFormat,+    awsDateFormatBS,+    awsParseTime,+    iso8601TimeFormat,+    UrlExpiry,+  )+where++import Data.ByteString.Char8 (pack)+import qualified Data.Time as Time+import Data.Time.Format.ISO8601 (iso8601Show)+import Lib.Prelude++-- | Time to expire for a presigned URL. It interpreted as a number of+-- seconds. The maximum duration that can be specified is 7 days.+type UrlExpiry = Int++awsTimeFormat :: UTCTime -> [Char]+awsTimeFormat = Time.formatTime Time.defaultTimeLocale "%Y%m%dT%H%M%SZ"++awsTimeFormatBS :: UTCTime -> ByteString+awsTimeFormatBS = pack . awsTimeFormat++awsDateFormat :: UTCTime -> [Char]+awsDateFormat = Time.formatTime Time.defaultTimeLocale "%Y%m%d"++awsDateFormatBS :: UTCTime -> ByteString+awsDateFormatBS = pack . awsDateFormat++awsParseTime :: [Char] -> Maybe UTCTime+awsParseTime = Time.parseTimeM False Time.defaultTimeLocale "%Y%m%dT%H%M%SZ"++iso8601TimeFormat :: UTCTime -> [Char]+iso8601TimeFormat = iso8601Show
+ vendor/minio-hs-1.7.0/src/Network/Minio/Errors.hs view
@@ -0,0 +1,96 @@+--+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.Errors+  ( MErrV (..),+    ServiceErr (..),+    MinioErr (..),+    toServiceErr,+  )+where++import Control.Exception (IOException)+import qualified Network.HTTP.Conduit as NC++---------------------------------+-- Errors+---------------------------------++-- | Various validation errors+data MErrV+  = MErrVSinglePUTSizeExceeded Int64+  | MErrVPutSizeExceeded Int64+  | MErrVETagHeaderNotFound+  | MErrVInvalidObjectInfoResponse+  | MErrVInvalidSrcObjSpec Text+  | MErrVInvalidSrcObjByteRange (Int64, Int64)+  | MErrVCopyObjSingleNoRangeAccepted+  | MErrVRegionNotSupported Text+  | MErrVXmlParse Text+  | MErrVInvalidBucketName Text+  | MErrVInvalidObjectName Text+  | MErrVInvalidUrlExpiry Int+  | MErrVJsonParse Text+  | MErrVInvalidHealPath+  | MErrVMissingCredentials+  | MErrVInvalidEncryptionKeyLength+  | MErrVStreamingBodyUnexpectedEOF+  | MErrVUnexpectedPayload+  | MErrVSTSEndpointNotFound+  deriving stock (Show, Eq)++instance Exception MErrV++-- | Errors returned by S3 compatible service+data ServiceErr+  = BucketAlreadyExists+  | BucketAlreadyOwnedByYou+  | NoSuchBucket+  | InvalidBucketName+  | NoSuchKey+  | SelectErr Text Text+  | ServiceErr Text Text+  deriving stock (Show, Eq)++instance Exception ServiceErr++toServiceErr :: Text -> Text -> ServiceErr+toServiceErr "NoSuchKey" _ = NoSuchKey+toServiceErr "NoSuchBucket" _ = NoSuchBucket+toServiceErr "InvalidBucketName" _ = InvalidBucketName+toServiceErr "BucketAlreadyOwnedByYou" _ = BucketAlreadyOwnedByYou+toServiceErr "BucketAlreadyExists" _ = BucketAlreadyExists+toServiceErr code message = ServiceErr code message++-- | Errors thrown by the library+data MinioErr+  = MErrHTTP NC.HttpException+  | MErrIO IOException+  | MErrService ServiceErr+  | MErrValidation MErrV+  deriving stock (Show)++instance Eq MinioErr where+  MErrHTTP _ == MErrHTTP _ = True+  MErrHTTP _ == _ = False+  MErrIO _ == MErrIO _ = True+  MErrIO _ == _ = False+  MErrService a == MErrService b = a == b+  MErrService _ == _ = False+  MErrValidation a == MErrValidation b = a == b+  MErrValidation _ == _ = False++instance Exception MinioErr
+ vendor/minio-hs-1.7.0/src/Network/Minio/JsonParser.hs view
@@ -0,0 +1,49 @@+--+-- MinIO Haskell SDK, (C) 2018 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.JsonParser+  ( parseErrResponseJSON,+  )+where++import Data.Aeson+  ( FromJSON,+    eitherDecode,+    parseJSON,+    withObject,+    (.:),+  )+import qualified Data.Text as T+import Lib.Prelude+import Network.Minio.Errors++data AdminErrJSON = AdminErrJSON+  { aeCode :: Text,+    aeMessage :: Text+  }+  deriving stock (Eq, Show)++instance FromJSON AdminErrJSON where+  parseJSON = withObject "AdminErrJSON" $ \v ->+    AdminErrJSON+      <$> v .: "Code"+      <*> v .: "Message"++parseErrResponseJSON :: (MonadIO m) => LByteString -> m ServiceErr+parseErrResponseJSON jsondata =+  case eitherDecode jsondata of+    Right aErr -> return $ toServiceErr (aeCode aErr) (aeMessage aErr)+    Left err -> throwIO $ MErrVJsonParse $ T.pack err
+ vendor/minio-hs-1.7.0/src/Network/Minio/ListOps.hs view
@@ -0,0 +1,180 @@+--+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.ListOps where++import qualified Data.Conduit as C+import qualified Data.Conduit.Combinators as CC+import qualified Data.Conduit.List as CL+import Network.Minio.Data+  ( Bucket,+    ListObjectsResult+      ( lorCPrefixes,+        lorHasMore,+        lorNextToken,+        lorObjects+      ),+    ListObjectsV1Result+      ( lorCPrefixes',+        lorHasMore',+        lorNextMarker,+        lorObjects'+      ),+    ListPartsResult (lprHasMore, lprNextPart, lprParts),+    ListUploadsResult+      ( lurHasMore,+        lurNextKey,+        lurNextUpload,+        lurUploads+      ),+    Minio,+    Object,+    ObjectInfo,+    ObjectPartInfo (opiSize),+    UploadId,+    UploadInfo (UploadInfo),+  )+import Network.Minio.S3API+  ( listIncompleteParts',+    listIncompleteUploads',+    listObjects',+    listObjectsV1',+  )++-- | Represents a list output item - either an object or an object+-- prefix (i.e. a directory).+data ListItem+  = ListItemObject ObjectInfo+  | ListItemPrefix Text+  deriving stock (Show, Eq)++-- | @'listObjects' bucket prefix recurse@ lists objects in a bucket+-- similar to a file system tree traversal.+--+-- If @prefix@ is not 'Nothing', only items with the given prefix are+-- listed, otherwise items under the bucket are returned.+--+-- If @recurse@ is set to @True@ all directories under the prefix are+-- recursively traversed and only objects are returned.+--+-- If @recurse@ is set to @False@, objects and directories immediately+-- under the given prefix are returned (no recursive traversal is+-- performed).+listObjects :: Bucket -> Maybe Text -> Bool -> C.ConduitM () ListItem Minio ()+listObjects bucket prefix recurse = loop Nothing+  where+    loop :: Maybe Text -> C.ConduitM () ListItem Minio ()+    loop nextToken = do+      let delimiter = bool (Just "/") Nothing recurse++      res <- lift $ listObjects' bucket prefix nextToken delimiter Nothing+      CL.sourceList $ map ListItemObject $ lorObjects res+      unless recurse $+        CL.sourceList $+          map ListItemPrefix $+            lorCPrefixes res+      when (lorHasMore res) $+        loop (lorNextToken res)++-- | Lists objects - similar to @listObjects@, however uses the older+-- V1 AWS S3 API. Prefer @listObjects@ to this.+listObjectsV1 ::+  Bucket ->+  Maybe Text ->+  Bool ->+  C.ConduitM () ListItem Minio ()+listObjectsV1 bucket prefix recurse = loop Nothing+  where+    loop :: Maybe Text -> C.ConduitM () ListItem Minio ()+    loop nextMarker = do+      let delimiter = bool (Just "/") Nothing recurse++      res <- lift $ listObjectsV1' bucket prefix nextMarker delimiter Nothing+      CL.sourceList $ map ListItemObject $ lorObjects' res+      unless recurse $+        CL.sourceList $+          map ListItemPrefix $+            lorCPrefixes' res+      when (lorHasMore' res) $+        loop (lorNextMarker res)++-- | List incomplete uploads in a bucket matching the given prefix. If+-- recurse is set to True incomplete uploads for the given prefix are+-- recursively listed.+listIncompleteUploads ::+  Bucket ->+  Maybe Text ->+  Bool ->+  C.ConduitM () UploadInfo Minio ()+listIncompleteUploads bucket prefix recurse = loop Nothing Nothing+  where+    loop :: Maybe Text -> Maybe Text -> C.ConduitM () UploadInfo Minio ()+    loop nextKeyMarker nextUploadIdMarker = do+      let delimiter = bool (Just "/") Nothing recurse++      res <-+        lift $+          listIncompleteUploads'+            bucket+            prefix+            delimiter+            nextKeyMarker+            nextUploadIdMarker+            Nothing++      aggrSizes <- lift $+        forM (lurUploads res) $ \(uKey, uId, _) -> do+          partInfos <-+            C.runConduit $+              listIncompleteParts bucket uKey uId+                C..| CC.sinkList+          return $ foldl' (\sizeSofar p -> opiSize p + sizeSofar) 0 partInfos++      CL.sourceList $+        zipWith+          ( curry+              ( \((uKey, uId, uInitTime), size) ->+                  UploadInfo uKey uId uInitTime size+              )+          )+          (lurUploads res)+          aggrSizes++      when (lurHasMore res) $+        loop (lurNextKey res) (lurNextUpload res)++-- | List object parts of an ongoing multipart upload for given+-- bucket, object and uploadId.+listIncompleteParts ::+  Bucket ->+  Object ->+  UploadId ->+  C.ConduitM () ObjectPartInfo Minio ()+listIncompleteParts bucket object uploadId = loop Nothing+  where+    loop :: Maybe Text -> C.ConduitM () ObjectPartInfo Minio ()+    loop nextPartMarker = do+      res <-+        lift $+          listIncompleteParts'+            bucket+            object+            uploadId+            Nothing+            nextPartMarker+      CL.sourceList $ lprParts res+      when (lprHasMore res) $+        loop (show <$> lprNextPart res)
+ vendor/minio-hs-1.7.0/src/Network/Minio/PresignedOperations.hs view
@@ -0,0 +1,355 @@+--+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+{-# LANGUAGE CPP #-}++module Network.Minio.PresignedOperations+  ( UrlExpiry,+    makePresignedUrl,+    presignedPutObjectUrl,+    presignedGetObjectUrl,+    presignedHeadObjectUrl,+    PostPolicyCondition (..),+    ppCondBucket,+    ppCondContentLengthRange,+    ppCondContentType,+    ppCondKey,+    ppCondKeyStartsWith,+    ppCondSuccessActionStatus,+    PostPolicy (..),+    PostPolicyError (..),+    newPostPolicy,+    showPostPolicy,+    presignedPostPolicy,+  )+where++import Data.Aeson ((.=))+import qualified Data.Aeson as Json+import Data.ByteString.Builder (byteString, toLazyByteString)+import qualified Data.HashMap.Strict as H+import qualified Data.Text as T+import qualified Data.Time as Time+import Lib.Prelude+import qualified Network.HTTP.Client as NClient+import qualified Network.HTTP.Types as HT+import Network.Minio.API (buildRequest)+import Network.Minio.Credentials+import Network.Minio.Data+import Network.Minio.Data.Time+import Network.Minio.Errors+import Network.Minio.Sign.V4+import Network.URI (uriToString)++{- ORMOLU_DISABLE -}+#if MIN_VERSION_aeson(2,0,0)+import qualified Data.Aeson.Key as A+#endif+{- ORMOLU_ENABLE -}++-- | Generate a presigned URL. This function allows for advanced usage+-- - for simple cases prefer the `presigned*Url` functions.+--+-- If region is Nothing, it is picked up from the connection+-- information (no check of bucket existence is performed).+--+-- All extra query parameters or headers are signed, and therefore are+-- required to be sent when the generated URL is actually used.+makePresignedUrl ::+  UrlExpiry ->+  HT.Method ->+  Maybe Bucket ->+  Maybe Object ->+  Maybe Region ->+  HT.Query ->+  HT.RequestHeaders ->+  Minio ByteString+makePresignedUrl expiry method bucket object region extraQuery extraHeaders = do+  when (expiry > 7 * 24 * 3600 || expiry < 0) $+    throwIO $+      MErrVInvalidUrlExpiry expiry++  let s3ri =+        defaultS3ReqInfo+          { riPresignExpirySecs = Just expiry,+            riMethod = method,+            riBucket = bucket,+            riObject = object,+            riRegion = region,+            riQueryParams = extraQuery,+            riHeaders = extraHeaders+          }++  req <- buildRequest s3ri+  let uri = NClient.getUri req+      uriString = uriToString identity uri ""++  return $ encodeUtf8 uriString++-- | Generate a URL with authentication signature to PUT (upload) an+-- object. Any extra headers if passed, are signed, and so they are+-- required when the URL is used to upload data. This could be used,+-- for example, to set user-metadata on the object.+--+-- For a list of possible headers to pass, please refer to the PUT+-- object REST API AWS S3 documentation.+presignedPutObjectUrl ::+  Bucket ->+  Object ->+  UrlExpiry ->+  HT.RequestHeaders ->+  Minio ByteString+presignedPutObjectUrl bucket object expirySeconds extraHeaders = do+  region <- asks (Just . connectRegion . mcConnInfo)+  makePresignedUrl+    expirySeconds+    HT.methodPut+    (Just bucket)+    (Just object)+    region+    []+    extraHeaders++-- | Generate a URL with authentication signature to GET (download) an+-- object. All extra query parameters and headers passed here will be+-- signed and are required when the generated URL is used. Query+-- parameters could be used to change the response headers sent by the+-- server. Headers can be used to set Etag match conditions among+-- others.+--+-- For a list of possible request parameters and headers, please refer+-- to the GET object REST API AWS S3 documentation.+presignedGetObjectUrl ::+  Bucket ->+  Object ->+  UrlExpiry ->+  HT.Query ->+  HT.RequestHeaders ->+  Minio ByteString+presignedGetObjectUrl bucket object expirySeconds extraQuery extraHeaders = do+  region <- asks (Just . connectRegion . mcConnInfo)+  makePresignedUrl+    expirySeconds+    HT.methodGet+    (Just bucket)+    (Just object)+    region+    extraQuery+    extraHeaders++-- | Generate a URL with authentication signature to make a HEAD+-- request on an object. This is used to fetch metadata about an+-- object. All extra headers passed here will be signed and are+-- required when the generated URL is used.+--+-- For a list of possible headers to pass, please refer to the HEAD+-- object REST API AWS S3 documentation.+presignedHeadObjectUrl ::+  Bucket ->+  Object ->+  UrlExpiry ->+  HT.RequestHeaders ->+  Minio ByteString+presignedHeadObjectUrl bucket object expirySeconds extraHeaders = do+  region <- asks (Just . connectRegion . mcConnInfo)+  makePresignedUrl+    expirySeconds+    HT.methodHead+    (Just bucket)+    (Just object)+    region+    []+    extraHeaders++-- | Represents individual conditions in a Post Policy document.+data PostPolicyCondition+  = PPCStartsWith Text Text+  | PPCEquals Text Text+  | PPCRange Text Int64 Int64+  deriving stock (Show, Eq)++{- ORMOLU_DISABLE -}+instance Json.ToJSON PostPolicyCondition where+  toJSON (PPCStartsWith k v) = Json.toJSON ["starts-with", k, v]+#if MIN_VERSION_aeson(2,0,0)+  toJSON (PPCEquals k v) = Json.object [(A.fromText k) .= v]+#else+  toJSON (PPCEquals k v) = Json.object [k .= v]+#endif+  toJSON (PPCRange k minVal maxVal) =+    Json.toJSON [Json.toJSON k, Json.toJSON minVal, Json.toJSON maxVal]++  toEncoding (PPCStartsWith k v) = Json.foldable ["starts-with", k, v]+#if MIN_VERSION_aeson(2,0,0)+  toEncoding (PPCEquals k v) = Json.pairs ((A.fromText k) .= v)+#else+  toEncoding (PPCEquals k v) = Json.pairs (k .= v)+#endif+  toEncoding (PPCRange k minVal maxVal) =+    Json.foldable [Json.toJSON k, Json.toJSON minVal, Json.toJSON maxVal]+{- ORMOLU_ENABLE -}++-- | A PostPolicy is required to perform uploads via browser forms.+data PostPolicy = PostPolicy+  { expiration :: UTCTime,+    conditions :: [PostPolicyCondition]+  }+  deriving stock (Show, Eq)++instance Json.ToJSON PostPolicy where+  toJSON (PostPolicy e c) =+    Json.object+      [ "expiration" .= iso8601TimeFormat e,+        "conditions" .= c+      ]+  toEncoding (PostPolicy e c) =+    Json.pairs ("expiration" .= iso8601TimeFormat e <> "conditions" .= c)++-- | Possible validation errors when creating a PostPolicy.+data PostPolicyError+  = PPEKeyNotSpecified+  | PPEBucketNotSpecified+  | PPEConditionKeyEmpty+  | PPERangeInvalid+  deriving stock (Show, Eq)++-- | Set the bucket name that the upload should use.+ppCondBucket :: Bucket -> PostPolicyCondition+ppCondBucket = PPCEquals "bucket"++-- | Set the content length range constraint with minimum and maximum+-- byte count values.+ppCondContentLengthRange ::+  Int64 ->+  Int64 ->+  PostPolicyCondition+ppCondContentLengthRange = PPCRange "content-length-range"++-- | Set the content-type header for the upload.+ppCondContentType :: Text -> PostPolicyCondition+ppCondContentType = PPCEquals "Content-Type"++-- | Set the object name constraint for the upload.+ppCondKey :: Object -> PostPolicyCondition+ppCondKey = PPCEquals "key"++-- | Set the object name prefix constraint for the upload.+ppCondKeyStartsWith :: Object -> PostPolicyCondition+ppCondKeyStartsWith = PPCStartsWith "key"++-- | Status code that the S3-server should send on a successful POST+-- upload+ppCondSuccessActionStatus :: Int -> PostPolicyCondition+ppCondSuccessActionStatus n =+  PPCEquals "success_action_status" (show n)++-- | This function creates a PostPolicy after validating its+-- arguments.+newPostPolicy ::+  UTCTime ->+  [PostPolicyCondition] ->+  Either PostPolicyError PostPolicy+newPostPolicy expirationTime conds+  -- object name condition must be present+  | not $ any (keyEquals "key") conds =+      Left PPEKeyNotSpecified+  -- bucket name condition must be present+  | not $ any (keyEquals "bucket") conds =+      Left PPEBucketNotSpecified+  -- a condition with an empty key is invalid+  | any (keyEquals "") conds || any isEmptyRangeKey conds =+      Left PPEConditionKeyEmpty+  -- invalid range check+  | any isInvalidRange conds =+      Left PPERangeInvalid+  -- all good!+  | otherwise =+      return $ PostPolicy expirationTime conds+  where+    keyEquals k' (PPCStartsWith k _) = k == k'+    keyEquals k' (PPCEquals k _) = k == k'+    keyEquals _ _ = False+    isEmptyRangeKey (PPCRange k _ _) = k == ""+    isEmptyRangeKey _ = False+    isInvalidRange (PPCRange _ mi ma) = mi < 0 || mi > ma+    isInvalidRange _ = False++-- | Convert Post Policy to a string (e.g. for printing).+showPostPolicy :: PostPolicy -> ByteString+showPostPolicy = toStrictBS . Json.encode++-- | Generate a presigned URL and POST policy to upload files via a+-- browser. On success, this function returns a URL and POST+-- form-data.+presignedPostPolicy ::+  PostPolicy ->+  Minio (ByteString, H.HashMap Text ByteString)+presignedPostPolicy p = do+  ci <- asks mcConnInfo+  signTime <- liftIO Time.getCurrentTime+  mgr <- asks mcConnManager+  cv <- liftIO $ getCredential (connectCreds ci) (getEndpoint ci) mgr++  let extraConditions signParams =+        [ PPCEquals "x-amz-date" (toText $ awsTimeFormat signTime),+          PPCEquals "x-amz-algorithm" "AWS4-HMAC-SHA256",+          PPCEquals+            "x-amz-credential"+            ( T.intercalate+                "/"+                [ coerce $ cvAccessKey cv,+                  decodeUtf8 $ credentialScope signParams+                ]+            )+        ]+      ppWithCreds signParams =+        p+          { conditions = conditions p ++ extraConditions signParams+          }+      sp =+        SignParams+          (coerce $ cvAccessKey cv)+          (coerce $ cvSecretKey cv)+          (coerce $ cvSessionToken cv)+          ServiceS3+          signTime+          (Just $ connectRegion ci)+          Nothing+          Nothing+      signData = signV4PostPolicy (showPostPolicy $ ppWithCreds sp) sp+      -- compute form-data+      mkPair (PPCStartsWith k v) = Just (k, v)+      mkPair (PPCEquals k v) = Just (k, v)+      mkPair _ = Nothing+      formFromPolicy =+        H.map encodeUtf8 $+          H.fromList $+            mapMaybe+              mkPair+              (conditions $ ppWithCreds sp)+      formData = formFromPolicy `H.union` signData+      -- compute POST upload URL+      bucket = H.lookupDefault "" "bucket" formData+      scheme = byteString $ bool "http://" "https://" $ connectIsSecure ci+      url =+        toStrictBS $+          toLazyByteString $+            scheme+              <> byteString (getHostAddr ci)+              <> byteString "/"+              <> byteString bucket+              <> byteString "/"++  return (url, formData)
+ vendor/minio-hs-1.7.0/src/Network/Minio/PutObject.hs view
@@ -0,0 +1,173 @@+--+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.PutObject+  ( putObjectInternal,+    ObjectData (..),+    selectPartSizes,+  )+where++import Conduit (takeC)+import qualified Conduit as C+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Conduit.Binary as CB+import qualified Data.Conduit.Combinators as CC+import qualified Data.Conduit.List as CL+import qualified Data.List as List+import Lib.Prelude+import Network.Minio.Data+import Network.Minio.Errors+import Network.Minio.S3API+import Network.Minio.Utils++-- | A data-type to represent the source data for an object. A+-- file-path or a producer-conduit may be provided.+--+-- For files, a size may be provided - this is useful in cases when+-- the file size cannot be automatically determined or if only some+-- prefix of the file is desired.+--+-- For streams also, a size may be provided. This is useful to limit+-- the input - if it is not provided, upload will continue until the+-- stream ends or the object reaches `maxObjectSize` size.+data ObjectData m+  = -- | Takes filepath and optional+    -- size.+    ODFile FilePath (Maybe Int64)+  | -- | Pass+    -- size+    -- (bytes)+    -- if+    -- known.+    ODStream (C.ConduitM () ByteString m ()) (Maybe Int64)++-- | Put an object from ObjectData. This high-level API handles+-- objects of all sizes, and even if the object size is unknown.+putObjectInternal ::+  Bucket ->+  Object ->+  PutObjectOptions ->+  ObjectData Minio ->+  Minio ETag+putObjectInternal b o opts (ODStream src sizeMay) = do+  case sizeMay of+    -- unable to get size, so assume non-seekable file+    Nothing -> sequentialMultipartUpload b o opts Nothing src+    -- got file size, so check for single/multipart upload+    Just size ->+      if+          | size <= 64 * oneMiB -> do+              bs <- C.runConduit $ src C..| takeC (fromIntegral size) C..| CB.sinkLbs+              putObjectSingle' b o (pooToHeaders opts) $ LBS.toStrict bs+          | size > maxObjectSize -> throwIO $ MErrVPutSizeExceeded size+          | otherwise -> sequentialMultipartUpload b o opts (Just size) src+putObjectInternal b o opts (ODFile fp sizeMay) = do+  hResE <- withNewHandle fp $ \h ->+    liftA2 (,) (isHandleSeekable h) (getFileSize h)++  (isSeekable, handleSizeMay) <-+    either+      (const $ return (False, Nothing))+      return+      hResE++  -- prefer given size to queried size.+  let finalSizeMay = listToMaybe $ catMaybes [sizeMay, handleSizeMay]++  case finalSizeMay of+    -- unable to get size, so assume non-seekable file+    Nothing -> sequentialMultipartUpload b o opts Nothing $ CB.sourceFile fp+    -- got file size, so check for single/multipart upload+    Just size ->+      if+          | size <= 64 * oneMiB ->+              either throwIO return+                =<< withNewHandle fp (\h -> putObjectSingle b o (pooToHeaders opts) h 0 size)+          | size > maxObjectSize -> throwIO $ MErrVPutSizeExceeded size+          | isSeekable -> parallelMultipartUpload b o opts fp size+          | otherwise ->+              sequentialMultipartUpload b o opts (Just size) $+                CB.sourceFile fp++parallelMultipartUpload ::+  Bucket ->+  Object ->+  PutObjectOptions ->+  FilePath ->+  Int64 ->+  Minio ETag+parallelMultipartUpload b o opts filePath size = do+  -- get a new upload id.+  uploadId <- newMultipartUpload b o (pooToHeaders opts)++  let partSizeInfo = selectPartSizes size++  let threads = fromMaybe 10 $ pooNumThreads opts++  -- perform upload with 'threads' threads+  uploadedPartsE <-+    limitedMapConcurrently+      (fromIntegral threads)+      (uploadPart uploadId)+      partSizeInfo++  -- if there were any errors, rethrow exception.+  mapM_ throwIO $ lefts uploadedPartsE++  -- if we get here, all parts were successfully uploaded.+  completeMultipartUpload b o uploadId $ rights uploadedPartsE+  where+    uploadPart uploadId (partNum, offset, sz) =+      withNewHandle filePath $ \h -> do+        let payload = PayloadH h offset sz+        putObjectPart b o uploadId partNum [] payload++-- | Upload multipart object from conduit source sequentially+sequentialMultipartUpload ::+  Bucket ->+  Object ->+  PutObjectOptions ->+  Maybe Int64 ->+  C.ConduitM () ByteString Minio () ->+  Minio ETag+sequentialMultipartUpload b o opts sizeMay src = do+  -- get a new upload id.+  uploadId <- newMultipartUpload b o (pooToHeaders opts)++  -- upload parts in loop+  let partSizes = selectPartSizes $ maybe maxObjectSize identity sizeMay+      (pnums, _, sizes) = List.unzip3 partSizes+  uploadedParts <-+    C.runConduit $+      src+        C..| chunkBSConduit (map fromIntegral sizes)+        C..| CL.map PayloadBS+        C..| uploadPart' uploadId pnums+        C..| CC.sinkList++  -- complete multipart upload+  completeMultipartUpload b o uploadId uploadedParts+  where+    uploadPart' _ [] = return ()+    uploadPart' uid (pn : pns) = do+      payloadMay <- C.await+      case payloadMay of+        Nothing -> return ()+        Just payload -> do+          pinfo <- lift $ putObjectPart b o uid pn [] payload+          C.yield pinfo+          uploadPart' uid pns
+ vendor/minio-hs-1.7.0/src/Network/Minio/S3API.hs view
@@ -0,0 +1,685 @@+--+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++-- |+-- Module:      Network.Minio.S3API+-- Copyright:   (c) 2017-2023 MinIO Dev Team+-- License:     Apache 2.0+-- Maintainer:  MinIO Dev Team <dev@min.io>+--+-- Lower-level API for S3 compatible object stores. Start with @Network.Minio@+-- and use this only if needed.+module Network.Minio.S3API+  ( Region,+    getLocation,++    -- * Listing buckets++    --------------------+    getService,++    -- * Listing objects++    --------------------+    ListObjectsResult (..),+    ListObjectsV1Result (..),+    listObjects',+    listObjectsV1',++    -- * Retrieving buckets+    headBucket,++    -- * Retrieving objects++    -----------------------+    getObject',+    headObject,++    -- * Creating buckets and objects++    ---------------------------------+    putBucket,+    ETag,+    maxSinglePutObjectSizeBytes,+    putObjectSingle',+    putObjectSingle,+    copyObjectSingle,++    -- * Multipart Upload APIs++    --------------------------+    UploadId,+    PartTuple,+    Payload (..),+    PartNumber,+    newMultipartUpload,+    putObjectPart,+    copyObjectPart,+    completeMultipartUpload,+    abortMultipartUpload,+    ListUploadsResult (..),+    listIncompleteUploads',+    ListPartsResult (..),+    listIncompleteParts',++    -- * Deletion APIs++    --------------------------+    deleteBucket,+    deleteObject,++    -- * Presigned Operations++    -----------------------------+    module Network.Minio.PresignedOperations,++    -- ** Bucket Policies+    getBucketPolicy,+    setBucketPolicy,++    -- * Bucket Notifications++    -------------------------+    Notification (..),+    NotificationConfig (..),+    Arn,+    Event (..),+    Filter (..),+    FilterKey (..),+    FilterRules (..),+    FilterRule (..),+    getBucketNotification,+    putBucketNotification,+    removeAllBucketNotification,+  )+where++import qualified Data.ByteString as BS+import qualified Data.Text as T+import Lib.Prelude+import qualified Network.HTTP.Conduit as NC+import qualified Network.HTTP.Types as HT+import Network.HTTP.Types.Status (status404)+import Network.Minio.API+import Network.Minio.APICommon+import Network.Minio.Data+import Network.Minio.Errors+import Network.Minio.PresignedOperations+import Network.Minio.Utils+import Network.Minio.XmlGenerator+import Network.Minio.XmlParser+import UnliftIO (Handler (Handler))++-- | Fetch all buckets from the service.+getService :: Minio [BucketInfo]+getService = do+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riNeedsLocation = False+        }+  parseListBuckets $ NC.responseBody resp++-- Parse headers from getObject and headObject calls.+parseGetObjectHeaders :: Object -> [HT.Header] -> Maybe ObjectInfo+parseGetObjectHeaders object headers =+  let metadataPairs = getMetadata headers+      userMetadata = getUserMetadataMap metadataPairs+      metadata = getNonUserMetadataMap metadataPairs+   in ObjectInfo+        <$> Just object+        <*> getLastModifiedHeader headers+        <*> getETagHeader headers+        <*> getContentLength headers+        <*> Just userMetadata+        <*> Just metadata++-- | GET an object from the service and return parsed ObjectInfo and a+-- conduit source for the object content+getObject' ::+  Bucket ->+  Object ->+  HT.Query ->+  [HT.Header] ->+  Minio GetObjectResponse+getObject' bucket object queryParams headers = do+  resp <- mkStreamRequest reqInfo+  let objInfoMaybe = parseGetObjectHeaders object $ NC.responseHeaders resp+  objInfo <-+    maybe+      (throwIO MErrVInvalidObjectInfoResponse)+      return+      objInfoMaybe+  return $+    GetObjectResponse+      { gorObjectInfo = objInfo,+        gorObjectStream = NC.responseBody resp+      }+  where+    reqInfo =+      defaultS3ReqInfo+        { riBucket = Just bucket,+          riObject = Just object,+          riQueryParams = queryParams,+          riHeaders =+            headers+              -- This header is required for safety as otherwise http-client,+              -- sends Accept-Encoding: gzip, and the server may actually gzip+              -- body. In that case Content-Length header will be missing.+              <> [("Accept-Encoding", "identity")]+        }++-- | Creates a bucket via a PUT bucket call.+putBucket :: Bucket -> Region -> Minio ()+putBucket bucket location = do+  ns <- asks getSvcNamespace+  void $+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodPut,+          riBucket = Just bucket,+          riPayload = PayloadBS $ mkCreateBucketConfig ns location,+          riNeedsLocation = False+        }++-- | Single PUT object size.+maxSinglePutObjectSizeBytes :: Int64+maxSinglePutObjectSizeBytes = 5 * 1024 * 1024 * 1024++-- | PUT an object into the service. This function performs a single+-- PUT object call and uses a strict ByteString as the object+-- data. `putObjectSingle` is preferable as the object data will not+-- be resident in memory.+putObjectSingle' :: Bucket -> Object -> [HT.Header] -> ByteString -> Minio ETag+putObjectSingle' bucket object headers bs = do+  let size = fromIntegral (BS.length bs)+  -- check length is within single PUT object size.+  when (size > maxSinglePutObjectSizeBytes) $+    throwIO $+      MErrVSinglePUTSizeExceeded size++  let payload = mkStreamingPayload $ PayloadBS bs+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodPut,+          riBucket = Just bucket,+          riObject = Just object,+          riHeaders = headers,+          riPayload = payload+        }++  let rheaders = NC.responseHeaders resp+      etag = getETagHeader rheaders+  maybe+    (throwIO MErrVETagHeaderNotFound)+    return+    etag++-- | PUT an object into the service. This function performs a single+-- PUT object call, and so can only transfer objects upto 5GiB.+putObjectSingle ::+  Bucket ->+  Object ->+  [HT.Header] ->+  Handle ->+  Int64 ->+  Int64 ->+  Minio ETag+putObjectSingle bucket object headers h offset size = do+  -- check length is within single PUT object size.+  when (size > maxSinglePutObjectSizeBytes) $+    throwIO $+      MErrVSinglePUTSizeExceeded size++  -- content-length header is automatically set by library.+  let payload = mkStreamingPayload $ PayloadH h offset size+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodPut,+          riBucket = Just bucket,+          riObject = Just object,+          riHeaders = headers,+          riPayload = payload+        }++  let rheaders = NC.responseHeaders resp+      etag = getETagHeader rheaders+  maybe+    (throwIO MErrVETagHeaderNotFound)+    return+    etag++-- | List objects in a bucket matching prefix up to delimiter,+-- starting from nextMarker.+listObjectsV1' ::+  Bucket ->+  Maybe Text ->+  Maybe Text ->+  Maybe Text ->+  Maybe Int ->+  Minio ListObjectsV1Result+listObjectsV1' bucket prefix nextMarker delimiter maxKeys = do+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodGet,+          riBucket = Just bucket,+          riQueryParams = mkOptionalParams params+        }+  parseListObjectsV1Response $ NC.responseBody resp+  where+    params =+      [ ("marker", nextMarker),+        ("prefix", prefix),+        ("delimiter", delimiter),+        ("max-keys", show <$> maxKeys)+      ]++-- | List objects in a bucket matching prefix up to delimiter,+-- starting from nextToken.+listObjects' ::+  Bucket ->+  Maybe Text ->+  Maybe Text ->+  Maybe Text ->+  Maybe Int ->+  Minio ListObjectsResult+listObjects' bucket prefix nextToken delimiter maxKeys = do+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodGet,+          riBucket = Just bucket,+          riQueryParams = mkOptionalParams params+        }+  parseListObjectsResponse $ NC.responseBody resp+  where+    params =+      [ ("list-type", Just "2"),+        ("continuation_token", nextToken),+        ("prefix", prefix),+        ("delimiter", delimiter),+        ("max-keys", show <$> maxKeys)+      ]++-- | DELETE a bucket from the service.+deleteBucket :: Bucket -> Minio ()+deleteBucket bucket =+  void $+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodDelete,+          riBucket = Just bucket+        }++-- | DELETE an object from the service.+deleteObject :: Bucket -> Object -> Minio ()+deleteObject bucket object =+  void $+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodDelete,+          riBucket = Just bucket,+          riObject = Just object+        }++-- | Create a new multipart upload.+newMultipartUpload :: Bucket -> Object -> [HT.Header] -> Minio UploadId+newMultipartUpload bucket object headers = do+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodPost,+          riBucket = Just bucket,+          riObject = Just object,+          riQueryParams = [("uploads", Nothing)],+          riHeaders = headers+        }+  parseNewMultipartUpload $ NC.responseBody resp++-- | PUT a part of an object as part of a multipart upload.+putObjectPart ::+  Bucket ->+  Object ->+  UploadId ->+  PartNumber ->+  [HT.Header] ->+  Payload ->+  Minio PartTuple+putObjectPart bucket object uploadId partNumber headers payload = do+  -- transform payload to conduit to enable streaming signature+  let payload' = mkStreamingPayload payload+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodPut,+          riBucket = Just bucket,+          riObject = Just object,+          riQueryParams = mkOptionalParams params,+          riHeaders = headers,+          riPayload = payload'+        }+  let rheaders = NC.responseHeaders resp+      etag = getETagHeader rheaders+  maybe+    (throwIO MErrVETagHeaderNotFound)+    (return . (partNumber,))+    etag+  where+    params =+      [ ("uploadId", Just uploadId),+        ("partNumber", Just $ show partNumber)+      ]++srcInfoToHeaders :: SourceInfo -> [HT.Header]+srcInfoToHeaders srcInfo =+  ( "x-amz-copy-source",+    encodeUtf8 $+      T.concat+        [ "/",+          srcBucket srcInfo,+          "/",+          srcObject srcInfo+        ]+  )+    : rangeHdr+    ++ zip names values+  where+    names =+      [ "x-amz-copy-source-if-match",+        "x-amz-copy-source-if-none-match",+        "x-amz-copy-source-if-unmodified-since",+        "x-amz-copy-source-if-modified-since"+      ]+    values =+      mapMaybe+        (fmap encodeUtf8 . (srcInfo &))+        [ srcIfMatch,+          srcIfNoneMatch,+          fmap formatRFC1123 . srcIfUnmodifiedSince,+          fmap formatRFC1123 . srcIfModifiedSince+        ]+    rangeHdr =+      maybe [] ((\a -> [("x-amz-copy-source-range", HT.renderByteRanges [a])]) . toByteRange) (srcRange srcInfo)+    toByteRange :: (Int64, Int64) -> HT.ByteRange+    toByteRange (x, y) = HT.ByteRangeFromTo (fromIntegral x) (fromIntegral y)++-- | Performs server-side copy of an object or part of an object as an+-- upload part of an ongoing multi-part upload.+copyObjectPart ::+  DestinationInfo ->+  SourceInfo ->+  UploadId ->+  PartNumber ->+  [HT.Header] ->+  Minio (ETag, UTCTime)+copyObjectPart dstInfo srcInfo uploadId partNumber headers = do+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodPut,+          riBucket = Just $ dstBucket dstInfo,+          riObject = Just $ dstObject dstInfo,+          riQueryParams = mkOptionalParams params,+          riHeaders = headers ++ srcInfoToHeaders srcInfo+        }++  parseCopyObjectResponse $ NC.responseBody resp+  where+    params =+      [ ("uploadId", Just uploadId),+        ("partNumber", Just $ show partNumber)+      ]++-- | Performs server-side copy of an object that is upto 5GiB in+-- size. If the object is greater than 5GiB, this function throws the+-- error returned by the server.+copyObjectSingle ::+  Bucket ->+  Object ->+  SourceInfo ->+  [HT.Header] ->+  Minio (ETag, UTCTime)+copyObjectSingle bucket object srcInfo headers = do+  -- validate that srcRange is Nothing for this API.+  when (isJust $ srcRange srcInfo) $+    throwIO MErrVCopyObjSingleNoRangeAccepted+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodPut,+          riBucket = Just bucket,+          riObject = Just object,+          riHeaders = headers ++ srcInfoToHeaders srcInfo+        }+  parseCopyObjectResponse $ NC.responseBody resp++-- | Complete a multipart upload.+completeMultipartUpload ::+  Bucket ->+  Object ->+  UploadId ->+  [PartTuple] ->+  Minio ETag+completeMultipartUpload bucket object uploadId partTuple = do+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodPost,+          riBucket = Just bucket,+          riObject = Just object,+          riQueryParams = mkOptionalParams params,+          riPayload =+            PayloadBS $+              mkCompleteMultipartUploadRequest partTuple+        }+  parseCompleteMultipartUploadResponse $ NC.responseBody resp+  where+    params = [("uploadId", Just uploadId)]++-- | Abort a multipart upload.+abortMultipartUpload :: Bucket -> Object -> UploadId -> Minio ()+abortMultipartUpload bucket object uploadId =+  void $+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodDelete,+          riBucket = Just bucket,+          riObject = Just object,+          riQueryParams = mkOptionalParams params+        }+  where+    params = [("uploadId", Just uploadId)]++-- | List incomplete multipart uploads.+listIncompleteUploads' ::+  Bucket ->+  Maybe Text ->+  Maybe Text ->+  Maybe Text ->+  Maybe Text ->+  Maybe Int ->+  Minio ListUploadsResult+listIncompleteUploads' bucket prefix delimiter keyMarker uploadIdMarker maxKeys = do+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodGet,+          riBucket = Just bucket,+          riQueryParams = params+        }+  parseListUploadsResponse $ NC.responseBody resp+  where+    -- build query params+    params =+      ("uploads", Nothing)+        : mkOptionalParams+          [ ("prefix", prefix),+            ("delimiter", delimiter),+            ("key-marker", keyMarker),+            ("upload-id-marker", uploadIdMarker),+            ("max-uploads", show <$> maxKeys)+          ]++-- | List parts of an ongoing multipart upload.+listIncompleteParts' ::+  Bucket ->+  Object ->+  UploadId ->+  Maybe Text ->+  Maybe Text ->+  Minio ListPartsResult+listIncompleteParts' bucket object uploadId maxParts partNumMarker = do+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodGet,+          riBucket = Just bucket,+          riObject = Just object,+          riQueryParams = mkOptionalParams params+        }+  parseListPartsResponse $ NC.responseBody resp+  where+    -- build optional query params+    params =+      [ ("uploadId", Just uploadId),+        ("part-number-marker", partNumMarker),+        ("max-parts", maxParts)+      ]++-- | Get metadata of an object.+headObject :: Bucket -> Object -> [HT.Header] -> Minio ObjectInfo+headObject bucket object reqHeaders = do+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodHead,+          riBucket = Just bucket,+          riObject = Just object,+          riHeaders =+            reqHeaders+              -- This header is required for safety as otherwise http-client,+              -- sends Accept-Encoding: gzip, and the server may actually gzip+              -- body. In that case Content-Length header will be missing.+              <> [("Accept-Encoding", "identity")]+        }+  maybe (throwIO MErrVInvalidObjectInfoResponse) return $+    parseGetObjectHeaders object $+      NC.responseHeaders resp++-- | Query the object store if a given bucket exists.+headBucket :: Bucket -> Minio Bool+headBucket bucket =+  headBucketEx+    `catches` [ Handler handleNoSuchBucket,+                Handler handleStatus404+              ]+  where+    handleNoSuchBucket :: ServiceErr -> Minio Bool+    handleNoSuchBucket e+      | e == NoSuchBucket = return False+      | otherwise = throwIO e+    handleStatus404 :: NC.HttpException -> Minio Bool+    handleStatus404 e@(NC.HttpExceptionRequest _ (NC.StatusCodeException res _)) =+      if NC.responseStatus res == status404+        then return False+        else throwIO e+    handleStatus404 e = throwIO e+    headBucketEx = do+      resp <-+        executeRequest $+          defaultS3ReqInfo+            { riMethod = HT.methodHead,+              riBucket = Just bucket+            }+      return $ NC.responseStatus resp == HT.ok200++-- | Set the notification configuration on a bucket.+putBucketNotification :: Bucket -> Notification -> Minio ()+putBucketNotification bucket ncfg = do+  ns <- asks getSvcNamespace+  void $+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodPut,+          riBucket = Just bucket,+          riQueryParams = [("notification", Nothing)],+          riPayload =+            PayloadBS $+              mkPutNotificationRequest ns ncfg+        }++-- | Retrieve the notification configuration on a bucket.+getBucketNotification :: Bucket -> Minio Notification+getBucketNotification bucket = do+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodGet,+          riBucket = Just bucket,+          riQueryParams = [("notification", Nothing)]+        }+  parseNotification $ NC.responseBody resp++-- | Remove all notifications configured on a bucket.+removeAllBucketNotification :: Bucket -> Minio ()+removeAllBucketNotification = flip putBucketNotification defaultNotification++-- | Fetch the policy if any on a bucket.+getBucketPolicy :: Bucket -> Minio Text+getBucketPolicy bucket = do+  resp <-+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodGet,+          riBucket = Just bucket,+          riQueryParams = [("policy", Nothing)]+        }+  return $ decodeUtf8Lenient $ toStrictBS $ NC.responseBody resp++-- | Set a new policy on a bucket.+-- As a special condition if the policy is empty+-- then we treat it as policy DELETE operation.+setBucketPolicy :: Bucket -> Text -> Minio ()+setBucketPolicy bucket policy = do+  if T.null policy+    then deleteBucketPolicy bucket+    else putBucketPolicy bucket policy++-- | Save a new policy on a bucket.+putBucketPolicy :: Bucket -> Text -> Minio ()+putBucketPolicy bucket policy = do+  void $+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodPut,+          riBucket = Just bucket,+          riQueryParams = [("policy", Nothing)],+          riPayload = PayloadBS $ encodeUtf8 policy+        }++-- | Delete any policy set on a bucket.+deleteBucketPolicy :: Bucket -> Minio ()+deleteBucketPolicy bucket = do+  void $+    executeRequest $+      defaultS3ReqInfo+        { riMethod = HT.methodDelete,+          riBucket = Just bucket,+          riQueryParams = [("policy", Nothing)]+        }
+ vendor/minio-hs-1.7.0/src/Network/Minio/SelectAPI.hs view
@@ -0,0 +1,294 @@+--+-- MinIO Haskell SDK, (C) 2017-2019 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.SelectAPI+  ( -- | The `selectObjectContent` allows querying CSV, JSON or Parquet+    -- format objects in AWS S3 and in MinIO using SQL Select+    -- statements. This allows significant reduction of data transfer+    -- from object storage for computation-intensive tasks, as relevant+    -- data is filtered close to the storage.+    selectObjectContent,+    SelectRequest,+    selectRequest,++    -- *** Input Serialization+    InputSerialization,+    defaultCsvInput,+    linesJsonInput,+    documentJsonInput,+    defaultParquetInput,+    setInputCSVProps,+    CompressionType (..),+    setInputCompressionType,++    -- *** CSV Format details++    -- | CSV format options such as delimiters and quote characters are+    -- specified using using the functions below. Options are combined+    -- monoidally.+    CSVProp,+    recordDelimiter,+    fieldDelimiter,+    quoteCharacter,+    quoteEscapeCharacter,+    commentCharacter,+    allowQuotedRecordDelimiter,+    FileHeaderInfo (..),+    fileHeaderInfo,+    QuoteFields (..),+    quoteFields,++    -- *** Output Serialization+    OutputSerialization,+    defaultCsvOutput,+    defaultJsonOutput,+    outputCSVFromProps,+    outputJSONFromRecordDelimiter,++    -- *** Progress messages+    setRequestProgressEnabled,++    -- *** Interpreting Select output++    -- | The conduit returned by `selectObjectContent` returns values of+    -- the `EventMessage` data type. This returns the query output+    -- messages formatted according to the chosen output serialization,+    -- interleaved with progress messages (if enabled by+    -- `setRequestProgressEnabled`), and at the end a statistics+    -- message.+    --+    -- If the application is interested in only the payload, then+    -- `getPayloadBytes` can be used. For example to simply print the+    -- payload to stdout:+    --+    -- > resultConduit <- selectObjectContent bucket object mySelectRequest+    -- > runConduit $ resultConduit .| getPayloadBytes .| stdoutC+    --+    -- Note that runConduit, the connect operator (.|) and stdoutC are+    -- all from the "conduit" package.+    getPayloadBytes,+    EventMessage (..),+    Progress (..),+    Stats,+  )+where++import Conduit ((.|))+import qualified Conduit as C+import qualified Data.Binary as Bin+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import Data.Digest.CRC32 (crc32, crc32Update)+import Lib.Prelude+import qualified Network.HTTP.Conduit as NC+import qualified Network.HTTP.Types as HT+import Network.Minio.API+import Network.Minio.Data+import Network.Minio.Errors+import Network.Minio.Utils+import Network.Minio.XmlGenerator+import Network.Minio.XmlParser+import UnliftIO (MonadUnliftIO)++data EventStreamException+  = ESEPreludeCRCFailed+  | ESEMessageCRCFailed+  | ESEUnexpectedEndOfStream+  | ESEDecodeFail [Char]+  | ESEInvalidHeaderType+  | ESEInvalidHeaderValueType+  | ESEInvalidMessageType+  deriving stock (Eq, Show)++instance Exception EventStreamException++-- chunkSize in bytes is 32KiB+chunkSize :: Int+chunkSize = 32 * 1024++parseBinary :: (Bin.Binary a) => ByteString -> IO a+parseBinary b = do+  case Bin.decodeOrFail $ LB.fromStrict b of+    Left (_, _, msg) -> throwIO $ ESEDecodeFail msg+    Right (_, _, r) -> return r++bytesToHeaderName :: Text -> IO MsgHeaderName+bytesToHeaderName t = case t of+  ":message-type" -> return MessageType+  ":event-type" -> return EventType+  ":content-type" -> return ContentType+  ":error-code" -> return ErrorCode+  ":error-message" -> return ErrorMessage+  _ -> throwIO ESEInvalidHeaderType++parseHeaders ::+  (MonadUnliftIO m) =>+  Word32 ->+  C.ConduitM ByteString a m [MessageHeader]+parseHeaders 0 = return []+parseHeaders hdrLen = do+  bs1 <- readNBytes 1+  n :: Word8 <- liftIO $ parseBinary bs1++  headerKeyBytes <- readNBytes $ fromIntegral n+  let headerKey = decodeUtf8Lenient headerKeyBytes+  headerName <- liftIO $ bytesToHeaderName headerKey++  bs2 <- readNBytes 1+  headerValueType :: Word8 <- liftIO $ parseBinary bs2+  when (headerValueType /= 7) $ throwIO ESEInvalidHeaderValueType++  bs3 <- readNBytes 2+  vLen :: Word16 <- liftIO $ parseBinary bs3+  headerValueBytes <- readNBytes $ fromIntegral vLen+  let headerValue = decodeUtf8Lenient headerValueBytes+      m = (headerName, headerValue)+      k = 1 + fromIntegral n + 1 + 2 + fromIntegral vLen++  ms <- parseHeaders (hdrLen - k)+  return (m : ms)++-- readNBytes returns N bytes read from the string and throws an+-- exception if N bytes are not present on the stream.+readNBytes :: (MonadUnliftIO m) => Int -> C.ConduitM ByteString a m ByteString+readNBytes n = do+  b <- LB.toStrict <$> (C.takeCE n .| C.sinkLazy)+  if B.length b /= n+    then throwIO ESEUnexpectedEndOfStream+    else return b++crcCheck ::+  (MonadUnliftIO m) =>+  C.ConduitM ByteString ByteString m ()+crcCheck = do+  b <- readNBytes 12+  n :: Word32 <- liftIO $ parseBinary $ B.take 4 b+  preludeCRC :: Word32 <- liftIO $ parseBinary $ B.drop 8 b+  when (crc32 (B.take 8 b) /= preludeCRC) $+    throwIO ESEPreludeCRCFailed++  -- we do not yield the checksum+  C.yield $ B.take 8 b++  -- 12 bytes have been read off the current message. Now read the+  -- next (n-12)-4 bytes and accumulate the checksum, and yield it.+  let startCrc = crc32 b+  finalCrc <- accumulateYield (fromIntegral n - 16) startCrc++  bs <- readNBytes 4+  expectedCrc :: Word32 <- liftIO $ parseBinary bs++  when (finalCrc /= expectedCrc) $+    throwIO ESEMessageCRCFailed++  -- we unconditionally recurse - downstream figures out when to+  -- quit reading the stream+  crcCheck+  where+    accumulateYield n checkSum = do+      let toRead = min n chunkSize+      b <- readNBytes toRead+      let c' = crc32Update checkSum b+          n' = n - B.length b+      C.yield b+      if n' > 0+        then accumulateYield n' c'+        else return c'++handleMessage :: (MonadUnliftIO m) => C.ConduitT ByteString EventMessage m ()+handleMessage = do+  b1 <- readNBytes 4+  msgLen :: Word32 <- liftIO $ parseBinary b1++  b2 <- readNBytes 4+  hdrLen :: Word32 <- liftIO $ parseBinary b2++  hs <- parseHeaders hdrLen++  let payloadLen = msgLen - hdrLen - 16+      getHdrVal h = fmap snd . find ((h ==) . fst)+      eventHdrValue = getHdrVal EventType hs+      msgHdrValue = getHdrVal MessageType hs+      errCode = getHdrVal ErrorCode hs+      errMsg = getHdrVal ErrorMessage hs++  case msgHdrValue of+    Just "event" -> do+      case eventHdrValue of+        Just "Records" -> passThrough $ fromIntegral payloadLen+        Just "Cont" -> return ()+        Just "Progress" -> do+          bs <- readNBytes $ fromIntegral payloadLen+          progress <- parseSelectProgress bs+          C.yield $ ProgressEventMessage progress+        Just "Stats" -> do+          bs <- readNBytes $ fromIntegral payloadLen+          stats <- parseSelectProgress bs+          C.yield $ StatsEventMessage stats+        Just "End" -> return ()+        _ -> throwIO ESEInvalidMessageType+      when (eventHdrValue /= Just "End") handleMessage+    Just "error" -> do+      let reqMsgMay = RequestLevelErrorMessage <$> errCode <*> errMsg+      maybe (throwIO ESEInvalidMessageType) C.yield reqMsgMay+    _ -> throwIO ESEInvalidMessageType+  where+    passThrough 0 = return ()+    passThrough n = do+      let c = min n chunkSize+      b <- readNBytes c+      C.yield $ RecordPayloadEventMessage b+      passThrough $ n - B.length b++selectProtoConduit ::+  (MonadUnliftIO m) =>+  C.ConduitT ByteString EventMessage m ()+selectProtoConduit = crcCheck .| handleMessage++-- | selectObjectContent calls the SelectRequest on the given+-- object. It returns a Conduit of event messages that can be consumed+-- by the client.+selectObjectContent ::+  Bucket ->+  Object ->+  SelectRequest ->+  Minio (C.ConduitT () EventMessage Minio ())+selectObjectContent b o r = do+  let reqInfo =+        defaultS3ReqInfo+          { riMethod = HT.methodPost,+            riBucket = Just b,+            riObject = Just o,+            riPayload = PayloadBS $ mkSelectRequest r,+            riNeedsLocation = False,+            riQueryParams = [("select", Nothing), ("select-type", Just "2")]+          }+  -- print $ mkSelectRequest r+  resp <- mkStreamRequest reqInfo+  return $ NC.responseBody resp .| selectProtoConduit++-- | A helper conduit that returns only the record payload bytes.+getPayloadBytes :: (MonadIO m) => C.ConduitT EventMessage ByteString m ()+getPayloadBytes = do+  evM <- C.await+  case evM of+    Just v -> do+      case v of+        RecordPayloadEventMessage b -> C.yield b+        RequestLevelErrorMessage c m -> liftIO $ throwIO $ SelectErr c m+        _ -> return ()+      getPayloadBytes+    Nothing -> return ()
+ vendor/minio-hs-1.7.0/src/Network/Minio/Sign/V4.hs view
@@ -0,0 +1,494 @@+--+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--+{-# LANGUAGE BangPatterns #-}++module Network.Minio.Sign.V4+  ( SignParams (..),+    signV4QueryParams,+    signV4,+    signV4PostPolicy,+    signV4Stream,+    Service (..),+    credentialScope,+  )+where++import qualified Conduit as C+import qualified Data.ByteArray as BA+import qualified Data.ByteString as B+import qualified Data.ByteString.Base64 as Base64+import qualified Data.ByteString.Char8 as B8+import qualified Data.ByteString.Lazy as LB+import Data.CaseInsensitive (mk)+import qualified Data.CaseInsensitive as CI+import qualified Data.HashMap.Strict as Map+import qualified Data.HashSet as Set+import Data.List (partition)+import qualified Data.List.NonEmpty as NE+import qualified Data.Time as Time+import Lib.Prelude+import qualified Network.HTTP.Conduit as NC+import Network.HTTP.Types (Header, SimpleQuery, hContentEncoding, parseQuery)+import qualified Network.HTTP.Types as H+import Network.HTTP.Types.Header (RequestHeaders)+import Network.Minio.Data.ByteString+import Network.Minio.Data.Crypto+import Network.Minio.Data.Time+import Network.Minio.Errors+import Text.Printf (printf)++-- these headers are not included in the string to sign when signing a+-- request+ignoredHeaders :: Set.HashSet ByteString+ignoredHeaders =+  Set.fromList $+    map+      CI.foldedCase+      [ H.hAuthorization,+        H.hContentType,+        H.hUserAgent+      ]++data Service = ServiceS3 | ServiceSTS+  deriving stock (Eq, Show)++toByteString :: Service -> ByteString+toByteString ServiceS3 = "s3"+toByteString ServiceSTS = "sts"++data SignParams = SignParams+  { spAccessKey :: Text,+    spSecretKey :: BA.ScrubbedBytes,+    spSessionToken :: Maybe BA.ScrubbedBytes,+    spService :: Service,+    spTimeStamp :: UTCTime,+    spRegion :: Maybe Text,+    spExpirySecs :: Maybe UrlExpiry,+    spPayloadHash :: Maybe ByteString+  }+  deriving stock (Show)++mkAuthHeader :: Text -> ByteString -> ByteString -> ByteString -> H.Header+mkAuthHeader accessKey scope signedHeaderKeys sign =+  let authValue =+        B.concat+          [ "AWS4-HMAC-SHA256 Credential=",+            encodeUtf8 accessKey,+            "/",+            scope,+            ", SignedHeaders=",+            signedHeaderKeys,+            ", Signature=",+            sign+          ]+   in (H.hAuthorization, authValue)++data IsStreaming = IsStreamingLength Int64 | NotStreaming+  deriving stock (Eq, Show)++amzSecurityToken :: ByteString+amzSecurityToken = "X-Amz-Security-Token"++-- | Given SignParams and request details, including request method,+-- request path, headers, query params and payload hash, generates an+-- updated set of headers, including the x-amz-date header and the+-- Authorization header, which includes the signature.+--+-- For normal requests (i.e. without an expiry time), the output is+-- the list of headers to add to authenticate the request.+--+-- If `expiry` is not Nothing, it is assumed that a presigned request+-- is being created. The expiry is interpreted as an integer number of+-- seconds. The output will be the list of query-parameters to add to+-- the request.+signV4QueryParams :: SignParams -> NC.Request -> SimpleQuery+signV4QueryParams !sp !req =+  let scope = credentialScope sp+      expiry = spExpirySecs sp++      headersToSign = getHeadersToSign $ NC.requestHeaders req+      signedHeaderKeys = B.intercalate ";" $ sort $ map fst headersToSign+      -- query-parameters to be added before signing for presigned URLs+      -- (i.e. when `isJust expiry`)+      authQP =+        [ ("X-Amz-Algorithm", "AWS4-HMAC-SHA256"),+          ("X-Amz-Credential", B.concat [encodeUtf8 $ spAccessKey sp, "/", scope]),+          ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp),+          ("X-Amz-Expires", maybe "" showBS expiry),+          ("X-Amz-SignedHeaders", signedHeaderKeys)+        ]+          ++ maybeToList ((amzSecurityToken,) . BA.convert <$> spSessionToken sp)+      finalQP =+        parseQuery (NC.queryString req)+          ++ if isJust expiry+            then (fmap . fmap) Just authQP+            else []+      -- 1. compute canonical request+      canonicalRequest =+        mkCanonicalRequest+          False+          sp+          (NC.setQueryString finalQP req)+          headersToSign++      -- 2. compute string to sign+      stringToSign = mkStringToSign (spTimeStamp sp) scope canonicalRequest+      -- 3.1 compute signing key+      signingKey = getSigningKey sp+      -- 3.2 compute signature+      signature = computeSignature stringToSign signingKey+   in ("X-Amz-Signature", signature) : authQP++-- | Given SignParams and request details, including request method, request+-- path, headers, query params and payload hash, generates an updated set of+-- headers, including the x-amz-date header and the Authorization header, which+-- includes the signature.+--+-- The output is the list of headers to be added to authenticate the request.+signV4 :: SignParams -> NC.Request -> [Header]+signV4 !sp !req =+  let scope = credentialScope sp++      -- extra headers to be added for signing purposes.+      extraHeaders =+        ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp)+          : ( -- payload hash is only used for S3 (not STS)+              [ ( "x-amz-content-sha256",+                  fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp+                )+                | spService sp == ServiceS3+              ]+            )+          ++ maybeToList ((mk amzSecurityToken,) . BA.convert <$> spSessionToken sp)++      -- 1. compute canonical request+      reqHeaders = NC.requestHeaders req ++ extraHeaders+      (canonicalRequest, signedHeaderKeys) =+        getCanonicalRequestAndSignedHeaders+          NotStreaming+          sp+          req+          reqHeaders++      -- 2. compute string to sign+      stringToSign = mkStringToSign (spTimeStamp sp) scope canonicalRequest+      -- 3.1 compute signing key+      signingKey = getSigningKey sp+      -- 3.2 compute signature+      signature = computeSignature stringToSign signingKey+      -- 4. compute auth header+      authHeader = mkAuthHeader (spAccessKey sp) scope signedHeaderKeys signature+   in authHeader : extraHeaders++credentialScope :: SignParams -> ByteString+credentialScope sp =+  let region = fromMaybe "" $ spRegion sp+   in B.intercalate+        "/"+        [ encodeUtf8 $ Time.formatTime Time.defaultTimeLocale "%Y%m%d" $ spTimeStamp sp,+          encodeUtf8 region,+          toByteString $ spService sp,+          "aws4_request"+        ]++-- Folds header name, trims whitespace in header values, skips ignored headers+-- and sorts headers.+getHeadersToSign :: [Header] -> [(ByteString, ByteString)]+getHeadersToSign !h =+  filter ((\hdr -> not $ Set.member hdr ignoredHeaders) . fst) $+    map (bimap CI.foldedCase stripBS) h++-- | Given the list of headers in the request, computes the canonical headers+-- and the signed headers strings.+getCanonicalHeaders :: NonEmpty Header -> (ByteString, ByteString)+getCanonicalHeaders h =+  let -- Folds header name, trims spaces in header values, skips ignored+      -- headers and sorts headers by name (we must not re-order multi-valued+      -- headers).+      headersToSign =+        NE.toList $+          NE.sortBy (\a b -> compare (fst a) (fst b)) $+            NE.fromList $+              NE.filter ((\hdr -> not $ Set.member hdr ignoredHeaders) . fst) $+                NE.map (bimap CI.foldedCase stripBS) h++      canonicalHeaders = mconcat $ map (\(a, b) -> a <> ":" <> b <> "\n") headersToSign+      signedHeaderKeys = B.intercalate ";" $ map fst headersToSign+   in (canonicalHeaders, signedHeaderKeys)++getCanonicalRequestAndSignedHeaders ::+  IsStreaming ->+  SignParams ->+  NC.Request ->+  [Header] ->+  (ByteString, ByteString)+getCanonicalRequestAndSignedHeaders isStreaming sp req requestHeaders =+  let httpMethod = NC.method req++      canonicalUri = uriEncode False $ NC.path req++      canonicalQueryString =+        B.intercalate "&" $+          map (\(x, y) -> B.concat [x, "=", y]) $+            sort $+              map+                ( bimap (uriEncode True) (maybe "" (uriEncode True))+                )+                (parseQuery $ NC.queryString req)++      (canonicalHeaders, signedHeaderKeys) = getCanonicalHeaders $ NE.fromList requestHeaders+      payloadHashStr =+        case isStreaming of+          IsStreamingLength _ -> "STREAMING-AWS4-HMAC-SHA256-PAYLOAD"+          NotStreaming -> fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp++      canonicalRequest =+        B.intercalate+          "\n"+          [ httpMethod,+            canonicalUri,+            canonicalQueryString,+            canonicalHeaders,+            signedHeaderKeys,+            payloadHashStr+          ]+   in (canonicalRequest, signedHeaderKeys)++mkCanonicalRequest ::+  Bool ->+  SignParams ->+  NC.Request ->+  [(ByteString, ByteString)] ->+  ByteString+mkCanonicalRequest !isStreaming !sp !req !headersForSign =+  let httpMethod = NC.method req+      canonicalUri = uriEncode False $ NC.path req+      canonicalQueryString =+        B.intercalate "&" $+          map (\(x, y) -> B.concat [x, "=", y]) $+            sortBy (\a b -> compare (fst a) (fst b)) $+              map+                ( bimap (uriEncode True) (maybe "" (uriEncode True))+                )+                (parseQuery $ NC.queryString req)+      sortedHeaders = sort headersForSign+      canonicalHeaders =+        B.concat $+          map (\(x, y) -> B.concat [x, ":", y, "\n"]) sortedHeaders+      signedHeaders = B.intercalate ";" $ map fst sortedHeaders+      payloadHashStr =+        if isStreaming+          then "STREAMING-AWS4-HMAC-SHA256-PAYLOAD"+          else fromMaybe "UNSIGNED-PAYLOAD" $ spPayloadHash sp+   in B.intercalate+        "\n"+        [ httpMethod,+          canonicalUri,+          canonicalQueryString,+          canonicalHeaders,+          signedHeaders,+          payloadHashStr+        ]++mkStringToSign :: UTCTime -> ByteString -> ByteString -> ByteString+mkStringToSign ts !scope !canonicalRequest =+  B.intercalate+    "\n"+    [ "AWS4-HMAC-SHA256",+      awsTimeFormatBS ts,+      scope,+      hashSHA256 canonicalRequest+    ]++getSigningKey :: SignParams -> ByteString+getSigningKey sp =+  hmacSHA256RawBS "aws4_request"+    . hmacSHA256RawBS (toByteString $ spService sp)+    . hmacSHA256RawBS (encodeUtf8 $ fromMaybe "" $ spRegion sp)+    . hmacSHA256RawBS (awsDateFormatBS $ spTimeStamp sp)+    $ B.concat ["AWS4", BA.convert $ spSecretKey sp]++computeSignature :: ByteString -> ByteString -> ByteString+computeSignature !toSign !key = digestToBase16 $ hmacSHA256 toSign key++-- | Takes a validated Post Policy JSON bytestring, the signing time,+-- and ConnInfo and returns form-data for the POST upload containing+-- just the signature and the encoded post-policy.+signV4PostPolicy ::+  ByteString ->+  SignParams ->+  Map.HashMap Text ByteString+signV4PostPolicy !postPolicyJSON !sp =+  let stringToSign = Base64.encode postPolicyJSON+      signingKey = getSigningKey sp+      signature = computeSignature stringToSign signingKey+   in Map.fromList $+        [ ("x-amz-signature", signature),+          ("policy", stringToSign)+        ]+          ++ maybeToList ((decodeUtf8 amzSecurityToken,) . BA.convert <$> spSessionToken sp)++chunkSizeConstant :: Int+chunkSizeConstant = 64 * 1024++-- base16Len computes the number of bytes required to represent @n (> 0)@ in+-- hexadecimal.+base16Len :: (Integral a) => a -> Int+base16Len n+  | n == 0 = 0+  | otherwise = 1 + base16Len (n `div` 16)++signedStreamLength :: Int64 -> Int64+signedStreamLength dataLen =+  let chunkSzInt = fromIntegral chunkSizeConstant+      (numChunks, lastChunkLen) = quotRem dataLen chunkSzInt+      -- Structure of a chunk:+      --   string(IntHexBase(chunk-size)) + ";chunk-signature=" + signature + \r\n + chunk-data + \r\n+      encodedChunkLen csz = fromIntegral (base16Len csz) + 17 + 64 + 2 + csz + 2+      fullChunkSize = encodedChunkLen chunkSzInt+      lastChunkSize = bool 0 (encodedChunkLen lastChunkLen) $ lastChunkLen > 0+      finalChunkSize = 1 + 17 + 64 + 2 + 2+   in numChunks * fullChunkSize + lastChunkSize + finalChunkSize++-- For streaming S3, we need to update the content-encoding header.+addContentEncoding :: [Header] -> [Header]+addContentEncoding hs =+  -- assume there is at most one content-encoding header.+  let (ceHdrs, others) = partition ((== hContentEncoding) . fst) hs+   in maybe+        (hContentEncoding, "aws-chunked")+        (\(k, v) -> (k, v <> ",aws-chunked"))+        (listToMaybe ceHdrs)+        : others++signV4Stream ::+  Int64 ->+  SignParams ->+  NC.Request ->+  (C.ConduitT () ByteString (C.ResourceT IO) () -> NC.Request)+signV4Stream !payloadLength !sp !req =+  let ts = spTimeStamp sp++      -- compute the updated list of headers to be added for signing purposes.+      signedContentLength = signedStreamLength payloadLength+      extraHeaders =+        [ ("X-Amz-Date", awsTimeFormatBS $ spTimeStamp sp),+          ("x-amz-decoded-content-length", showBS payloadLength),+          ("content-length", showBS signedContentLength),+          ("x-amz-content-sha256", "STREAMING-AWS4-HMAC-SHA256-PAYLOAD")+        ]+          ++ maybeToList ((mk amzSecurityToken,) . BA.convert <$> spSessionToken sp)+      requestHeaders =+        addContentEncoding $+          foldr setHeader (NC.requestHeaders req) extraHeaders++      -- 1. Compute Seed Signature+      -- 1.1 Canonical Request+      (canonicalReq, signedHeaderKeys) =+        getCanonicalRequestAndSignedHeaders+          (IsStreamingLength payloadLength)+          sp+          req+          requestHeaders++      scope = credentialScope sp+      accessKey = spAccessKey sp+      -- 1.2 String toSign+      stringToSign = mkStringToSign ts scope canonicalReq+      -- 1.3 Compute signature+      -- 1.3.1 compute signing key+      signingKey = getSigningKey sp+      -- 1.3.2 Compute signature+      seedSignature = computeSignature stringToSign signingKey+      -- 1.3.3 Compute Auth Header+      authHeader = mkAuthHeader accessKey scope signedHeaderKeys seedSignature+      -- 1.4 Updated headers for the request+      finalReqHeaders = authHeader : requestHeaders+      -- headersToAdd = authHeader : datePair : streamingHeaders++      toHexStr n = B8.pack $ printf "%x" n+      (numParts, lastPSize) = payloadLength `quotRem` fromIntegral chunkSizeConstant+      -- Function to compute string to sign for each chunk.+      chunkStrToSign prevSign currChunkHash =+        B.intercalate+          "\n"+          [ "AWS4-HMAC-SHA256-PAYLOAD",+            awsTimeFormatBS ts,+            scope,+            prevSign,+            hashSHA256 "",+            currChunkHash+          ]+      -- Read n byte from upstream and return a strict bytestring.+      mustTakeN n = do+        bs <- LB.toStrict <$> (C.takeCE n C..| C.sinkLazy)+        when (B.length bs /= n) $+          throwIO MErrVStreamingBodyUnexpectedEOF+        return bs+      signerConduit n lps prevSign =+        -- First case encodes a full chunk of length+        -- 'chunkSizeConstant'.+        if+            | n > 0 -> do+                bs <- mustTakeN chunkSizeConstant+                let strToSign = chunkStrToSign prevSign (hashSHA256 bs)+                    nextSign = computeSignature strToSign signingKey+                    chunkBS =+                      toHexStr chunkSizeConstant+                        <> ";chunk-signature="+                        <> nextSign+                        <> "\r\n"+                        <> bs+                        <> "\r\n"+                C.yield chunkBS+                signerConduit (n - 1) lps nextSign++            -- Second case encodes the last chunk which is smaller than+            -- 'chunkSizeConstant'+            | lps > 0 -> do+                bs <- mustTakeN $ fromIntegral lps+                let strToSign = chunkStrToSign prevSign (hashSHA256 bs)+                    nextSign = computeSignature strToSign signingKey+                    chunkBS =+                      toHexStr lps+                        <> ";chunk-signature="+                        <> nextSign+                        <> "\r\n"+                        <> bs+                        <> "\r\n"+                C.yield chunkBS+                signerConduit 0 0 nextSign++            -- Last case encodes the final signature chunk that has no+            -- data.+            | otherwise -> do+                let strToSign = chunkStrToSign prevSign (hashSHA256 "")+                    nextSign = computeSignature strToSign signingKey+                    lastChunkBS = "0;chunk-signature=" <> nextSign <> "\r\n\r\n"+                C.yield lastChunkBS+   in \src ->+        req+          { NC.requestHeaders = finalReqHeaders,+            NC.requestBody =+              NC.requestBodySource signedContentLength $+                src C..| signerConduit numParts lastPSize seedSignature+          }++-- "setHeader r hdr" adds the hdr to r, replacing it in r if it already exists.+setHeader :: Header -> RequestHeaders -> RequestHeaders+setHeader hdr r =+  let r' = filter (\(name, _) -> name /= fst hdr) r+   in hdr : r'
+ vendor/minio-hs-1.7.0/src/Network/Minio/Utils.hs view
@@ -0,0 +1,285 @@+--+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.Utils where++import qualified Conduit as C+import Control.Monad.IO.Unlift (MonadUnliftIO)+import qualified Control.Monad.Trans.Resource as R+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import Data.CaseInsensitive (mk, original)+import qualified Data.Conduit.Binary as CB+import qualified Data.HashMap.Strict as H+import qualified Data.Text as T+import Data.Text.Read (decimal)+import Data.Time+  ( defaultTimeLocale,+    parseTimeM,+    rfc822DateFormat,+  )+import Lib.Prelude+import Network.HTTP.Conduit (Response)+import qualified Network.HTTP.Conduit as NC+import qualified Network.HTTP.Types as HT+import qualified Network.HTTP.Types.Header as Hdr+import Network.Minio.Data.ByteString+import Network.Minio.JsonParser (parseErrResponseJSON)+import Network.Minio.XmlCommon (parseErrResponse)+import qualified System.IO as IO+import qualified UnliftIO as U+import qualified UnliftIO.Async as A++allocateReadFile ::+  (MonadUnliftIO m, R.MonadResource m) =>+  FilePath ->+  m (R.ReleaseKey, Handle)+allocateReadFile fp = do+  (rk, hdlE) <- R.allocate (openReadFile fp) cleanup+  either (\(e :: U.IOException) -> throwIO e) (return . (rk,)) hdlE+  where+    openReadFile f = U.try $ IO.openBinaryFile f IO.ReadMode+    cleanup = either (const $ return ()) IO.hClose++-- | Queries the file size from the handle. Catches any file operation+-- exceptions and returns Nothing instead.+getFileSize ::+  (MonadUnliftIO m) =>+  Handle ->+  m (Maybe Int64)+getFileSize h = do+  resE <- liftIO $ try $ fromIntegral <$> IO.hFileSize h+  case resE of+    Left (_ :: U.IOException) -> return Nothing+    Right s -> return $ Just s++-- | Queries if handle is seekable. Catches any file operation+-- exceptions and return False instead.+isHandleSeekable ::+  (R.MonadResource m) =>+  Handle ->+  m Bool+isHandleSeekable h = do+  resE <- liftIO $ try $ IO.hIsSeekable h+  case resE of+    Left (_ :: U.IOException) -> return False+    Right v -> return v++-- | Helper function that opens a handle to the filepath and performs+-- the given action on it. Exceptions of type MError are caught and+-- returned - both during file handle allocation and when the action+-- is run.+withNewHandle ::+  (MonadUnliftIO m, R.MonadResource m) =>+  FilePath ->+  (Handle -> m a) ->+  m (Either U.IOException a)+withNewHandle fp fileAction = do+  -- opening a handle can throw MError exception.+  handleE <- try $ allocateReadFile fp+  either (return . Left) doAction handleE+  where+    doAction (rkey, h) = do+      -- fileAction may also throw MError exception, so we catch and+      -- return it.+      resE <- try $ fileAction h+      R.release rkey+      return resE++mkHeaderFromPairs :: [(ByteString, ByteString)] -> [HT.Header]+mkHeaderFromPairs = map (first mk)++lookupHeader :: HT.HeaderName -> [HT.Header] -> Maybe ByteString+lookupHeader hdr = listToMaybe . map snd . filter (\(h, _) -> h == hdr)++getETagHeader :: [HT.Header] -> Maybe Text+getETagHeader hs = decodeUtf8Lenient <$> lookupHeader Hdr.hETag hs++getMetadata :: [HT.Header] -> [(Text, Text)]+getMetadata =+  map (\(x, y) -> (decodeUtf8Lenient $ original x, decodeUtf8Lenient $ stripBS y))++-- | If the given header name has the @X-Amz-Meta-@ prefix, it is+-- stripped and a Just is returned.+userMetadataHeaderNameMaybe :: Text -> Maybe Text+userMetadataHeaderNameMaybe k =+  let prefix = T.toCaseFold "X-Amz-Meta-"+      n = T.length prefix+   in if T.toCaseFold (T.take n k) == prefix+        then Just (T.drop n k)+        else Nothing++toMaybeMetadataHeader :: (Text, Text) -> Maybe (Text, Text)+toMaybeMetadataHeader (k, v) =+  (,v) <$> userMetadataHeaderNameMaybe k++getNonUserMetadataMap :: [(Text, Text)] -> H.HashMap Text Text+getNonUserMetadataMap =+  H.fromList+    . filter+      ( isNothing+          . userMetadataHeaderNameMaybe+          . fst+      )++addXAmzMetaPrefix :: Text -> Text+addXAmzMetaPrefix s+  | isJust (userMetadataHeaderNameMaybe s) = s+  | otherwise = "X-Amz-Meta-" <> s++mkHeaderFromMetadata :: [(Text, Text)] -> [HT.Header]+mkHeaderFromMetadata = map (\(x, y) -> (mk $ encodeUtf8 $ addXAmzMetaPrefix x, encodeUtf8 y))++-- | This function collects all headers starting with `x-amz-meta-`+-- and strips off this prefix, and returns a map.+getUserMetadataMap :: [(Text, Text)] -> H.HashMap Text Text+getUserMetadataMap =+  H.fromList+    . mapMaybe toMaybeMetadataHeader++getHostHeader :: (ByteString, Int) -> ByteString+getHostHeader (host_, port_) =+  if port_ == 80 || port_ == 443+    then host_+    else host_ <> ":" <> show port_++getLastModifiedHeader :: [HT.Header] -> Maybe UTCTime+getLastModifiedHeader hs = do+  modTimebs <- decodeUtf8Lenient <$> lookupHeader Hdr.hLastModified hs+  parseTimeM True defaultTimeLocale rfc822DateFormat (T.unpack modTimebs)++getContentLength :: [HT.Header] -> Maybe Int64+getContentLength hs = do+  nbs <- decodeUtf8Lenient <$> lookupHeader Hdr.hContentLength hs+  fst <$> either (const Nothing) Just (decimal nbs)++decodeUtf8Lenient :: ByteString -> Text+decodeUtf8Lenient = decodeUtf8With lenientDecode++isSuccessStatus :: HT.Status -> Bool+isSuccessStatus sts =+  let s = HT.statusCode sts+   in (s >= 200 && s < 300)++httpLbs ::+  (MonadIO m) =>+  NC.Request ->+  NC.Manager ->+  m (NC.Response LByteString)+httpLbs req mgr = do+  respE <- liftIO $ tryHttpEx $ NC.httpLbs req mgr+  resp <- either throwIO return respE+  unless (isSuccessStatus $ NC.responseStatus resp) $+    case contentTypeMay resp of+      Just "application/xml" -> do+        sErr <- parseErrResponse $ NC.responseBody resp+        throwIO sErr+      Just "application/json" -> do+        sErr <- parseErrResponseJSON $ NC.responseBody resp+        throwIO sErr+      _ ->+        throwIO $+          NC.HttpExceptionRequest req $+            NC.StatusCodeException (void resp) (showBS resp)++  return resp+  where+    tryHttpEx ::+      IO (NC.Response LByteString) ->+      IO (Either NC.HttpException (NC.Response LByteString))+    tryHttpEx = try+    contentTypeMay resp =+      lookupHeader Hdr.hContentType $+        NC.responseHeaders resp++http ::+  (MonadUnliftIO m, R.MonadResource m) =>+  NC.Request ->+  NC.Manager ->+  m (Response (C.ConduitT () ByteString m ()))+http req mgr = do+  respE <- tryHttpEx $ NC.http req mgr+  resp <- either throwIO return respE+  unless (isSuccessStatus $ NC.responseStatus resp) $+    case contentTypeMay resp of+      Just "application/xml" -> do+        respBody <- C.connect (NC.responseBody resp) CB.sinkLbs+        sErr <- parseErrResponse respBody+        throwIO sErr+      _ -> do+        content <- LB.toStrict . NC.responseBody <$> NC.lbsResponse resp+        throwIO $+          NC.HttpExceptionRequest req $+            NC.StatusCodeException (void resp) content++  return resp+  where+    tryHttpEx ::+      (MonadUnliftIO m) =>+      m a ->+      m (Either NC.HttpException a)+    tryHttpEx = try+    contentTypeMay resp =+      lookupHeader Hdr.hContentType $+        NC.responseHeaders resp++-- Similar to mapConcurrently but limits the number of threads that+-- can run using a quantity semaphore.+limitedMapConcurrently ::+  (MonadUnliftIO m) =>+  Int ->+  (t -> m a) ->+  [t] ->+  m [a]+limitedMapConcurrently 0 _ _ = return []+limitedMapConcurrently count act args = do+  t' <- U.newTVarIO count+  threads <- mapM (A.async . wThread t') args+  mapM A.wait threads+  where+    wThread t arg =+      U.bracket_ (waitSem t) (signalSem t) $ act arg+    -- quantity semaphore implementation using TVar+    waitSem t = U.atomically $ do+      v <- U.readTVar t+      if v > 0+        then U.writeTVar t (v - 1)+        else U.retrySTM+    signalSem t = U.atomically $ do+      v <- U.readTVar t+      U.writeTVar t (v + 1)++-- helper function to 'drop' empty optional parameter.+mkQuery :: Text -> Maybe Text -> Maybe (Text, Text)+mkQuery k mv = (k,) <$> mv++-- helper function to build query parameters that are optional.+-- don't use it with mandatory query params with empty value.+mkOptionalParams :: [(Text, Maybe Text)] -> HT.Query+mkOptionalParams params = HT.toQuery $ uncurry mkQuery <$> params++-- | Conduit that rechunks bytestrings into the given chunk+-- lengths. Stops after given chunk lengths are yielded. Stops if+-- there are no more chunks to yield or if a shorter chunk is+-- received. Does not throw any errors.+chunkBSConduit :: (Monad m) => [Int] -> C.ConduitM ByteString ByteString m ()+chunkBSConduit [] = return ()+chunkBSConduit (s : ss) = do+  bs <- fmap LB.toStrict $ C.takeCE s C..| C.sinkLazy+  if+      | B.length bs == s -> C.yield bs >> chunkBSConduit ss+      | B.length bs > 0 -> C.yield bs+      | otherwise -> return ()
+ vendor/minio-hs-1.7.0/src/Network/Minio/XmlCommon.hs view
@@ -0,0 +1,65 @@+--+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.XmlCommon where++import qualified Data.Text as T+import Data.Text.Read (decimal)+import Data.Time (UTCTime)+import Data.Time.Format.ISO8601 (iso8601ParseM)+import Lib.Prelude (throwIO)+import Network.Minio.Errors+import Text.XML (Name (Name), def, parseLBS)+import Text.XML.Cursor (Axis, Cursor, content, element, fromDocument, laxElement, ($/), (&/))++s3Name :: Text -> Text -> Name+s3Name ns s = Name s (Just ns) Nothing++uncurry4 :: (a -> b -> c -> d -> e) -> (a, b, c, d) -> e+uncurry4 f (a, b, c, d) = f a b c d++uncurry6 :: (a -> b -> c -> d -> e -> f -> g) -> (a, b, c, d, e, f) -> g+uncurry6 f (a, b, c, d, e, g) = f a b c d e g++-- | Parse time strings from XML+parseS3XMLTime :: (MonadIO m) => Text -> m UTCTime+parseS3XMLTime t =+  maybe (throwIO $ MErrVXmlParse $ "timestamp parse failure: " <> t) return $+    iso8601ParseM $+      toString t++parseDecimal :: (MonadIO m, Integral a) => Text -> m a+parseDecimal numStr =+  either (throwIO . MErrVXmlParse . show) return $+    fst <$> decimal numStr++parseDecimals :: (MonadIO m, Integral a) => [Text] -> m [a]+parseDecimals numStr = forM numStr parseDecimal++s3Elem :: Text -> Text -> Axis+s3Elem ns = element . s3Name ns++parseRoot :: (MonadIO m) => LByteString -> m Cursor+parseRoot =+  either (throwIO . MErrVXmlParse . show) (return . fromDocument)+    . parseLBS def++parseErrResponse :: (MonadIO m) => LByteString -> m ServiceErr+parseErrResponse xmldata = do+  r <- parseRoot xmldata+  let code = T.concat $ r $/ laxElement "Code" &/ content+      message = T.concat $ r $/ laxElement "Message" &/ content+  return $ toServiceErr code message
+ vendor/minio-hs-1.7.0/src/Network/Minio/XmlGenerator.hs view
@@ -0,0 +1,231 @@+--+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.XmlGenerator+  ( mkCreateBucketConfig,+    mkCompleteMultipartUploadRequest,+    mkPutNotificationRequest,+    mkSelectRequest,+  )+where++import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as T+import Network.Minio.Data+import Network.Minio.XmlCommon+import Text.XML++-- | Create a bucketConfig request body XML+mkCreateBucketConfig :: Text -> Region -> ByteString+mkCreateBucketConfig ns location = LBS.toStrict $ renderLBS def bucketConfig+  where+    s3Element n = Element (s3Name ns n) mempty+    root =+      s3Element+        "CreateBucketConfiguration"+        [ NodeElement $+            s3Element+              "LocationConstraint"+              [NodeContent location]+        ]+    bucketConfig = Document (Prologue [] Nothing []) root []++-- | Create a completeMultipartUpload request body XML+mkCompleteMultipartUploadRequest :: [PartTuple] -> ByteString+mkCompleteMultipartUploadRequest partInfo =+  LBS.toStrict $ renderLBS def cmur+  where+    root =+      Element "CompleteMultipartUpload" mempty $+        map (NodeElement . mkPart) partInfo+    mkPart (n, etag) =+      Element+        "Part"+        mempty+        [ NodeElement $+            Element+              "PartNumber"+              mempty+              [NodeContent $ T.pack $ show n],+          NodeElement $+            Element+              "ETag"+              mempty+              [NodeContent etag]+        ]+    cmur = Document (Prologue [] Nothing []) root []++-- Simplified XML representation without element attributes.+data XNode+  = XNode Text [XNode]+  | XLeaf Text Text+  deriving stock (Eq, Show)++toXML :: Text -> XNode -> ByteString+toXML ns node =+  LBS.toStrict $+    renderLBS def $+      Document (Prologue [] Nothing []) (xmlNode node) []+  where+    xmlNode :: XNode -> Element+    xmlNode (XNode name nodes) =+      Element (s3Name ns name) mempty $+        map (NodeElement . xmlNode) nodes+    xmlNode (XLeaf name content) =+      Element+        (s3Name ns name)+        mempty+        [NodeContent content]++class ToXNode a where+  toXNode :: a -> XNode++instance ToXNode Event where+  toXNode = XLeaf "Event" . toText++instance ToXNode Notification where+  toXNode (Notification qc tc lc) =+    XNode "NotificationConfiguration" $+      map (toXNodesWithArnName "QueueConfiguration" "Queue") qc+        ++ map (toXNodesWithArnName "TopicConfiguration" "Topic") tc+        ++ map (toXNodesWithArnName "CloudFunctionConfiguration" "CloudFunction") lc++toXNodesWithArnName :: Text -> Text -> NotificationConfig -> XNode+toXNodesWithArnName eltName arnName (NotificationConfig itemId arn events fRule) =+  XNode eltName $+    [XLeaf "Id" itemId, XLeaf arnName arn]+      ++ map toXNode events+      ++ [toXNode fRule]++instance ToXNode Filter where+  toXNode (Filter (FilterKey (FilterRules rules))) =+    XNode "Filter" [XNode "S3Key" (map getFRXNode rules)]++getFRXNode :: FilterRule -> XNode+getFRXNode (FilterRule n v) =+  XNode+    "FilterRule"+    [ XLeaf "Name" n,+      XLeaf "Value" v+    ]++mkPutNotificationRequest :: Text -> Notification -> ByteString+mkPutNotificationRequest ns = toXML ns . toXNode++mkSelectRequest :: SelectRequest -> ByteString+mkSelectRequest r = LBS.toStrict $ renderLBS def sr+  where+    sr = Document (Prologue [] Nothing []) root []+    root =+      Element "SelectRequest" mempty $+        [ NodeElement+            ( Element+                "Expression"+                mempty+                [NodeContent $ srExpression r]+            ),+          NodeElement+            ( Element+                "ExpressionType"+                mempty+                [NodeContent $ show $ srExpressionType r]+            ),+          NodeElement+            ( Element "InputSerialization" mempty $+                inputSerializationNodes $+                  srInputSerialization r+            ),+          NodeElement+            ( Element "OutputSerialization" mempty $+                outputSerializationNodes $+                  srOutputSerialization r+            )+        ]+          ++ maybe [] reqProgElem (srRequestProgressEnabled r)+    reqProgElem enabled =+      [ NodeElement+          ( Element+              "RequestProgress"+              mempty+              [ NodeElement+                  ( Element+                      "Enabled"+                      mempty+                      [ NodeContent+                          (if enabled then "TRUE" else "FALSE")+                      ]+                  )+              ]+          )+      ]+    inputSerializationNodes is =+      comprTypeNode (isCompressionType is)+        ++ [NodeElement $ formatNode (isFormatInfo is)]+    comprTypeNode (Just c) =+      [ NodeElement $+          Element+            "CompressionType"+            mempty+            [ NodeContent $ case c of+                CompressionTypeNone -> "NONE"+                CompressionTypeGzip -> "GZIP"+                CompressionTypeBzip2 -> "BZIP2"+            ]+      ]+    comprTypeNode Nothing = []+    kvElement (k, v) = Element (Name k Nothing Nothing) mempty [NodeContent v]+    formatNode (InputFormatCSV c) =+      Element+        "CSV"+        mempty+        (map (NodeElement . kvElement) (csvPropsList c))+    formatNode (InputFormatJSON p) =+      Element+        "JSON"+        mempty+        [ NodeElement+            ( Element+                "Type"+                mempty+                [ NodeContent $ case jsonipType p of+                    JSONTypeDocument -> "DOCUMENT"+                    JSONTypeLines -> "LINES"+                ]+            )+        ]+    formatNode InputFormatParquet = Element "Parquet" mempty []+    outputSerializationNodes (OutputSerializationJSON j) =+      [ NodeElement+          ( Element "JSON" mempty $+              rdElem $+                jsonopRecordDelimiter j+          )+      ]+    outputSerializationNodes (OutputSerializationCSV c) =+      [ NodeElement $+          Element+            "CSV"+            mempty+            (map (NodeElement . kvElement) (csvPropsList c))+      ]+    rdElem Nothing = []+    rdElem (Just t) =+      [ NodeElement $+          Element+            "RecordDelimiter"+            mempty+            [NodeContent t]+      ]
+ vendor/minio-hs-1.7.0/src/Network/Minio/XmlParser.hs view
@@ -0,0 +1,230 @@+--+-- MinIO Haskell SDK, (C) 2017-2023 MinIO, Inc.+--+-- Licensed under the Apache License, Version 2.0 (the "License");+-- you may not use this file except in compliance with the License.+-- You may obtain a copy of the License at+--+--     http://www.apache.org/licenses/LICENSE-2.0+--+-- Unless required by applicable law or agreed to in writing, software+-- distributed under the License is distributed on an "AS IS" BASIS,+-- WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+-- See the License for the specific language governing permissions and+-- limitations under the License.+--++module Network.Minio.XmlParser+  ( parseListBuckets,+    parseLocation,+    parseNewMultipartUpload,+    parseCompleteMultipartUploadResponse,+    parseCopyObjectResponse,+    parseListObjectsResponse,+    parseListObjectsV1Response,+    parseListUploadsResponse,+    parseListPartsResponse,+    parseErrResponse,+    parseNotification,+    parseSelectProgress,+  )+where++import qualified Data.ByteString.Lazy as LB+import qualified Data.HashMap.Strict as H+import Data.List (zip4, zip6)+import qualified Data.Text as T+import Data.Time+import Network.Minio.Data+import Network.Minio.XmlCommon+import Text.XML.Cursor hiding (bool)++-- | Parse the response XML of a list buckets call.+parseListBuckets :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m [BucketInfo]+parseListBuckets xmldata = do+  r <- parseRoot xmldata+  ns <- asks getSvcNamespace+  let s3Elem' = s3Elem ns+      names = r $// s3Elem' "Bucket" &// s3Elem' "Name" &/ content+      timeStrings = r $// s3Elem' "Bucket" &// s3Elem' "CreationDate" &/ content++  times <- mapM parseS3XMLTime timeStrings+  return $ zipWith BucketInfo names times++-- | Parse the response XML of a location request.+parseLocation :: (MonadIO m) => LByteString -> m Region+parseLocation xmldata = do+  r <- parseRoot xmldata+  let region = T.concat $ r $/ content+  return $ bool "us-east-1" region $ region /= ""++-- | Parse the response XML of an newMultipartUpload call.+parseNewMultipartUpload :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m UploadId+parseNewMultipartUpload xmldata = do+  r <- parseRoot xmldata+  ns <- asks getSvcNamespace+  let s3Elem' = s3Elem ns+  return $ T.concat $ r $// s3Elem' "UploadId" &/ content++-- | Parse the response XML of completeMultipartUpload call.+parseCompleteMultipartUploadResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ETag+parseCompleteMultipartUploadResponse xmldata = do+  r <- parseRoot xmldata+  ns <- asks getSvcNamespace+  let s3Elem' = s3Elem ns+  return $ T.concat $ r $// s3Elem' "ETag" &/ content++-- | Parse the response XML of copyObject and copyObjectPart+parseCopyObjectResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m (ETag, UTCTime)+parseCopyObjectResponse xmldata = do+  r <- parseRoot xmldata+  ns <- asks getSvcNamespace+  let s3Elem' = s3Elem ns+      mtimeStr = T.concat $ r $// s3Elem' "LastModified" &/ content++  mtime <- parseS3XMLTime mtimeStr+  return (T.concat $ r $// s3Elem' "ETag" &/ content, mtime)++-- | Parse the response XML of a list objects v1 call.+parseListObjectsV1Response ::+  (MonadReader env m, HasSvcNamespace env, MonadIO m) =>+  LByteString ->+  m ListObjectsV1Result+parseListObjectsV1Response xmldata = do+  r <- parseRoot xmldata+  ns <- asks getSvcNamespace+  let s3Elem' = s3Elem ns+      hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)+      nextMarker = listToMaybe $ r $/ s3Elem' "NextMarker" &/ content+      prefixes = r $/ s3Elem' "CommonPrefixes" &/ s3Elem' "Prefix" &/ content+      keys = r $/ s3Elem' "Contents" &/ s3Elem' "Key" &/ content+      modTimeStr = r $/ s3Elem' "Contents" &/ s3Elem' "LastModified" &/ content+      etagsList = r $/ s3Elem' "Contents" &/ s3Elem' "ETag" &/ content+      -- if response xml contains empty etag response fill them with as+      -- many empty Text for the zip4 below to work as intended.+      etags = etagsList ++ repeat ""+      sizeStr = r $/ s3Elem' "Contents" &/ s3Elem' "Size" &/ content++  modTimes <- mapM parseS3XMLTime modTimeStr+  sizes <- parseDecimals sizeStr++  let objects =+        map (uncurry6 ObjectInfo) $+          zip6 keys modTimes etags sizes (repeat H.empty) (repeat H.empty)++  return $ ListObjectsV1Result hasMore nextMarker objects prefixes++-- | Parse the response XML of a list objects call.+parseListObjectsResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ListObjectsResult+parseListObjectsResponse xmldata = do+  r <- parseRoot xmldata+  ns <- asks getSvcNamespace+  let s3Elem' = s3Elem ns+      hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)+      nextToken = listToMaybe $ r $/ s3Elem' "NextContinuationToken" &/ content+      prefixes = r $/ s3Elem' "CommonPrefixes" &/ s3Elem' "Prefix" &/ content+      keys = r $/ s3Elem' "Contents" &/ s3Elem' "Key" &/ content+      modTimeStr = r $/ s3Elem' "Contents" &/ s3Elem' "LastModified" &/ content+      etagsList = r $/ s3Elem' "Contents" &/ s3Elem' "ETag" &/ content+      -- if response xml contains empty etag response fill them with as+      -- many empty Text for the zip4 below to work as intended.+      etags = etagsList ++ repeat ""+      sizeStr = r $/ s3Elem' "Contents" &/ s3Elem' "Size" &/ content++  modTimes <- mapM parseS3XMLTime modTimeStr+  sizes <- parseDecimals sizeStr++  let objects =+        map (uncurry6 ObjectInfo) $+          zip6 keys modTimes etags sizes (repeat H.empty) (repeat H.empty)++  return $ ListObjectsResult hasMore nextToken objects prefixes++-- | Parse the response XML of a list incomplete multipart upload call.+parseListUploadsResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ListUploadsResult+parseListUploadsResponse xmldata = do+  r <- parseRoot xmldata+  ns <- asks getSvcNamespace+  let s3Elem' = s3Elem ns+      hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)+      prefixes = r $/ s3Elem' "CommonPrefixes" &/ s3Elem' "Prefix" &/ content+      nextKey = listToMaybe $ r $/ s3Elem' "NextKeyMarker" &/ content+      nextUpload = listToMaybe $ r $/ s3Elem' "NextUploadIdMarker" &/ content+      uploadKeys = r $/ s3Elem' "Upload" &/ s3Elem' "Key" &/ content+      uploadIds = r $/ s3Elem' "Upload" &/ s3Elem' "UploadId" &/ content+      uploadInitTimeStr = r $/ s3Elem' "Upload" &/ s3Elem' "Initiated" &/ content++  uploadInitTimes <- mapM parseS3XMLTime uploadInitTimeStr++  let uploads = zip3 uploadKeys uploadIds uploadInitTimes++  return $ ListUploadsResult hasMore nextKey nextUpload uploads prefixes++parseListPartsResponse :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m ListPartsResult+parseListPartsResponse xmldata = do+  r <- parseRoot xmldata+  ns <- asks getSvcNamespace+  let s3Elem' = s3Elem ns+      hasMore = ["true"] == (r $/ s3Elem' "IsTruncated" &/ content)+      nextPartNumStr = listToMaybe $ r $/ s3Elem' "NextPartNumberMarker" &/ content+      partNumberStr = r $/ s3Elem' "Part" &/ s3Elem' "PartNumber" &/ content+      partModTimeStr = r $/ s3Elem' "Part" &/ s3Elem' "LastModified" &/ content+      partETags = r $/ s3Elem' "Part" &/ s3Elem' "ETag" &/ content+      partSizeStr = r $/ s3Elem' "Part" &/ s3Elem' "Size" &/ content++  partModTimes <- mapM parseS3XMLTime partModTimeStr+  partSizes <- parseDecimals partSizeStr+  partNumbers <- parseDecimals partNumberStr+  nextPartNum <- parseDecimals $ maybeToList nextPartNumStr++  let partInfos =+        map (uncurry4 ObjectPartInfo) $+          zip4 partNumbers partETags partSizes partModTimes++  return $ ListPartsResult hasMore (listToMaybe nextPartNum) partInfos++parseNotification :: (MonadReader env m, HasSvcNamespace env, MonadIO m) => LByteString -> m Notification+parseNotification xmldata = do+  r <- parseRoot xmldata+  ns <- asks getSvcNamespace+  let s3Elem' = s3Elem ns+      qcfg = map node $ r $/ s3Elem' "QueueConfiguration"+      tcfg = map node $ r $/ s3Elem' "TopicConfiguration"+      lcfg = map node $ r $/ s3Elem' "CloudFunctionConfiguration"+  Notification+    <$> mapM (parseNode ns "Queue") qcfg+    <*> mapM (parseNode ns "Topic") tcfg+    <*> mapM (parseNode ns "CloudFunction") lcfg+  where+    getFilterRule ns c =+      let name = T.concat $ c $/ s3Elem ns "Name" &/ content+          value = T.concat $ c $/ s3Elem ns "Value" &/ content+       in FilterRule name value+    parseNode ns arnName nodeData = do+      let c = fromNode nodeData+          itemId = T.concat $ c $/ s3Elem ns "Id" &/ content+          arn = T.concat $ c $/ s3Elem ns arnName &/ content+          events = mapMaybe textToEvent (c $/ s3Elem ns "Event" &/ content)+          rules =+            c+              $/ s3Elem ns "Filter"+              &/ s3Elem ns "S3Key"+              &/ s3Elem ns "FilterRule"+              &| getFilterRule ns+      return $+        NotificationConfig+          itemId+          arn+          events+          (Filter $ FilterKey $ FilterRules rules)++parseSelectProgress :: (MonadIO m) => ByteString -> m Progress+parseSelectProgress xmldata = do+  r <- parseRoot $ LB.fromStrict xmldata+  let bScanned = T.concat $ r $/ element "BytesScanned" &/ content+      bProcessed = T.concat $ r $/ element "BytesProcessed" &/ content+      bReturned = T.concat $ r $/ element "BytesReturned" &/ content+  Progress+    <$> parseDecimal bScanned+    <*> parseDecimal bProcessed+    <*> parseDecimal bReturned
+ vendor/placeholder-0/src/Control/Placeholder.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE ImplicitParams #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Copyright  : (c) Edward Kmett 2024+-- License    : BSD-2-Clause OR Apache-2.0+-- Maintainer : Edward Kmett <ekmett@gmail.com>+-- Stability  : experimental+-- Portability: non-portable+--+-- Various functions to indicate unfinished or generally unimplemented code ++#if __GLASGOW_HASKELL__ >= 980+#define WARNING_IN_XTODO WARNING in "x-todo"+#else+#define WARNING_IN_XTODO WARNING+#endif++module Control.Placeholder+  (+  -- * Combinators+    todo+  , unimplemented+  -- * Patterns+  , pattern TODO+  , pattern Unimplemented+  -- * IO+  , todoIO+  , unimplementedIO+  -- * Exceptions+  , TodoException(TodoException, TodoExceptionWithLocation)+  , UnimplementedException(UnimplementedException, UnimplementedExceptionWithLocation)+  ) where++import Control.Exception+import Data.List (intercalate)+import Data.Typeable+import GHC.Base (raise#, raiseIO#, TYPE, RuntimeRep)+import GHC.Exception+import GHC.Stack+import GHC.Types (IO(IO))+import System.IO.Unsafe++-- | This is the 'Exception' thrown by 'todo', 'TODO' and 'todoIO'.+newtype TodoException = TodoExceptionWithLocation String+  deriving (Typeable, Exception)++instance Show TodoException where+  showsPrec _ (TodoExceptionWithLocation loc)+    = showString todoMessage . showChar '\n' . showString loc++-- | This lets us discard the location information in a TodoException+pattern TodoException :: TodoException+pattern TodoException <- TodoExceptionWithLocation _ where+  TodoException = TodoExceptionWithLocation missingLocation++-- | This is the 'Exception' thrown by 'unimplemented', 'Unimplemented', and 'unimplementedIO'.+newtype UnimplementedException = UnimplementedExceptionWithLocation String+  deriving (Typeable, Exception)++instance Show UnimplementedException where+  showsPrec _ (UnimplementedExceptionWithLocation loc)+    = showString unimplementedMessage . showChar '\n' . showString loc++pattern UnimplementedException :: UnimplementedException+pattern UnimplementedException <- UnimplementedExceptionWithLocation _ where+  UnimplementedException = UnimplementedExceptionWithLocation missingLocation++-- | robust retrieval of the current callstack suitable for custom exception types+withCallStack :: Exception a => (String -> a) -> CallStack -> SomeException+withCallStack f stk = unsafeDupablePerformIO do+  ccsStack <- currentCallStack+  let+    implicitParamCallStack = prettyCallStackLines stk+    ccsCallStack+      | [] <- ccsStack = []+      | otherwise = "CallStack (from -prof):" : map ("  " ++) (reverse ccsStack)+    stack = intercalate "\n" $ implicitParamCallStack ++ ccsCallStack+  pure $ toException $ f stack++{- | 'todo' indicates unfinished code.++It is to be used whenever you want to indicate that you are missing a part of+the implementation and want to fill that in later.++The main difference to other alternatives like 'undefined'+or 'error' is this also emits a warning at compile time.++Similarly to 'undefined' and 'error', this will throw an error if+it is evaluated at runtime which can only be caught in 'IO'. Unlike typed holes,+at least without @-fdefer-typed-holes@ enabled, compilation is allowed to proceed+and the program can be run.++Variants such as 'TODO' and 'todoIO' allow usage in patterns and offer more control+over when the exception is thrown when this code is encountered at runtime.++This is intended to *never* stay in code but exists purely for signifying+"work in progress" code.++To make the emitted warning error instead (e.g. for the use in CI), add+the @-Werror=x-todo@ flag to your @OPTIONS_GHC@.++==== __Examples__++@+superComplexFunction :: 'Maybe' a -> 'IO' 'Int'+-- we already know how to implement this in the 'Nothing' case+superComplexFunction 'Nothing' = 'pure' 42+-- but the 'Just' case is super complicated, so we leave it as 'todo' for now+superComplexFunction ('Just' a) = 'todo'+@++==== __Representation Polymorphism__++'todo', in contrast to 'TODO', is fully representation polymorphic+-}+todo :: forall {r :: RuntimeRep} (a :: TYPE r). HasCallStack => a+todo = raise# $ withCallStack TodoExceptionWithLocation ?callStack+{-# WARNING_IN_XTODO todo "'todo' left in code" #-}++{- | 'todoIO' indicates unfinished code that lives in the IO monad.++It should be used similarly to how 'throwIO' should be used rather than 'throw' in IO+to throw at the time the IO action is run rather than at the time it is created.++-}+todoIO :: HasCallStack => IO a+todoIO = IO $ raiseIO# $ withCallStack TodoExceptionWithLocation ?callStack+{-# WARNING_IN_XTODO todoIO "'todoIO' left in code" #-}++{- | 'TODO' indicates unfinished code or an unfinished pattern match++You can use this in most positions where you could pass 'todo', but it also can be used in pattern position+to indicate that there are cases you haven't considered.++There remain some circumstances where you can only use 'todo', however, they arise when using this in a "PolyKinded" situation.++This pattern synonym is marked @COMPLETE@, implying that every match after matching on 'TODO'+will /emit a redundant pattern match warning/. Adding new options to your datatype, similarly+to how wildcard patterns (patterns starting with an underscore) work, will /not cause any warnings or errors/.++==== __Examples__++Since the pattern match is strict, even if the branch itself does not evaluate to bottom, matching on+'TODO' will.++@+>>> x = []+>>> case x of+...   (x : _) -> x+...   'TODO' -> 42+*** Exception: Control.Placeholder.todo: not yet implemented+@++As usual, this behaviour can be reversed by using a @~@ in front of 'TODO' in pattern position.++@+>>> x = []+>>> case x of+...   (x : _) -> x+...   ~'TODO' -> 42+42+@++In most situations, 'TODO' can be used just like 'todo', where the above is equivalent to the below++@+>>> y :: 'Data.Int.Int' = 'todo'+>>> x :: 'Data.Int.Int' = 'TODO'+@+++==== __Representation Polymorphism__++Mind that pattern synonyms may not be representation polymorphic, hence, if you need something+that can be used with some kind other than 'Data.Kind.Type', you have to use 'todo'. For example,+'TODO' cannot stand instead of a pattern match on an @'GHC.Exts.Int#' :: 'TYPE' 'GHC.Exts.IntRep'@+or as a placeholder for a @'GHC.Exts.ByteArray#' :: 'GHC.Exts.UnliftedType'@+-}+pattern TODO :: HasCallStack => () => a+pattern TODO <- (raise# (withCallStack TodoExceptionWithLocation ?callStack) -> _unused) where+  TODO = raise# $ withCallStack TodoExceptionWithLocation ?callStack+{-# WARNING_IN_XTODO TODO "'TODO' left in code" #-}+{-# COMPLETE TODO #-}++{- | 'unimplemented' indicates that the relevant code is unimplemented. Unlike 'todo', it is expected that this _may_ remain in code+long term, and so no warning is supplied. Use cases might include places where a typeclass would theoretically require a member to be+implemented, but where the resulting violation is actually intended.+-}++unimplemented :: forall {r :: RuntimeRep} (a :: TYPE r). HasCallStack => a+unimplemented = raise# $ withCallStack UnimplementedExceptionWithLocation ?callStack++{- | 'unimplementedIO' indicates that the method is unimplemented, but it lives in IO, and so only throws when actually run, rather+than when it is constructed. Unlike 'todoIO' it does not provide a compile-time warning, as it is expected that this _may_ remain in+code long term.++-}++unimplementedIO :: HasCallStack => IO a+unimplementedIO = IO $ raiseIO# $ withCallStack UnimplementedExceptionWithLocation ?callStack++{- | 'Unimplemented' can be used in most circumstances 'unimplemented' can, but it can also be used in pattern position to indicate cases+haven't been considered yet. Unlike 'TODO' it does not provide a compile-time warning, as it is expected that this _may_ remain in code long term.++-}+pattern Unimplemented :: HasCallStack => () => a+pattern Unimplemented <- (raise# (withCallStack UnimplementedExceptionWithLocation ?callStack) -> _unused) where+  Unimplemented = raise# $ withCallStack UnimplementedExceptionWithLocation ?callStack+{-# COMPLETE Unimplemented #-}++missingLocation :: String+missingLocation = ""+{-# NOINLINE missingLocation #-}++todoMessage :: String+todoMessage = "Control.Placeholder.todo: not yet implemented"+{-# NOINLINE todoMessage #-}++unimplementedMessage :: String+unimplementedMessage = "Control.Placeholder.unimplemented: unimplemented"+{-# NOINLINE unimplementedMessage #-}+
+ vendor/warp-tls-3.4.13/Network/Wai/Handler/WarpTLS.hs view
@@ -0,0 +1,562 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}++-- | HTTP over TLS support for Warp via the TLS package.+--+--   If HTTP\/2 is negotiated by ALPN, HTTP\/2 over TLS is used.+--   Otherwise HTTP\/1.1 over TLS is used.+--+--   Support for SSL is now obsoleted.+module Network.Wai.Handler.WarpTLS (+    -- * Runner+    runTLS,+    runTLSSocket,++    -- * Settings+    TLSSettings,+    defaultTlsSettings,++    -- * Smart constructors++    -- ** From files+    tlsSettings,+    tlsSettingsChain,++    -- ** From memory+    tlsSettingsMemory,+    tlsSettingsChainMemory,++    -- ** From references+    tlsSettingsRef,+    tlsSettingsChainRef,+    CertSettings,++    -- ** Dynamically retrieved+    tlsSettingsSni,++    -- * Accessors+    tlsCredentials,+    tlsLogging,+    tlsAllowedVersions,+    tlsCiphers,+    tlsWantClientCert,+    tlsServerHooks,+    tlsServerDHEParams,+    tlsSessionManagerConfig,+    tlsSessionManager,+    onInsecure,+    OnInsecure (..),++    -- * Exception+    WarpTLSException (..),++    -- * Low-level+    attachConn+) where++import Control.Applicative ((<|>))+import Control.Exception (+    Exception,+    IOException,+    SomeException (..),+    bracket,+    finally,+    fromException,+    handle,+    handleJust,+    onException,+    throwIO,+    try,+ )+import Control.Monad (guard, void)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.IORef as I+import Data.Streaming.Network (bindPortTCP, safeRecv)+import Data.Typeable (Typeable)+import GHC.IO.Exception (IOErrorType (..))+import Network.Socket (+    SockAddr,+    Socket,+    close,+    getSocketName,+#if MIN_VERSION_network(3,1,1)+    gracefulClose,+#endif+    withSocketsDo,+ )+import qualified Control.Exception as E+import Network.Socket.BufferPool+import Network.Socket.ByteString (sendAll)+import qualified Network.TLS as TLS+import qualified Network.TLS.SessionManager as SM+import Network.Wai (Application)+import Network.Wai.Handler.Warp+import Network.Wai.Handler.Warp.Internal+import Network.Wai.Handler.WarpTLS.Internal+import System.IO.Error (ioeGetErrorType, isEOFError)+import System.Timeout (timeout)++----------------------------------------------------------------++-- | A smart constructor for 'TLSSettings' based on 'defaultTlsSettings'.+tlsSettings+    :: FilePath+    -- ^ Certificate file+    -> FilePath+    -- ^ Key file+    -> TLSSettings+tlsSettings cert key =+    defaultTlsSettings+        { certSettings = CertFromFile cert [] key+        }++-- | A smart constructor for 'TLSSettings' that allows specifying+-- chain certificates based on 'defaultTlsSettings'.+--+-- Since 3.0.3+tlsSettingsChain+    :: FilePath+    -- ^ Certificate file+    -> [FilePath]+    -- ^ Chain certificate files+    -> FilePath+    -- ^ Key file+    -> TLSSettings+tlsSettingsChain cert chainCerts key =+    defaultTlsSettings+        { certSettings = CertFromFile cert chainCerts key+        }++-- | A smart constructor for 'TLSSettings', but uses in-memory representations+-- of the certificate and key based on 'defaultTlsSettings'.+--+-- Since 3.0.1+tlsSettingsMemory+    :: S.ByteString+    -- ^ Certificate bytes+    -> S.ByteString+    -- ^ Key bytes+    -> TLSSettings+tlsSettingsMemory cert key =+    defaultTlsSettings+        { certSettings = CertFromMemory cert [] key+        }++-- | A smart constructor for 'TLSSettings', but uses in-memory representations+-- of the certificate and key based on 'defaultTlsSettings'.+--+-- Since 3.0.3+tlsSettingsChainMemory+    :: S.ByteString+    -- ^ Certificate bytes+    -> [S.ByteString]+    -- ^ Chain certificate bytes+    -> S.ByteString+    -- ^ Key bytes+    -> TLSSettings+tlsSettingsChainMemory cert chainCerts key =+    defaultTlsSettings+        { certSettings = CertFromMemory cert chainCerts key+        }++-- | Smart constructor for TLS settings that obtains its credentials during+-- Server Name Indication. Can be used to return different credentials+-- depending on the hostname but also to retrieve dynamically updated+-- credentials from an IORef. Credentials can be loaded from PEM-encoded chain+-- and key files using 'TLS.credentialLoadX509'.+--+-- @since 3.4.13+tlsSettingsSni :: (Maybe TLS.HostName -> IO TLS.Credentials) -> TLSSettings+tlsSettingsSni onServerNameIndicationHook =+  defaultTlsSettings+    { tlsCredentials = Just (TLS.Credentials [])+    , tlsServerHooks = (tlsServerHooks defaultTlsSettings)+      { TLS.onServerNameIndication =  onServerNameIndicationHook+      }+    }++-- | A smart constructor for 'TLSSettings', but uses references to in-memory+-- representations of the certificate and key based on 'defaultTlsSettings'.+--+-- @since 3.3.0+tlsSettingsRef+    :: I.IORef S.ByteString+    -- ^ Reference to certificate bytes+    -> I.IORef S.ByteString+    -- ^ Reference to key bytes+    -> TLSSettings+tlsSettingsRef cert key =+    defaultTlsSettings+        { certSettings = CertFromRef cert [] key+        }++{-# DEPRECATED tlsSettingsRef "This function was added to allow Warp to serve new certificates without restarting, but it has always behaved the same as 'tlsSettingsMemory'. It will be removed in the next major release. To retain existing behavior, swich to 'tlsSettingsMemory'. To dynamically update credentials, see 'tlsSettingsSni'." #-}++-- | A smart constructor for 'TLSSettings', but uses references to in-memory+-- representations of the certificate and key based on 'defaultTlsSettings'.+--+-- @since 3.3.0+tlsSettingsChainRef+    :: I.IORef S.ByteString+    -- ^ Reference to certificate bytes+    -> [I.IORef S.ByteString]+    -- ^ Reference to chain certificate bytes+    -> I.IORef S.ByteString+    -- ^ Reference to key bytes+    -> TLSSettings+tlsSettingsChainRef cert chainCerts key =+    defaultTlsSettings+        { certSettings = CertFromRef cert chainCerts key+        }++{-# DEPRECATED tlsSettingsChainRef "This function was added to allow Warp to serve new certificates without restarting, but it has always behaved the same as 'tlsSettingsChainMemory'. It will be removed in the next major release. To retain existing behavior, swich to 'tlsSettingsChainMemory'. To dynamically update credentials, see 'tlsSettingsSni'." #-}++----------------------------------------------------------------++-- | Running 'Application' with 'TLSSettings' and 'Settings'.+runTLS :: TLSSettings -> Settings -> Application -> IO ()+runTLS tset set app =+    withSocketsDo $+        bracket+            (bindPortTCP (getPort set) (getHost set))+            close+            ( \sock -> do+                setSocketCloseOnExec sock+                runTLSSocket tset set sock app+            )++----------------------------------------------------------------++loadCredentials :: TLSSettings -> IO TLS.Credentials+loadCredentials TLSSettings{tlsCredentials = Just creds} = return creds+loadCredentials TLSSettings{..} = case certSettings of+    CertFromFile cert chainFiles key -> do+        cred <- either error id <$> TLS.credentialLoadX509Chain cert chainFiles key+        return $ TLS.Credentials [cred]+    CertFromRef certRef chainCertsRef keyRef -> do+        cert <- I.readIORef certRef+        chainCerts <- mapM I.readIORef chainCertsRef+        key <- I.readIORef keyRef+        cred <-+            either error return $ TLS.credentialLoadX509ChainFromMemory cert chainCerts key+        return $ TLS.Credentials [cred]+    CertFromMemory certMemory chainCertsMemory keyMemory -> do+        cred <-+            either error return $+                TLS.credentialLoadX509ChainFromMemory certMemory chainCertsMemory keyMemory+        return $ TLS.Credentials [cred]++getSessionManager :: TLSSettings -> IO TLS.SessionManager+getSessionManager TLSSettings{tlsSessionManager = Just mgr} = return mgr+getSessionManager TLSSettings{..} = case tlsSessionManagerConfig of+    Nothing -> return TLS.noSessionManager+    Just config -> SM.newSessionManager config++-- | Running 'Application' with 'TLSSettings' and 'Settings' using+--   specified 'Socket'.+runTLSSocket :: TLSSettings -> Settings -> Socket -> Application -> IO ()+runTLSSocket tlsset set sock app = do+    settingsInstallShutdownHandler set (close sock)+    credentials <- loadCredentials tlsset+    mgr <- getSessionManager tlsset+    runTLSSocket' tlsset set credentials mgr sock app++runTLSSocket'+    :: TLSSettings+    -> Settings+    -> TLS.Credentials+    -> TLS.SessionManager+    -> Socket+    -> Application+    -> IO ()+runTLSSocket' tlsset@TLSSettings{..} set credentials mgr sock =+    runSettingsConnectionMakerSecure set get+  where+    get = getter tlsset set sock params+    params =+        TLS.defaultParamsServer+            { TLS.serverWantClientCert = tlsWantClientCert+            , TLS.serverCACertificates = []+            , TLS.serverDHEParams = tlsServerDHEParams+            , TLS.serverHooks = hooks+            , TLS.serverShared = shared+            , TLS.serverSupported = supported+#if MIN_VERSION_tls(1,5,0)+            , TLS.serverEarlyDataSize = 2018+#endif+            }+    -- Adding alpn to user's tlsServerHooks.+    hooks =+        tlsServerHooks+            { TLS.onALPNClientSuggest =+                TLS.onALPNClientSuggest tlsServerHooks+                    <|> (if settingsHTTP2Enabled set then Just alpn else Nothing)+            }+    shared =+        TLS.defaultShared+            { TLS.sharedCredentials = credentials+            , TLS.sharedSessionManager = mgr+            }+    supported =+        TLS.defaultSupported+            { TLS.supportedVersions = tlsAllowedVersions+            , TLS.supportedCiphers = tlsCiphers+            , TLS.supportedCompressions = [TLS.nullCompression]+            , TLS.supportedSecureRenegotiation = True+            , TLS.supportedClientInitiatedRenegotiation = False+            , TLS.supportedSession = True+            , TLS.supportedFallbackScsv = True+            , TLS.supportedHashSignatures = tlsSupportedHashSignatures+            , TLS.supportedExtendedMainSecret = TLS.AllowEMS+#if MIN_VERSION_tls(1,5,0)+            , TLS.supportedGroups = [TLS.X25519,TLS.P256,TLS.P384]+#endif+            }++alpn :: [S.ByteString] -> IO S.ByteString+alpn xs+    | "h2" `elem` xs = return "h2"+    | otherwise = return "http/1.1"++----------------------------------------------------------------++getter+    :: TLS.TLSParams params+    => TLSSettings+    -> Settings+    -> Socket+    -> params+    -> IO (IO (Connection, Transport), SockAddr)+getter tlsset set@Settings{settingsAccept = accept'} sock params = do+    (s, sa) <- accept' sock+    setSocketCloseOnExec s+    return (mkConn tlsset set s params, sa)++mkConn+    :: TLS.TLSParams params+    => TLSSettings+    -> Settings+    -> Socket+    -> params+    -> IO (Connection, Transport)+mkConn tlsset set s params = do+    let tm = settingsTimeout set * 1000000+    mbs <- timeout tm recvFirstBS+    case mbs of+      Nothing -> throwIO IncompleteHeaders+      Just bs -> switch bs+  where+    recvFirstBS = safeRecv s 4096 `onException` close s+    switch firstBS+        | S.null firstBS = close s >> throwIO ClientClosedConnectionPrematurely+        | S.head firstBS == 0x16 = httpOverTls tlsset set s firstBS params+        | otherwise = plainHTTP tlsset set s firstBS++----------------------------------------------------------------++isAsyncException :: Exception e => e -> Bool+isAsyncException e =+    case E.fromException (E.toException e) of+        Just (E.SomeAsyncException _) -> True+        Nothing -> False++throughAsync :: IO a -> SomeException -> IO a+throughAsync action (SomeException e)+  | isAsyncException e = E.throwIO e+  | otherwise          = action++httpOverTls+    :: TLS.TLSParams params+    => TLSSettings+    -> Settings+    -> Socket+    -> S.ByteString+    -> params+    -> IO (Connection, Transport)+httpOverTls TLSSettings{..} set s bs0 params =+    makeConn `onException` close s+  where+    makeConn = do+        pool <- newBufferPool 2048 16384+        rawRecvN <- makeRecvN bs0 $ receive s pool+        let recvN = wrappedRecvN rawRecvN+        ctx <- TLS.contextNew (backend recvN) params+        TLS.contextHookSetLogging ctx tlsLogging+        let tm = settingsTimeout set * 1000000+        mconn <- timeout tm $ do+            TLS.handshake ctx+            mysa <- getSocketName s+            attachConn mysa ctx+        case mconn of+          Nothing -> throwIO IncompleteHeaders+          Just conn -> return conn+    wrappedRecvN recvN n = handle (throughAsync (return "")) $ recvN n+    backend recvN =+        TLS.Backend+            { TLS.backendFlush = return ()+#if MIN_VERSION_network(3,1,1)+            , TLS.backendClose =+                gracefulClose s 5000 `E.catch` throughAsync (return ())+#else+            , TLS.backendClose = close s+#endif+            , TLS.backendSend = sendAll' s+            , TLS.backendRecv = recvN+            }+    sendAll' sock bs =+        E.handleJust+            ( \e ->+                if ioeGetErrorType e == ResourceVanished+                    then Just ConnectionClosedByPeer+                    else Nothing+            )+            throwIO+            $ sendAll sock bs++-- | Get "Connection" and "Transport" for a TLS connection that is already did the handshake.+-- @since 3.4.7+attachConn :: SockAddr -> TLS.Context -> IO (Connection, Transport)+attachConn mysa ctx = do+    h2 <- (== Just "h2") <$> TLS.getNegotiatedProtocol ctx+    isH2 <- I.newIORef h2+    writeBuffer <- createWriteBuffer 16384+    writeBufferRef <- I.newIORef writeBuffer+    -- Creating a cache for leftover input data.+    tls <- getTLSinfo ctx+    return (conn writeBufferRef isH2, tls)+  where+    conn writeBufferRef isH2 =+        Connection+            { connSendMany = TLS.sendData ctx . L.fromChunks+            , connSendAll = sendall+            , connSendFile = sendfile+            , connClose = close'+            , connRecv = recv+            , connRecvBuf = \_ _ -> return True -- obsoleted+            , connWriteBuffer = writeBufferRef+            , connHTTP2 = isH2+            , connMySockAddr = mysa+            }+      where+        sendall = TLS.sendData ctx . L.fromChunks . return+        recv = handle onEOF $ TLS.recvData ctx+          where+            onEOF e+#if MIN_VERSION_tls(1,8,0)+                | Just (TLS.PostHandshake TLS.Error_EOF) <- E.fromException e = return S.empty+#else+                | Just TLS.Error_EOF <- fromException e = return S.empty+#endif+                | Just ioe <- fromException e, isEOFError ioe = return S.empty+                | otherwise = throwIO e+        sendfile fid offset len hook headers = do+            writeBuffer <- I.readIORef writeBufferRef+            readSendFile+                (bufBuffer writeBuffer)+                (bufSize writeBuffer)+                sendall+                fid+                offset+                len+                hook+                headers++        close' =+            void (tryIO sendBye)+                `finally` TLS.contextClose ctx++        sendBye =+            -- It's fine if the connection was closed by the other side before+            -- receiving close_notify, see RFC 5246 section 7.2.1.+            handleJust+                (\e -> guard (e == ConnectionClosedByPeer) >> return e)+                (const (return ()))+                (TLS.bye ctx)++getTLSinfo :: TLS.Context -> IO Transport+getTLSinfo ctx = do+    proto <- TLS.getNegotiatedProtocol ctx+    minfo <- TLS.contextGetInformation ctx+    case minfo of+        Nothing -> return TCP+        Just info -> do+            let (major, minor) = case TLS.infoVersion info of+                    TLS.SSL2 -> (2, 0)+                    TLS.SSL3 -> (3, 0)+                    TLS.TLS10 -> (3, 1)+                    TLS.TLS11 -> (3, 2)+                    TLS.TLS12 -> (3, 3)+                    _ -> (3,4)+            clientCert <- TLS.getClientCertificateChain ctx+            return+                TLS+                    { tlsMajorVersion = major+                    , tlsMinorVersion = minor+                    , tlsNegotiatedProtocol = proto+                    , tlsChiperID = TLS.cipherID $ TLS.infoCipher info+                    , tlsClientCertificate = clientCert+                    }++tryIO :: IO a -> IO (Either IOException a)+tryIO = try++----------------------------------------------------------------++plainHTTP+    :: TLSSettings -> Settings -> Socket -> S.ByteString -> IO (Connection, Transport)+plainHTTP TLSSettings{..} set s bs0 = case onInsecure of+    AllowInsecure -> do+        conn' <- socketConnection set s+        cachedRef <- I.newIORef bs0+        let conn'' =+                conn'+                    { connRecv = recvPlain cachedRef (connRecv conn')+                    }+        return (conn'', TCP)+    DenyInsecure lbs -> do+        -- Listening port 443 but TLS records do not arrive.+        -- We want to let the browser know that TLS is required.+        -- So, we use 426.+        --     http://tools.ietf.org/html/rfc2817#section-4.2+        --     https://tools.ietf.org/html/rfc7231#section-6.5.15+        -- FIXME: should we distinguish HTTP/1.1 and HTTP/2?+        --        In the case of HTTP/2, should we send+        --        GOAWAY + INADEQUATE_SECURITY?+        -- FIXME: Content-Length:+        -- FIXME: TLS/<version>+        sendAll+            s+            "HTTP/1.1 426 Upgrade Required\+            \\r\nUpgrade: TLS/1.0, HTTP/1.1\+            \\r\nConnection: Upgrade\+            \\r\nContent-Type: text/plain\r\n\r\n"+        mapM_ (sendAll s) $ L.toChunks lbs+        close s+        throwIO InsecureConnectionDenied++----------------------------------------------------------------++-- | Modify the given receive function to first check the given @IORef@ for a+-- chunk of data. If present, takes the chunk of data from the @IORef@ and+-- empties out the @IORef@. Otherwise, calls the supplied receive function.+recvPlain :: I.IORef S.ByteString -> IO S.ByteString -> IO S.ByteString+recvPlain ref fallback = do+    bs <- I.readIORef ref+    if S.null bs+        then fallback+        else do+            I.writeIORef ref S.empty+            return bs++----------------------------------------------------------------++data WarpTLSException+    = InsecureConnectionDenied+    | ClientClosedConnectionPrematurely+    deriving (Show, Typeable)+instance Exception WarpTLSException
+ vendor/warp-tls-3.4.13/Network/Wai/Handler/WarpTLS/Internal.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.Wai.Handler.WarpTLS.Internal (+    CertSettings (..),+    TLSSettings (..),+    defaultTlsSettings,+    OnInsecure (..),++    -- * Accessors+    getCertSettings,+) where++import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import qualified Data.IORef as I+import qualified Network.TLS as TLS+import qualified Network.TLS.Extra as TLSExtra+import qualified Network.TLS.SessionManager as SM++----------------------------------------------------------------++-- | Determines where to load the certificate, chain+-- certificates, and key from.+data CertSettings+    = CertFromFile !FilePath ![FilePath] !FilePath+    | CertFromMemory !S.ByteString ![S.ByteString] !S.ByteString+    | CertFromRef+        !(I.IORef S.ByteString)+        ![I.IORef S.ByteString]+        !(I.IORef S.ByteString)++instance Show CertSettings where+    show (CertFromFile a b c) = "CertFromFile " ++ show a ++ " " ++ show b ++ " " ++ show c+    show (CertFromMemory a b c) = "CertFromMemory " ++ show a ++ " " ++ show b ++ " " ++ show c+    show CertFromRef{} = "CertFromRef"++----------------------------------------------------------------++-- | An action when a plain HTTP comes to HTTP over TLS/SSL port.+data OnInsecure+    = DenyInsecure L.ByteString+    | AllowInsecure+    deriving (Show)++----------------------------------------------------------------++-- | Settings for WarpTLS.+data TLSSettings = TLSSettings+    { certSettings :: CertSettings+    -- ^ Where are the certificate, chain certificates, and key+    -- loaded from?+    --+    -- >>> certSettings defaultTlsSettings+    -- CertFromFile "certificate.pem" [] "key.pem"+    --+    -- @since 3.3.0+    , onInsecure :: OnInsecure+    -- ^ Do we allow insecure connections with this server as well?+    --+    -- >>> onInsecure defaultTlsSettings+    -- DenyInsecure "This server only accepts secure HTTPS connections."+    --+    -- Since 1.4.0+    , tlsLogging :: TLS.Logging+    -- ^ The level of logging to turn on.+    --+    -- Default: 'TLS.defaultLogging'.+    --+    -- Since 1.4.0+    , tlsAllowedVersions :: [TLS.Version]+    -- ^ The TLS versions this server accepts.+    --+    -- Since 1.4.2+    , tlsCiphers+        :: [TLS.Cipher]+    -- ^ The TLS ciphers this server accepts.+    --+    -- Since 1.4.2+    , tlsWantClientCert :: Bool+    -- ^ Whether or not to demand a certificate from the client.  If this+    -- is set to True, you must handle received certificates in a server hook+    -- or all connections will fail.+    --+    -- >>> tlsWantClientCert defaultTlsSettings+    -- False+    --+    -- Since 3.0.2+    , tlsServerHooks :: TLS.ServerHooks+    -- ^ The server-side hooks called by the tls package, including actions+    -- to take when a client certificate is received.  See the "Network.TLS"+    -- module for details.+    --+    -- Default: defaultServerHooks+    --+    -- Since 3.0.2+    , tlsServerDHEParams :: Maybe TLS.DHParams+    -- ^ Configuration for ServerDHEParams+    -- more function lives in `crypton` package+    --+    -- Default: Nothing+    --+    -- Since 3.2.2+    , tlsSessionManagerConfig :: Maybe SM.Config+    -- ^ Configuration for in-memory TLS session manager.+    -- If Nothing, 'TLS.noSessionManager' is used.+    -- Otherwise, an in-memory TLS session manager is created+    -- according to 'Config'.+    --+    -- Default: Nothing+    --+    -- Since 3.2.4+    , tlsCredentials :: Maybe TLS.Credentials+    -- ^ Specifying 'TLS.Credentials' directly.  If this value is+    --   specified, other fields such as 'certFile' are ignored.+    --+    --   Since 3.2.12+    , tlsSessionManager :: Maybe TLS.SessionManager+    -- ^ Specifying 'TLS.SessionManager' directly. If this value is+    --   specified, 'tlsSessionManagerConfig' is ignored.+    --+    --   Since 3.2.12+    , tlsSupportedHashSignatures :: [TLS.HashAndSignatureAlgorithm]+    -- ^ Specifying supported hash/signature algorithms, ordered by decreasing+    -- priority. See the "Network.TLS" module for details+    --+    --   Since 3.3.3+    }++-- Since 3.3.1++-- | Some programs need access to cert settings+getCertSettings :: TLSSettings -> CertSettings+getCertSettings = certSettings++-- | The default 'CertSettings'.+defaultCertSettings :: CertSettings+defaultCertSettings = CertFromFile "certificate.pem" [] "key.pem"++----------------------------------------------------------------++-- | Default 'TLSSettings'. Use this to create 'TLSSettings' with the field record name (aka accessors).+defaultTlsSettings :: TLSSettings+defaultTlsSettings =+    TLSSettings+        { certSettings = defaultCertSettings+        , onInsecure = DenyInsecure "This server only accepts secure HTTPS connections."+        , tlsLogging = TLS.defaultLogging+        , tlsAllowedVersions = TLS.supportedVersions TLS.defaultSupported+        , tlsCiphers = ciphers+        , tlsWantClientCert = False+        , tlsServerHooks = TLS.defaultServerHooks+        , tlsServerDHEParams = Nothing+        , tlsSessionManagerConfig = Nothing+        , tlsCredentials = Nothing+        , tlsSessionManager = Nothing+        , tlsSupportedHashSignatures = TLS.supportedHashSignatures TLS.defaultSupported+        }++-- taken from stunnel example in tls-extra+ciphers :: [TLS.Cipher]+ciphers = TLSExtra.ciphersuite_strong