pax_global_header00006660000000000000000000000064151602725520014517gustar00rootroot0000000000000052 comment=86dca4e08241668b5ce2805b7ca2b9a2eaed245a guile-knots-0.1/000077500000000000000000000000001516027255200136205ustar00rootroot00000000000000guile-knots-0.1/.forgejo/000077500000000000000000000000001516027255200153315ustar00rootroot00000000000000guile-knots-0.1/.forgejo/workflows/000077500000000000000000000000001516027255200173665ustar00rootroot00000000000000guile-knots-0.1/.forgejo/workflows/build-website.yaml000066400000000000000000000017201516027255200230110ustar00rootroot00000000000000on: push: branches: - trunk jobs: test: runs-on: host steps: - run: git clone --depth=1 https://$FORGEJO_TOKEN@forge.cbaines.net/cbaines/guile-knots.git knots-trunk - run: git clone --depth=1 https://$FORGEJO_TOKEN@forge.cbaines.net/cbaines/guile-knots.git --branch=pages knots-pages - run: | cd knots-trunk guix shell -D -f guix-dev.scm -- documenta api "knots.scm knots/" guix shell texinfo -- makeinfo --css-ref=https://luis-felipe.gitlab.io/texinfo-css/static/css/texinfo-7.css --no-split --html -c SHOW_TITLE=true -o ../knots-pages/index.html doc/index.texi - run: | cd knots-pages git add . if [[ -z "$(git status -s)" ]]; then echo "Nothing to push" else git config user.email "" git config user.name "Automatic website updater" git commit -m "Automatic website update" git push fi guile-knots-0.1/.gitignore000066400000000000000000000003031516027255200156040ustar00rootroot00000000000000*.go Makefile.in Makefile aclocal.m4 autom4te.cache config.log config.status configure build-aux/install-sh build-aux/missing *.log tests/*.log tests/*.trs pre-inst-env test-env .local.envrc guile-knots-0.1/COPYING000066400000000000000000001045131516027255200146570ustar00rootroot00000000000000 GNU GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The GNU General Public License is a free, copyleft license for software and other kinds of works. The licenses for most software and other practical works are designed to take away your freedom to share and change the works. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change all versions of a program--to make sure it remains free software for all its users. We, the Free Software Foundation, use the GNU General Public License for most of our software; it applies also to any other work released this way by its authors. You can apply it to your programs, too. When we speak of free software, we are referring to freedom, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for them if you wish), that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs, and that you know you can do these things. To protect your rights, we need to prevent others from denying you these rights or asking you to surrender the rights. Therefore, you have certain responsibilities if you distribute copies of the software, or if you modify it: responsibilities to respect the freedom of others. For example, if you distribute copies of such a program, whether gratis or for a fee, you must pass on to the recipients the same freedoms that you received. You must make sure that they, too, receive or can get the source code. And you must show them these terms so they know their rights. Developers that use the GNU GPL protect your rights with two steps: (1) assert copyright on the software, and (2) offer you this License giving you legal permission to copy, distribute and/or modify it. For the developers' and authors' protection, the GPL clearly explains that there is no warranty for this free software. For both users' and authors' sake, the GPL requires that modified versions be marked as changed, so that their problems will not be attributed erroneously to authors of previous versions. Some devices are designed to deny users access to install or run modified versions of the software inside them, although the manufacturer can do so. This is fundamentally incompatible with the aim of protecting users' freedom to change the software. The systematic pattern of such abuse occurs in the area of products for individuals to use, which is precisely where it is most unacceptable. Therefore, we have designed this version of the GPL to prohibit the practice for those products. If such problems arise substantially in other domains, we stand ready to extend this provision to those domains in future versions of the GPL, as needed to protect the freedom of users. Finally, every program is threatened constantly by software patents. States should not allow patents to restrict development and use of software on general-purpose computers, but in those that do, we wish to avoid the special danger that patents applied to a free program could make it effectively proprietary. To prevent this, the GPL assures that patents cannot be used to render the program non-free. The precise terms and conditions for copying, distribution and modification follow. TERMS AND CONDITIONS 0. Definitions. "This License" refers to version 3 of the GNU General Public License. "Copyright" also means copyright-like laws that apply to other kinds of works, such as semiconductor masks. "The Program" refers to any copyrightable work licensed under this License. Each licensee is addressed as "you". "Licensees" and "recipients" may be individuals or organizations. To "modify" a work means to copy from or adapt all or part of the work in a fashion requiring copyright permission, other than the making of an exact copy. The resulting work is called a "modified version" of the earlier work or a work "based on" the earlier work. A "covered work" means either the unmodified Program or a work based on the Program. To "propagate" a work means to do anything with it that, without permission, would make you directly or secondarily liable for infringement under applicable copyright law, except executing it on a computer or modifying a private copy. Propagation includes copying, distribution (with or without modification), making available to the public, and in some countries other activities as well. To "convey" a work means any kind of propagation that enables other parties to make or receive copies. Mere interaction with a user through a computer network, with no transfer of a copy, is not conveying. An interactive user interface displays "Appropriate Legal Notices" to the extent that it includes a convenient and prominently visible feature that (1) displays an appropriate copyright notice, and (2) tells the user that there is no warranty for the work (except to the extent that warranties are provided), that licensees may convey the work under this License, and how to view a copy of this License. If the interface presents a list of user commands or options, such as a menu, a prominent item in the list meets this criterion. 1. Source Code. The "source code" for a work means the preferred form of the work for making modifications to it. "Object code" means any non-source form of a work. A "Standard Interface" means an interface that either is an official standard defined by a recognized standards body, or, in the case of interfaces specified for a particular programming language, one that is widely used among developers working in that language. The "System Libraries" of an executable work include anything, other than the work as a whole, that (a) is included in the normal form of packaging a Major Component, but which is not part of that Major Component, and (b) serves only to enable use of the work with that Major Component, or to implement a Standard Interface for which an implementation is available to the public in source code form. A "Major Component", in this context, means a major essential component (kernel, window system, and so on) of the specific operating system (if any) on which the executable work runs, or a compiler used to produce the work, or an object code interpreter used to run it. The "Corresponding Source" for a work in object code form means all the source code needed to generate, install, and (for an executable work) run the object code and to modify the work, including scripts to control those activities. However, it does not include the work's System Libraries, or general-purpose tools or generally available free programs which are used unmodified in performing those activities but which are not part of the work. For example, Corresponding Source includes interface definition files associated with source files for the work, and the source code for shared libraries and dynamically linked subprograms that the work is specifically designed to require, such as by intimate data communication or control flow between those subprograms and other parts of the work. The Corresponding Source need not include anything that users can regenerate automatically from other parts of the Corresponding Source. The Corresponding Source for a work in source code form is that same work. 2. Basic Permissions. All rights granted under this License are granted for the term of copyright on the Program, and are irrevocable provided the stated conditions are met. This License explicitly affirms your unlimited permission to run the unmodified Program. The output from running a covered work is covered by this License only if the output, given its content, constitutes a covered work. This License acknowledges your rights of fair use or other equivalent, as provided by copyright law. You may make, run and propagate covered works that you do not convey, without conditions so long as your license otherwise remains in force. You may convey covered works to others for the sole purpose of having them make modifications exclusively for you, or provide you with facilities for running those works, provided that you comply with the terms of this License in conveying all material for which you do not control copyright. Those thus making or running the covered works for you must do so exclusively on your behalf, under your direction and control, on terms that prohibit them from making any copies of your copyrighted material outside their relationship with you. Conveying under any other circumstances is permitted solely under the conditions stated below. Sublicensing is not allowed; section 10 makes it unnecessary. 3. Protecting Users' Legal Rights From Anti-Circumvention Law. No covered work shall be deemed part of an effective technological measure under any applicable law fulfilling obligations under article 11 of the WIPO copyright treaty adopted on 20 December 1996, or similar laws prohibiting or restricting circumvention of such measures. When you convey a covered work, you waive any legal power to forbid circumvention of technological measures to the extent such circumvention is effected by exercising rights under this License with respect to the covered work, and you disclaim any intention to limit operation or modification of the work as a means of enforcing, against the work's users, your or third parties' legal rights to forbid circumvention of technological measures. 4. Conveying Verbatim Copies. You may convey verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice; keep intact all notices stating that this License and any non-permissive terms added in accord with section 7 apply to the code; keep intact all notices of the absence of any warranty; and give all recipients a copy of this License along with the Program. You may charge any price or no price for each copy that you convey, and you may offer support or warranty protection for a fee. 5. Conveying Modified Source Versions. You may convey a work based on the Program, or the modifications to produce it from the Program, in the form of source code under the terms of section 4, provided that you also meet all of these conditions: a) The work must carry prominent notices stating that you modified it, and giving a relevant date. b) The work must carry prominent notices stating that it is released under this License and any conditions added under section 7. This requirement modifies the requirement in section 4 to "keep intact all notices". c) You must license the entire work, as a whole, under this License to anyone who comes into possession of a copy. This License will therefore apply, along with any applicable section 7 additional terms, to the whole of the work, and all its parts, regardless of how they are packaged. This License gives no permission to license the work in any other way, but it does not invalidate such permission if you have separately received it. d) If the work has interactive user interfaces, each must display Appropriate Legal Notices; however, if the Program has interactive interfaces that do not display Appropriate Legal Notices, your work need not make them do so. A compilation of a covered work with other separate and independent works, which are not by their nature extensions of the covered work, and which are not combined with it such as to form a larger program, in or on a volume of a storage or distribution medium, is called an "aggregate" if the compilation and its resulting copyright are not used to limit the access or legal rights of the compilation's users beyond what the individual works permit. Inclusion of a covered work in an aggregate does not cause this License to apply to the other parts of the aggregate. 6. Conveying Non-Source Forms. You may convey a covered work in object code form under the terms of sections 4 and 5, provided that you also convey the machine-readable Corresponding Source under the terms of this License, in one of these ways: a) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by the Corresponding Source fixed on a durable physical medium customarily used for software interchange. b) Convey the object code in, or embodied in, a physical product (including a physical distribution medium), accompanied by a written offer, valid for at least three years and valid for as long as you offer spare parts or customer support for that product model, to give anyone who possesses the object code either (1) a copy of the Corresponding Source for all the software in the product that is covered by this License, on a durable physical medium customarily used for software interchange, for a price no more than your reasonable cost of physically performing this conveying of source, or (2) access to copy the Corresponding Source from a network server at no charge. c) Convey individual copies of the object code with a copy of the written offer to provide the Corresponding Source. This alternative is allowed only occasionally and noncommercially, and only if you received the object code with such an offer, in accord with subsection 6b. d) Convey the object code by offering access from a designated place (gratis or for a charge), and offer equivalent access to the Corresponding Source in the same way through the same place at no further charge. You need not require recipients to copy the Corresponding Source along with the object code. If the place to copy the object code is a network server, the Corresponding Source may be on a different server (operated by you or a third party) that supports equivalent copying facilities, provided you maintain clear directions next to the object code saying where to find the Corresponding Source. Regardless of what server hosts the Corresponding Source, you remain obligated to ensure that it is available for as long as needed to satisfy these requirements. e) Convey the object code using peer-to-peer transmission, provided you inform other peers where the object code and Corresponding Source of the work are being offered to the general public at no charge under subsection 6d. A separable portion of the object code, whose source code is excluded from the Corresponding Source as a System Library, need not be included in conveying the object code work. A "User Product" is either (1) a "consumer product", which means any tangible personal property which is normally used for personal, family, or household purposes, or (2) anything designed or sold for incorporation into a dwelling. In determining whether a product is a consumer product, doubtful cases shall be resolved in favor of coverage. For a particular product received by a particular user, "normally used" refers to a typical or common use of that class of product, regardless of the status of the particular user or of the way in which the particular user actually uses, or expects or is expected to use, the product. A product is a consumer product regardless of whether the product has substantial commercial, industrial or non-consumer uses, unless such uses represent the only significant mode of use of the product. "Installation Information" for a User Product means any methods, procedures, authorization keys, or other information required to install and execute modified versions of a covered work in that User Product from a modified version of its Corresponding Source. The information must suffice to ensure that the continued functioning of the modified object code is in no case prevented or interfered with solely because modification has been made. If you convey an object code work under this section in, or with, or specifically for use in, a User Product, and the conveying occurs as part of a transaction in which the right of possession and use of the User Product is transferred to the recipient in perpetuity or for a fixed term (regardless of how the transaction is characterized), the Corresponding Source conveyed under this section must be accompanied by the Installation Information. But this requirement does not apply if neither you nor any third party retains the ability to install modified object code on the User Product (for example, the work has been installed in ROM). The requirement to provide Installation Information does not include a requirement to continue to provide support service, warranty, or updates for a work that has been modified or installed by the recipient, or for the User Product in which it has been modified or installed. Access to a network may be denied when the modification itself materially and adversely affects the operation of the network or violates the rules and protocols for communication across the network. Corresponding Source conveyed, and Installation Information provided, in accord with this section must be in a format that is publicly documented (and with an implementation available to the public in source code form), and must require no special password or key for unpacking, reading or copying. 7. Additional Terms. "Additional permissions" are terms that supplement the terms of this License by making exceptions from one or more of its conditions. Additional permissions that are applicable to the entire Program shall be treated as though they were included in this License, to the extent that they are valid under applicable law. If additional permissions apply only to part of the Program, that part may be used separately under those permissions, but the entire Program remains governed by this License without regard to the additional permissions. When you convey a copy of a covered work, you may at your option remove any additional permissions from that copy, or from any part of it. (Additional permissions may be written to require their own removal in certain cases when you modify the work.) You may place additional permissions on material, added by you to a covered work, for which you have or can give appropriate copyright permission. Notwithstanding any other provision of this License, for material you add to a covered work, you may (if authorized by the copyright holders of that material) supplement the terms of this License with terms: a) Disclaiming warranty or limiting liability differently from the terms of sections 15 and 16 of this License; or b) Requiring preservation of specified reasonable legal notices or author attributions in that material or in the Appropriate Legal Notices displayed by works containing it; or c) Prohibiting misrepresentation of the origin of that material, or requiring that modified versions of such material be marked in reasonable ways as different from the original version; or d) Limiting the use for publicity purposes of names of licensors or authors of the material; or e) Declining to grant rights under trademark law for use of some trade names, trademarks, or service marks; or f) Requiring indemnification of licensors and authors of that material by anyone who conveys the material (or modified versions of it) with contractual assumptions of liability to the recipient, for any liability that these contractual assumptions directly impose on those licensors and authors. All other non-permissive additional terms are considered "further restrictions" within the meaning of section 10. If the Program as you received it, or any part of it, contains a notice stating that it is governed by this License along with a term that is a further restriction, you may remove that term. If a license document contains a further restriction but permits relicensing or conveying under this License, you may add to a covered work material governed by the terms of that license document, provided that the further restriction does not survive such relicensing or conveying. If you add terms to a covered work in accord with this section, you must place, in the relevant source files, a statement of the additional terms that apply to those files, or a notice indicating where to find the applicable terms. Additional terms, permissive or non-permissive, may be stated in the form of a separately written license, or stated as exceptions; the above requirements apply either way. 8. Termination. You may not propagate or modify a covered work except as expressly provided under this License. Any attempt otherwise to propagate or modify it is void, and will automatically terminate your rights under this License (including any patent licenses granted under the third paragraph of section 11). However, if you cease all violation of this License, then your license from a particular copyright holder is reinstated (a) provisionally, unless and until the copyright holder explicitly and finally terminates your license, and (b) permanently, if the copyright holder fails to notify you of the violation by some reasonable means prior to 60 days after the cessation. Moreover, your license from a particular copyright holder is reinstated permanently if the copyright holder notifies you of the violation by some reasonable means, this is the first time you have received notice of violation of this License (for any work) from that copyright holder, and you cure the violation prior to 30 days after your receipt of the notice. Termination of your rights under this section does not terminate the licenses of parties who have received copies or rights from you under this License. If your rights have been terminated and not permanently reinstated, you do not qualify to receive new licenses for the same material under section 10. 9. Acceptance Not Required for Having Copies. You are not required to accept this License in order to receive or run a copy of the Program. Ancillary propagation of a covered work occurring solely as a consequence of using peer-to-peer transmission to receive a copy likewise does not require acceptance. However, nothing other than this License grants you permission to propagate or modify any covered work. These actions infringe copyright if you do not accept this License. Therefore, by modifying or propagating a covered work, you indicate your acceptance of this License to do so. 10. Automatic Licensing of Downstream Recipients. Each time you convey a covered work, the recipient automatically receives a license from the original licensors, to run, modify and propagate that work, subject to this License. You are not responsible for enforcing compliance by third parties with this License. An "entity transaction" is a transaction transferring control of an organization, or substantially all assets of one, or subdividing an organization, or merging organizations. If propagation of a covered work results from an entity transaction, each party to that transaction who receives a copy of the work also receives whatever licenses to the work the party's predecessor in interest had or could give under the previous paragraph, plus a right to possession of the Corresponding Source of the work from the predecessor in interest, if the predecessor has it or can get it with reasonable efforts. You may not impose any further restrictions on the exercise of the rights granted or affirmed under this License. For example, you may not impose a license fee, royalty, or other charge for exercise of rights granted under this License, and you may not initiate litigation (including a cross-claim or counterclaim in a lawsuit) alleging that any patent claim is infringed by making, using, selling, offering for sale, or importing the Program or any portion of it. 11. Patents. A "contributor" is a copyright holder who authorizes use under this License of the Program or a work on which the Program is based. The work thus licensed is called the contributor's "contributor version". A contributor's "essential patent claims" are all patent claims owned or controlled by the contributor, whether already acquired or hereafter acquired, that would be infringed by some manner, permitted by this License, of making, using, or selling its contributor version, but do not include claims that would be infringed only as a consequence of further modification of the contributor version. For purposes of this definition, "control" includes the right to grant patent sublicenses in a manner consistent with the requirements of this License. Each contributor grants you a non-exclusive, worldwide, royalty-free patent license under the contributor's essential patent claims, to make, use, sell, offer for sale, import and otherwise run, modify and propagate the contents of its contributor version. In the following three paragraphs, a "patent license" is any express agreement or commitment, however denominated, not to enforce a patent (such as an express permission to practice a patent or covenant not to sue for patent infringement). To "grant" such a patent license to a party means to make such an agreement or commitment not to enforce a patent against the party. If you convey a covered work, knowingly relying on a patent license, and the Corresponding Source of the work is not available for anyone to copy, free of charge and under the terms of this License, through a publicly available network server or other readily accessible means, then you must either (1) cause the Corresponding Source to be so available, or (2) arrange to deprive yourself of the benefit of the patent license for this particular work, or (3) arrange, in a manner consistent with the requirements of this License, to extend the patent license to downstream recipients. "Knowingly relying" means you have actual knowledge that, but for the patent license, your conveying the covered work in a country, or your recipient's use of the covered work in a country, would infringe one or more identifiable patents in that country that you have reason to believe are valid. If, pursuant to or in connection with a single transaction or arrangement, you convey, or propagate by procuring conveyance of, a covered work, and grant a patent license to some of the parties receiving the covered work authorizing them to use, propagate, modify or convey a specific copy of the covered work, then the patent license you grant is automatically extended to all recipients of the covered work and works based on it. A patent license is "discriminatory" if it does not include within the scope of its coverage, prohibits the exercise of, or is conditioned on the non-exercise of one or more of the rights that are specifically granted under this License. You may not convey a covered work if you are a party to an arrangement with a third party that is in the business of distributing software, under which you make payment to the third party based on the extent of your activity of conveying the work, and under which the third party grants, to any of the parties who would receive the covered work from you, a discriminatory patent license (a) in connection with copies of the covered work conveyed by you (or copies made from those copies), or (b) primarily for and in connection with specific products or compilations that contain the covered work, unless you entered into that arrangement, or that patent license was granted, prior to 28 March 2007. Nothing in this License shall be construed as excluding or limiting any implied license or other defenses to infringement that may otherwise be available to you under applicable patent law. 12. No Surrender of Others' Freedom. If conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot convey a covered work so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not convey it at all. For example, if you agree to terms that obligate you to collect a royalty for further conveying from those to whom you convey the Program, the only way you could satisfy both those terms and this License would be to refrain entirely from conveying the Program. 13. Use with the GNU Affero General Public License. Notwithstanding any other provision of this License, you have permission to link or combine any covered work with a work licensed under version 3 of the GNU Affero General Public License into a single combined work, and to convey the resulting work. The terms of this License will continue to apply to the part which is the covered work, but the special requirements of the GNU Affero General Public License, section 13, concerning interaction through a network will apply to the combination as such. 14. Revised Versions of this License. The Free Software Foundation may publish revised and/or new versions of the GNU General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies that a certain numbered version of the GNU General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that numbered version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the GNU General Public License, you may choose any version ever published by the Free Software Foundation. If the Program specifies that a proxy can decide which future versions of the GNU General Public License can be used, that proxy's public statement of acceptance of a version permanently authorizes you to choose that version for the Program. Later license versions may give you additional or different permissions. However, no additional obligations are imposed on any author or copyright holder as a result of your choosing to follow a later version. 15. Disclaimer of Warranty. THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. Limitation of Liability. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. 17. Interpretation of Sections 15 and 16. If the disclaimer of warranty and limitation of liability provided above cannot be given local legal effect according to their terms, reviewing courts shall apply local law that most closely approximates an absolute waiver of all civil liability in connection with the Program, unless a warranty or assumption of liability accompanies a copy of the Program in return for a fee. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to the public, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively state the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation, either version 3 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program. If not, see . Also add information on how to contact you by electronic and paper mail. If the program does terminal interaction, make it output a short notice like this when it starts in an interactive mode: Copyright (C) This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, your program's commands might be different; for a GUI interface, you would use an "about box". You should also get your employer (if you work as a programmer) or school, if any, to sign a "copyright disclaimer" for the program, if necessary. For more information on this, and how to apply and follow the GNU GPL, see . The GNU General Public License does not permit incorporating your program into proprietary programs. If your program is a subroutine library, you may consider it more useful to permit linking proprietary applications with the library. If this is what you want to do, use the GNU Lesser General Public License instead of this License. But first, please read . guile-knots-0.1/Makefile.am000066400000000000000000000014741516027255200156620ustar00rootroot00000000000000include guile.am SOURCES = \ knots.scm \ knots/backtraces.scm \ knots/non-blocking.scm \ knots/parallelism.scm \ knots/promise.scm \ knots/queue.scm \ knots/resource-pool.scm \ knots/sort.scm \ knots/thread-pool.scm \ knots/timeout.scm \ knots/web-server.scm \ knots/web.scm SCM_TESTS = \ tests/backtraces.scm \ tests/non-blocking.scm \ tests/non-blocking.scm \ tests/parallelism.scm \ tests/promise.scm \ tests/queue.scm \ tests/web.scm \ tests/resource-pool.scm \ tests/sort.scm \ tests/thread-pool.scm \ tests/timeout.scm \ tests/web-server.scm TESTS_GOBJECTS = $(SCM_TESTS:%.scm=%.go) EXTRA_DIST = \ README \ bootstrap \ pre-inst-env.in check: $(GOBJECTS) $(TESTS_GOBJECTS) find tests -maxdepth 1 -name "*.scm" | xargs -t -L1 ./test-env guile guile-knots-0.1/README.org000066400000000000000000000006711516027255200152720ustar00rootroot00000000000000-*- mode: org -*- * Guile Knots Guile Knots is a library providing higher-level patterns and building blocks for programming with [[https://codeberg.org/guile/fibers][Guile Fibers]]. This includes: - Parallel map/for-each with configurable concurrency limits - Resource and thread pools - Fiber-aware promises for lazy and eager parallel evaluation - Timeouts for fibers and I/O ports - A HTTP web server - Non-blocking socket utilities guile-knots-0.1/bootstrap000077500000000000000000000000631516027255200155620ustar00rootroot00000000000000#! /bin/sh autoreconf --verbose --install --force guile-knots-0.1/configure.ac000066400000000000000000000007731516027255200161150ustar00rootroot00000000000000AC_INIT([guile-knots], [0.1]) AC_CONFIG_AUX_DIR([build-aux]) AM_INIT_AUTOMAKE([-Wall -Werror foreign]) GUILE_PKG([3.0]) GUILE_PROGS if test "x$GUILD" = "x"; then AC_MSG_ERROR(['guild' binary not found; please check your guile 3 installation.]) fi if test "$cross_compiling" != no; then GUILE_TARGET="--target=$host_alias" AC_SUBST([GUILE_TARGET]) fi AC_CONFIG_FILES([Makefile]) AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env]) AC_CONFIG_FILES([test-env], [chmod +x test-env]) AC_OUTPUT guile-knots-0.1/doc/000077500000000000000000000000001516027255200143655ustar00rootroot00000000000000guile-knots-0.1/doc/index.texi000066400000000000000000000032151516027255200163700ustar00rootroot00000000000000\input texinfo @setfilename guile-knots @c HEADER @settitle Guile Knots @documentlanguage en @documentencoding UTF-8 @afourpaper @c END HEADER @c MASTER MENU @node Top @top Overview Guile Knots is a library providing tools and patterns for programming with @url{https://codeberg.org/guile/fibers, Guile Fibers}. Guile Knots provides higher level building blocks for writing programs using Guile Fibers, including managing code that can't run in a thread used by fibers. Also included is a web server implementation using Fibers, which while being similar to the web server provided by Fibers, can provide some benefits in specific circumstances. @c END MASTER MENU @c TABLE OF CONTENTS @contents @c END TABLE OF CONTENTS @c CHAPTER: API @include api/index.texi @c END CHAPTER: API @c APPENDICES @node Version History @appendix Version History @table @dfn @item Version 0.Y.0, Month DD, 20YY @itemize @item No initial release has yet been made. @end itemize @end table @node Copying Information @appendix Copying Information Copyright © 2024, 2025 Christopher Baines This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. @c END APPENDICES @c INDICES @node Concept Index @unnumbered Concept Index @printindex cp @node Data Type Index @unnumbered Data Type Index @printindex tp @node Procedure Index @unnumbered Procedure Index @printindex fn @node Variable Index @unnumbered Variable Index @printindex vr @c END INDICES @bye guile-knots-0.1/guile.am000066400000000000000000000014321516027255200152440ustar00rootroot00000000000000moddir=$(datadir)/guile/site/$(GUILE_EFFECTIVE_VERSION) godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache GOBJECTS = $(SOURCES:%.scm=%.go) nobase_dist_mod_DATA = $(SOURCES) $(NOCOMP_SOURCES) nobase_go_DATA = $(GOBJECTS) # Make sure source files are installed first, so that the mtime of # installed compiled files is greater than that of installed source # files. See # # for details. guile_install_go_files = install-nobase_goDATA $(guile_install_go_files): install-nobase_dist_modDATA CLEANFILES = $(GOBJECTS) GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat SUFFIXES = .scm .go .scm.go: $(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILD) compile $(GUILE_TARGET) $(GUILE_WARNINGS) -o "$@" "$<" guile-knots-0.1/guix-dev.scm000066400000000000000000000031671516027255200160630ustar00rootroot00000000000000;;; Guile Knots ;;; Copyright © 2020 Christopher Baines ;;; ;;; This file is part of Guile Knots. ;;; ;;; The Guile Knots 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. ;;; ;;; The Guile Knots 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 the guix-data-service. If not, see ;;; . ;;; Run the following command to enter a development environment for ;;; Guile Knots: ;;; ;;; $ guix environment -l guix-dev.scm (use-modules ((guix licenses) #:prefix license:) (guix packages) (guix build-system gnu) (gnu packages) (gnu packages autotools) (gnu packages guile) (gnu packages guile-xyz) (gnu packages pkg-config) (gnu packages texinfo) (srfi srfi-1)) (package (name "guile-knots") (version "0.0.0") (source #f) (build-system gnu-build-system) (inputs (list guile-next guile-fibers-next)) (native-inputs (list autoconf automake pkg-config guile-documenta texinfo)) (synopsis "TODO") (description "TODO") (home-page "TODO") (license license:gpl3+)) guile-knots-0.1/knots.scm000066400000000000000000000157771516027255200155030ustar00rootroot00000000000000;;; Guile Knots ;;; Copyright © 2026 Christopher Baines ;;; ;;; This file is part of Guile Knots. ;;; ;;; The Guile Knots 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. ;;; ;;; The Guile Knots 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 the guix-data-service. If not, see ;;; . (define-module (knots) #:use-module (srfi srfi-1) #:use-module (srfi srfi-43) #:use-module (ice-9 match) #:use-module (ice-9 threads) #:use-module (ice-9 binary-ports) #:use-module (ice-9 suspendable-ports) #:use-module (rnrs bytevectors) #:use-module (fibers) #:use-module (fibers channels) #:use-module (fibers conditions) #:use-module (ice-9 format) #:use-module (knots backtraces) #:re-export (&knots-exception make-knots-exception knots-exception? knots-exception-stack print-backtrace-and-exception/knots) #:export (call-with-default-io-waiters wait-when-system-clock-behind call-with-sigint display/knots simple-format/knots format/knots call-with-temporary-thread spawn-fiber/knots)) (define (call-with-default-io-waiters thunk) "Run THUNK with Guile's default blocking I/O waiters active. This is useful when restoring the default Guile I/O waiters from within a context (like Fibers) where different I/O waiters are used, for example when creating a new thread from a fiber." (parameterize ((current-read-waiter (@@ (ice-9 suspendable-ports) default-read-waiter)) (current-write-waiter (@@ (ice-9 suspendable-ports) default-write-waiter))) (thunk))) (define (wait-when-system-clock-behind) "Block until the system clock reads at least 2001-01-02. Useful at startup in environments (virtual machines, embedded systems) where the clock may start at or near the Unix epoch. Prints a warning to the current error port every 20 seconds while waiting." ;; Jan 02 2001 02:00:00 (let ((start-of-the-year-2001 978400800)) (while (< (current-time) start-of-the-year-2001) (simple-format (current-error-port) "warning: system clock potentially behind, waiting\n") (sleep 20)))) ;; Copied from (fibers web server) (define (call-with-sigint thunk cvar) "Run THUNK with a SIGINT handler that signals the Fibers condition CVAR. Restores the previous handler when THUNK returns. Typical usage is to pass a condition variable to this procedure and wait on CVAR in a fiber to implement clean shutdown on Ctrl-C: @example (let ((quit-cvar (make-condition))) (call-with-sigint (lambda () (wait quit-cvar)) quit-cvar)) @end example" (let ((handler #f)) (dynamic-wind (lambda () (set! handler (sigaction SIGINT (lambda (sig) (signal-condition! cvar))))) thunk (lambda () (if handler ;; restore Scheme handler, SIG_IGN or SIG_DFL. (sigaction SIGINT (car handler) (cdr handler)) ;; restore original C handler. (sigaction SIGINT #f)))))) (define (call-with-temporary-thread thunk) "Run THUNK in a temporary thread and return its result to the calling fiber." (let ((channel (make-channel))) (call-with-new-thread (lambda () (call-with-default-io-waiters (lambda () (with-exception-handler (lambda (exn) (put-message channel `(exception . ,exn))) (lambda () (with-exception-handler (lambda (exn) (let ((stack (match (fluid-ref %stacks) ((stack-tag . prompt-tag) (make-stack #t 0 prompt-tag 0 (and prompt-tag 1))) (_ (make-stack #t))))) (raise-exception (make-exception exn (make-knots-exception stack))))) (lambda () (call-with-values thunk (lambda values (put-message channel `(values ,@values))))))) #:unwind? #t))))) (match (get-message channel) (('values . results) (apply values results)) (('exception . exn) (raise-exception exn))))) (define* (display/knots obj #:optional (port (current-output-port))) "Write OBJ to PORT (default: current output port) as a UTF-8 byte sequence via @code{put-bytevector}. When used with ports without buffering, this should be safer than display." (put-bytevector port (string->utf8 (call-with-output-string (lambda (port) (display obj port)))))) (define (simple-format/knots port s . args) "Like @code{simple-format} but should be safer when used with a port without buffering." (let ((str (apply simple-format #f s args))) (if (eq? #f port) str (display/knots str (if (eq? #t port) (current-output-port) port))))) (define (format/knots port s . args) "Like @code{format} but should be safer when used with a port without buffering." (let ((str (apply format #f s args))) (if (eq? #f port) str (display/knots str (if (eq? #t port) (current-output-port) port))))) (define* (spawn-fiber/knots thunk #:optional scheduler #:key parallel?) "Spawn a fiber to run THUNK, with knots exception handling. Accepts the same optional SCHEDULER and @code{#:parallel?} arguments as @code{spawn-fiber}." (spawn-fiber (lambda () (with-exception-handler (lambda (exn) (display/knots "Uncaught exception in task:\n" (current-error-port)) (print-backtrace-and-exception/knots exn)) (lambda () (with-exception-handler (lambda (exn) (let ((stack (match (fluid-ref %stacks) ((stack-tag . prompt-tag) (make-stack #t 0 prompt-tag 0 (and prompt-tag 1))) (_ (make-stack #t))))) (raise-exception (make-exception exn (make-knots-exception stack))))) thunk)) #:unwind? #t)) scheduler #:parallel? parallel?)) guile-knots-0.1/knots/000077500000000000000000000000001516027255200147565ustar00rootroot00000000000000guile-knots-0.1/knots/backtraces.scm000066400000000000000000000320161516027255200175660ustar00rootroot00000000000000;;; Guile Knots ;;; Copyright © 2026 Christopher Baines ;;; ;;; This file is part of Guile Knots. ;;; ;;; The Guile Knots 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. ;;; ;;; The Guile Knots 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 the guix-data-service. If not, see ;;; . (define-module (knots backtraces) #:use-module (srfi srfi-1) #:use-module (srfi srfi-43) #:use-module (ice-9 match) #:use-module (ice-9 format) #:use-module (system repl debug) #:use-module (system vm frame) #:use-module ((knots) #:select (display/knots simple-format/knots format/knots)) #:export (&knots-exception make-knots-exception knots-exception? knots-exception-stack print-backtrace-and-exception/knots)) (define &knots-exception (make-exception-type '&knots-exception &exception '(stack))) (define make-knots-exception (record-constructor &knots-exception)) (set-procedure-property! make-knots-exception 'documentation "Construct a @code{&knots-exception} with the given stack.") (define knots-exception? (exception-predicate &knots-exception)) (set-procedure-property! knots-exception? 'documentation "Return @code{#t} if OBJ is a @code{&knots-exception}.") (define knots-exception-stack (exception-accessor &knots-exception (record-accessor &knots-exception 'stack))) (set-procedure-property! knots-exception-stack 'documentation "Return the stack from a @code{&knots-exception}.") (define (backtrace-debug-mode?) (let ((val (getenv "KNOTS_BACKTRACE_DEBUG"))) (and val (not (string=? val "")) (not (string=? val "0"))))) (define (debug-print-stack port label full-vec included-vec) (simple-format/knots port "[KNOTS DEBUG] ~A\n" label) (if (vector-empty? full-vec) (simple-format/knots port " (empty)\n") (vector-fold-right (lambda (i _ frame) (let ((marker (if (vector-index (lambda (f) (eq? f frame)) included-vec) ">" " ")) (name (symbol->string (or (frame-procedure-name frame) '_)))) (match (frame-source frame) (#f (format/knots port " ~a ~3d unknown ~a~%" marker i name)) ((_ file line . col) (format/knots port " ~a ~3d ~a:~a:~a ~a~%" marker i file (1+ line) col name))))) #f full-vec)) (force-output port)) (define (internal-file? file) (or (string-prefix? "ice-9/" file) (string-prefix? "system/" file) (string-prefix? "srfi/" file) (string=? file "knots.scm") (string-prefix? "knots/" file) (string=? file "fibers.scm") (string-prefix? "fibers/" file))) (define (frame-file frame) (let ((src (frame-source frame))) (and src (cadr src)))) (define (user-frame? frame) (let ((file (frame-file frame))) (and (string? file) (not (internal-file? file))))) (define (raise-machinery-frame? frame) ;; Return #t for frames that are part of the raise/unwind machinery ;; and should be skipped when looking for the raise site. ;; Specifically: C/unknown frames (no source file) and ;; ice-9/boot-9.scm frames. Other internal frames such as ;; ice-9/vlist.scm are part of the actual call path and should be ;; preserved. (let ((file (frame-file frame))) (or (not file) (string=? file "ice-9/boot-9.scm")))) (define (fibers-frame? frame) ;; Return #t if FRAME belongs to the fibers library. (let ((file (frame-file frame))) (and (string? file) (or (string=? file "fibers.scm") (string-prefix? "fibers/" file))))) ;; The number of frames in Guile's eval-machinery tail appended to every ;; top-level script stack: ;; ;; [n-6] ice-9/boot-9.scm _ ;; [n-5] ice-9/boot-9.scm save-module-excursion ;; [n-4] ice-9/eval.scm _ ;; [n-3] ice-9/boot-9.scm call-with-prompt ;; [n-2] C/unknown apply-smob/0 ;; [n-1] ice-9/boot-9.scm with-exception-handler (define script-eval-tail-length 6) (define (classify-stack-situation stack-vector) (cond ((vector-any fibers-frame? stack-vector) 'run-fibers) ((let ((len (vector-length stack-vector))) (and (>= len script-eval-tail-length) (equal? (frame-file (vector-ref stack-vector (- len 1))) "ice-9/boot-9.scm") (eq? (frame-procedure-name (vector-ref stack-vector (- len 3))) 'call-with-prompt) (not (vector-any (lambda (frame) (eq? (frame-procedure-name frame) '%start-stack)) stack-vector)))) 'script) (else 'unknown))) (define (filter-knots-stack-vector vector) ;; Extract user frames from a pre-captured knots stack. The bottom 3 frames ;; are always fixed overhead: make-stack (C), the handler body frame at the ;; make-stack call site (exactly 1 Scheme frame), and raise-exception ;; (boot-9). User frames start at index 3. (let ((last-user (vector-index-right user-frame? vector))) (if (or (not last-user) (< last-user 3)) #() (vector-copy vector 3 (+ last-user 1))))) (define (filter-stack-vector vector) ;; Return the slice of VECTOR containing the frames relevant for ;; display. Skips the fixed 2-frame overhead (make-stack + call ;; site) and any raise machinery to find after-raise, then bounds at ;; the eval-machinery tail (script) or the first fibers scheduler ;; frame (run-fibers/unknown). (define (skip-handler-and-raise vector start) ;; Scan forward from START in VECTOR, first past any user frames ;; (the handler body), then past raise-machinery frames (C/unknown ;; and ice-9/boot-9.scm). Returns the index of the first ;; remaining frame — the raise site or context. Other internal ;; frames such as ice-9/vlist.scm are preserved because they are ;; part of the actual call path. (let* ((len (vector-length vector)) (after-handler (let loop ((i start)) (if (or (>= i len) (not (user-frame? (vector-ref vector i)))) i (loop (+ i 1)))))) (let loop ((i after-handler)) (cond ((>= i len) i) ((raise-machinery-frame? (vector-ref vector i)) (loop (+ i 1))) (else i))))) (let* ((len (vector-length vector)) (situation (classify-stack-situation vector)) (after-raise (skip-handler-and-raise vector (min 2 len))) (end (if (and (eq? situation 'script) (> (- len script-eval-tail-length) after-raise)) (- len script-eval-tail-length) (let loop ((i after-raise)) (cond ((>= i len) i) ((fibers-frame? (vector-ref vector i)) i) (else (loop (+ i 1)))))))) (if (>= after-raise end) #() (vector-copy vector after-raise end)))) ;; Based on print-frame from (system repl debug), but without the ;; frame indexes (define* (print-frame/no-index frame #:optional (port (current-output-port)) #:key (width (terminal-width)) (last-source #f) (innermost? #f)) (define (source-file src) (match src (#f "unknown file") ((_ #f . _) "current input") ((_ file . _) file))) (let* ((source (frame-source frame)) (file (source-file source))) (when (not (equal? file (source-file last-source))) (format port "~&In ~a:~&" file)) (format port "~9@a ~v:@y~%" (match source (#f "") ((_ _ line . col) (simple-format #f "~A:~A" (1+ line) col))) width (frame-call-representation frame #:top-frame? innermost?)))) (define* (print-backtrace-and-exception/knots exn #:key (port (current-error-port))) "Print the backtrace and exception information from EXN to PORT. This procedure captures the stack, so should be run before the stack is unwound, so using @code{with-exception-handler} without @code{#:unwind? #t}, the exception may need to then be re-raised and handled in an outer exception handler. @example (with-exception-handler (lambda (exn) ;; Recover from the exception #f) (lambda () (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) (raise-exception exn)) (lambda () (do-things)))) #:unwind? #t) @end example It's important to use @code{print-backtrace-and-exception/knots} for displaying backtraces involving functionality from Guile Knots, since the stack involved is potentially split across several fibers. The stacks involved are attached to the exception, and this procedure extracts this information out and assembles a backtrace including all the code involved. " (define (get-string out stack) (let* ((stack-vector (stack->vector stack)) (knots-stack-vectors (map (lambda (exn) (stack->vector (knots-exception-stack exn))) (reverse (filter knots-exception? (simple-exceptions exn))))) (filtered-stack-vector (filter-stack-vector stack-vector)) (filtered-knots-stack-vectors (map filter-knots-stack-vector knots-stack-vectors))) (when (backtrace-debug-mode?) (let ((debug-port (current-error-port)) (situation (classify-stack-situation stack-vector))) (simple-format/knots debug-port "[KNOTS DEBUG] situation: ~A\n" situation) (debug-print-stack debug-port "stack" stack-vector filtered-stack-vector) (let ((stack-count (length knots-stack-vectors))) (for-each (lambda (knots-vec user-vec index) (debug-print-stack debug-port (format #f "knots stack ~a/~a" index stack-count) knots-vec user-vec)) knots-stack-vectors filtered-knots-stack-vectors (iota stack-count 1))) (display/knots "\n" debug-port) (force-output debug-port))) (for-each (lambda (vec) (vector-fold-right (lambda (i last-source frame) (print-frame/no-index frame out #:innermost? (= i 0) #:last-source last-source) (frame-source frame)) #f vec)) (cons filtered-stack-vector filtered-knots-stack-vectors)) (print-exception out #f '%exception (list (if (backtrace-debug-mode?) exn (apply make-exception (remove knots-exception? (simple-exceptions exn)))))))) (let* ((stack (match (fluid-ref %stacks) ((stack-tag . prompt-tag) (make-stack #t 0 prompt-tag 0 (and prompt-tag 1))) (_ (make-stack #t)))) (string-port (open-output-string)) (output (with-exception-handler (lambda (output-exn) (display/knots (get-output-string string-port) port) (close-output-port string-port) (display/knots "\n\n" port) (let* ((stack (make-stack #t)) (backtrace (call-with-output-string (lambda (port) (display-backtrace stack port) (newline port))))) (display/knots backtrace port)) (simple-format/knots port "\nexception in print-backtrace-and-exception/knots: ~A\n" output-exn) (raise-exception output-exn)) (lambda () (get-string string-port stack) (let ((str (get-output-string string-port))) (close-output-port string-port) str))))) (display/knots output port))) guile-knots-0.1/knots/non-blocking.scm000066400000000000000000000047751516027255200200570ustar00rootroot00000000000000;;; Guile Knots ;;; Copyright © 2020 Christopher Baines ;;; ;;; This file is part of Guile Knots. ;;; ;;; The Guile Knots 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. ;;; ;;; The Guile Knots 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 the guix-data-service. If not, see ;;; . (define-module (knots non-blocking) #:use-module (web uri) #:use-module (web client) #:export (non-blocking-port non-blocking-open-socket-for-uri)) (define (non-blocking-port port) "Make PORT non-blocking and return it." (let ((flags (fcntl port F_GETFL))) (when (zero? (logand O_NONBLOCK flags)) (fcntl port F_SETFL (logior O_NONBLOCK flags))) port)) (define* (non-blocking-open-socket-for-uri uri #:key (verify-certificate? #t)) "Open a socket for URI and return it as a non-blocking port. For HTTPS URIs the TLS handshake is completed while the socket is still blocking (required because Guile's TLS wrapper does not support non-blocking handshakes), then the underlying socket is made non-blocking. For plain HTTP the socket is made non-blocking immediately. @code{#:verify-certificate?} controls TLS certificate verification and defaults to @code{#t}." (define tls-wrap (@@ (web client) tls-wrap)) (define https? (eq? 'https (uri-scheme uri))) (define plain-uri (if https? (build-uri 'http #:userinfo (uri-userinfo uri) #:host (uri-host uri) #:port (or (uri-port uri) 443) #:path (uri-path uri) #:query (uri-query uri) #:fragment (uri-fragment uri)) uri)) (let ((s (open-socket-for-uri plain-uri))) (if https? (let ((port (tls-wrap s (uri-host uri) #:verify-certificate? verify-certificate?))) ;; Guile/guile-gnutls don't handle the handshake happening on a non ;; blocking socket, so change the behavior here. (non-blocking-port s) port) (non-blocking-port s)))) guile-knots-0.1/knots/parallelism.scm000066400000000000000000000320041516027255200177660ustar00rootroot00000000000000;;; Guile Knots ;;; Copyright © 2020 Christopher Baines ;;; ;;; This file is part of Guile Knots. ;;; ;;; The Guile Knots 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. ;;; ;;; The Guile Knots 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 the guix-data-service. If not, see ;;; . (define-module (knots parallelism) #:use-module (srfi srfi-1) #:use-module (srfi srfi-71) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-43) #:use-module (ice-9 match) #:use-module (ice-9 control) #:use-module (ice-9 exceptions) #:use-module (fibers) #:use-module (fibers channels) #:use-module (fibers operations) #:use-module (knots) #:use-module (knots resource-pool) #:export (fibers-batch-map fibers-map fibers-map-with-progress fibers-batch-for-each fibers-for-each fibers-parallel fibers-let fiberize make-parallelism-limiter parallelism-limiter? destroy-parallelism-limiter call-with-parallelism-limiter with-parallelism-limiter)) (define (defer-to-parallel-fiber thunk) (let ((reply (make-channel))) (spawn-fiber (lambda () (with-exception-handler (lambda (exn) (put-message reply (cons 'exception exn))) (lambda () (with-exception-handler (lambda (exn) (let ((stack (match (fluid-ref %stacks) ((stack-tag . prompt-tag) (make-stack #t 0 prompt-tag 0 (and prompt-tag 1))) (_ (make-stack #t))))) (raise-exception (make-exception exn (make-knots-exception stack))))) (lambda () (call-with-values (lambda () (start-stack #t (thunk))) (lambda vals (put-message reply (cons 'result vals))))))) #:unwind? #t)) #:parallel? #t) reply)) (define (fetch-result-of-defered-thunks . reply-channels) (let ((responses (map get-message reply-channels))) (map (match-lambda (('exception . exn) (raise-exception exn)) (('result . vals) (apply values vals))) responses))) (define (fibers-batch-map proc parallelism-limit . lists) "Map PROC over LISTS in parallel, with a PARALLELISM-LIMIT. If any of the invocations of PROC raise an exception, this will be raised once all of the calls to PROC have finished." (define vecs (map (lambda (list-or-vec) (if (vector? list-or-vec) list-or-vec (list->vector list-or-vec))) lists)) (define vecs-length (vector-length (first vecs))) (define result-vec (make-vector vecs-length)) (let loop ((next-to-process-index (if (= 0 vecs-length) #f 0)) (channel-indexes '())) (if (and (eq? #f next-to-process-index) (null? channel-indexes)) (let ((processed-result-vec (vector-map (lambda (_ result-or-exn) (match result-or-exn (('exception . exn) (raise-exception exn)) (('result . vals) (car vals)))) result-vec))) (if (vector? (first lists)) processed-result-vec (vector->list processed-result-vec))) (if (or (= (length channel-indexes) (min parallelism-limit vecs-length)) (eq? #f next-to-process-index)) (let ((new-index new-channel-indexes (perform-operation (apply choice-operation (map (lambda (index) (wrap-operation (get-operation (vector-ref result-vec index)) (lambda (result) (vector-set! result-vec index result) (values next-to-process-index (lset-difference = channel-indexes (list index)))))) channel-indexes))))) (loop new-index new-channel-indexes)) (loop (if (= (+ 1 next-to-process-index) vecs-length) #f (+ 1 next-to-process-index)) (begin (vector-set! result-vec next-to-process-index (defer-to-parallel-fiber (lambda () (apply proc (map (lambda (vec) (vector-ref vec next-to-process-index)) vecs))))) (cons next-to-process-index channel-indexes))))))) (define (fibers-map proc . lists) "Map PROC over LISTS in parallel, running up to 20 fibers in PARALLEL. If any of the invocations of PROC raise an exception, this will be raised once all of the calls to PROC have finished." (apply fibers-batch-map proc 20 lists)) (define (fibers-batch-for-each proc parallelism-limit . lists) "Call PROC on LISTS, running up to PARALLELISM-LIMIT fibers in parallel." (apply fibers-batch-map (lambda args (apply proc args) *unspecified*) parallelism-limit lists) *unspecified*) (define (fibers-for-each proc . lists) "Call PROC on LISTS, running up to 20 fibers in parallel." (apply fibers-batch-for-each proc 20 lists)) (define-syntax fibers-parallel (lambda (x) "Run each expression in parallel. If any expression raises an exception, this will be raised after all exceptions have finished." (syntax-case x () ((_ e0 ...) (with-syntax (((tmp0 ...) (generate-temporaries (syntax (e0 ...))))) #'(let ((tmp0 (defer-to-parallel-fiber (lambda () e0))) ...) (apply values (fetch-result-of-defered-thunks tmp0 ...)))))))) (define-syntax-rule (fibers-let ((v e) ...) b0 b1 ...) "Let, but run each binding in a fiber in parallel." (call-with-values (lambda () (fibers-parallel e ...)) (lambda (v ...) b0 b1 ...))) (define* (fibers-map-with-progress proc lists #:key report) "Map PROC over LISTS, calling #:REPORT if specified after each invocation of PROC finishes. REPORT is passed the results for each element of LISTS, or #f if no result has been received yet." (let loop ((channels-to-results (apply map (lambda args (cons (defer-to-parallel-fiber (lambda () (apply proc args))) #f)) lists))) (let ((active-channels (filter-map car channels-to-results))) (when report (report (apply map list (map cdr channels-to-results) lists))) (if (null? active-channels) (map (match-lambda ((#f . ('exception . exn)) (raise-exception exn)) ((#f . ('result . vals)) (car vals))) channels-to-results) (loop (perform-operation (apply choice-operation (filter-map (lambda (p) (match p ((channel . _) (if channel (wrap-operation (get-operation channel) (lambda (result) (map (match-lambda ((c . r) (if (eq? channel c) (cons #f result) (cons c r)))) channels-to-results))) #f)))) channels-to-results)))))))) (define* (fiberize proc #:key (parallelism 1) (input-channel (make-channel)) (process-channel input-channel)) "Convert PROC into a procedure backed by @code{#:parallelism} (default: 1) background fibers. Returns a wrapper that sends its arguments to one of the fibers and blocks until the result is returned. @code{#:input-channel} is the channel that callers write requests to; defaults to a fresh channel. @code{#:process-channel} is the channel the fibers read from; defaults to @code{#:input-channel}. Setting them differently allows external parties to bypass the wrapper and write directly to @code{process-channel}." (for-each (lambda _ (spawn-fiber (lambda () (while #t (let ((reply-channel args (car+cdr (get-message process-channel)))) (put-message reply-channel (with-exception-handler (lambda (exn) (cons 'exception exn)) (lambda () (with-exception-handler (lambda (exn) (let ((stack (match (fluid-ref %stacks) ((stack-tag . prompt-tag) (make-stack #t 0 prompt-tag 0 (and prompt-tag 1))) (_ (make-stack #t))))) (raise-exception (make-exception exn (make-knots-exception stack))))) (lambda () (call-with-values (lambda () (start-stack #t (apply proc args))) (lambda vals (cons 'result vals)))))) #:unwind? #t))))) #:parallel? #t)) (iota parallelism)) (lambda args (let ((reply-channel (make-channel))) (put-message input-channel (cons reply-channel args)) (match (get-message reply-channel) (('result . vals) (apply values vals)) (('exception . exn) (raise-exception exn)))))) (define-record-type (make-parallelism-limiter-record resource-pool) parallelism-limiter? (resource-pool parallelism-limiter-resource-pool)) (set-procedure-property! (macro-transformer (module-ref (current-module) 'parallelism-limiter?)) 'documentation "Return @code{#t} if OBJ is a @code{}.") (define* (make-parallelism-limiter limit #:key (name "unnamed")) "Return a parallelism limiter that allows at most LIMIT concurrent fibers to execute within @code{with-parallelism-limiter} at the same time. Further fibers block until a slot becomes free. @code{#:name} is a string used in log messages. Defaults to @code{\"unnamed\"}." (make-parallelism-limiter-record (make-fixed-size-resource-pool (iota limit) #:name name))) (define (destroy-parallelism-limiter parallelism-limiter) "Destroy PARALLELISM-LIMITER, releasing its underlying resource pool." (destroy-resource-pool (parallelism-limiter-resource-pool parallelism-limiter))) (define* (call-with-parallelism-limiter parallelism-limiter thunk) "Acquire a slot from PARALLELISM-LIMITER, call THUNK, release the slot, and return the values from THUNK. Blocks if no slot is currently available." (call-with-resource-from-pool (parallelism-limiter-resource-pool parallelism-limiter) (lambda _ (thunk)))) (define-syntax-rule (with-parallelism-limiter parallelism-limiter exp ...) "Evaluate EXP ... while holding a slot from PARALLELISM-LIMITER. Syntactic sugar around @code{call-with-parallelism-limiter}." (call-with-parallelism-limiter parallelism-limiter (lambda () exp ...))) guile-knots-0.1/knots/promise.scm000066400000000000000000000126251516027255200171460ustar00rootroot00000000000000;;; Guile Knots ;;; Copyright © 2020 Christopher Baines ;;; ;;; This file is part of Guile Knots. ;;; ;;; The Guile Knots 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. ;;; ;;; The Guile Knots 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 the guix-data-service. If not, see ;;; . (define-module (knots promise) #:use-module (srfi srfi-9) #:use-module (ice-9 match) #:use-module (ice-9 atomic) #:use-module (ice-9 exceptions) #:use-module (fibers) #:use-module (fibers conditions) #:use-module (knots) #:export (fibers-promise? fibers-delay fibers-delay/eager fibers-force fibers-promise-reset fibers-promise-result-available?)) (define-record-type (make-fibers-promise thunk values-box evaluated-condition) fibers-promise? (thunk fibers-promise-thunk) (values-box fibers-promise-values-box) (evaluated-condition fibers-promise-evaluated-condition)) (set-procedure-property! (macro-transformer (module-ref (current-module) 'fibers-promise?)) 'documentation "Return @code{#t} if OBJ is a @code{}.") (define (fibers-delay thunk) "Return a new fiber-aware promise that will evaluate THUNK when first forced. THUNK is not called until @code{fibers-force} is called on the promise." (make-fibers-promise thunk (make-atomic-box #f) (make-condition))) (define (fibers-force fp) "Force the fiber-aware promise FP, returning its values. The first call evaluates the promise's thunk. Concurrent callers block on a condition variable until evaluation finishes, then receive the same result. If the thunk raises an exception, the exception is stored and re-raised for all callers." (unless (fibers-promise? fp) (raise-exception (make-exception (make-exception-with-message "fibers-force: not a fibers promise") (make-exception-with-irritants fp)))) (let ((res (atomic-box-compare-and-swap! (fibers-promise-values-box fp) #f 'started))) (cond ((eq? #f res) (call-with-values (lambda () (with-exception-handler (lambda (exn) (atomic-box-set! (fibers-promise-values-box fp) exn) (signal-condition! (fibers-promise-evaluated-condition fp)) (raise-exception exn)) (lambda () (with-exception-handler (lambda (exn) (let ((stack (match (fluid-ref %stacks) ((stack-tag . prompt-tag) (make-stack #t 0 prompt-tag 0 (and prompt-tag 1))) (_ (make-stack #t))))) (raise-exception (make-exception exn (make-knots-exception stack))))) (lambda () (start-stack #t ((fibers-promise-thunk fp)))))) #:unwind? #t)) (lambda vals (atomic-box-set! (fibers-promise-values-box fp) vals) (signal-condition! (fibers-promise-evaluated-condition fp)) (apply values vals)))) ((eq? res 'started) (begin (wait (fibers-promise-evaluated-condition fp)) (let ((result (atomic-box-ref (fibers-promise-values-box fp)))) (if (exception? result) (raise-exception result) (apply values result))))) (else (if (exception? res) (raise-exception res) (apply values res)))))) (define (fibers-delay/eager thunk) "Return a new fiber-aware promise and immediately begin evaluating THUNK in a new fiber. Exceptions during eager evaluation are silently discarded; they will be re-raised when @code{fibers-force} is called." (let ((promise (fibers-delay thunk))) (spawn-fiber (lambda () (with-exception-handler (lambda _ ;; Silently handle this exception #f) (lambda () (fibers-force promise)) #:unwind? #t))) promise)) (define (fibers-promise-reset fp) "Reset the fiber-aware promise FP so that the next call to @code{fibers-force} re-evaluates its thunk." (atomic-box-set! (fibers-promise-values-box fp) #f)) (define (fibers-promise-result-available? fp) "Return @code{#t} if the fiber-aware promise FP has been evaluated (successfully or with an exception) and @code{#f} if evaluation has not yet started or is still in progress." (let ((val (atomic-box-ref (fibers-promise-values-box fp)))) (not (or (eq? val #f) (eq? val 'started))))) guile-knots-0.1/knots/queue.scm000066400000000000000000000037621516027255200166160ustar00rootroot00000000000000;;; Guile Knots ;;; Copyright © 2020 Christopher Baines ;;; ;;; This file is part of Guile Knots. ;;; ;;; The Guile Knots 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. ;;; ;;; The Guile Knots 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 the guix-data-service. If not, see ;;; . (define-module (knots queue) #:use-module (ice-9 q) #:use-module (fibers) #:use-module (fibers channels) #:use-module (fibers operations) #:export (spawn-queueing-fiber)) (define (spawn-queueing-fiber dest-channel) "Spawn a fiber that serialises items onto DEST-CHANNEL in FIFO order. Returns a new input channel. Multiple producers can put items on the returned channel concurrently. The fiber buffers them locally and forwards them to DEST-CHANNEL one at a time, preserving arrival order." (define queue (make-q)) (let ((queue-channel (make-channel))) (spawn-fiber (lambda () (while #t (if (q-empty? queue) (enq! queue (perform-operation (get-operation queue-channel))) (let ((front (q-front queue))) (perform-operation (choice-operation (wrap-operation (get-operation queue-channel) (lambda (val) (enq! queue val))) (wrap-operation (put-operation dest-channel front) (lambda _ (q-pop! queue)))))))))) queue-channel)) guile-knots-0.1/knots/resource-pool.scm000066400000000000000000001732731516027255200202750ustar00rootroot00000000000000;;; Guile Knots ;;; Copyright © 2020 Christopher Baines ;;; ;;; This file is part of Guile Knots. ;;; ;;; The Guile Knots 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. ;;; ;;; The Guile Knots 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 the guix-data-service. If not, see ;;; . (define-module (knots resource-pool) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-9 gnu) #:use-module (srfi srfi-43) #:use-module (srfi srfi-71) #:use-module (ice-9 q) #:use-module (ice-9 match) #:use-module (ice-9 exceptions) #:use-module (fibers) #:use-module (fibers timers) #:use-module (fibers channels) #:use-module (fibers scheduler) #:use-module (fibers operations) #:use-module (fibers conditions) #:use-module (knots) #:use-module (knots parallelism) #:export (make-fixed-size-resource-pool make-resource-pool resource-pool? resource-pool-name resource-pool-channel resource-pool-configuration destroy-resource-pool &resource-pool-timeout resource-pool-timeout-error-pool resource-pool-timeout-error? &resource-pool-too-many-waiters resource-pool-too-many-waiters-error-pool resource-pool-too-many-waiters-error-waiters-count resource-pool-too-many-waiters-error? &resource-pool-destroyed resource-pool-destroyed-error-pool resource-pool-destroyed-error? &resource-pool-destroy-resource make-resource-pool-destroy-resource-exception resource-pool-destroy-resource-exception? resource-pool-delay-logger resource-pool-duration-logger resource-pool-default-timeout-handler call-with-resource-from-pool with-resource-from-pool resource-pool-stats)) (define &resource-pool-abort-add-resource (make-exception-type '&recource-pool-abort-add-resource &error '())) (define make-resource-pool-abort-add-resource-error (record-constructor &resource-pool-abort-add-resource)) (define resource-pool-abort-add-resource-error? (exception-predicate &resource-pool-abort-add-resource)) (define-record-type (make-resource-pool-record name channel destroy-condition configuration) resource-pool? (name resource-pool-name) (channel resource-pool-channel set-resource-pool-channel!) (destroy-condition resource-pool-destroy-condition) (configuration resource-pool-configuration)) (set-procedure-property! (macro-transformer (module-ref (current-module) 'resource-pool?)) 'documentation "Return @code{#t} if OBJ is a @code{}.") (set-procedure-property! (macro-transformer (module-ref (current-module) 'resource-pool-name)) 'documentation "Return the name of the resource pool.") (set-procedure-property! (macro-transformer (module-ref (current-module) 'resource-pool-channel)) 'documentation "Return the channel used by the resource pool.") (set-procedure-property! (macro-transformer (module-ref (current-module) 'resource-pool-configuration)) 'documentation "Return the configuration alist of the resource pool.") (define (resource-pool-delay-logger resource-pool) (assq-ref (resource-pool-configuration resource-pool) 'delay-logger)) (define (resource-pool-duration-logger resource-pool) (assq-ref (resource-pool-configuration resource-pool) 'duration-logger)) (set-record-type-printer! (lambda (resource-pool port) (display/knots (simple-format #f "#" (resource-pool-name resource-pool)) port))) (define (safe-deq q) (if (null? (car q)) #f (let ((it (caar q)) (next (cdar q))) (if (null? next) (set-cdr! q #f)) (set-car! q next) it))) (define-record-type (make-resource-details value checkout-count last-used) resource-details? (value resource-details-value) (checkout-count resource-details-checkout-count set-resource-details-checkout-count!) (last-used resource-details-last-used set-resource-details-last-used!)) (define-inlinable (increment-resource-checkout-count! resource) (set-resource-details-checkout-count! resource (1+ (resource-details-checkout-count resource)))) (define-inlinable (decrement-resource-checkout-count! resource) (set-resource-details-checkout-count! resource (1- (resource-details-checkout-count resource)))) (define (spawn-fiber-for-checkout channel reply-channel reply-timeout resource-id resource) (spawn-fiber (lambda () (let ((checkout-success? (perform-operation (choice-operation (wrap-operation (put-operation reply-channel (list 'success resource-id resource)) (const #t)) (wrap-operation (sleep-operation reply-timeout) (const #f)))))) (unless checkout-success? (put-message channel (list 'return-failed-checkout resource-id))))))) (define* (make-fixed-size-resource-pool resources-list-or-vector #:key (delay-logger #f) (duration-logger #f) scheduler (name "unnamed") default-checkout-timeout default-max-waiters) "Create a resource pool from RESOURCES-LIST-OR-VECTOR, a list or vector of pre-existing resource values. Use @code{with-resource-from-pool} or @code{call-with-resource-from-pool} to borrow a resource and return it automatically when done. Optional keyword arguments: @table @code @item #:name A optional string used in log messages. Defaults to @code{\"unnamed\"}. @item #:default-checkout-timeout Default checkout timeout when requesting a resource from the pool, unset by default. @item #:default-max-waiters Maximum number of fibers that may queue waiting for a resource. When this limit is exceeded, @code{&resource-pool-too-many-waiters} is raised when a resource is requested. Defaults to @code{#f} (no limit). @item #:delay-logger Called as @code{(delay-logger seconds)} with the time spent waiting for a resource to become available. Defaults to @code{#f} (no logging). @item #:duration-logger Called as @code{(duration-logger seconds)} after the proc passed to @code{call-with-resource-from-pool} completes, whether it returned normally or raised an exception. Can be overridden per-call via the @code{#:duration-logger} keyword argument to @code{call-with-resource-from-pool}. Defaults to @code{#f} (no logging). @item #:scheduler The Fibers scheduler to use for the pool's internal fiber. Defaults to the current scheduler. @end table" (define channel (make-channel)) (define destroy-condition (make-condition)) (define pool (make-resource-pool-record name channel destroy-condition `((delay-logger . ,delay-logger) (duration-logger . ,duration-logger) (scheduler . ,scheduler) (name . ,name) (default-checkout-timeout . ,default-checkout-timeout) (default-max-waiters . ,default-max-waiters)))) (define checkout-failure-count 0) (define resources (vector-map (lambda (_ resource) (make-resource-details resource 0 #f)) (if (vector? resources-list-or-vector) resources-list-or-vector (list->vector resources-list-or-vector)))) (define (destroy-loop) (define (empty?) (vector-every (lambda (r) (eq? r #f)) resources)) (let loop () (match (get-message channel) (('checkout reply timeout-time max-waiters) (spawn-fiber (lambda () (let ((op (put-operation reply (cons 'resource-pool-destroyed #f)))) (perform-operation (if timeout-time (choice-operation op (wrap-operation (sleep-operation (/ (- timeout-time (get-internal-real-time)) internal-time-units-per-second)) (const #f))) op))))) (loop)) (((and (or 'return 'return-failed-checkout) return-type) resource-id) (vector-set! resources resource-id #f) (if (empty?) (begin (set-resource-pool-channel! pool #f) (signal-condition! destroy-condition) ;; No loop *unspecified*) (loop))) (('stats reply timeout-time) (let ((stats `((resources . ,(vector-length resources)) (available . 0) (waiters . 0) (checkout-failure-count . ,checkout-failure-count)))) (spawn-fiber (lambda () (let ((op (put-operation reply stats))) (perform-operation (if timeout-time (choice-operation op (sleep-operation (/ (- timeout-time (get-internal-real-time)) internal-time-units-per-second))) op)))))) (loop)) (('destroy) (loop)) (unknown (simple-format (current-error-port) "unrecognised message to ~A resource pool channel: ~A\n" name unknown) (loop))))) (define (main-loop) (let loop ((available (iota (vector-length resources))) (waiters (make-q))) (match (get-message channel) (('checkout reply timeout-time max-waiters) (if (null? available) (let ((waiters-count (q-length waiters))) (if (and max-waiters (>= waiters-count max-waiters)) (begin (spawn-fiber (lambda () (let ((op (put-operation reply (cons 'too-many-waiters waiters-count)))) (perform-operation (if timeout-time (choice-operation op (wrap-operation (sleep-operation (/ (- timeout-time (get-internal-real-time)) internal-time-units-per-second)) (const #f))) op))))) (loop available waiters)) (loop available (enq! waiters (cons reply timeout-time))))) (if timeout-time (let ((current-internal-time (get-internal-real-time))) ;; If this client is still waiting (if (> timeout-time current-internal-time) (let ((reply-timeout (/ (- timeout-time current-internal-time) internal-time-units-per-second)) (resource-id new-available (car+cdr available))) ;; Don't sleep in this fiber, so spawn a new ;; fiber to handle handing over the resource, ;; and returning it if there's a timeout (spawn-fiber-for-checkout channel reply reply-timeout resource-id (resource-details-value (vector-ref resources resource-id))) (loop new-available waiters)) (loop available waiters))) (let* ((resource-id next-available (car+cdr available)) (resource-details (vector-ref resources resource-id))) (put-message reply (list 'success resource-id (resource-details-value resource-details))) (loop next-available waiters))))) (((and (or 'return 'return-failed-checkout) return-type) resource-id) (when (eq? 'return-failed-checkout return-type) (set! checkout-failure-count (+ 1 checkout-failure-count))) (let ((current-internal-time (get-internal-real-time))) (let waiter-loop ((waiter (safe-deq waiters))) (match waiter (#f (loop (cons resource-id available) waiters)) ((reply . timeout) (if (and timeout (< timeout current-internal-time)) (waiter-loop (safe-deq waiters)) (if timeout (let ((reply-timeout (/ (- timeout current-internal-time) internal-time-units-per-second))) ;; Don't sleep in this fiber, so spawn a ;; new fiber to handle handing over the ;; resource, and returning it if there's ;; a timeout (spawn-fiber-for-checkout channel reply reply-timeout resource-id (resource-details-value (vector-ref resources resource-id)))) (put-message reply (list 'success resource-id (resource-details-value (vector-ref resources resource-id)))))) (loop available waiters)))))) (('list-resources reply) (spawn-fiber (lambda () (put-message reply (vector->list resources)))) (loop available waiters)) (('stats reply timeout-time) (let ((stats `((resources . ,(vector-length resources)) (available . ,(length available)) (waiters . ,(q-length waiters)) (checkout-failure-count . ,checkout-failure-count)))) (spawn-fiber (lambda () (let ((op (put-operation reply stats))) (perform-operation (if timeout-time (choice-operation op (sleep-operation (/ (- timeout-time (get-internal-real-time)) internal-time-units-per-second))) op)))))) (loop available waiters)) (('destroy) (let ((current-internal-time (get-internal-real-time))) ;; Notify all waiters that the pool has been destroyed (for-each (match-lambda ((reply . timeout) (when (or (not timeout) (> timeout current-internal-time)) (spawn-fiber (lambda () (let ((op (put-operation reply (cons 'resource-pool-destroyed #f)))) (perform-operation (if timeout (choice-operation op (wrap-operation (sleep-operation (/ (- timeout (get-internal-real-time)) internal-time-units-per-second)) (const #f))) op)))))))) (car waiters)) (if (= (vector-length resources) (length available)) (begin (set-resource-pool-channel! pool #f) (signal-condition! destroy-condition) ;; No loop *unspecified*) (destroy-loop)))) (unknown (simple-format (current-error-port) "unrecognised message to ~A resource pool channel: ~A\n" name unknown) (loop available waiters))))) (spawn-fiber (lambda () (with-exception-handler (lambda (exn) #f) (lambda () (with-exception-handler (lambda (exn) (let* ((stack (make-stack #t)) (error-string (call-with-output-string (lambda (port) (display-backtrace stack port 3) (simple-format port "exception in the ~A pool fiber, " name) (print-exception port (stack-ref stack 3) '%exception (list exn)))))) (display/knots error-string (current-error-port))) (raise-exception exn)) (lambda () (start-stack #t (main-loop))))) #:unwind? #t)) (or scheduler (current-scheduler))) pool) (define* (make-resource-pool return-new-resource max-size #:key (min-size 0) (idle-seconds #f) (delay-logger #f) (duration-logger #f) destructor lifetime scheduler (name "unnamed") (add-resources-parallelism 1) default-checkout-timeout default-max-waiters) "Create a dynamic resource pool. RETURN-NEW-RESOURCE is a thunk called to create each new resource value. MAX-SIZE is the maximum number of resources the pool will hold simultaneously. Resources are created on demand when a checkout is requested and the pool is not yet at MAX-SIZE. Use @code{with-resource-from-pool} or @code{call-with-resource-from-pool} to request a resource and return it automatically when done. Optional keyword arguments: @table @code @item #:min-size Minimum number of resources to keep alive even when idle. Defaults to @code{0}. @item #:idle-seconds Seconds a resource may remain unused before being destroyed, provided the pool is above @code{#:min-size}. Defaults to @code{#f} (never expire idle resources). @item #:lifetime Maximum number of checkouts a single resource will serve before being destroyed and replaced by a fresh one. Defaults to @code{#f} (no limit). @item #:destructor A procedure called as @code{(destructor resource)} when a resource is removed from the pool. Defaults to @code{#f}. @item #:add-resources-parallelism Maximum number of concurrent calls to RETURN-NEW-RESOURCE when the pool needs to grow. Allowing resources to be created in parallel can result in more resources being created than can fit inside the pool, if this happens, the surplus resources are destroyed. Defaults to @code{1}. @item #:name A string used in log messages. Defaults to @code{\"unnamed\"}. @item #:default-checkout-timeout Default checkout timeout when requesting a resource from the pool, unset by default. @item #:default-max-waiters Maximum number of fibers that may queue waiting for a resource. When this limit is exceeded, @code{&resource-pool-too-many-waiters} is raised when a resource is requested. Defaults to @code{#f} (no limit). @item #:delay-logger Called as @code{(delay-logger seconds)} with the time spent waiting for a resource to become available. Defaults to @code{#f} (no logging). @item #:duration-logger Called as @code{(duration-logger seconds)} after the proc passed to @code{call-with-resource-from-pool} completes, whether it returned normally or raised an exception. Can be overridden per-call via the @code{#:duration-logger} keyword argument to @code{call-with-resource-from-pool}. Defaults to @code{#f} (no logging). @item #:scheduler The Fibers scheduler to use for the pool's internal fiber. Defaults to the current scheduler. @end table" (define channel (make-channel)) (define destroy-condition (make-condition)) (define pool (make-resource-pool-record name channel destroy-condition `((max-size . ,max-size) (min-size . ,min-size) (idle-seconds . ,idle-seconds) (delay-logger . ,delay-logger) (duration-logger . ,duration-logger) (destructor . ,destructor) (lifetime . ,lifetime) (scheduler . ,scheduler) (name . ,name) (default-checkout-timeout . ,default-checkout-timeout) (default-max-waiters . ,default-max-waiters)))) (define checkout-failure-count 0) (define resources (make-hash-table)) (define-inlinable (count-resources resources) (hash-count (const #t) resources)) (define return-new-resource/parallelism-limiter (make-parallelism-limiter (or add-resources-parallelism max-size) #:name (string-append name " resource pool new resource parallelism limiter"))) (define (spawn-fiber-to-return-new-resource) (spawn-fiber (lambda () (with-exception-handler (lambda (exn) ;; This can happen if the resource pool is destroyed very ;; quickly (if (resource-pool-destroyed-error? exn) #f (raise-exception exn))) (lambda () (let loop () (let ((success? (with-parallelism-limiter return-new-resource/parallelism-limiter (let ((max-size (assq-ref (resource-pool-configuration pool) 'max-size)) (size (count-resources resources))) (or (>= size max-size) (with-exception-handler (lambda _ #f) (lambda () (with-exception-handler (lambda (exn) (simple-format (current-error-port) "exception adding resource to pool ~A: ~A\n\n" name return-new-resource) (print-backtrace-and-exception/knots exn) (raise-exception exn)) (lambda () (let ((new-resource (start-stack #t (return-new-resource)))) (put-message channel (list 'add-resource new-resource))) #t))) #:unwind? #t)))))) (unless success? ;; TODO Maybe this should be configurable? (sleep 1) ;; Important to retry here and eventually create ;; a new resource, as there might be waiters ;; stuck waiting for a resource, especially if ;; the pool is empty. (loop))))) #:unwind? #t)))) (define (spawn-fiber-to-destroy-resource resource-id resource-value) (spawn-fiber (lambda () (let loop () (let* ((success? (with-exception-handler (lambda _ #f) (lambda () (with-exception-handler (lambda (exn) (simple-format (current-error-port) "exception running resource pool destructor (~A): ~A\n" name destructor) (print-backtrace-and-exception/knots exn) (raise-exception exn)) (lambda () (start-stack #t (destructor resource-value)) #t))) #:unwind? #t))) (if success? (put-message channel (list 'remove resource-id)) (begin (sleep 5) (loop)))))))) (define (destroy-loop resources next-resource-id) (let loop ((next-resource-id next-resource-id)) (match (get-message channel) (('add-resource resource) (if destructor (begin (spawn-fiber-to-destroy-resource next-resource-id resource) (hash-set! resources next-resource-id resource) (loop (1+ next-resource-id))) (loop next-resource-id))) (('checkout reply timeout-time max-waiters) (spawn-fiber (lambda () (let ((op (put-operation reply (cons 'resource-pool-destroyed #f)))) (perform-operation (if timeout-time (choice-operation op (wrap-operation (sleep-operation (/ (- timeout-time (get-internal-real-time)) internal-time-units-per-second)) (const #f))) op))))) (loop next-resource-id)) (((and (or 'return 'return-failed-checkout 'remove) return-type) resource-id) (when (and (not (eq? return-type 'remove)) destructor) (spawn-fiber-to-destroy-resource resource-id (resource-details-value (hash-ref resources resource-id)))) (hash-remove! resources resource-id) (if (= 0 (count-resources resources)) (begin (set-resource-pool-channel! pool #f) (signal-condition! destroy-condition) ;; No loop *unspecified*) (loop next-resource-id))) (('stats reply timeout-time) (let ((stats `((resources . ,(count-resources resources)) (available . 0) (waiters . 0) (checkout-failure-count . ,checkout-failure-count)))) (spawn-fiber (lambda () (let ((op (put-operation reply stats))) (perform-operation (if timeout-time (choice-operation op (sleep-operation (/ (- timeout-time (get-internal-real-time)) internal-time-units-per-second))) op)))))) (loop next-resource-id)) (('check-for-idle-resources) (loop next-resource-id)) (('destroy) (loop next-resource-id)) (unknown (simple-format (current-error-port) "unrecognised message to ~A resource pool channel: ~A\n" name unknown) (loop next-resource-id))))) (define (main-loop) (let loop ((next-resource-id 0) (available '()) (waiters (make-q))) (match (get-message channel) (('add-resource resource) (if (= (count-resources resources) max-size) (if destructor (begin (hash-set! resources next-resource-id (make-resource-details resource 0 (get-internal-real-time))) (spawn-fiber-to-destroy-resource next-resource-id resource) (loop (1+ next-resource-id) available waiters)) (loop next-resource-id available waiters)) (let* ((current-internal-time (get-internal-real-time)) (resource-details (make-resource-details resource 0 current-internal-time))) (hash-set! resources next-resource-id resource-details) (let waiter-loop ((waiter (safe-deq waiters))) (match waiter (#f (loop (1+ next-resource-id) (cons next-resource-id available) waiters)) ((reply . timeout) (if (and timeout (< timeout current-internal-time)) (waiter-loop (safe-deq waiters)) (if timeout (let ((reply-timeout (/ (- timeout current-internal-time) internal-time-units-per-second))) ;; Don't sleep in this fiber, so spawn a ;; new fiber to handle handing over the ;; resource, and returning it if there's ;; a timeout (spawn-fiber-for-checkout channel reply reply-timeout next-resource-id resource)) (put-message reply (list 'success next-resource-id resource)))) (set-resource-details-checkout-count! resource-details 1) (loop (1+ next-resource-id) available waiters))))))) (('checkout reply timeout-time max-waiters) (if (null? available) (begin (unless (= (count-resources resources) max-size) (spawn-fiber-to-return-new-resource)) (let ((waiters-count (q-length waiters))) (if (and max-waiters (>= waiters-count max-waiters)) (begin (spawn-fiber (lambda () (let ((op (put-operation reply (cons 'too-many-waiters waiters-count)))) (perform-operation (if timeout-time (choice-operation op (wrap-operation (sleep-operation (/ (- timeout-time (get-internal-real-time)) internal-time-units-per-second)) (const #f))) op))))) (loop next-resource-id available waiters)) (loop next-resource-id available (enq! waiters (cons reply timeout-time)))))) (if timeout-time (let ((current-internal-time (get-internal-real-time))) ;; If this client is still waiting (if (> timeout-time current-internal-time) (let* ((reply-timeout (/ (- timeout-time current-internal-time) internal-time-units-per-second)) (resource-id (car available)) (resource-details (hash-ref resources resource-id))) (increment-resource-checkout-count! resource-details) ;; Don't sleep in this fiber, so spawn a new ;; fiber to handle handing over the resource, ;; and returning it if there's a timeout (spawn-fiber-for-checkout channel reply reply-timeout resource-id (resource-details-value resource-details)) (loop next-resource-id (cdr available) waiters)) (loop next-resource-id available waiters))) (let* ((resource-id next-available (car+cdr available)) (resource-details (hash-ref resources resource-id))) (increment-resource-checkout-count! resource-details) (put-message reply (list 'success resource-id (resource-details-value resource-details))) (loop next-resource-id next-available waiters))))) (((and (or 'return 'return-failed-checkout) return-type) resource-id) (when (eq? 'return-failed-checkout return-type) (set! checkout-failure-count (+ 1 checkout-failure-count))) (let ((current-internal-time (get-internal-real-time)) (resource-details (hash-ref resources resource-id))) (if (and lifetime (>= (resource-details-checkout-count resource-details) lifetime)) (begin (spawn-fiber-to-destroy-resource resource-id (resource-details-value resource-details)) (loop next-resource-id available waiters)) (let waiter-loop ((waiter (safe-deq waiters))) (match waiter (#f (if (eq? 'return-failed-checkout return-type) (decrement-resource-checkout-count! resource-details) (set-resource-details-last-used! resource-details current-internal-time)) (loop next-resource-id (cons resource-id available) waiters)) ((reply . timeout) (if (and timeout (< timeout current-internal-time)) (waiter-loop (safe-deq waiters)) (if timeout (let ((reply-timeout (/ (- timeout current-internal-time) internal-time-units-per-second))) ;; Don't sleep in this fiber, so spawn a ;; new fiber to handle handing over the ;; resource, and returning it if there's ;; a timeout (spawn-fiber-for-checkout channel reply reply-timeout resource-id (resource-details-value resource-details))) (put-message reply (list 'success resource-id (resource-details-value resource-details))))) (set-resource-details-last-used! resource-details current-internal-time) (when (eq? 'return-failed-checkout return-type) (decrement-resource-checkout-count! resource-details)) (loop next-resource-id available waiters))))))) (('remove resource-id) (hash-remove! resources resource-id) (when (and (not (q-empty? waiters)) (< (- (count-resources resources) 1) max-size)) (spawn-fiber-to-return-new-resource)) (loop next-resource-id available ; resource shouldn't be in this list waiters)) (('destroy resource-id) (let ((resource-details (hash-ref resources resource-id))) (spawn-fiber-to-destroy-resource resource-id (resource-details-value resource-details)) (loop next-resource-id available waiters))) (('list-resources reply) (spawn-fiber (lambda () (put-message reply (hash-map->list (lambda (_ value) value) resources)))) (loop next-resource-id available waiters)) (('stats reply timeout-time) (let ((stats `((resources . ,(count-resources resources)) (available . ,(length available)) (waiters . ,(q-length waiters)) (resources-checkout-count . ,(hash-fold (lambda (_ resource-details result) (cons (resource-details-checkout-count resource-details) result)) '() resources)) (checkout-failure-count . ,checkout-failure-count)))) (spawn-fiber (lambda () (let ((op (put-operation reply stats))) (perform-operation (if timeout-time (choice-operation op (sleep-operation (/ (- timeout-time (get-internal-real-time)) internal-time-units-per-second))) op)))))) (loop next-resource-id available waiters)) (('check-for-idle-resources) (let* ((internal-real-time (get-internal-real-time)) (candidate-resource-ids-to-destroy (filter-map (lambda (resource-id) (let ((resource-details (hash-ref resources resource-id))) (if (> (/ (- internal-real-time (resource-details-last-used resource-details)) internal-time-units-per-second) idle-seconds) resource-id #f))) available)) (max-resources-to-destroy (max 0 (- (count-resources resources) min-size))) (resources-to-destroy (take candidate-resource-ids-to-destroy (min max-resources-to-destroy (length candidate-resource-ids-to-destroy))))) (when destructor (for-each (lambda (resource-id) (spawn-fiber-to-destroy-resource resource-id (resource-details-value (hash-ref resources resource-id)))) resources-to-destroy)) (loop next-resource-id (lset-difference = available resources-to-destroy) waiters))) (('destroy) (let ((current-internal-time (get-internal-real-time))) (for-each (match-lambda ((reply . timeout) (when (or (not timeout) (> timeout current-internal-time)) (spawn-fiber (lambda () (let ((op (put-operation reply (cons 'resource-pool-destroyed #f)))) (perform-operation (if timeout (choice-operation op (wrap-operation (sleep-operation (/ (- timeout (get-internal-real-time)) internal-time-units-per-second)) (const #f))) op)))))))) (car waiters)) (when destructor (for-each (lambda (resource-id) (spawn-fiber-to-destroy-resource resource-id (resource-details-value (hash-ref resources resource-id)))) available)) ;; Do this in parallel to avoid deadlocks between the ;; limiter and returning new resources to this pool (and=> return-new-resource/parallelism-limiter (lambda (limiter) (spawn-fiber (lambda () (destroy-parallelism-limiter limiter))))) (if (or (= 0 (count-resources resources)) (not destructor)) (begin (set-resource-pool-channel! pool #f) (signal-condition! destroy-condition) ;; No loop *unspecified*) (destroy-loop resources next-resource-id)))) (unknown (simple-format (current-error-port) "unrecognised message to ~A resource pool channel: ~A\n" name unknown) (loop next-resource-id available waiters))))) (spawn-fiber (lambda () (when idle-seconds (spawn-fiber (lambda () (let loop () (put-message channel '(check-for-idle-resources)) (when (perform-operation (choice-operation (wrap-operation (sleep-operation idle-seconds) (const #t)) (wrap-operation (wait-operation destroy-condition) (const #f)))) (loop)))))) (with-exception-handler (lambda (exn) #f) (lambda () (with-exception-handler (lambda (exn) (let* ((stack (make-stack #t)) (error-string (call-with-output-string (lambda (port) (display-backtrace stack port 3) (simple-format port "exception in the ~A pool fiber, " name) (print-exception port (stack-ref stack 3) '%exception (list exn)))))) (display/knots error-string (current-error-port))) (raise-exception exn)) (lambda () (start-stack #t (main-loop))))) #:unwind? #t)) (or scheduler (current-scheduler))) pool) (define (destroy-resource-pool pool) "Destroy POOL, preventing any new checkouts. Blocks until all checked-out resources have been returned, running the pool's @code{#:destructor} on each. Any fibers waiting for a resource receive @code{&resource-pool-destroyed}." (perform-operation (choice-operation (wrap-operation (put-operation (resource-pool-channel pool) (list 'destroy)) (lambda _ (wait (resource-pool-destroy-condition pool)))) (wait-operation (resource-pool-destroy-condition pool)))) #t) (define &resource-pool-timeout (make-exception-type '&recource-pool-timeout &error '(pool))) (define resource-pool-timeout-error-pool (exception-accessor &resource-pool-timeout (record-accessor &resource-pool-timeout 'pool))) (set-procedure-property! resource-pool-timeout-error-pool 'documentation "Return the pool from a @code{&resource-pool-timeout} exception.") (define make-resource-pool-timeout-error (record-constructor &resource-pool-timeout)) (define resource-pool-timeout-error? (exception-predicate &resource-pool-timeout)) (set-procedure-property! resource-pool-timeout-error? 'documentation "Return @code{#t} if OBJ is a @code{&resource-pool-timeout} exception.") (define &resource-pool-too-many-waiters (make-exception-type '&recource-pool-too-many-waiters &error '(pool waiters-count))) (define resource-pool-too-many-waiters-error-pool (exception-accessor &resource-pool-too-many-waiters (record-accessor &resource-pool-too-many-waiters 'pool))) (set-procedure-property! resource-pool-too-many-waiters-error-pool 'documentation "Return the pool from a @code{&resource-pool-too-many-waiters} exception.") (define resource-pool-too-many-waiters-error-waiters-count (exception-accessor &resource-pool-too-many-waiters (record-accessor &resource-pool-too-many-waiters 'waiters-count))) (set-procedure-property! resource-pool-too-many-waiters-error-waiters-count 'documentation "Return the waiters count from a @code{&resource-pool-too-many-waiters} exception.") (define make-resource-pool-too-many-waiters-error (record-constructor &resource-pool-too-many-waiters)) (define resource-pool-too-many-waiters-error? (exception-predicate &resource-pool-too-many-waiters)) (set-procedure-property! resource-pool-too-many-waiters-error? 'documentation "Return @code{#t} if OBJ is a @code{&resource-pool-too-many-waiters} exception.") (define &resource-pool-destroyed (make-exception-type '&recource-pool-destroyed &error '(pool))) (define resource-pool-destroyed-error-pool (exception-accessor &resource-pool-destroyed (record-accessor &resource-pool-destroyed 'pool))) (set-procedure-property! resource-pool-destroyed-error-pool 'documentation "Return the pool from a @code{&resource-pool-destroyed} exception.") (define make-resource-pool-destroyed-error (record-constructor &resource-pool-destroyed)) (define resource-pool-destroyed-error? (exception-predicate &resource-pool-destroyed)) (set-procedure-property! resource-pool-destroyed-error? 'documentation "Return @code{#t} if OBJ is a @code{&resource-pool-destroyed} exception.") (define &resource-pool-destroy-resource (make-exception-type '&recource-pool-destroy-resource &exception '())) (define make-resource-pool-destroy-resource-exception (record-constructor &resource-pool-destroy-resource)) (set-procedure-property! make-resource-pool-destroy-resource-exception 'documentation "Construct a @code{&resource-pool-destroy-resource} exception.") (define resource-pool-destroy-resource-exception? (exception-predicate &resource-pool-destroy-resource)) (set-procedure-property! resource-pool-destroy-resource-exception? 'documentation "Return @code{#t} if OBJ is a @code{&resource-pool-destroy-resource} exception.") (define resource-pool-default-timeout-handler (make-parameter #f)) (define* (call-with-resource-from-pool pool proc #:key (timeout 'default) (timeout-handler (resource-pool-default-timeout-handler)) (max-waiters 'default) (channel (resource-pool-channel pool)) (destroy-resource-on-exception? #f) (delay-logger (resource-pool-delay-logger pool)) (duration-logger (resource-pool-duration-logger pool))) "Call PROC with a resource from POOL, blocking until a resource becomes available. Return the resource once PROC has returned. @code{#:delay-logger} is called as @code{(delay-logger seconds)} with the time spent waiting for a resource to become available. Defaults to the pool's @code{#:delay-logger} if not specified. @code{#:duration-logger} is called as @code{(duration-logger seconds)} after PROC completes, whether it returned normally or raised an exception. Defaults to the pool's @code{#:duration-logger} if not specified." (define timeout-or-default (if (eq? timeout 'default) (assq-ref (resource-pool-configuration pool) 'default-checkout-timeout) timeout)) (define max-waiters-or-default (if (eq? max-waiters 'default) (assq-ref (resource-pool-configuration pool) 'default-max-waiters) max-waiters)) (define (delay-logger/safe seconds) (with-exception-handler ;; Ignore exceptions, since this would break returning the ;; resource (lambda (exn) #f) (lambda () (delay-logger seconds)) #:unwind? #t)) (define (duration-logger/safe seconds) (with-exception-handler ;; Ignore exceptions, since this would break returning the ;; resource (lambda (exn) #f) (lambda () (duration-logger seconds)) #:unwind? #t)) (define checkout-start-time (get-internal-real-time)) (unless channel (raise-exception (make-resource-pool-destroyed-error pool))) (let ((reply (if timeout-or-default (let loop ((reply (make-channel)) (start-time (get-internal-real-time))) (let ((request-success? (perform-operation (choice-operation (wrap-operation (put-operation channel (list 'checkout reply (+ start-time (* timeout-or-default internal-time-units-per-second)) max-waiters-or-default)) (const #t)) (wrap-operation (sleep-operation timeout-or-default) (const #f)))))) (if request-success? (let ((time-remaining (- timeout-or-default (/ (- (get-internal-real-time) start-time) internal-time-units-per-second)))) (if (> time-remaining 0) (let ((response (perform-operation (choice-operation (get-operation reply) (wrap-operation (sleep-operation time-remaining) (const #f)))))) (if (or (not response) (eq? response 'resource-pool-retry-checkout)) (if (> (- timeout-or-default (/ (- (get-internal-real-time) start-time) internal-time-units-per-second)) 0) (loop (make-channel) start-time) 'timeout) response)) 'timeout)) 'timeout))) (let ((reply (make-channel))) (put-message channel (list 'checkout reply #f max-waiters-or-default)) (get-message reply))))) (match reply ('timeout (when timeout-handler (timeout-handler pool proc timeout)) (raise-exception (make-resource-pool-timeout-error pool))) (('too-many-waiters . count) (raise-exception (make-resource-pool-too-many-waiters-error pool count))) (('resource-pool-destroyed . #f) (raise-exception (make-resource-pool-destroyed-error pool))) (('success resource-id resource-value) (when delay-logger (delay-logger/safe (/ (- (get-internal-real-time) checkout-start-time) internal-time-units-per-second))) (let ((proc-start-time (get-internal-real-time))) (call-with-values (lambda () (with-exception-handler (lambda (exn) ;; Unwind the stack before calling put-message, as ;; this avoids inconsistent behaviour with ;; continuation barriers (when duration-logger (duration-logger/safe (/ (- (get-internal-real-time) proc-start-time) internal-time-units-per-second))) (put-message channel (list (if (or destroy-resource-on-exception? (resource-pool-destroy-resource-exception? exn)) 'destroy 'return) resource-id)) (raise-exception exn)) (lambda () (with-exception-handler (lambda (exn) (let ((stack (match (fluid-ref %stacks) ((stack-tag . prompt-tag) (make-stack #t 0 prompt-tag 0 (and prompt-tag 1))) (_ (make-stack #t))))) (raise-exception (make-exception exn (make-knots-exception stack))))) (lambda () (proc resource-value)))) #:unwind? #t)) (lambda vals (when duration-logger (duration-logger/safe (/ (- (get-internal-real-time) proc-start-time) internal-time-units-per-second))) (put-message channel `(return ,resource-id)) (apply values vals)))))))) (define-syntax-rule (with-resource-from-pool pool resource exp ...) "Evaluate EXP ... with RESOURCE bound to a resource checked out from POOL. Syntactic sugar around @code{call-with-resource-from-pool}." (call-with-resource-from-pool pool (lambda (resource) exp ...))) (define* (resource-pool-stats pool #:key (timeout 5)) "Return an alist of statistics for POOL with the following keys: @table @code @item resources Total number of resources currently held by the pool. @item available Number of resources not currently checked out. @item waiters Number of fibers currently queued waiting for a resource. @item checkout-failure-count Cumulative number of checkouts where an exception was raised inside the proc. @end table Blocks waiting for the pool fiber to respond. @code{#:timeout} is the number of seconds to wait; defaults to @code{5}. Raises @code{&resource-pool-timeout} if the pool does not respond in time." (define channel (resource-pool-channel pool)) (unless channel (raise-exception (make-resource-pool-destroyed-error pool))) (if timeout (let* ((reply (make-channel)) (start-time (get-internal-real-time)) (timeout-time (+ start-time (* internal-time-units-per-second timeout)))) (perform-operation (choice-operation (wrap-operation (put-operation channel `(stats ,reply ,timeout-time)) (const #t)) (wrap-operation (sleep-operation timeout) (lambda _ (raise-exception (make-resource-pool-timeout-error pool)))))) (let ((time-remaining (- timeout (/ (- (get-internal-real-time) start-time) internal-time-units-per-second)))) (if (> time-remaining 0) (perform-operation (choice-operation (get-operation reply) (wrap-operation (sleep-operation time-remaining) (lambda _ (raise-exception (make-resource-pool-timeout-error pool)))))) (raise-exception (make-resource-pool-timeout-error pool))))) (let ((reply (make-channel))) (put-message channel `(stats ,reply #f)) (get-message reply)))) (define (resource-pool-list-resources pool) (define channel (resource-pool-channel pool)) (unless channel (raise-exception (make-resource-pool-destroyed-error pool))) (let ((reply (make-channel))) (put-message (resource-pool-channel pool) (list 'list-resources reply)) (get-message reply))) guile-knots-0.1/knots/sort.scm000066400000000000000000000064711516027255200164610ustar00rootroot00000000000000;;; Guile Knots ;;; Copyright © 2020, 2025 Christopher Baines ;;; ;;; This file is part of Guile Knots. ;;; ;;; The Guile Knots 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. ;;; ;;; The Guile Knots 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 the guix-data-service. If not, see ;;; . (define-module (knots sort) #:use-module (srfi srfi-1) #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (fibers scheduler) #:use-module (knots promise) #:export (fibers-sort!)) (define (try-split-at! lst i) (cond ((< i 0) (error "negitive split size")) ((= i 0) (values '() lst)) (else (let lp ((l lst) (n (- i 1))) (if (<= n 0) (let ((tmp (cdr l))) (unless (null? tmp) (set-cdr! l '())) (values lst tmp)) (if (or (null? l) (null? (cdr l))) (values lst '()) (lp (cdr l) (- n 1)))))))) (define (chunk! lst max-length) (let loop ((chunks '()) (lst lst)) (let ((chunk rest (try-split-at! lst max-length))) (if (null? rest) (reverse! (cons chunk chunks)) (loop (cons chunk chunks) rest))))) (define* (fibers-sort! items less #:key parallelism) "Sort ITEMS destructively using LESS as the comparison procedure, using a parallel merge sort. Returns the sorted list. Splits ITEMS into chunks, sorts each in an eager fiber-promise in parallel, then merges pairs of sorted chunks in parallel until one sorted list remains. @code{#:parallelism} sets the number of initial chunks. Defaults to the current fibers parallelism." (define requested-chunk-count (or parallelism (+ 1 (length (scheduler-remote-peers (current-scheduler)))))) (define items-length (length items)) (if (= 0 items-length) items (let* ((chunk-length (ceiling (/ items-length requested-chunk-count))) (chunks (chunk! items chunk-length))) (let loop ((sorted-chunk-promises (map (lambda (chunk) (fibers-delay/eager (lambda () (sort! chunk less)))) chunks))) (if (null? (cdr sorted-chunk-promises)) (fibers-force (first sorted-chunk-promises)) (loop (map (match-lambda ((items) items) ((a b) (fibers-delay/eager (lambda () (merge! (fibers-force a) (fibers-force b) less))))) (chunk! sorted-chunk-promises 2)))))))) guile-knots-0.1/knots/thread-pool.scm000066400000000000000000000633301516027255200177050ustar00rootroot00000000000000;;; Guile Knots ;;; Copyright © 2020 Christopher Baines ;;; ;;; This file is part of Guile Knots. ;;; ;;; The Guile Knots 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. ;;; ;;; The Guile Knots 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 the guix-data-service. If not, see ;;; . (define-module (knots thread-pool) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-19) #:use-module (srfi srfi-71) #:use-module (system foreign) #:use-module (system base target) #:use-module (rnrs bytevectors) #:use-module (ice-9 q) #:use-module (ice-9 match) #:use-module (ice-9 atomic) #:use-module (ice-9 threads) #:use-module (fibers) #:use-module (fibers timers) #:use-module (fibers channels) #:use-module (fibers operations) #:use-module (knots) #:use-module (knots resource-pool) #:export (set-thread-name thread-name &thread-pool-timeout-error thread-pool-timeout-error-pool thread-pool-timeout-error? make-thread-pool thread-pool? thread-pool-resource-pool make-fixed-size-thread-pool fixed-size-thread-pool? fixed-size-thread-pool-channel fixed-size-thread-pool-current-procedures ;; These procedures work for thread pools and fixed size ;; thread pools thread-pool-arguments-parameter thread-pool-default-checkout-timeout thread-pool-delay-logger thread-pool-duration-logger destroy-thread-pool call-with-thread)) (define* (syscall->procedure return-type name argument-types #:key library) "Return a procedure that wraps the C function NAME using the dynamic FFI, and that returns two values: NAME's return value, and errno. When LIBRARY is specified, look up NAME in that library rather than in the global symbol name space. If an error occurs while creating the binding, defer the error report until the returned procedure is called." (catch #t (lambda () ;; Note: When #:library is set, try it first and fall back to libc ;; proper. This is because libraries like libutil.so have been subsumed ;; by libc.so with glibc >= 2.34. (let ((ptr (dynamic-func name (if library (or (false-if-exception (dynamic-link library)) (dynamic-link)) (dynamic-link))))) ;; The #:return-errno? facility was introduced in Guile 2.0.12. (pointer->procedure return-type ptr argument-types #:return-errno? #t))) (lambda args (lambda _ (throw 'system-error name "~A" (list (strerror ENOSYS)) (list ENOSYS)))))) (define %prctl ;; Should it win the API contest against 'ioctl'? You tell us! (syscall->procedure int "prctl" (list int unsigned-long unsigned-long unsigned-long unsigned-long))) (define PR_SET_NAME 15) ; (define PR_GET_NAME 16) (define PR_SET_CHILD_SUBREAPER 36) (define (set-child-subreaper!) "Set the CHILD_SUBREAPER capability for the current process." (%prctl PR_SET_CHILD_SUBREAPER 1 0 0 0)) (define %max-thread-name-length ;; Maximum length in bytes of the process name, including the terminating ;; zero. 16) (define (set-thread-name!/linux name) "Set the name of the calling thread to NAME. NAME is truncated to 15 bytes." (let ((ptr (string->pointer name))) (let ((ret err (%prctl PR_SET_NAME (pointer-address ptr) 0 0 0))) (unless (zero? ret) (throw 'set-process-name "set-process-name" "set-process-name: ~A" (list (strerror err)) (list err)))))) (define (bytes->string bytes) "Read BYTES, a list of bytes, and return the null-terminated string decoded from there, or #f if that would be an empty string." (match (take-while (negate zero?) bytes) (() #f) (non-zero (list->string (map integer->char non-zero))))) (define (thread-name/linux) "Return the name of the calling thread as a string." (let ((buf (make-bytevector %max-thread-name-length))) (let ((ret err (%prctl PR_GET_NAME (pointer-address (bytevector->pointer buf)) 0 0 0))) (if (zero? ret) (bytes->string (bytevector->u8-list buf)) (throw 'process-name "process-name" "process-name: ~A" (list (strerror err)) (list err)))))) (define set-thread-name (if (string-contains %host-type "linux") set-thread-name!/linux (const #f))) (define thread-name (if (string-contains %host-type "linux") thread-name/linux (const ""))) (define-record-type (thread-pool resource-pool arguments-parameter) thread-pool? (resource-pool thread-pool-resource-pool) (arguments-parameter thread-pool-arguments-parameter-accessor)) (set-procedure-property! (macro-transformer (module-ref (current-module) 'thread-pool?)) 'documentation "Return @code{#t} if OBJ is a @code{}.") (set-procedure-property! (macro-transformer (module-ref (current-module) 'thread-pool-resource-pool)) 'documentation "Return the underlying resource pool of the thread pool.") (define-record-type (fixed-size-thread-pool channel arguments-parameter current-procedures default-checkout-timeout delay-logger duration-logger threads) fixed-size-thread-pool? (channel fixed-size-thread-pool-channel) (arguments-parameter fixed-size-thread-pool-arguments-parameter) (current-procedures fixed-size-thread-pool-current-procedures) (default-checkout-timeout fixed-size-thread-pool-default-checkout-timeout) (delay-logger fixed-size-thread-pool-delay-logger) (duration-logger fixed-size-thread-pool-duration-logger) (threads fixed-size-thread-pool-threads)) (set-procedure-property! (macro-transformer (module-ref (current-module) 'fixed-size-thread-pool?)) 'documentation "Return @code{#t} if OBJ is a @code{}.") (set-procedure-property! (macro-transformer (module-ref (current-module) 'fixed-size-thread-pool-channel)) 'documentation "Return the channel of the fixed-size thread pool.") (set-procedure-property! (macro-transformer (module-ref (current-module) 'fixed-size-thread-pool-current-procedures)) 'documentation "Return the current procedures vector of the fixed-size thread pool.") ;; Since both thread pool records have this field, use a procedure ;; than handles the appropriate accessor (define (thread-pool-arguments-parameter pool) "Return the arguments parameter for POOL, dispatching on pool type." (if (fixed-size-thread-pool? pool) (fixed-size-thread-pool-arguments-parameter pool) (thread-pool-arguments-parameter-accessor pool))) (define (thread-pool-default-checkout-timeout pool) "Return the default checkout timeout for POOL." (if (fixed-size-thread-pool? pool) (fixed-size-thread-pool-default-checkout-timeout pool) (assq-ref (resource-pool-configuration (thread-pool-resource-pool pool)) 'default-checkout-timeout))) (define (thread-pool-delay-logger pool) "Return the delay logger for POOL, dispatching on pool type." (if (fixed-size-thread-pool? pool) (fixed-size-thread-pool-delay-logger pool) (resource-pool-delay-logger (thread-pool-resource-pool pool)))) (define (thread-pool-duration-logger pool) "Return the duration logger for POOL, dispatching on pool type." (if (fixed-size-thread-pool? pool) (fixed-size-thread-pool-duration-logger pool) (resource-pool-duration-logger (thread-pool-resource-pool pool)))) (define &thread-pool-timeout-error (make-exception-type '&thread-pool-timeout-error &error '(pool))) (define make-thread-pool-timeout-error (record-constructor &thread-pool-timeout-error)) (define thread-pool-timeout-error-pool (exception-accessor &thread-pool-timeout-error (record-accessor &thread-pool-timeout-error 'pool))) (set-procedure-property! thread-pool-timeout-error-pool 'documentation "Return the pool from a @code{&thread-pool-timeout-error} exception.") (define thread-pool-timeout-error? (exception-predicate &thread-pool-timeout-error)) (set-procedure-property! thread-pool-timeout-error? 'documentation "Return @code{#t} if OBJ is a @code{&thread-pool-timeout-error} exception.") (define* (make-fixed-size-thread-pool size #:key thread-initializer thread-destructor delay-logger duration-logger thread-lifetime (expire-on-exception? #f) (name "unnamed") (use-default-io-waiters? #t) default-checkout-timeout) "Create a pool of SIZE threads started immediately. Use @code{call-with-thread} to run a procedure in one of the threads. Optional keyword arguments: @table @code @item #:thread-initializer A thunk called once when each thread starts. Its return value is passed as extra arguments to every procedure run in that thread. Defaults to @code{#f} (no extra arguments). @item #:thread-destructor A procedure called with the value returned by @code{#:thread-initializer} when a thread exits. Defaults to @code{#f}. @item #:thread-lifetime Maximum number of procedures a thread will run before restarting (and re-running @code{#:thread-initializer}). Defaults to @code{#f} (no limit). @item #:expire-on-exception? When @code{#t}, replace a thread after any unhandled exception. Defaults to @code{#f}. @item #:use-default-io-waiters? When @code{#t} (the default), each thread uses blocking I/O waiters so that port reads and writes block the thread rather than trying to suspend a fiber. @item #:name String used in thread names and log messages. Defaults to @code{\"unnamed\"}. @item #:default-checkout-timeout Seconds to wait for a free thread slot before raising @code{&thread-pool-timeout-error}. Defaults to @code{#f} (wait forever). @item #:delay-logger Called as @code{(delay-logger seconds)} with the time spent waiting for a thread to become available. @item #:duration-logger Called as @code{(duration-logger seconds)} after each procedure completes, whether it returned normally or raised an exception. @end table" (define channel (make-channel)) (define param (make-parameter #f)) (define thread-proc-vector (make-vector size #f)) (define (initializer/safe) (let ((args (with-exception-handler (lambda _ #f) (lambda () (with-exception-handler (lambda (exn) (simple-format (current-error-port) "exception running initializer in thread pool (~A): ~A\n" name thread-initializer) (print-backtrace-and-exception/knots exn) (raise-exception exn)) thread-initializer)) #:unwind? #t))) (if args args ;; never give up, just keep retrying (begin (sleep 1) (initializer/safe))))) (define (destructor/safe args) (let ((success? (with-exception-handler (lambda _ #f) (lambda () (with-exception-handler (lambda (exn) (simple-format (current-error-port) "exception running destructor in thread pool (~A): ~A\n" name thread-destructor) (print-backtrace-and-exception/knots exn) (raise-exception exn)) (lambda () (apply thread-destructor args) #t))) #:unwind? #t))) (or success? #t (begin (sleep 1) (destructor/safe args))))) (define (process thread-index channel args) (let loop ((lifetime thread-lifetime)) (match (get-message channel) ('destroy #f) ((reply proc) (let* ((start-time (get-internal-real-time)) (response (with-exception-handler (lambda (exn) (list 'thread-pool-error (/ (- (get-internal-real-time) start-time) internal-time-units-per-second) exn)) (lambda () (vector-set! thread-proc-vector thread-index proc) (with-exception-handler (lambda (exn) (let ((stack (match (fluid-ref %stacks) ((stack-tag . prompt-tag) (make-stack #t 0 prompt-tag 0 (and prompt-tag 1))) (_ (make-stack #t))))) (raise-exception (make-exception exn (make-knots-exception stack))))) (lambda () (call-with-values (lambda () (start-stack #t (apply proc args))) (lambda vals (cons (/ (- (get-internal-real-time) start-time) internal-time-units-per-second) vals)))))) #:unwind? #t))) (vector-set! thread-proc-vector thread-index #f) (put-message reply response) (let ((exception? (match response (('thread-pool-error duration _) (when duration-logger (duration-logger duration)) #t) ((duration . _) (when duration-logger (duration-logger duration)) #f)))) (if (and exception? expire-on-exception?) #t (if lifetime (if (<= lifetime 1) #t (loop (- lifetime 1))) (loop lifetime))))))))) (define (start-thread index channel) (call-with-new-thread (lambda () (catch 'system-error (lambda () (set-thread-name (string-append name " w t " (number->string index)))) (const #t)) (let init ((args (if thread-initializer (initializer/safe) '()))) (let ((continue? (with-exception-handler (lambda (exn) (simple-format (current-error-port) "knots: thread-pool: internal exception: ~A\n" exn)) (lambda () (parameterize ((param args)) (process index channel args))) #:unwind? #t))) (when thread-destructor (destructor/safe args)) (when continue? (init (if thread-initializer (initializer/safe) '())))))))) (define threads (map (lambda (i) (if use-default-io-waiters? (call-with-default-io-waiters (lambda () (start-thread i channel))) (start-thread i channel))) (iota size))) (fixed-size-thread-pool channel param thread-proc-vector default-checkout-timeout delay-logger duration-logger threads)) (define* (make-thread-pool max-size #:key (min-size max-size) scheduler thread-initializer thread-destructor delay-logger duration-logger thread-lifetime (expire-on-exception? #f) (name "unnamed") (use-default-io-waiters? #t) default-checkout-timeout default-max-waiters) "Create a dynamic thread pool with up to MAX-SIZE threads. Use @code{call-with-thread} to run a procedure in one of the threads. Unlike @code{make-fixed-size-thread-pool}, threads are created on demand and may be reclaimed when idle (controlled by @code{#:min-size} and the resource pool's idle management). Accepts the same @code{#:thread-initializer}, @code{#:thread-destructor}, @code{#:thread-lifetime}, @code{#:expire-on-exception?}, @code{#:use-default-io-waiters?}, @code{#:name}, @code{#:default-checkout-timeout}, @code{#:delay-logger}, and @code{#:duration-logger} arguments as @code{make-fixed-size-thread-pool}, plus: @table @code @item #:min-size Minimum number of threads to keep alive. Defaults to MAX-SIZE (i.e.@: the pool is pre-filled and never shrinks). @item #:scheduler Fibers scheduler for the pool's internal resource pool fiber. Defaults to the current scheduler. @item #:default-max-waiters Maximum number of fibers that may queue waiting for a thread. Raises @code{&thread-pool-timeout-error} when exceeded. Defaults to @code{#f} (no limit). @end table" (define param (make-parameter #f)) (let ((resource-pool (make-resource-pool (lambda () (make-fixed-size-thread-pool 1 #:thread-initializer thread-initializer #:thread-destructor thread-destructor #:expire-on-exception? expire-on-exception? #:name name #:use-default-io-waiters? use-default-io-waiters?)) max-size #:destructor destroy-thread-pool #:min-size min-size #:delay-logger delay-logger #:lifetime thread-lifetime #:scheduler scheduler #:duration-logger duration-logger #:default-checkout-timeout default-checkout-timeout #:default-max-waiters default-max-waiters))) (thread-pool resource-pool param))) (define* (call-with-thread thread-pool proc #:key (delay-logger (thread-pool-delay-logger thread-pool)) (duration-logger (thread-pool-duration-logger thread-pool)) checkout-timeout channel destroy-thread-on-exception? (max-waiters 'default)) "Run PROC in THREAD-POOL and return its values, blocking until complete. If called from within a thread that already belongs to THREAD-POOL, PROC is called directly in that thread. Optional keyword arguments: @table @code @item #:checkout-timeout Seconds to wait for a free thread before raising @code{&thread-pool-timeout-error}. Defaults to the pool's @code{#:default-checkout-timeout}. @item #:max-waiters Maximum number of fibers that may queue waiting for a thread (for dynamic pools). Defaults to the pool's @code{#:default-max-waiters}. @item #:destroy-thread-on-exception? When @code{#t}, destroy the thread after PROC raises an exception. Equivalent to per-call @code{#:expire-on-exception?}. Defaults to @code{#f}. @item #:delay-logger Called as @code{(delay-logger seconds)} with the time spent waiting for a thread to become available. Defaults to the pool's @code{#:delay-logger} if not specified. @item #:duration-logger Called as @code{(duration-logger seconds)} after PROC completes (whether or not it raised an exception). Defaults to the pool's @code{#:duration-logger} if not specified. @item #:channel Override the channel used to communicate with the thread. @end table" (define (handle-proc fixed-size-thread-pool reply-channel start-time timeout delay-logger) (let* ((request-channel (or channel (fixed-size-thread-pool-channel fixed-size-thread-pool))) (operation-success? (perform-operation (let ((put (wrap-operation (put-operation request-channel (list reply-channel proc)) (const #t)))) (if timeout (choice-operation put (wrap-operation (sleep-operation timeout) (const #f))) put))))) (unless operation-success? (raise-exception (make-thread-pool-timeout-error))) (when delay-logger (delay-logger (/ (- (get-internal-real-time) start-time) internal-time-units-per-second))) (let ((reply (get-message reply-channel))) (match reply (('thread-pool-error duration exn) (when duration-logger (duration-logger duration)) (raise-exception exn)) ((duration . result) (when duration-logger (duration-logger duration)) (apply values result)))))) (let ((args ((thread-pool-arguments-parameter thread-pool)))) (if args (apply proc args) (let ((start-time (get-internal-real-time)) (reply-channel (make-channel))) (if (fixed-size-thread-pool? thread-pool) (handle-proc thread-pool reply-channel start-time checkout-timeout delay-logger) (with-exception-handler (lambda (exn) (if (and (resource-pool-timeout-error? exn) (eq? (resource-pool-timeout-error-pool exn) (thread-pool-resource-pool thread-pool))) (raise-exception (make-thread-pool-timeout-error thread-pool)) (raise-exception exn))) (lambda () (call-with-resource-from-pool (thread-pool-resource-pool thread-pool) (lambda (fixed-size-thread-pool) (if checkout-timeout (let ((remaining-time (/ (- (get-internal-real-time) start-time) internal-time-units-per-second))) (if (< remaining-time checkout-timeout) (handle-proc fixed-size-thread-pool reply-channel start-time remaining-time #f) (raise-exception (make-thread-pool-timeout-error thread-pool)))) (handle-proc fixed-size-thread-pool reply-channel start-time #f #f))) #:delay-logger delay-logger #:duration-logger #f #:max-waiters max-waiters #:timeout checkout-timeout #:destroy-resource-on-exception? destroy-thread-on-exception?)))))))) (define (destroy-thread-pool pool) "Destroy POOL, stopping all of its threads and calling the destructor if specified. This procedure will block until the destruction is complete." (if (fixed-size-thread-pool? pool) (let ((channel (fixed-size-thread-pool-channel pool)) (threads (fixed-size-thread-pool-threads pool))) (for-each (lambda _ (put-message channel 'destroy)) threads) (for-each join-thread threads)) (destroy-resource-pool (thread-pool-resource-pool pool)))) guile-knots-0.1/knots/timeout.scm000066400000000000000000000211621516027255200171520ustar00rootroot00000000000000;;; Guile Knots ;;; Copyright © 2020 Christopher Baines ;;; ;;; This file is part of Guile Knots. ;;; ;;; The Guile Knots 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. ;;; ;;; The Guile Knots 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 the guix-data-service. If not, see ;;; . (define-module (knots timeout) #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 atomic) #:use-module (ice-9 exceptions) #:use-module (ice-9 ports internal) #:use-module (ice-9 suspendable-ports) #:use-module (fibers) #:use-module (fibers timers) #:use-module (fibers channels) #:use-module (fibers scheduler) #:use-module (fibers operations) #:export (with-fibers-timeout wait-until-port-readable-operation wait-until-port-writable-operation &port-timeout-error port-timeout-error? &port-read-timeout-error port-read-timeout-error? &port-write-timeout-error port-write-timeout-error? with-port-timeouts)) (define* (with-fibers-timeout thunk #:key timeout (on-timeout (const *unspecified*))) "Run THUNK in a new fiber and return its values, waiting TIMEOUT seconds for it to finish. If THUNK does not complete within TIMEOUT seconds, the ON-TIMEOUT procedure is called and with-fibers-timeout returns the result of ON-TIMEOUT instead. If THUNK raises an exception it is re-raised in the calling fiber." (let ((channel (make-channel))) (spawn-fiber (lambda () (with-exception-handler (lambda (exn) (perform-operation (choice-operation (put-operation channel (cons 'exception exn)) (sleep-operation timeout)))) (lambda () (call-with-values thunk (lambda vals (perform-operation (choice-operation (put-operation channel vals) (sleep-operation timeout)))))) #:unwind? #t))) (match (perform-operation (choice-operation (get-operation channel) (wrap-operation (sleep-operation timeout) (const 'timeout)))) ('timeout (on-timeout)) (('exception . exn) (raise-exception exn)) (vals (apply values vals))))) (define &port-timeout-error (make-exception-type '&port-timeout-error &external-error '(thunk port))) (define make-port-timeout-error (record-constructor &port-timeout-error)) (define port-timeout-error? (exception-predicate &port-timeout-error)) (set-procedure-property! port-timeout-error? 'documentation "Return @code{#t} if OBJ is a @code{&port-timeout-error}.") (define &port-read-timeout-error (make-exception-type '&port-read-timeout-error &port-timeout-error '())) (define make-port-read-timeout-error (record-constructor &port-read-timeout-error)) (define port-read-timeout-error? (exception-predicate &port-read-timeout-error)) (set-procedure-property! port-read-timeout-error? 'documentation "Return @code{#t} if OBJ is a @code{&port-read-timeout-error}.") (define &port-write-timeout-error (make-exception-type '&port-write-timeout-error &port-timeout-error '())) (define make-port-write-timeout-error (record-constructor &port-write-timeout-error)) (define port-write-timeout-error? (exception-predicate &port-write-timeout-error)) (set-procedure-property! port-write-timeout-error? 'documentation "Return @code{#t} if OBJ is a @code{&port-write-timeout-error}.") (define (readable? port) "Test if PORT is readable." (= 1 (port-poll port "r" 0))) (define (writable? port) "Test if PORT is writable." (= 1 (port-poll port "w" 0))) (define (make-wait-operation ready? schedule-when-ready port port-ready-fd this-procedure) (make-base-operation #f (lambda _ (and (ready? port) values)) (lambda (flag sched resume) (define (commit) (match (atomic-box-compare-and-swap! flag 'W 'S) ('W (resume values)) ('C (commit)) ('S #f))) (schedule-when-ready sched (port-ready-fd port) commit)))) (define (wait-until-port-readable-operation port) "Make an operation that will succeed when PORT is readable." (unless (input-port? port) (error "refusing to wait forever for input on non-input port")) (make-wait-operation readable? schedule-task-when-fd-readable port port-read-wait-fd wait-until-port-readable-operation)) (define (wait-until-port-writable-operation port) "Make an operation that will succeed when PORT is writable." (unless (output-port? port) (error "refusing to wait forever for output on non-output port")) (make-wait-operation writable? schedule-task-when-fd-writable port port-write-wait-fd wait-until-port-writable-operation)) (define* (with-port-timeouts thunk #:key timeout (read-timeout timeout) (write-timeout timeout)) "Run THUNK with per-operation I/O timeouts on all ports. If any read or write blocks for longer than the given number of seconds, an exception is raised. @code{#:timeout} sets both read and write timeouts. @code{#:read-timeout} and @code{#:write-timeout} specify the timeout for reads and writes respectively. All three default to @code{#f} (no timeout). This procedure works both with fibers, and without fibers by using the poll system call with a timeout. On read timeout, raises @code{&port-read-timeout-error}. On write timeout, raises @code{&port-write-timeout-error}. Both carry the @code{thunk} and @code{port} fields from @code{&port-timeout-error}." (define (no-fibers-wait thunk port mode timeout) (define poll-timeout-ms 200) ;; When the GC runs, it restarts the poll syscall, but the timeout ;; remains unchanged! When the timeout is longer than the time ;; between the syscall restarting, I think this renders the ;; timeout useless. Therefore, this code uses a short timeout, and ;; repeatedly calls poll while watching the clock to see if it has ;; timed out overall. (let ((timeout-internal (+ (get-internal-real-time) (* internal-time-units-per-second timeout)))) (let loop ((poll-value (port-poll port mode poll-timeout-ms))) (if (= poll-value 0) (if (> (get-internal-real-time) timeout-internal) (raise-exception (if (string=? mode "r") (make-port-read-timeout-error thunk port) (make-port-write-timeout-error thunk port))) (loop (port-poll port mode poll-timeout-ms))) poll-value)))) (parameterize ((current-read-waiter (lambda (port) (if (current-scheduler) (perform-operation (choice-operation (wait-until-port-readable-operation port) (wrap-operation (sleep-operation read-timeout) (lambda () (raise-exception (make-port-read-timeout-error thunk port)))))) (no-fibers-wait thunk port "r" read-timeout)))) (current-write-waiter (lambda (port) (if (current-scheduler) (perform-operation (choice-operation (wait-until-port-writable-operation port) (wrap-operation (sleep-operation write-timeout) (lambda () (raise-exception (make-port-write-timeout-error thunk port)))))) (no-fibers-wait thunk port "w" write-timeout))))) (thunk))) guile-knots-0.1/knots/web-server.scm000066400000000000000000000572311516027255200175530ustar00rootroot00000000000000;;; Guile Knots ;;; Copyright © 2020 Christopher Baines ;;; Copyright (C) 2010-2013,2015,2017 Free Software Foundation, Inc. ;; This library is free software; you can redistribute it and/or ;; modify it under the terms of the GNU Lesser General Public ;; License as published by the Free Software Foundation; either ;; version 3 of the License, or (at your option) any later version. ;; ;; This library 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 ;; Lesser General Public License for more details. ;; ;; You should have received a copy of the GNU Lesser General Public License ;; along with this program. If not, see . (define-module (knots web-server) #:use-module (srfi srfi-9) #:use-module (srfi srfi-71) #:use-module (ice-9 control) #:use-module (fibers) #:use-module (fibers timers) #:use-module (fibers operations) #:use-module (fibers conditions) #:use-module (rnrs bytevectors) #:use-module (ice-9 binary-ports) #:use-module (ice-9 textual-ports) #:use-module (ice-9 iconv) #:use-module (ice-9 match) #:use-module (ice-9 exceptions) #:use-module ((srfi srfi-9 gnu) #:select (set-field)) #:use-module (system repl error-handling) #:use-module (web uri) #:use-module (web http) #:use-module (web request) #:use-module (web response) #:use-module (knots) #:use-module (knots timeout) #:use-module (knots non-blocking) #:export (run-knots-web-server make-chunked-output-port/knots &request-body-ended-prematurely request-body-ended-prematurely-error? sanitize-response request-body-port/knots read-request-body/knots default-write-response-exception-handler web-server? web-server-socket web-server-port)) (define (make-default-socket family addr port) (let ((sock (socket PF_INET SOCK_STREAM 0))) (setsockopt sock SOL_SOCKET SO_REUSEADDR 1) (fcntl sock F_SETFD FD_CLOEXEC) (bind sock family addr port) sock)) (define crlf-bv (string->utf8 "\r\n")) (define (chunked-output-port-overhead-bytes write-size) (+ (string-length (number->string write-size 16)) (bytevector-length crlf-bv) (bytevector-length crlf-bv))) (define* (make-chunked-output-port/knots port #:key (keep-alive? #f) (buffering 1200)) "Returns a new port which translates non-encoded data into a HTTP chunked transfer encoded data and writes this to PORT. Data written to this port is buffered until the port is flushed, at which point it is all sent as one chunk. The port will otherwise be flushed every BUFFERING bytes, which defaults to 1200. Take care to close the port when done, as it will output the remaining data, and encode the final zero chunk. When the port is closed it will also close PORT, unless KEEP-ALIVE? is true." (define (write! bv start count) (let ((len-string (number->string count 16))) (put-string port len-string)) (put-bytevector port crlf-bv 0 2) (put-bytevector port bv start count) (put-bytevector port crlf-bv 0 2) (force-output port) count) (define (close) (put-string port "0\r\n\r\n") (force-output port) (unless keep-alive? (close-port port))) (define ret (make-custom-binary-output-port "chunked http" write! #f #f close)) (setvbuf ret 'block buffering) ret) (define* (make-delimited-input-port port len fail #:key (keep-alive? #t)) "Return an input port that reads from PORT, and makes sure that exactly LEN bytes are available from PORT. Closing the returned port closes PORT, unless KEEP-ALIVE? is true." (define bytes-read 0) (define (read! bv start count) (let ((count (min count (- len bytes-read)))) (let loop ((ret (get-bytevector-n! port bv start count))) (cond ((eof-object? ret) (if (= bytes-read len) 0 ; EOF (fail bytes-read))) ((and (zero? ret) (> count 0)) ;; Do not return zero since zero means EOF, so try again. (loop (get-bytevector-n! port bv start count))) (else (set! bytes-read (+ bytes-read ret)) ret))))) (define close (and (not keep-alive?) (lambda () (close-port port)))) (make-custom-binary-input-port "delimited input port" read! #f #f close)) ;; Chunked Responses (define &request-body-ended-prematurely (make-exception-type '&request-body-ended-prematurely &external-error '(bytes-read))) (define make-request-body-ended-prematurely-error (record-constructor &request-body-ended-prematurely)) (define request-body-ended-prematurely-error? (exception-predicate &request-body-ended-prematurely)) (set-procedure-property! request-body-ended-prematurely-error? 'documentation "Return @code{#t} if OBJ is a @code{&request-body-ended-prematurely} exception.") (define (request-body-port/knots request) "Return an input port for reading the body of request REQUEST. Handles chunked transfer encoding." (cond ((member '(chunked) (request-transfer-encoding request)) (make-chunked-input-port (request-port request) #:keep-alive? #t)) (else (let ((content-length (request-content-length request))) (make-delimited-input-port (request-port request) content-length (lambda (bytes-read) (raise-exception (make-request-body-ended-prematurely-error bytes-read)))))))) (define (read-request-body/knots r) "Read and return the full body of request R as a bytevector. Handles chunked transfer encoding." (cond ((member '(chunked) (request-transfer-encoding r)) (get-bytevector-all (request-body-port/knots r))) (else (let ((content-length (request-content-length r))) (if content-length (get-bytevector-n (request-body-port/knots r) content-length) #f))))) (define (extend-response r k v . additional) (define (extend-alist alist k v) (let ((pair (assq k alist))) (acons k v (if pair (delq pair alist) alist)))) (let ((r (set-field r (response-headers) (extend-alist (response-headers r) k v)))) (if (null? additional) r (apply extend-response r additional)))) (define (response-maybe-add-connection-header-value request response) (if (memq 'close (response-connection response)) ;; Nothing to do response (let* ((v (request-version request)) (add-close-header? (case (car v) ((1) (case (cdr v) ((1) (memq 'close (request-connection request))) ((0) (not (memq 'keep-alive (request-connection request)))))) (else #t)))) (if add-close-header? (extend-response response 'connection '(close)) (if (and (= 1 (car v)) (= 0 (cdr v))) (extend-response response 'connection '(keep-alive)) response))))) ;; -> response body (define (sanitize-response request response body) "\"Sanitize\" the given response and body, making them appropriate for the given request. As a convenience to web handler authors, RESPONSE may be given as an alist of headers, in which case it is used to construct a default response. Ensures that the response version corresponds to the request version. If BODY is a string, encodes the string to a bytevector, in an encoding appropriate for RESPONSE. Adds a ‘content-length’ and ‘content-type’ header, as necessary. If BODY is a procedure, it is called with a port as an argument, and the output collected as a bytevector. In the future we might try to instead use a compressing, chunk-encoded port, and call this procedure later, in the write-client procedure. Authors are advised not to rely on the procedure being called at any particular time." (cond ((list? response) (sanitize-response request (build-response #:version (request-version request) #:headers response) body)) ((not (equal? (request-version request) (response-version response))) (sanitize-response request (adapt-response-version response (request-version request)) body)) ((string? body) (let* ((type (response-content-type response '(text/plain))) (declared-charset (assq-ref (cdr type) 'charset)) (charset (or declared-charset "utf-8"))) (sanitize-response request (if declared-charset response (extend-response response 'content-type `(,@type (charset . ,charset)))) (string->bytevector body charset)))) ((not (or (bytevector? body) (procedure? body) (eq? #f body))) (raise-exception (make-exception-with-irritants (list (make-exception-with-message "unexpected body type") body)))) ((and (response-must-not-include-body? response) body) (raise-exception (make-exception-with-irritants (list (make-exception-with-message "response with this status code must not include body") response)))) (else ;; check length; assert type; add other required fields? (values (response-maybe-add-connection-header-value request (cond ((procedure? body) (if (response-content-length response) response (extend-response response 'transfer-encoding '((chunked))))) ((bytevector? body) (let ((rlen (response-content-length response)) (blen (bytevector-length body))) (cond (rlen (if (= rlen blen) response (error "bad content-length" rlen blen))) (else (extend-response response 'content-length blen))))) (else response))) (if (eq? (request-method request) 'HEAD) #f body))))) (define (with-stack-and-prompt thunk) (call-with-prompt (default-prompt-tag) (lambda () (start-stack #t (thunk))) (lambda (k proc) (with-stack-and-prompt (lambda () (proc k)))))) (define (keep-alive? response) (not (memq 'close (response-connection response)))) (define (default-read-request-exception-handler exn) (display/knots "While reading request:\n" (current-error-port)) (print-exception (current-error-port) #f '%exception (list exn)) #f) (define (default-write-response-exception-handler exn request) "Default handler for exceptions raised while writing an HTTP response. Logs the error for REQUEST to the current error port." (if (and (exception-with-origin? exn) (string=? (exception-origin exn) "fport_write")) (simple-format/knots (current-error-port) "~A ~A: error replying to client\n" (request-method request) (uri-path (request-uri request))) (simple-format/knots (current-error-port) "knots web server: ~A ~A: exception replying to client: ~A\n" (request-method request) (uri-path (request-uri request)) exn)) ;; Close the client port #f) (define* (handle-request handler client sockaddr read-request-exception-handler write-response-exception-handler buffer-size #:key post-request-hook) (define meta `((sockaddr . ,sockaddr))) (let ((request (with-exception-handler read-request-exception-handler (lambda () (read-request client meta)) #:unwind? #t)) (read-request-time (get-internal-real-time))) (let ((response body (cond ((not request) ;; Bad request. (values (build-response #:version '(1 . 0) #:code 400 #:headers '((content-length . 0) (connection . (close)))) #vu8())) (else (with-exception-handler (lambda (exn) (sanitize-response request (build-response #:code 500) (string->utf8 "internal server error"))) (lambda () (with-exception-handler (lambda (exn) (let* ((error-string (call-with-output-string (lambda (port) (simple-format port "exception when processing: ~A ~A\n" (request-method request) (uri-path (request-uri request))) (print-backtrace-and-exception/knots exn #:port port))))) (display/knots error-string (current-error-port)))) (lambda () (start-stack #t (call-with-values (lambda () (handler request)) (match-lambda* ((response body) (sanitize-response request response body)) (other (raise-exception (make-exception-with-irritants (list (make-exception-with-message (simple-format #f "wrong number of values returned from handler, expecting 2, got ~A" (length other))) handler)))))))))) #:unwind? #t))))) (with-exception-handler (lambda (exn) (write-response-exception-handler exn request)) (lambda () (write-response response client) (let ((response-start-time (get-internal-real-time)) (body-written? (cond ((and (procedure? body) (not (eq? (request-method request) 'HEAD))) (let* ((type (response-content-type response '(text/plain))) (declared-charset (assq-ref (cdr type) 'charset)) (charset (or declared-charset "ISO-8859-1")) (body-port (if (response-content-length response) client (make-chunked-output-port/knots client #:keep-alive? #t #:buffering (- buffer-size (chunked-output-port-overhead-bytes buffer-size)))))) (set-port-encoding! body-port charset) (let ((body-written? (with-exception-handler (lambda (exn) #f) (lambda () (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) (raise-exception exn)) (lambda () (body body-port))) #t) #:unwind? #t))) (unless (response-content-length response) (close-port body-port)) body-written?))) ((bytevector? body) (put-bytevector client body) #t) (else ;; No body to write #t)))) (if body-written? (begin (force-output client) (when post-request-hook (post-request-hook request #:read-request-time read-request-time #:response-start-time response-start-time #:response-end-time (get-internal-real-time))) (when (and (procedure? body) (response-content-length response)) (set-port-encoding! client "ISO-8859-1")) (keep-alive? response)) #f))) #:unwind? #t)))) (define* (client-loop client handler sockaddr read-request-exception-handler write-response-exception-handler connection-idle-timeout buffer-size post-request-hook) ;; Always disable Nagle's algorithm, as we handle buffering ;; ourselves; when we force-output, we really want the data to go ;; out. (setvbuf client 'block buffer-size) (setsockopt client IPPROTO_TCP TCP_NODELAY 1) (let loop () (cond ((with-exception-handler (lambda (exn) (unless (and (exception-with-origin? exn) (string=? (exception-origin exn) "fport_read")) (display/knots "knots web-server, exception in client loop:\n" (current-error-port)) (display/knots (call-with-output-string (lambda (port) (print-exception port #f '%exception (list exn)))) (current-error-port))) #t) (lambda () (or (if (eq? #f connection-idle-timeout) #f (perform-operation (choice-operation (wrap-operation (wait-until-port-readable-operation client) (const #f)) (wrap-operation (sleep-operation connection-idle-timeout) (const #t))))) (eof-object? (lookahead-u8 client)))) #:unwind? #t) (close-port client)) (else (let ((keep-alive? (handle-request handler client sockaddr read-request-exception-handler write-response-exception-handler buffer-size #:post-request-hook post-request-hook))) (if keep-alive? (loop) (close-port client))))))) (define (post-request-hook/safe post-request-hook) (if post-request-hook (lambda args (with-exception-handler (lambda (exn) #f) (lambda () (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) (raise-exception exn)) (lambda () (apply post-request-hook args)))) #:unwind? #t)) #f)) (define-record-type (make-web-server socket port) web-server? (socket web-server-socket) (port web-server-port)) (set-procedure-property! (macro-transformer (module-ref (current-module) 'web-server?)) 'documentation "Return @code{#t} if OBJ is a @code{}.") (set-procedure-property! (macro-transformer (module-ref (current-module) 'web-server-socket)) 'documentation "Return the socket of the web server.") (set-procedure-property! (macro-transformer (module-ref (current-module) 'web-server-port)) 'documentation "Return the port number of the web server.") (define* (run-knots-web-server handler #:key (host #f) (family AF_INET) (addr (if host (inet-pton family host) INADDR_LOOPBACK)) (port 8080) (socket (make-default-socket family addr port)) (read-request-exception-handler default-read-request-exception-handler) (write-response-exception-handler default-write-response-exception-handler) (connection-idle-timeout #f) (connection-buffer-size 1024) post-request-hook) "Run the knots web server. HANDLER should be a procedure that takes one argument, the HTTP request and returns two values, the response and response body. For example, here is a simple \"Hello, World!\" server: @example (define (handler request) (let ((body (read-request-body request))) (values '((content-type . (text/plain))) \"Hello, World!\"))) (run-knots-web-server handler) @end example The response and body will be run through ‘sanitize-response’ before sending back to the client." (non-blocking-port socket) ;; We use a large backlog by default. If the server is suddenly hit ;; with a number of connections on a small backlog, clients won't ;; receive confirmation for their SYN, leading them to retry -- ;; probably successfully, but with a large latency. (listen socket 1024) (sigaction SIGPIPE SIG_IGN) (spawn-fiber (lambda () (while #t (with-exception-handler (const #t) (lambda () (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn)) (lambda () (let loop () (match (accept socket (logior SOCK_NONBLOCK SOCK_CLOEXEC)) ((client . sockaddr) (spawn-fiber (lambda () (client-loop client handler sockaddr read-request-exception-handler write-response-exception-handler connection-idle-timeout connection-buffer-size (post-request-hook/safe post-request-hook))) #:parallel? #t) (loop))))))) #:unwind? #t)))) (make-web-server socket (vector-ref (getsockname socket) 2))) ; Not sure what this structure is guile-knots-0.1/knots/web.scm000066400000000000000000000176461516027255200162550ustar00rootroot00000000000000;;; Guile Knots ;;; Copyright © 2026 Christopher Baines ;;; ;;; This file is part of Guile Knots. ;;; ;;; The Guile Knots 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. ;;; ;;; The Guile Knots 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 the guix-data-service. If not, see ;;; . (define-module (knots web) #:use-module (srfi srfi-1) #:use-module (srfi srfi-71) #:use-module (ice-9 match) #:use-module (ice-9 exceptions) #:use-module (web uri) #:use-module (web request) #:use-module (web response) #:use-module (knots) #:use-module (knots non-blocking) #:use-module (knots resource-pool) #:export (make-connection-cache call-with-connection-cache call-with-cached-connection http-fold-requests)) (define* (make-connection-cache uri max-cached-connections #:key (verify-certificate? #t)) "Create a resource pool of up to MAX-CACHED-CONNECTIONS to URI." (make-resource-pool (lambda () ;; Open the socket in a temporary thread so that the blocking ;; connection attempt does not stall the fiber scheduler. (call-with-temporary-thread (lambda () (non-blocking-open-socket-for-uri uri #:verify-certificate? verify-certificate?)))) max-cached-connections #:destructor close-port)) (define* (call-with-connection-cache uri max-cached-connections proc #:key (verify-certificate? #t)) "Create a connection cache for URI with up to MAX-CACHED-CONNECTIONS, call @code{(proc cache)}, then destroy the cache and return the values returned by PROC." (let ((cache (make-connection-cache uri max-cached-connections #:verify-certificate? verify-certificate?))) (call-with-values (lambda () (proc cache)) (lambda vals (destroy-resource-pool cache) (apply values vals))))) (define* (call-with-cached-connection cache proc #:key (close-connection-on-exception? #t)) "Check out a connection port from CACHE and call @code{(proc port)}, returning the result. The port is returned to the cache when PROC returns, or closed on exception if CLOSE-CONNECTION-ON-EXCEPTION? is true (the default)." (with-exception-handler (lambda (exn) (if (resource-pool-destroy-resource-exception? exn) (call-with-cached-connection cache proc #:close-connection-on-exception? close-connection-on-exception?) (raise-exception exn))) (lambda () (with-exception-handler (lambda (exn) (let ((stack (match (fluid-ref %stacks) ((stack-tag . prompt-tag) (make-stack #t 0 prompt-tag 0 (and prompt-tag 1))) (_ (make-stack #t))))) (raise-exception (make-exception exn (make-knots-exception stack))))) (lambda () (call-with-resource-from-pool cache (lambda (port) (when (port-closed? port) (raise-exception (make-resource-pool-destroy-resource-exception))) (proc port)) #:destroy-resource-on-exception? close-connection-on-exception?)))) #:unwind? #t)) (define* (http-fold-requests connection-cache proc seed requests #:key (batch-size 1000)) "Fold PROC over HTTP request/response pairs using CONNECTION-CACHE for connections. PROC is called as @code{(proc request response body-port accumulator)} and its return value becomes the new accumulator. Requests are sent in batches of up to BATCH-SIZE before responses are read (HTTP pipelining). When the server closes the connection mid-batch the remaining requests are retried on a fresh connection from the cache." (define &send-error (make-exception-type '&send-error &exception '())) (define make-send-error (record-constructor &send-error)) (define send-error? (exception-predicate &send-error)) (define (read-responses port batch result) (let loop ((request (car batch)) (remaining-requests (cdr batch)) (result result)) (let ((response (with-exception-handler (lambda (exn) (close-port port) #f) (lambda () (read-response port)) #:unwind? #t))) (if (not response) (values (cons request remaining-requests) result) (let* ((body (response-body-port response)) (new-result (proc request response body result))) (if (memq 'close (response-connection response)) (begin (close-port port) (values remaining-requests new-result)) (if (null? remaining-requests) (values '() new-result) (loop (car remaining-requests) (cdr remaining-requests) new-result)))))))) ;; Send up to BATCH-SIZE requests then hand off to read-responses. ;; If writing fails the connection has dropped; raise &send-error so the ;; outer loop retries all remaining requests on a fresh connection. (define (send-batch port batch) (with-exception-handler (lambda (exn) (close-port port) (raise-exception (make-send-error))) (lambda () (for-each (lambda (req) (write-request req port)) batch) (force-output port)) #:unwind? #t)) (let loop ((remaining-requests requests) (result seed)) (if (null? remaining-requests) result (let ((next-remaining-requests next-result (with-exception-handler (lambda (exn) (if (or (send-error? exn) (resource-pool-destroy-resource-exception? exn)) (values remaining-requests result) (raise-exception exn))) (lambda () (call-with-resource-from-pool connection-cache (lambda (port) (if (port-closed? port) (raise-exception (make-resource-pool-destroy-resource-exception)) (let ((batch pending (split-at remaining-requests (min batch-size (length remaining-requests))))) (send-batch port batch) (let ((remaining-requests next-result (read-responses port batch result))) (values (append remaining-requests pending) next-result))))) #:destroy-resource-on-exception? #t)) #:unwind? #t))) (loop next-remaining-requests next-result))))) guile-knots-0.1/pre-inst-env.in000066400000000000000000000006511516027255200165010ustar00rootroot00000000000000#!/bin/sh abs_top_srcdir="`cd "@abs_top_srcdir@" > /dev/null; pwd`" abs_top_builddir="`cd "@abs_top_builddir@" > /dev/null; pwd`" GUILE_LOAD_COMPILED_PATH="$abs_top_builddir${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH" GUILE_LOAD_PATH="$abs_top_builddir:$abs_top_srcdir${GUILE_LOAD_PATH:+:}:$GUILE_LOAD_PATH" export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH PATH="$abs_top_builddir:$PATH" export PATH exec "$@" guile-knots-0.1/test-env.in000066400000000000000000000010341516027255200157130ustar00rootroot00000000000000#!/bin/sh abs_top_srcdir="`cd "@abs_top_srcdir@" > /dev/null; pwd`" abs_top_builddir="`cd "@abs_top_builddir@" > /dev/null; pwd`" GUILE_LOAD_COMPILED_PATH="${abs_top_builddir}/tests${GUILE_LOAD_COMPILED_PATH:+:}$abs_top_builddir${GUILE_LOAD_COMPILED_PATH:+:}$GUILE_LOAD_COMPILED_PATH" GUILE_LOAD_PATH="$abs_top_builddir/tests:$abs_top_srcdir${GUILE_LOAD_PATH:+:}$abs_top_builddir:$abs_top_srcdir${GUILE_LOAD_PATH:+:}:$GUILE_LOAD_PATH" export GUILE_LOAD_COMPILED_PATH GUILE_LOAD_PATH PATH="$abs_top_builddir:$PATH" export PATH exec "$@" guile-knots-0.1/tests.scm000066400000000000000000000017071516027255200154730ustar00rootroot00000000000000(define-module (tests) #:use-module (ice-9 exceptions) #:use-module (fibers) #:use-module (knots) #:export (run-fibers-for-tests assert-no-heap-growth)) (define* (run-fibers-for-tests thunk #:key (drain? #t)) (let ((result (run-fibers (lambda () (with-exception-handler (lambda (exn) exn) (lambda () (simple-format #t "running ~A\n" thunk) (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) (raise-exception exn)) (lambda () (start-stack #t (thunk)))) #t) #:unwind? #t)) #:hz 0 #:parallelism 1 #:drain? drain?))) (if (exception? result) (raise-exception result) result))) (define (assert-no-heap-growth thunk) (thunk)) guile-knots-0.1/tests/000077500000000000000000000000001516027255200147625ustar00rootroot00000000000000guile-knots-0.1/tests/backtraces.scm000066400000000000000000000322021516027255200175670ustar00rootroot00000000000000(use-modules (srfi srfi-1) (srfi srfi-13) (ice-9 popen) (ice-9 rdelim) (ice-9 match)) (define (run-backtrace-script file) (let* ((pipe (open-pipe (string-append "./test-env guile " file " 2>&1") OPEN_READ)) (output (read-string pipe))) (close-pipe pipe) output)) (define (read-backtrace-entry-annotation script keyword) ;; Scan SCRIPT line by line and return the annotation for the expected ;; backtrace entry matching KEYWORD (e.g. "FIRST" or "LAST"), or #f if ;; none is found. ;; ;; Two forms are recognised: ;; ;; ; KEYWORD BACKTRACE ENTRY HERE ;; — placed inline on a code line. Returns ('here LINE COL) where LINE ;; is the 1-based line number and COL is the 0-based column of the ;; first non-space character on that line. ;; ;; ; KEYWORD BACKTRACE ENTRY: STRING ;; — STRING is a literal substring expected to appear in the output. ;; Returns ('string STRING). (let ((here-marker (string-append keyword " BACKTRACE ENTRY HERE")) (string-marker (string-append keyword " BACKTRACE ENTRY: "))) (call-with-input-file script (lambda (port) (let loop ((line (read-line port)) (line-num 1)) (cond ((eof-object? line) #f) ((string-contains line here-marker) (let ((col (string-index line (lambda (c) (not (char=? c #\space)))))) (list 'here line-num col))) ((string-contains line string-marker) (let* ((idx (+ (string-contains line string-marker) (string-length string-marker))) (content (string-trim-right (substring line idx)))) (list 'string content))) (else (loop (read-line port) (+ line-num 1))))))))) (define (frame-line? line) ;; Return #t if LINE looks like a backtrace frame line: leading whitespace ;; followed by digits:digits (LINE:COL). (and (> (string-length line) 0) (let* ((stripped (string-trim line)) (colon (string-index stripped #\:))) (and colon (> colon 0) (string-every char-set:digit stripped 0 colon))))) (define (extract-frame-lines output) ;; Return all backtrace frame lines before "ERROR:" in OUTPUT. (let* ((error-pos (string-contains output "\nERROR:")) (before-error (if error-pos (substring output 0 error-pos) output))) (filter frame-line? (string-split before-error #\newline)))) (define (innermost-frame-line output) ;; Return the last backtrace frame line before "ERROR:" in OUTPUT, or #f. (let ((frame-lines (extract-frame-lines output))) (if (null? frame-lines) #f (last frame-lines)))) (define (outermost-frame-line output) ;; Return the first backtrace frame line before "ERROR:" in OUTPUT, or #f. (let ((frame-lines (extract-frame-lines output))) (if (null? frame-lines) #f (car frame-lines)))) ;;; Assertions (define current-test-fail-count 0) (define (expect! label ok? detail) ;; Print one expectation line; record a failure if not ok. (if ok? (format #t " PASS ~a~%" label) (begin (set! current-test-fail-count (+ current-test-fail-count 1)) (format #t " FAIL ~a~% ~a~%" label detail)))) (define (assert-output-contains output expected) (expect! (format #f "output contains ~s" expected) (string-contains output expected) "not found in output")) (define (assert-output-excludes output unexpected) (expect! (format #f "output excludes ~s" unexpected) (not (string-contains output unexpected)) "unexpectedly found in output")) (define (assert-backtrace-entry output script keyword frame-line-proc) (let ((annotation (read-backtrace-entry-annotation script keyword)) (frame (frame-line-proc output))) (when annotation (match annotation (('here line col) (let ((expected (string-append (number->string line) ":" (number->string col)))) (expect! (format #f "~a backtrace entry ~a" keyword expected) (and frame (string-contains frame expected)) (format #f "got ~s" (or frame "(none)"))))) (('string content) (expect! (format #f "~a backtrace entry ~s" keyword content) (string-contains output content) "not found in output")))))) (define (assert-first-backtrace-entry output script) (assert-backtrace-entry output script "FIRST" outermost-frame-line)) (define (assert-last-backtrace-entry output script) (assert-backtrace-entry output script "LAST" innermost-frame-line)) ;;; Test runner (define pass-count 0) (define fail-count 0) (define (run-test name thunk) (set! current-test-fail-count 0) (format #t "~%~a~%" name) (catch #t thunk (lambda (key . args) (set! current-test-fail-count (+ current-test-fail-count 1)) (format #t " ERROR unexpected exception: ~s~%" (cons key args)))) (if (zero? current-test-fail-count) (set! pass-count (+ pass-count 1)) (set! fail-count (+ fail-count 1)))) ;;; Tests (run-test "plain-exception" (lambda () (let* ((script "tests/backtraces/plain-exception.scm") (output (run-backtrace-script script))) (assert-first-backtrace-entry output script) (assert-last-backtrace-entry output script) (assert-output-contains output "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"plain error message\"")))) (run-test "triple-with-exception-handler" (lambda () (let* ((script "tests/backtraces/triple-with-exception-handler.scm") (output (run-backtrace-script script))) (assert-first-backtrace-entry output script) (assert-last-backtrace-entry output script) (assert-output-contains output "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"plain error message\"")))) (run-test "wrapped-exception" (lambda () (let* ((script "tests/backtraces/wrapped-exception.scm") (output (run-backtrace-script script))) (assert-first-backtrace-entry output script) (assert-last-backtrace-entry output script) (assert-output-contains output "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"wrapped error message\"")))) (run-test "temporary-thread" (lambda () (let* ((script "tests/backtraces/temporary-thread.scm") (output (run-backtrace-script script))) (assert-first-backtrace-entry output script) (assert-last-backtrace-entry output script) (assert-output-contains output "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"error from temporary thread\"")))) (run-test "fibers-map" (lambda () (let* ((script "tests/backtraces/fibers-map.scm") (output (run-backtrace-script script))) (assert-first-backtrace-entry output script) (assert-last-backtrace-entry output script) (assert-output-contains output "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"error from fibers-map\"")))) (run-test "call-with-resource-from-pool" (lambda () (let* ((script "tests/backtraces/call-with-resource-from-pool.scm") (output (run-backtrace-script script))) (assert-first-backtrace-entry output script) (assert-last-backtrace-entry output script) (assert-output-contains output "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"error from call-with-resource-from-pool\"")))) ;; Two knots stacks are printed (one per fiber boundary); ERROR: appears ;; once at the end after both frame blocks. (run-test "call-with-cached-connection" (lambda () (let* ((script "tests/backtraces/call-with-cached-connection.scm") (output (run-backtrace-script script))) (assert-first-backtrace-entry output script) (assert-last-backtrace-entry output script) (assert-output-contains output "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"error from call-with-cached-connection\"")))) (run-test "fibers-force" (lambda () (let* ((script "tests/backtraces/fibers-force.scm") (output (run-backtrace-script script))) (assert-first-backtrace-entry output script) (assert-last-backtrace-entry output script) (assert-output-contains output "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"error from fibers-force\"")))) (run-test "call-with-thread" (lambda () (let* ((script "tests/backtraces/call-with-thread.scm") (output (run-backtrace-script script))) (assert-first-backtrace-entry output script) (assert-last-backtrace-entry output script) (assert-output-contains output "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"error from call-with-thread\"")))) ;; Nested fibers-map: user frames that survive fiber boundaries appear; ;; intermediate functions (one-deep, two-deep, three-deep) are lost at ;; their respective boundaries because fibers-map yields before the ;; exception propagates back. knots/parallelism.scm and srfi frames ;; appear as call-path context between the surviving user frames. (run-test "nested-parallelism" (lambda () (let* ((script "tests/backtraces/nested-parallelism.scm") (output (run-backtrace-script script))) (assert-first-backtrace-entry output script) (assert-last-backtrace-entry output script) (assert-output-contains output "ERROR:\n 1. &error\n 2. &origin: #f\n 3. &message: \"deeply nested error ~S\"") (assert-output-contains output "(run-work)") (assert-output-contains output "(process-batch _)") (assert-output-contains output "(deeply-nested _)") (assert-output-excludes output "In fibers")))) (run-test "guile-error-in-thread" (lambda () (let* ((script "tests/backtraces/guile-error-in-thread.scm") (output (run-backtrace-script script))) (assert-first-backtrace-entry output script) (assert-last-backtrace-entry output script) (assert-output-contains output "ERROR:\n 1. &assertion-failure\n 2. &origin: \"+\"\n 3. &message: \"Wrong type argument in position ~A: ~S\"\n 4. &irritants: (1 a)")))) ;; sort is a C function and appears as "In unknown file:" between the user frames. (run-test "guile-error-deep-in-thread" (lambda () (let* ((script "tests/backtraces/guile-error-deep-in-thread.scm") (output (run-backtrace-script script))) (assert-first-backtrace-entry output script) (assert-last-backtrace-entry output script) (assert-output-contains output "ERROR:\n 1. &assertion-failure\n 2. &origin: \"+\"") (assert-output-contains output "(do-sort)") (assert-output-contains output "In unknown file:") (assert-output-contains output "(sort (1 2 3)") (assert-output-excludes output "In knots/") (assert-output-excludes output "In srfi/")))) ;; The error fires inside ice-9/vlist.scm (vlist-fold passed a non-vlist), ;; so vlist-fold appears as the innermost frame and ice-9/vlist.scm frames ;; appear between the user frames. (run-test "vhash-fold" (lambda () (let* ((script "tests/backtraces/vhash-fold.scm") (output (run-backtrace-script script))) (assert-first-backtrace-entry output script) (assert-last-backtrace-entry output script) (assert-output-contains output "ERROR:\n 1. &assertion-failure\n 2. &origin: #f") (assert-output-contains output "(do-fold)") (assert-output-contains output "In ice-9/vlist.scm:") (assert-output-contains output "(vlist-fold")))) ;; do-fold calls vhash-fold in non-tail position so its frame is preserved. ;; ice-9/vlist.scm frames appear between the user frames, as in vhash-fold. (run-test "vhash-fold-in-thread" (lambda () (let* ((script "tests/backtraces/vhash-fold-in-thread.scm") (output (run-backtrace-script script))) (assert-first-backtrace-entry output script) (assert-last-backtrace-entry output script) (assert-output-contains output "ERROR:\n 1. &assertion-failure\n 2. &origin: #f") (assert-output-contains output "(do-fold)") (assert-output-contains output "In ice-9/vlist.scm:") (assert-output-contains output "(vlist-fold") (assert-output-excludes output "In knots/")))) (run-test "stack-situation-script" (lambda () (let* ((script "tests/backtraces/stack-situation-script.scm") (output (run-backtrace-script script))) (assert-output-contains output "situation: script")))) (run-test "stack-situation-fibers" (lambda () (let* ((script "tests/backtraces/stack-situation-fibers.scm") (output (run-backtrace-script script))) (assert-output-contains output "situation: run-fibers")))) (run-test "stack-situation-unknown" (lambda () (let* ((script "tests/backtraces/stack-situation-unknown.scm") (output (run-backtrace-script script))) (assert-output-contains output "situation: unknown")))) ;;; Summary (newline) (if (zero? fail-count) (format #t "All ~a scripts passed.~%" pass-count) (format #t "~a of ~a scripts had failures.~%" fail-count (+ pass-count fail-count))) (when (> fail-count 0) (primitive-exit 1)) guile-knots-0.1/tests/backtraces/000077500000000000000000000000001516027255200170645ustar00rootroot00000000000000guile-knots-0.1/tests/backtraces/call-with-cached-connection.scm000066400000000000000000000013151516027255200250160ustar00rootroot00000000000000(use-modules (knots) (fibers) (knots resource-pool) (knots web)) (run-fibers (lambda () (let ((cache (make-fixed-size-resource-pool (list (open-input-string "fake"))))) ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (e) (print-backtrace-and-exception/knots e) (primitive-exit 1)) (lambda () (call-with-cached-connection cache (lambda (port) (error "error from call-with-cached-connection")) ; LAST BACKTRACE ENTRY HERE #:close-connection-on-exception? #f))))) #:hz 0 #:parallelism 1) guile-knots-0.1/tests/backtraces/call-with-resource-from-pool.scm000066400000000000000000000011231516027255200252060ustar00rootroot00000000000000(use-modules (knots) (fibers) (knots resource-pool)) (run-fibers (lambda () (let ((pool (make-resource-pool (const 'resource) 1))) ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (e) (print-backtrace-and-exception/knots e) (primitive-exit 1)) (lambda () (call-with-resource-from-pool pool (lambda (resource) (error "error from call-with-resource-from-pool"))))))) ; LAST BACKTRACE ENTRY HERE #:hz 0 #:parallelism 1) guile-knots-0.1/tests/backtraces/call-with-thread.scm000066400000000000000000000006311516027255200227210ustar00rootroot00000000000000(use-modules (knots) (knots thread-pool)) (define thread-pool (make-fixed-size-thread-pool 1)) ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) (primitive-exit 1)) (lambda () (call-with-thread thread-pool (lambda () (error "error from call-with-thread"))))) ; LAST BACKTRACE ENTRY HERE guile-knots-0.1/tests/backtraces/fibers-force.scm000066400000000000000000000006601516027255200221400ustar00rootroot00000000000000(use-modules (knots) (fibers) (knots promise)) (run-fibers (lambda () ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (e) (print-backtrace-and-exception/knots e) (primitive-exit 1)) (lambda () (fibers-force (fibers-delay (lambda () (error "error from fibers-force"))))))) ; LAST BACKTRACE ENTRY HERE #:hz 0 #:parallelism 1) guile-knots-0.1/tests/backtraces/fibers-map.scm000066400000000000000000000011471516027255200216200ustar00rootroot00000000000000(use-modules (knots) (fibers) (knots parallelism)) (run-fibers (lambda () (with-exception-handler (lambda _ ;; To avoid the test hanging if there's an exception (primitive-exit 1)) (lambda () ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (e) (print-backtrace-and-exception/knots e) (primitive-exit 1)) (lambda () (fibers-map (lambda (x) (error "error from fibers-map")) ; LAST BACKTRACE ENTRY HERE '(1))))))) #:hz 0 #:parallelism 1) guile-knots-0.1/tests/backtraces/guile-error-deep-in-thread.scm000066400000000000000000000006551516027255200246160ustar00rootroot00000000000000(use-modules (knots)) (define (do-sort) (begin (sort '(1 2 3) (lambda _ (+ 1 'a))) ; LAST BACKTRACE ENTRY HERE 'unreachable)) ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) (primitive-exit 1)) (lambda () (call-with-temporary-thread (lambda () (do-sort) 'done)))) guile-knots-0.1/tests/backtraces/guile-error-in-thread.scm000066400000000000000000000004641516027255200237010ustar00rootroot00000000000000(use-modules (knots)) ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) (primitive-exit 1)) (lambda () (call-with-temporary-thread (lambda () (+ 1 'a))))) ; LAST BACKTRACE ENTRY HERE guile-knots-0.1/tests/backtraces/nested-parallelism.scm000066400000000000000000000022141516027255200233540ustar00rootroot00000000000000(use-modules (knots) (fibers) (knots parallelism)) ;; Deep call chain within the innermost fiber. Each function calls the next ;; via `begin', placing the call in non-tail position so Guile's TCO does not ;; collapse the frames; all four frames survive and appear in the backtrace. (define (deeply-nested x) (error "deeply nested error" x)) ; LAST BACKTRACE ENTRY HERE (define (three-deep x) (fibers-map deeply-nested (list x))) (define (two-deep x) (fibers-map three-deep (list x))) (define (one-deep x) (fibers-map two-deep (list x))) ;; process-batch runs inside one fiber and dispatches the deep call chain into ;; a nested fiber via a second fibers-map, creating two fiber boundaries. (define (process-batch items) (begin (fibers-map one-deep (list items)) 'unreachable)) (define (run-work) (begin (fibers-map process-batch '(1)) 'unreachable)) (define result (run-fibers (lambda () ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (e) (print-backtrace-and-exception/knots e) (primitive-exit 1)) run-work)) #:hz 0 #:parallelism 1)) guile-knots-0.1/tests/backtraces/plain-exception.scm000066400000000000000000000004171516027255200226710ustar00rootroot00000000000000(use-modules (knots)) ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) (primitive-exit 1)) (lambda () (error "plain error message"))) ; LAST BACKTRACE ENTRY HERE guile-knots-0.1/tests/backtraces/stack-situation-fibers.scm000066400000000000000000000011701516027255200241610ustar00rootroot00000000000000(use-modules (knots) (knots backtraces) (fibers) (system repl debug)) (run-fibers (lambda () (with-exception-handler (lambda (exn) (let ((stack (make-stack #t))) (print-backtrace-and-exception/knots exn) (simple-format/knots #t "situation: ~A\n" ((@@ (knots backtraces) classify-stack-situation) (stack->vector stack)))) (primitive-exit 0)) (lambda () (error "test")))) #:hz 0 #:parallelism 1) guile-knots-0.1/tests/backtraces/stack-situation-script.scm000066400000000000000000000010141516027255200242100ustar00rootroot00000000000000(use-modules (knots) (knots backtraces) (system repl debug)) (with-exception-handler (lambda (exn) (let ((stack (make-stack #t))) (print-backtrace-and-exception/knots exn) (simple-format/knots #t "situation: ~A\n" ((@@ (knots backtraces) classify-stack-situation) (stack->vector stack)))) (primitive-exit 0)) (lambda () (error "test"))) guile-knots-0.1/tests/backtraces/stack-situation-unknown.scm000066400000000000000000000010621516027255200244060ustar00rootroot00000000000000(use-modules (knots) (knots backtraces) (fibers) (system repl debug)) (start-stack #t (with-exception-handler (lambda (exn) (let* ((stack (make-stack #t)) (stack-classification ((@@ (knots backtraces) classify-stack-situation) (stack->vector stack)))) (print-backtrace-and-exception/knots exn) (simple-format/knots #t "situation: ~A\n" stack-classification) (primitive-exit 0))) (lambda () (error "test")))) guile-knots-0.1/tests/backtraces/temporary-thread.scm000066400000000000000000000005101516027255200230530ustar00rootroot00000000000000(use-modules (knots)) ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) (primitive-exit 1)) (lambda () (call-with-temporary-thread (lambda () (error "error from temporary thread"))))) ; LAST BACKTRACE ENTRY HERE guile-knots-0.1/tests/backtraces/triple-with-exception-handler.scm000066400000000000000000000006711516027255200254530ustar00rootroot00000000000000(use-modules (knots)) ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda _ #f) (lambda () (with-exception-handler (lambda _ #f) (lambda () (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) (primitive-exit 1)) (lambda () (error "plain error message"))))))) ; LAST BACKTRACE ENTRY HERE guile-knots-0.1/tests/backtraces/vhash-fold-in-thread.scm000066400000000000000000000011201516027255200234660ustar00rootroot00000000000000(use-modules (knots) (ice-9 vlist)) ;; LAST BACKTRACE ENTRY: 257:2 (define (do-fold) (begin (vhash-fold (lambda (key value result) ;; Shouldn't be reached #f) 0 ;; The aim here is to pass in #f for the vlist, and cause an ;; exception within the (ice-9 vlist) module #f) 'done)) ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) (primitive-exit 1)) (lambda () (call-with-temporary-thread (lambda () (do-fold) 'done)))) guile-knots-0.1/tests/backtraces/vhash-fold.scm000066400000000000000000000010301516027255200216150ustar00rootroot00000000000000(use-modules (knots) (ice-9 vlist)) ;; LAST BACKTRACE ENTRY: 257:2 (define (do-fold) (begin (vhash-fold (lambda (key value result) ;; Shouldn't be reached #f) 0 ;; The aim here is to pass in #f for the vlist, and cause an ;; exception within the (ice-9 vlist) module #f) 'done)) ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) (primitive-exit 1)) (lambda () (do-fold) 'done)) guile-knots-0.1/tests/backtraces/wrapped-exception.scm000066400000000000000000000007211516027255200232260ustar00rootroot00000000000000(use-modules (knots)) ;; FIRST BACKTRACE ENTRY: (with-exception-handler (with-exception-handler (lambda (exn) (print-backtrace-and-exception/knots exn) (primitive-exit 1)) (lambda () (with-exception-handler (lambda (exn) (raise-exception (make-exception exn (make-knots-exception (make-stack #t))))) (lambda () (error "wrapped error message"))))) ; LAST BACKTRACE ENTRY HERE guile-knots-0.1/tests/non-blocking.scm000066400000000000000000000014401516027255200200450ustar00rootroot00000000000000(use-modules (tests) (fibers) (unit-test) (web uri) (web client) (web response) (knots web-server) (knots non-blocking)) (run-fibers-for-tests (lambda () (let* ((web-server (run-knots-web-server (lambda (request) (values '((content-type . (text/plain))) "Hello, World!")) #:port 0)) ;; Bind to any port (port (web-server-port web-server)) (uri (build-uri 'http #:host "127.0.0.1" #:port port))) (assert-equal 200 (response-code (http-get uri #:port (non-blocking-open-socket-for-uri uri))))))) (display "non-blocking test finished successfully\n") guile-knots-0.1/tests/parallelism.scm000066400000000000000000000064101516027255200177740ustar00rootroot00000000000000(use-modules (tests) (fibers) (unit-test) (ice-9 exceptions) (knots parallelism)) ;; Test fibers-map (run-fibers-for-tests (lambda () (assert-equal 1122 (apply + (fibers-map (lambda (i) (* 2 i)) (iota 34)))))) ;; Test fibers-batch-map with a large batch size (run-fibers-for-tests (lambda () (assert-equal 1122 (apply + (fibers-batch-map (lambda (i) (* 2 i)) 100 (iota 34)))))) ;; Test fibers-map with an empty list (run-fibers-for-tests (lambda () (fibers-map identity '()))) ;; Test fibers-map with an empty vector (run-fibers-for-tests (lambda () (fibers-map identity #()))) ;; Test fibers-map with vectors (run-fibers-for-tests (lambda () (assert-equal 1122 (apply + (vector->list (fibers-map (lambda (i) (* 2 i)) (list->vector (iota 34)))))))) ;; Test fibers-for-each (run-fibers-for-tests (lambda () (fibers-for-each (lambda (i) (* 2 i)) (iota 34)))) ;; Test fibers-map-with-progress with an empty list (run-fibers-for-tests (lambda () (fibers-map-with-progress identity '(())))) (run-fibers-for-tests (lambda () (with-exception-handler (lambda (exn) (unless (and (exception-with-message? exn) (string=? (exception-message exn) "foo")) (raise-exception exn))) (lambda () (fibers-map-with-progress (lambda _ (raise-exception (make-exception-with-message "foo"))) '((1))) (error 'should-not-reach-here)) #:unwind? #t))) (run-fibers-for-tests (lambda () (with-exception-handler (lambda (exn) (unless (and (exception-with-message? exn) (string=? (exception-message exn) "foo")) (raise-exception exn))) (lambda () (fibers-for-each (lambda (i) (raise-exception (make-exception-with-message "foo"))) (iota 2))) #:unwind? #t))) (run-fibers-for-tests (lambda () (with-exception-handler (lambda (exn) (unless (and (exception-with-message? exn) (string=? (exception-message exn) "foo")) (raise-exception exn))) (lambda () ((fiberize (lambda (i) (raise-exception (make-exception-with-message "foo")))) 1)) #:unwind? #t))) (run-fibers-for-tests (lambda () (let ((a 0)) (call-with-values (lambda () (fibers-parallel (begin (sleep 1) 1) (begin (set! a 1) 2))) (lambda (a b) (assert-equal a 1) (assert-equal b 2))) (assert-equal a 1)))) (run-fibers-for-tests (lambda () (let ((parallelism-limiter (make-parallelism-limiter 2))) (fibers-for-each (lambda _ (with-parallelism-limiter parallelism-limiter #f)) (iota 50)) (destroy-parallelism-limiter parallelism-limiter)))) (display "parallelism test finished successfully\n") guile-knots-0.1/tests/promise.scm000066400000000000000000000011751516027255200171500ustar00rootroot00000000000000(use-modules (tests) (fibers) (unit-test) (knots parallelism) (knots promise)) (run-fibers-for-tests (lambda () (let ((promises (map (lambda (i) (fibers-delay (lambda () (* i 2)))) (iota 10)))) (assert-equal #f (fibers-promise-result-available? (car promises))) (assert-equal 90 (apply + (fibers-map fibers-force promises))) (assert-equal #t (fibers-promise-result-available? (car promises)))))) (display "promise test finished successfully\n") guile-knots-0.1/tests/queue.scm000066400000000000000000000011201516027255200166040ustar00rootroot00000000000000(use-modules (tests) (fibers) (fibers channels) (unit-test) (knots queue)) (run-fibers-for-tests (lambda () (let* ((dest-channel (make-channel)) (queue-channel (spawn-queueing-fiber dest-channel))) (put-message queue-channel 1) (put-message queue-channel 2) (put-message queue-channel 3) (assert-equal 1 (get-message dest-channel)) (assert-equal 2 (get-message dest-channel)) (assert-equal 3 (get-message dest-channel))))) (display "queue test finished successfully\n") guile-knots-0.1/tests/resource-pool.scm000066400000000000000000000223771516027255200202770ustar00rootroot00000000000000(use-modules (tests) (fibers) (fibers channels) (unit-test) (knots parallelism) (knots resource-pool)) (run-fibers-for-tests (lambda () (let ((parallelism-limiter (make-parallelism-limiter 1))) (with-parallelism-limiter parallelism-limiter #f) (destroy-parallelism-limiter parallelism-limiter)))) (run-fibers-for-tests (lambda () (let ((parallelism-limiter (make-parallelism-limiter 1)) (channel (make-channel))) (spawn-fiber (lambda () (with-parallelism-limiter parallelism-limiter (put-message channel #t) (sleep 1)))) (get-message channel) (destroy-parallelism-limiter parallelism-limiter)))) (define new-number (let ((val 0)) (lambda () (set! val (1+ val)) val))) (run-fibers-for-tests (lambda () (let ((resource-pool (make-resource-pool new-number 1))) (assert-true (number? (with-resource-from-pool resource-pool res res))) (destroy-resource-pool resource-pool)))) (run-fibers-for-tests (lambda () (let ((resource-pool (make-fixed-size-resource-pool (list 1)))) (assert-true (number? (with-resource-from-pool resource-pool res res))) (destroy-resource-pool resource-pool)))) (run-fibers-for-tests (lambda () (let ((resource-pool (make-resource-pool new-number 1 #:add-resources-parallelism 1))) (assert-true (number? (with-resource-from-pool resource-pool res res))) (destroy-resource-pool resource-pool)))) (let* ((error-constructor (record-constructor &resource-pool-timeout)) (err (error-constructor 'foo))) (assert-equal (resource-pool-timeout-error-pool err) 'foo)) (run-fibers-for-tests (lambda () (let ((resource-pool (make-resource-pool new-number 2))) (fibers-for-each (lambda _ (with-resource-from-pool resource-pool res res)) (iota 20)) (destroy-resource-pool resource-pool)))) (run-fibers-for-tests (lambda () (let ((resource-pool (make-resource-pool new-number 2 #:destructor (lambda (res) #t)))) (fibers-for-each (lambda _ (with-resource-from-pool resource-pool res res)) (iota 20)) (destroy-resource-pool resource-pool)))) (run-fibers-for-tests (lambda () (let ((resource-pool (make-resource-pool new-number 2 #:idle-seconds 0.5 #:destructor (lambda (res) #t)))) (fibers-for-each (lambda _ (with-resource-from-pool resource-pool res res)) (iota 20)) (let loop ((stats (resource-pool-stats resource-pool #:timeout #f))) (unless (= 0 (assq-ref stats 'resources)) (sleep 0.1) (loop (resource-pool-stats resource-pool #:timeout #f)))) (destroy-resource-pool resource-pool)))) (run-fibers-for-tests (lambda () (let* ((counter 0) (resource-pool (make-resource-pool (lambda () (let ((start-val counter)) (sleep 0.05) (if (= start-val counter) (set! counter (+ 1 counter)) (error "collision detected"))) (new-number)) 1))) (fibers-batch-for-each (lambda _ (with-resource-from-pool resource-pool res (let ((start-val counter)) (sleep 0.05) (if (= start-val counter) (set! counter (+ 1 counter)) (error "collision detected"))))) 20 (iota 50)) (destroy-resource-pool resource-pool)))) (run-fibers-for-tests (lambda () (let* ((counter 0) (resource-pool (make-resource-pool (lambda () (let ((start-val counter)) (sleep 0.05) (if (= start-val counter) (set! counter (+ 1 counter)) (error "collision detected"))) (new-number)) 1 #:default-checkout-timeout 5))) (fibers-batch-for-each (lambda _ (with-resource-from-pool resource-pool res (let ((start-val counter)) (sleep 0.05) (if (= start-val counter) (set! counter (+ 1 counter)) (error "collision detected"))))) 20 (iota 50)) (destroy-resource-pool resource-pool)))) (run-fibers-for-tests (lambda () (let ((resource-pool (make-resource-pool (lambda () #f) 1 #:default-max-waiters 1))) (call-with-resource-from-pool resource-pool (lambda (res) ;; 1st waiter (spawn-fiber (lambda () (with-exception-handler (lambda (exn) (if (resource-pool-destroyed-error? exn) #t (raise-exception exn))) (lambda () (call-with-resource-from-pool resource-pool (lambda (res) #f))) #:unwind? #t))) (while (= 0 (assq-ref (resource-pool-stats resource-pool #:timeout #f) 'waiters)) (sleep 0.1)) (with-exception-handler (lambda (exn) (if (resource-pool-too-many-waiters-error? exn) #t (raise-exception exn))) (lambda () ;; 2nd waiter (call-with-resource-from-pool resource-pool (lambda (res) (error 'should-not-be-reached)))) #:unwind? #t))) (destroy-resource-pool resource-pool)))) (run-fibers-for-tests (lambda () (let ((resource-pool (make-resource-pool (const 'foo) 1 #:lifetime 1 #:destructor (const #t)))) (for-each (lambda _ (with-resource-from-pool resource-pool res res)) (iota 20)) (destroy-resource-pool resource-pool)))) ;; Test allocating resources to waiters and destroying resources (run-fibers-for-tests (lambda () (let ((resource-pool (make-resource-pool (lambda () (sleep 1) 'res) 2 #:idle-seconds 1 #:add-resources-parallelism 10 #:destructor (const #t)))) (fibers-for-each (lambda _ (with-resource-from-pool resource-pool res res)) (iota 20)) (sleep 2) (fibers-for-each (lambda _ (with-resource-from-pool resource-pool res res)) (iota 20)) (destroy-resource-pool resource-pool)))) ;; Test delay-logger and duration-logger (run-fibers-for-tests (lambda () (let* ((logged-delay #f) (logged-duration #f) (resource-pool (make-fixed-size-resource-pool (list 1) #:delay-logger (lambda (seconds) (set! logged-delay seconds)) #:duration-logger (lambda (seconds) (set! logged-duration seconds))))) (call-with-resource-from-pool resource-pool (lambda (res) (sleep 0.2))) (assert-true (number? logged-delay)) (assert-true (number? logged-duration)) (assert-true (>= logged-duration 0.1)) (destroy-resource-pool resource-pool)))) ;; Test per-call duration-logger overrides pool default (run-fibers-for-tests (lambda () (let* ((pool-logged #f) (call-logged #f) (resource-pool (make-fixed-size-resource-pool (list 1) #:duration-logger (lambda (seconds) (set! pool-logged seconds))))) (call-with-resource-from-pool resource-pool (lambda (res) #t) #:duration-logger (lambda (seconds) (set! call-logged seconds))) (assert-true (not pool-logged)) (assert-true (number? call-logged)) (destroy-resource-pool resource-pool)))) (display "resource-pool test finished successfully\n") guile-knots-0.1/tests/sort.scm000066400000000000000000000010331516027255200164520ustar00rootroot00000000000000(use-modules (tests) (fibers) (unit-test) (knots sort)) (run-fibers-for-tests (lambda () (assert-equal '() (fibers-sort! '() <)) (assert-equal '(1) (fibers-sort! (list 1) <)) (assert-equal '(1) (fibers-sort! (list 1) < #:parallelism 10)) (assert-equal '(1 2) (fibers-sort! (list 2 1) <)) (assert-equal (sort (reverse! (iota 100)) <) (fibers-sort! (reverse! (iota 100)) < #:parallelism 10)))) (display "sort test finished successfully\n") guile-knots-0.1/tests/thread-pool.scm000066400000000000000000000122551516027255200177110ustar00rootroot00000000000000(use-modules (tests) (ice-9 atomic) (ice-9 threads) (srfi srfi-71) (fibers) (unit-test) (knots) (knots thread-pool)) (let ((thread-pool (make-fixed-size-thread-pool 2))) (assert-equal (call-with-thread thread-pool (lambda () 4)) 4)) (let ((thread-pool (make-fixed-size-thread-pool 2 #:thread-initializer (const '(2))))) (assert-equal (call-with-thread thread-pool (lambda (num) (* 2 num))) 4)) (let ((thread-pool (make-fixed-size-thread-pool 2))) (assert-equal #t (with-exception-handler (lambda (exn) (knots-exception? exn)) (lambda () (call-with-thread thread-pool (lambda () (+ 1 'a)))) #:unwind? #t))) (run-fibers-for-tests (lambda () (let ((thread-pool (make-thread-pool 2))) (assert-equal (call-with-thread thread-pool (lambda () 4)) 4)))) (run-fibers-for-tests (lambda () (let ((thread-pool (make-thread-pool 2 #:thread-initializer (const '(2))))) (assert-equal (call-with-thread thread-pool (lambda (num) (* 2 num))) 4)))) (run-fibers-for-tests (lambda () (let ((thread-pool (make-thread-pool 2))) (assert-equal #t (with-exception-handler (lambda (exn) (knots-exception? exn)) (lambda () (call-with-thread thread-pool (lambda () (+ 1 'a)))) #:unwind? #t))))) (let ((thread-pool (make-fixed-size-thread-pool 1 #:thread-lifetime 1 #:thread-initializer (lambda () (list (make-atomic-box #t)))))) (for-each (lambda _ (call-with-thread thread-pool (lambda (box) (if (atomic-box-ref box) (atomic-box-set! box #f) (error (atomic-box-ref box)))))) (iota 10))) (run-fibers-for-tests (lambda () (let ((thread-pool (make-thread-pool 1 #:thread-lifetime 1))) (for-each (lambda _ (call-with-thread thread-pool (lambda () #f))) (iota 10))))) (let ((thread-pool (make-fixed-size-thread-pool 1 #:thread-lifetime 2 #:thread-initializer (lambda () (list (make-atomic-box 2)))))) (define (ref-and-decrement box) (let ((val (atomic-box-ref box))) (atomic-box-set! box (- val 1)) val)) (unless (= 2 (call-with-thread thread-pool ref-and-decrement)) (error)) (unless (= 1 (call-with-thread thread-pool ref-and-decrement)) (error)) (unless (= 2 (call-with-thread thread-pool ref-and-decrement)) (error))) ;; Test that the destructor is called when a size 1 fixed-size thread ;; pool is destroyed, and that destroy-thread-pool blocks until it has ;; completed. (let* ((destructor-called? #f) (thread-pool (make-fixed-size-thread-pool 1 #:thread-destructor (lambda () (set! destructor-called? #t))))) (destroy-thread-pool thread-pool) (assert-equal #t destructor-called?)) ;; Test that the destructor is called for every thread when a ;; multi-thread fixed-size thread pool is destroyed, and that ;; destroy-thread-pool blocks until all destructors have completed. (let* ((destructor-count 0) (mutex (make-mutex)) (pool-size 3) (thread-pool (make-fixed-size-thread-pool pool-size #:thread-destructor (lambda () (with-mutex mutex (set! destructor-count (+ destructor-count 1))))))) (destroy-thread-pool thread-pool) (assert-equal pool-size destructor-count)) ;; Test delay-logger and duration-logger for fixed-size thread pool (let* ((logged-delay #f) (logged-duration #f) (thread-pool (make-fixed-size-thread-pool 1 #:delay-logger (lambda (seconds) (set! logged-delay seconds)) #:duration-logger (lambda (seconds) (set! logged-duration seconds))))) (call-with-thread thread-pool (lambda () (usleep 100000))) (assert-true (number? logged-delay)) (assert-true (number? logged-duration)) (assert-true (>= logged-duration 0.1)) (destroy-thread-pool thread-pool)) ;; Test delay-logger and duration-logger for dynamic thread pool (run-fibers-for-tests (lambda () (let* ((logged-delay #f) (logged-duration #f) (thread-pool (make-thread-pool 1 #:delay-logger (lambda (seconds) (set! logged-delay seconds)) #:duration-logger (lambda (seconds) (set! logged-duration seconds))))) (call-with-thread thread-pool (lambda () (usleep 100000))) (assert-true (number? logged-delay)) (assert-true (number? logged-duration)) (assert-true (>= logged-duration 0.1)) (destroy-thread-pool thread-pool)))) (display "thread-pool test finished successfully\n") guile-knots-0.1/tests/timeout.scm000066400000000000000000000006211516027255200171530ustar00rootroot00000000000000(use-modules (tests) (fibers) (unit-test) (knots timeout)) (run-fibers-for-tests (lambda () (assert-equal 1 (with-fibers-timeout (const 1) #:timeout 10)) (assert-equal 2 (with-fibers-timeout (lambda () (sleep 10)) #:timeout 0.1 #:on-timeout (const 2))))) (display "timeout test finished successfully\n") guile-knots-0.1/tests/web-server.scm000066400000000000000000000226571516027255200175630ustar00rootroot00000000000000(use-modules (srfi srfi-71) (rnrs bytevectors) (ice-9 match) (ice-9 binary-ports) (ice-9 textual-ports) (tests) (fibers) (fibers channels) (unit-test) (web uri) (web client) (web request) (web response) (knots web-server) (knots non-blocking)) (run-fibers-for-tests (lambda () (let* ((web-server (run-knots-web-server (lambda (request) (values '((content-type . (text/plain))) "Hello, World!")) #:port 0)) ;; Bind to any port (port (web-server-port web-server)) (uri (build-uri 'http #:host "127.0.0.1" #:port port))) (assert-equal 200 (response-code (http-get uri #:port (non-blocking-open-socket-for-uri uri))))))) (run-fibers-for-tests (lambda () (let* ((web-server (run-knots-web-server (lambda (request) "Hello, World!") #:port 0)) ;; Bind to any port (port (web-server-port web-server)) (uri (build-uri 'http #:host "127.0.0.1" #:port port))) (assert-equal 500 (response-code (http-get uri #:port (non-blocking-open-socket-for-uri uri))))))) (run-fibers-for-tests (lambda () (let* ((web-server (run-knots-web-server (lambda (request) (values '((content-type . (text/plain)) (content-length . 3)) (lambda (port) (display "foo" port)))) #:port 0)) ;; Bind to any port (port (web-server-port web-server)) (uri (build-uri 'http #:host "127.0.0.1" #:port port))) (let ((response body (http-get uri #:port (non-blocking-open-socket-for-uri uri)))) (assert-equal "foo" body))))) (run-fibers-for-tests (lambda () (let* ((web-server (run-knots-web-server (lambda (request) (values '((content-type . (text/plain (charset . "utf-8")))) (lambda (port) (display "☺" port)))) #:port 0)) ;; Bind to any port (port (web-server-port web-server)) (uri (build-uri 'http #:host "127.0.0.1" #:port port))) (let ((response body (http-get uri #:port (non-blocking-open-socket-for-uri uri)))) (assert-equal "☺" body))))) (run-fibers-for-tests (lambda () (let* ((web-server (run-knots-web-server (lambda (request) (values '((content-type . (text/plain (charset . "utf-8"))) (content-length . 3)) (lambda (port) (display "☺" port)))) #:port 0)) ;; Bind to any port (port (web-server-port web-server)) (uri (build-uri 'http #:host "127.0.0.1" #:port port))) (let ((response body (http-get uri ;; TODO Remove once using Guile 3.0.10 #:streaming? #t #:port (non-blocking-open-socket-for-uri uri)))) (assert-equal "☺" (utf8->string (get-bytevector-n body 3))))))) (run-fibers-for-tests (lambda () (let* ((web-server (run-knots-web-server (lambda (request) (if (string=? (utf8->string (read-request-body/knots request)) "☺") (values (build-response #:code 200) "") (values (build-response #:code 500) ""))) #:port 0)) ;; Bind to any port (port (web-server-port web-server)) (uri (build-uri 'http #:host "127.0.0.1" #:port port))) (let ((response body (http-post uri #:body "☺" #:port (non-blocking-open-socket-for-uri uri)))) (assert-equal 200 (response-code response)))))) (run-fibers-for-tests (lambda () (let* ((channel (make-channel)) (web-server (run-knots-web-server (lambda (request) (with-exception-handler (lambda (exn) (put-message channel exn)) (lambda () (read-request-body/knots request)) #:unwind? #t)) #:port 0)) ;; Bind to any port (port (web-server-port web-server)) (uri (build-uri 'http #:host "127.0.0.1" #:port port))) (let* ((port (non-blocking-open-socket-for-uri uri)) (request (build-request uri #:method 'POST #:version '(1 . 1) #:headers `((connection close) (content-length . 20) (Content-Type . "application/octet-stream")) #:port port))) (set-port-encoding! port "ISO-8859-1") (let ((request (write-request request port))) (display "12") (force-output port) (close-port port))) (assert-true (request-body-ended-prematurely-error? (get-message channel)))))) ;; Test handling of exceptions when writing the response to a client (run-fibers-for-tests (lambda () (let* ((exception-handled-sucecssfully-channel (make-channel)) (port-closed-channel (make-channel)) (web-server (run-knots-web-server (lambda (request) ;; TODO Not sure why buffering makes a difference here (setvbuf (request-port request) 'none) (get-message port-closed-channel) (values '((content-type . (text/plain))) "Hello, World!")) #:write-response-exception-handler (lambda (exn request) (spawn-fiber (lambda () (put-message exception-handled-sucecssfully-channel #t))) #f) #:port 0)) ;; Bind to any port (port (web-server-port web-server)) (uri (build-uri 'http #:host "127.0.0.1" #:port port))) (let ((request-port (non-blocking-open-socket-for-uri uri))) (write-request (build-request uri) request-port) (close-port request-port)) (put-message port-closed-channel #t) (assert-equal (get-message exception-handled-sucecssfully-channel) #t)))) (run-fibers-for-tests (lambda () (let* ((web-server (run-knots-web-server (lambda (request) (match (split-and-decode-uri-path (uri-path (request-uri request))) (("head-no-body") (values '((content-type . (text/plain))) #f)) (("head-empty-body") (values '((content-type . (text/plain))) "")) (("head-no-body-with-content-length") (values '((content-type . (text/plain)) (content-length . 10)) #f)) (("head-with-body") (values '((content-type . (text/plain))) "foo")) (("head-procedure-body") (values '((content-type . (text/plain))) (lambda _ (error "should not be run")))) (("head-procedure-body-with-content-length") (values '((content-type . (text/plain)) (content-length . 10)) (lambda _ (error "should not be run")))))) #:port 0)) ;; Bind to any port (port (web-server-port web-server))) (define* (head path) (let ((uri (build-uri 'http #:host "127.0.0.1" #:port port #:path path))) (http-head uri #:port (non-blocking-open-socket-for-uri uri)))) (let ((response (head "/head-no-body"))) (assert-equal 200 (response-code response))) (let ((response (head "/head-empty-body"))) (assert-equal 200 (response-code response)) (assert-equal 0 (response-content-length response))) (let ((response (head "/head-no-body-with-content-length"))) (assert-equal 200 (response-code response)) (assert-equal 10 (response-content-length response))) (let ((response (head "/head-with-body"))) (assert-equal 200 (response-code response)) (assert-equal 3 (response-content-length response))) (let ((response (head "/head-procedure-body"))) (assert-equal 200 (response-code response))) (let ((response (head "/head-procedure-body-with-content-length"))) (assert-equal 200 (response-code response)) (assert-equal 10 (response-content-length response)))))) (display "web-server test finished successfully\n") guile-knots-0.1/tests/web.scm000066400000000000000000000200461516027255200162450ustar00rootroot00000000000000(use-modules (tests) (fibers) (srfi srfi-71) (ice-9 rdelim) (ice-9 exceptions) (unit-test) (web uri) (web client) (web request) (web response) (knots resource-pool) (knots web-server) (knots web)) ;; Test that call-with-cached-connection passes the port to proc and ;; returns its result. (run-fibers-for-tests (lambda () (let* ((port (open-input-string "")) (cache (make-fixed-size-resource-pool (list port)))) (assert-equal 'ok (call-with-cached-connection cache (lambda (p) 'ok))) (destroy-resource-pool cache)))) ;; Test that call-with-cached-connection retries when the checked-out ;; port is already closed, using a fresh connection from the pool. (run-fibers-for-tests (lambda () (let* ((n 0) (cache (make-resource-pool (lambda () (set! n (+ n 1)) (if (= n 1) (let ((p (open-input-string ""))) (close-port p) p) (open-input-string ""))) 1 ;; Without a destructor, the resource pool calls (#f port) ;; when destroying the closed-port resource, looping forever. #:destructor (const #t)))) (assert-equal 'ok (call-with-cached-connection cache (lambda (p) 'ok))) (destroy-resource-pool cache)))) ;; Test that call-with-connection-cache provides a working cache and ;; destroys it after the body returns. (run-fibers-for-tests (lambda () (let* ((web-server (run-knots-web-server (lambda (request) (values '((content-type . (text/plain))) "ok")) #:port 0)) (server-port (web-server-port web-server)) (uri (build-uri 'http #:host "127.0.0.1" #:port server-port))) (assert-equal 200 (call-with-connection-cache uri 1 (lambda (cache) (call-with-cached-connection cache (lambda (p) (let ((response body (http-get uri #:port p #:keep-alive? #t))) (response-code response)))))))))) ;; Test that http-fold-requests sends requests and folds over responses. ;; The proc must drain the body port between responses so that HTTP ;; pipelining works correctly. (run-fibers-for-tests (lambda () (let* ((web-server (run-knots-web-server (lambda (request) (values '((content-type . (text/plain))) "ok")) #:port 0)) (server-port (web-server-port web-server)) (uri (build-uri 'http #:host "127.0.0.1" #:port server-port)) (cache (make-connection-cache uri 1)) (requests (list (build-request uri) (build-request uri)))) (let ((codes (http-fold-requests cache (lambda (req resp body result) (read-string body) ; drain body before next pipelined response (cons (response-code resp) result)) '() requests))) (assert-equal '(200 200) codes)) (destroy-resource-pool cache)))) ;; Test that http-fold-requests reconnects and retries remaining requests when ;; the server closes the connection mid-batch via Connection: close. Three ;; requests are sent in one batch; the server closes after the first response, ;; so the remaining two must be retried on a fresh connection. (run-fibers-for-tests (lambda () (let* ((n 0) (web-server (run-knots-web-server (lambda (request) (set! n (1+ n)) (if (= n 1) (values '((content-type . (text/plain)) (connection . (close))) "ok") (values '((content-type . (text/plain))) "ok"))) #:port 0)) (server-port (web-server-port web-server)) (uri (build-uri 'http #:host "127.0.0.1" #:port server-port)) (cache (make-connection-cache uri 1)) (requests (list (build-request uri) (build-request uri) (build-request uri)))) (let ((codes (http-fold-requests cache (lambda (req resp body result) (read-string body) (cons (response-code resp) result)) '() requests))) (assert-equal '(200 200 200) codes)) (destroy-resource-pool cache)))) ;; Test that write errors in send-batch are handled gracefully. Each request ;; carries a large header so that the batch data exceeds the TCP send buffer, ;; causing write-request to fail while the server has already closed the ;; connection after the first response. (run-fibers-for-tests (lambda () (let* ((n 0) (web-server (run-knots-web-server (lambda (request) (set! n (1+ n)) (if (= n 1) (values '((content-type . (text/plain)) (connection . (close))) "ok") (values '((content-type . (text/plain))) "ok"))) #:port 0)) (server-port (web-server-port web-server)) (uri (build-uri 'http #:host "127.0.0.1" #:port server-port)) (cache (make-connection-cache uri 1)) (n-requests 100) ;; 100 requests x ~100 KB of headers each = ~10 MB, well above ;; the typical TCP send buffer, so writes fail mid-batch. (large-request (build-request uri #:headers `((x-padding . ,(make-string 100000 #\a))))) (requests (make-list n-requests large-request))) (let ((codes (http-fold-requests cache (lambda (req resp body result) (read-string body) (cons (response-code resp) result)) '() requests))) (assert-equal (make-list n-requests 200) codes)) (destroy-resource-pool cache)))) ;; Test that http-fold-requests processes multiple batches. With batch-size 2 ;; and 5 requests, three batches are needed; without the pending fix only the ;; first batch would be processed. (run-fibers-for-tests (lambda () (let* ((web-server (run-knots-web-server (lambda (request) (values '((content-type . (text/plain))) "ok")) #:port 0)) (server-port (web-server-port web-server)) (uri (build-uri 'http #:host "127.0.0.1" #:port server-port)) (cache (make-connection-cache uri 1)) (requests (make-list 5 (build-request uri)))) (let ((codes (http-fold-requests cache (lambda (req resp body result) (read-string body) (cons (response-code resp) result)) '() requests #:batch-size 2))) (assert-equal (make-list 5 200) codes)) (destroy-resource-pool cache)))) ;; Test that an exception raised by proc propagates out of http-fold-requests. (run-fibers-for-tests (lambda () (let* ((web-server (run-knots-web-server (lambda (request) (values '((content-type . (text/plain))) "ok")) #:port 0)) (server-port (web-server-port web-server)) (uri (build-uri 'http #:host "127.0.0.1" #:port server-port)) (cache (make-connection-cache uri 1)) (requests (list (build-request uri)))) (assert-equal 'proc-exception (exception-message (with-exception-handler (lambda (exn) exn) (lambda () (http-fold-requests cache (lambda (req resp body result) (raise-exception (make-exception-with-message 'proc-exception))) '() requests)) #:unwind? #t))) (destroy-resource-pool cache)))) (display "web test finished successfully\n")