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

Guile Knots

+
+ + + + + +
+
+

+Next:   [Contents][Index]

+
+

Overview

+ +

Guile Knots is a library providing tools and patterns for programming +with 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. +

+ + + + + + + +
+
+
+

+Next: , Previous: , Up: Overview   [Contents][Index]

+
+

1 API

+

The following is the list of modules provided by this library. +

+ + + +
+
+
+

+Next: , Up: API   [Contents][Index]

+
+

1.1 (knots)

+ + + + + + +
+

1.1.1 Procedures

+ + +
+
Procedure: call-with-default-io-waiters a
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: call-with-sigint a b
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: knots-exception-stack obj
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: knots-exception? obj
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: make-knots-exception a
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: print-backtrace-and-exception/knots _ KEY: #:port
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: wait-when-system-clock-behind
+

Undocumented procedure. +

+
+ + + + + +
+
+

1.1.2 Record Types

+ + +
+
Record type: &knots-exception
+

This record type has the following fields: +

+
    +
  • stack
+ +
+ + + + + + +
+
+
+
+
+

+Next: , Previous: , Up: API   [Contents][Index]

+
+

1.2 (knots non-blocking)

+ + + + + + +
+

1.2.1 Procedures

+ + +
+
Procedure: non-blocking-open-socket-for-uri _ KEY: #:verify-certificate?
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: non-blocking-port a
+

Make PORT non-blocking and return it. +

+
+ + + + + + +
+
+
+
+
+

+Next: , Previous: , Up: API   [Contents][Index]

+
+

1.3 (knots parallelism)

+ + + + + + +
+

1.3.1 Macros

+ + +
+
Macro: fibers-let a
+

Let, but run each binding in a fiber in parallel. +

+
+ + + + +
+
Macro: fibers-parallel a
+

Run each expression in parallel. If any expression raises an exception, +this will be raised after all exceptions have finished. +

+
+ + + + +
+
Macro: parallelism-limiter? a
+

Undocumented macro. +

+
+ + + + +
+
Macro: with-parallelism-limiter a
+

Undocumented macro. +

+
+ + + + + +
+
+

1.3.2 Procedures

+ + +
+
Procedure: call-with-parallelism-limiter a b
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: destroy-parallelism-limiter a
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: fiberize _ KEY: #:parallelism #:input-channel #:process-channel
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: fibers-batch-for-each a b . rest
+

Call PROC on LISTS, running up to PARALLELISM-LIMIT fibers in parallel. +

+
+ + + + +
+
Procedure: fibers-batch-map a b . rest
+

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. +

+
+ + + + +
+
Procedure: fibers-for-each a . rest
+

Call PROC on LISTS, running up to 20 fibers in parallel. +

+
+ + + + +
+
Procedure: fibers-map a . rest
+

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. +

+
+ + + + +
+
Procedure: fibers-map-with-progress _ _ 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. +

+
+ + + + +
+
Procedure: make-parallelism-limiter _ KEY: #:name
+

Undocumented procedure. +

+
+ + + + + + +
+
+
+
+
+

+Next: , Previous: , Up: API   [Contents][Index]

+
+

1.4 (knots promise)

+ + + + + + +
+

1.4.1 Macros

+ + +
+
Macro: fibers-promise? a
+

Undocumented macro. +

+
+ + + + + +
+
+

1.4.2 Procedures

+ + +
+
Procedure: fibers-delay a
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: fibers-force a
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: fibers-promise-reset a
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: fibers-promise-result-available? a
+

Undocumented procedure. +

+
+ + + + + + +
+
+
+
+
+

+Next: , Previous: , Up: API   [Contents][Index]

+
+

1.5 (knots queue)

+ + + + + + +
+

1.5.1 Procedures

+ + +
+
Procedure: spawn-queueing-fiber a
+

Undocumented procedure. +

+
+ + + + + + +
+
+
+
+
+

+Next: , Previous: , Up: API   [Contents][Index]

+
+

1.6 (knots resource-pool)

+ + + + + + +
+

1.6.1 Macros

+ + +
+
Macro: resource-pool-channel a
+

Undocumented macro. +

+
+ + + + +
+
Macro: resource-pool-configuration a
+

Undocumented macro. +

+
+ + + + +
+
Macro: resource-pool-name a
+

Undocumented macro. +

+
+ + + + +
+
Macro: resource-pool? a
+

Undocumented macro. +

+
+ + + + +
+
Macro: with-resource-from-pool a
+

Undocumented macro. +

+
+ + + + + +
+
+

1.6.2 Parameters

+ + +
+
Parameter: resource-pool-default-timeout-handler
+

Default value: +

+
#f
+
+
+ + + + + +
+
+

1.6.3 Procedures

+ + +
+
Procedure: call-with-resource-from-pool _ _ KEY: #:timeout #:timeout-handler #:max-waiters #:channel #:destroy-resource-on-exception?
+

Call PROC with a resource from POOL, blocking until a resource becomes +available. Return the resource once PROC has returned. +

+
+ + + + +
+
Procedure: destroy-resource-pool a
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: make-fixed-size-resource-pool _ KEY: #:delay-logger #:duration-logger #:destructor #:scheduler #:name #:default-checkout-timeout #:default-max-waiters
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: make-resource-pool _ _ KEY: #:min-size #:idle-seconds #:delay-logger #:duration-logger #:destructor #:lifetime #:scheduler #:name #:add-resources-parallelism #:default-checkout-timeout #:default-max-waiters
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: make-resource-pool-destroy-resource-exception
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: resource-pool-destroy-resource-exception? obj
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: resource-pool-destroyed-error-pool obj
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: resource-pool-destroyed-error? obj
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: resource-pool-stats _ KEY: #:timeout
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: resource-pool-timeout-error-pool obj
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: resource-pool-timeout-error? obj
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: resource-pool-too-many-waiters-error-pool obj
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: resource-pool-too-many-waiters-error-waiters-count obj
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: resource-pool-too-many-waiters-error? obj
+

Undocumented procedure. +

+
+ + + + + +
+
+

1.6.4 Record Types

+ + +
+
Record type: &resource-pool-destroy-resource
+

This record type has the following fields: +

+
    +
+ +
+ + + + +
+
Record type: &resource-pool-destroyed
+

This record type has the following fields: +

+
    +
  • pool
+ +
+ + + + +
+
Record type: &resource-pool-timeout
+

This record type has the following fields: +

+
    +
  • pool
+ +
+ + + + +
+
Record type: &resource-pool-too-many-waiters
+

This record type has the following fields: +

+
    +
  • pool
  • waiters-count
+ +
+ + + + + + +
+
+
+
+
+

+Next: , Previous: , Up: API   [Contents][Index]

+
+

1.7 (knots thread-pool)

+ + + + + + +
+

1.7.1 Macros

+ + +
+
Macro: fixed-size-thread-pool-channel a
+

Undocumented macro. +

+
+ + + + +
+
Macro: fixed-size-thread-pool-current-procedures a
+

Undocumented macro. +

+
+ + + + +
+
Macro: fixed-size-thread-pool? a
+

Undocumented macro. +

+
+ + + + +
+
Macro: thread-pool-resource-pool a
+

Undocumented macro. +

+
+ + + + +
+
Macro: thread-pool? a
+

Undocumented macro. +

+
+ + + + + +
+
+

1.7.2 Procedures

+ + +
+
Procedure: call-with-thread _ _ KEY: #:duration-logger #:checkout-timeout #:channel #:destroy-thread-on-exception? #:max-waiters
+

Send PROC to the thread pool through CHANNEL. Return the result of +PROC. If already in the thread pool, call PROC immediately. +

+
+ + + + +
+
Procedure: destroy-thread-pool a
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: make-fixed-size-thread-pool _ KEY: #:thread-initializer #:thread-destructor #:delay-logger #:duration-logger #:thread-lifetime #:expire-on-exception? #:name #:use-default-io-waiters? #:default-checkout-timeout
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: make-thread-pool _ KEY: #:min-size #:scheduler #:thread-initializer #:thread-destructor #:delay-logger #:duration-logger #:thread-lifetime #:expire-on-exception? #:name #:use-default-io-waiters? #:default-checkout-timeout
+

Return a channel used to offload work to a dedicated thread. ARGS are +the arguments of the thread pool procedure. +

+
+ + + + +
+
Procedure: set-thread-name a
+

Set the name of the calling thread to NAME. NAME is truncated to 15 +bytes. +

+
+ + + + +
+
Procedure: thread-name
+

Return the name of the calling thread as a string. +

+
+ + + + +
+
Procedure: thread-pool-arguments-parameter a
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: thread-pool-default-checkout-timeout a
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: thread-pool-timeout-error-pool obj
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: thread-pool-timeout-error? obj
+

Undocumented procedure. +

+
+ + + + + +
+
+

1.7.3 Record Types

+ + +
+
Record type: &thread-pool-timeout-error
+

This record type has the following fields: +

+
    +
  • pool
+ +
+ + + + + + +
+
+
+
+
+

+Next: , Previous: , Up: API   [Contents][Index]

+
+

1.8 (knots timeout)

+ + + + + + +
+

1.8.1 Procedures

+ + +
+
Procedure: port-read-timeout-error? obj
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: port-timeout-error? obj
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: port-write-timeout-error? obj
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: wait-until-port-readable-operation a
+

Make an operation that will succeed when PORT is readable. +

+
+ + + + +
+
Procedure: wait-until-port-writable-operation a
+

Make an operation that will succeed when PORT is writable. +

+
+ + + + +
+
Procedure: with-fibers-timeout _ KEY: #:timeout #:on-timeout
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: with-port-timeouts _ KEY: #:timeout #:read-timeout #:write-timeout
+

Undocumented procedure. +

+
+ + + + + +
+
+

1.8.2 Record Types

+ + +
+
Record type: &port-read-timeout-error
+

This record type has the following fields: +

+
    +
  • thunk
  • port
+ +
+ + + + +
+
Record type: &port-timeout-error
+

This record type has the following fields: +

+
    +
  • thunk
  • port
+ +
+ + + + +
+
Record type: &port-write-timeout-error
+

This record type has the following fields: +

+
    +
  • thunk
  • port
+ +
+ + + + + + +
+
+
+
+
+

+Previous: , Up: API   [Contents][Index]

+
+

1.9 (knots web-server)

+ + + + + + +
+

1.9.1 Macros

+ + +
+
Macro: web-server-port a
+

Undocumented macro. +

+
+ + + + +
+
Macro: web-server-socket a
+

Undocumented macro. +

+
+ + + + +
+
Macro: web-server? a
+

Undocumented macro. +

+
+ + + + + +
+
+

1.9.2 Procedures

+ + +
+
Procedure: default-write-response-exception-handler a b
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: make-chunked-output-port/knots _ KEY: #:keep-alive? #:buffering
+

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. +

+
+ + + + +
+
Procedure: read-request-body/knots a
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: request-body-ended-prematurely-error? obj
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: request-body-port/knots a
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: run-knots-web-server _ KEY: #:host #:family #:addr #:port #:socket #:read-request-exception-handler #:write-response-exception-handler #:connection-idle-timeout #:connection-buffer-size #: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: +

+
+
 (define (handler request)
+   (let ((body (read-request-body request)))
+     (values '((content-type . (text/plain)))
+             "Hello, World!")))
+ (run-knots-web-server handler)
+
+ +

The response and body will be run through ‘sanitize-response’ before +sending back to the client. +

+
+ + + + +
+
Procedure: sanitize-response a b c
+

"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. +

+
+ + + + + +
+
+

1.9.3 Record Types

+ + +
+
Record type: &request-body-ended-prematurely
+

This record type has the following fields: +

+
    +
  • bytes-read
+ +
+ + + + + + + + +
+
+
+
+
+
+

+Next: , Previous: , Up: Overview   [Contents][Index]

+
+

Appendix A Version History

+ +
+
Version 0.Y.0, Month DD, 20YY
+
    +
  • No initial release has yet been made. +
+ +
+
+ + + +
+
+
+
+

+Next: , Previous: , Up: Overview   [Contents][Index]

+
+

Appendix B Copying Information

+ +

Copyright © 2024, 2025 Christopher Baines <mail@cbaines.net> +

+

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. +

+ + + +
+
+
+
+

+Next: , Previous: , Up: Overview   [Contents][Index]

+
+

Concept Index

+ + + +
+
+ +
+
+

+Next: , Previous: , Up: Overview   [Contents][Index]

+
+

Procedure Index

+ +
+
Jump to:   C +   +D +   +F +   +K +   +M +   +N +   +P +   +R +   +S +   +T +   +W +   +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Index EntrySection
C
call-with-default-io-waitersknots
call-with-parallelism-limiterknots_parallelism
call-with-resource-from-poolknots_resource-pool
call-with-sigintknots
call-with-threadknots_thread-pool
D
default-write-response-exception-handlerknots_web-server
destroy-parallelism-limiterknots_parallelism
destroy-resource-poolknots_resource-pool
destroy-thread-poolknots_thread-pool
F
fiberizeknots_parallelism
fibers-batch-for-eachknots_parallelism
fibers-batch-mapknots_parallelism
fibers-delayknots_promise
fibers-for-eachknots_parallelism
fibers-forceknots_promise
fibers-letknots_parallelism
fibers-mapknots_parallelism
fibers-map-with-progressknots_parallelism
fibers-parallelknots_parallelism
fibers-promise-resetknots_promise
fibers-promise-result-available?knots_promise
fibers-promise?knots_promise
fixed-size-thread-pool-channelknots_thread-pool
fixed-size-thread-pool-current-proceduresknots_thread-pool
fixed-size-thread-pool?knots_thread-pool
K
knots-exception-stackknots
knots-exception?knots
M
make-chunked-output-port/knotsknots_web-server
make-fixed-size-resource-poolknots_resource-pool
make-fixed-size-thread-poolknots_thread-pool
make-knots-exceptionknots
make-parallelism-limiterknots_parallelism
make-resource-poolknots_resource-pool
make-resource-pool-destroy-resource-exceptionknots_resource-pool
make-thread-poolknots_thread-pool
N
non-blocking-open-socket-for-uriknots_non-blocking
non-blocking-portknots_non-blocking
P
parallelism-limiter?knots_parallelism
port-read-timeout-error?knots_timeout
port-timeout-error?knots_timeout
port-write-timeout-error?knots_timeout
print-backtrace-and-exception/knotsknots
R
read-request-body/knotsknots_web-server
request-body-ended-prematurely-error?knots_web-server
request-body-port/knotsknots_web-server
resource-pool-channelknots_resource-pool
resource-pool-configurationknots_resource-pool
resource-pool-destroy-resource-exception?knots_resource-pool
resource-pool-destroyed-error-poolknots_resource-pool
resource-pool-destroyed-error?knots_resource-pool
resource-pool-nameknots_resource-pool
resource-pool-statsknots_resource-pool
resource-pool-timeout-error-poolknots_resource-pool
resource-pool-timeout-error?knots_resource-pool
resource-pool-too-many-waiters-error-poolknots_resource-pool
resource-pool-too-many-waiters-error-waiters-countknots_resource-pool
resource-pool-too-many-waiters-error?knots_resource-pool
resource-pool?knots_resource-pool
run-knots-web-serverknots_web-server
S
sanitize-responseknots_web-server
set-thread-nameknots_thread-pool
spawn-queueing-fiberknots_queue
T
thread-nameknots_thread-pool
thread-pool-arguments-parameterknots_thread-pool
thread-pool-default-checkout-timeoutknots_thread-pool
thread-pool-resource-poolknots_thread-pool
thread-pool-timeout-error-poolknots_thread-pool
thread-pool-timeout-error?knots_thread-pool
thread-pool?knots_thread-pool
W
wait-until-port-readable-operationknots_timeout
wait-until-port-writable-operationknots_timeout
wait-when-system-clock-behindknots
web-server-portknots_web-server
web-server-socketknots_web-server
web-server?knots_web-server
with-fibers-timeoutknots_timeout
with-parallelism-limiterknots_parallelism
with-port-timeoutsknots_timeout
with-resource-from-poolknots_resource-pool
+
Jump to:   C +   +D +   +F +   +K +   +M +   +N +   +P +   +R +   +S +   +T +   +W +   +
+
+ + +
+
+
+
+

+Previous: , Up: Overview   [Contents][Index]

+
+

Variable Index

+ +
+ + + + + + +
Index EntrySection
R
resource-pool-default-timeout-handlerknots_resource-pool
+
+ + +
+
+ + + + + diff --git a/knots.scm b/knots.scm deleted file mode 100644 index 05b2a1a..0000000 --- a/knots.scm +++ /dev/null @@ -1,130 +0,0 @@ -(define-module (knots) - #:use-module (srfi srfi-1) - #:use-module (ice-9 match) - #:use-module (ice-9 suspendable-ports) - #:use-module (fibers conditions) - #:use-module (system repl debug) - #:export (call-with-default-io-waiters - - wait-when-system-clock-behind - - call-with-sigint - - &knots-exception - make-knots-exception - knots-exception? - knots-exception-stack - - print-backtrace-and-exception/knots)) - -(define (call-with-default-io-waiters thunk) - (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) - (let ((start-of-the-year-2000 946684800)) - (while (< (current-time) - start-of-the-year-2000) - (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) - (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 &knots-exception - (make-exception-type '&knots-exception - &exception - '(stack))) - -(define make-knots-exception - (record-constructor &knots-exception)) - -(define knots-exception? - (exception-predicate &knots-exception)) - -(define knots-exception-stack - (exception-accessor - &knots-exception - (record-accessor &knots-exception 'stack))) - -(define* (print-backtrace-and-exception/knots - exn - #:key (port (current-error-port))) - (let* ((stack - (match (fluid-ref %stacks) - ((stack-tag . prompt-tag) - (make-stack #t - 0 prompt-tag - 0 (and prompt-tag 1))) - (_ - (make-stack #t)))) - (stack-len - (stack-length stack)) - (error-string - (call-with-output-string - (lambda (port) - (let ((knots-stacks - (map knots-exception-stack - (filter knots-exception? - (simple-exceptions exn))))) - - (let* ((stack-vec - (stack->vector stack)) - (stack-vec-length - (vector-length stack-vec))) - (print-frames (list->vector - (drop - (vector->list stack-vec) - (if (< stack-vec-length 5) - 0 - 4))) - port - #:count (stack-length stack))) - (for-each - (lambda (stack) - (let* ((stack-vec - (stack->vector stack)) - (stack-vec-length - (vector-length stack-vec))) - (print-frames (list->vector - (drop - (vector->list stack-vec) - (if (< stack-vec-length 4) - 0 - 3))) - port - #:count (stack-length stack)))) - knots-stacks) - (print-exception - port - (if (null? knots-stacks) - (stack-ref stack - (if (< stack-len 4) - stack-len - 4)) - (let* ((stack (last knots-stacks)) - (stack-len (stack-length stack))) - (stack-ref stack - (if (< stack-len 3) - stack-len - 3)))) - '%exception - (list exn))))))) - (display error-string port))) diff --git a/knots/non-blocking.scm b/knots/non-blocking.scm deleted file mode 100644 index 4473b63..0000000 --- a/knots/non-blocking.scm +++ /dev/null @@ -1,62 +0,0 @@ -;;; 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)) - (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)))) diff --git a/knots/parallelism.scm b/knots/parallelism.scm deleted file mode 100644 index 7631055..0000000 --- a/knots/parallelism.scm +++ /dev/null @@ -1,340 +0,0 @@ -;;; 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)) - (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)) - -(define* (make-parallelism-limiter limit #:key (name "unnamed")) - (make-parallelism-limiter-record - (make-fixed-size-resource-pool - (iota limit) - #:name name))) - -(define (destroy-parallelism-limiter parallelism-limiter) - (destroy-resource-pool - (parallelism-limiter-resource-pool - parallelism-limiter))) - -(define* (call-with-parallelism-limiter parallelism-limiter thunk) - (call-with-resource-from-pool - (parallelism-limiter-resource-pool parallelism-limiter) - (lambda _ - (thunk)))) - -(define-syntax-rule (with-parallelism-limiter parallelism-limiter exp ...) - (call-with-parallelism-limiter - parallelism-limiter - (lambda () exp ...))) diff --git a/knots/promise.scm b/knots/promise.scm deleted file mode 100644 index 9df376b..0000000 --- a/knots/promise.scm +++ /dev/null @@ -1,112 +0,0 @@ -;;; 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-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)) - -(define (fibers-delay thunk) - (make-fibers-promise - thunk - (make-atomic-box #f) - (make-condition))) - -(define (fibers-force fp) - (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))))) - (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-promise-reset fp) - (atomic-box-set! (fibers-promise-values-box fp) - #f)) - -(define (fibers-promise-result-available? fp) - (let ((val (atomic-box-ref (fibers-promise-values-box fp)))) - (not (or (eq? val #f) - (eq? val 'started))))) diff --git a/knots/queue.scm b/knots/queue.scm deleted file mode 100644 index ec9f703..0000000 --- a/knots/queue.scm +++ /dev/null @@ -1,47 +0,0 @@ -;;; 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) - (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)) diff --git a/knots/resource-pool.scm b/knots/resource-pool.scm deleted file mode 100644 index 6e9c353..0000000 --- a/knots/resource-pool.scm +++ /dev/null @@ -1,1428 +0,0 @@ -;;; 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-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-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) - (destroy-condition resource-pool-destroy-condition) - (configuration resource-pool-configuration)) - -(set-record-type-printer! - - (lambda (resource-pool port) - (display - (simple-format #f "#" - (resource-pool-name resource-pool)) - port))) - -(define (remove-at-index! lst i) - (let ((start - end - (split-at! lst i))) - (append - start - (cdr end)))) - -(define* (make-fixed-size-resource-pool resources - #:key - (delay-logger (const #f)) - (duration-logger (const #f)) - destructor - scheduler - (name "unnamed") - default-checkout-timeout - default-max-waiters) - (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) - (destructor . ,destructor) - (scheduler . ,scheduler) - (name . ,name) - (default-checkout-timeout . ,default-checkout-timeout) - (default-max-waiters . ,default-max-waiters)))) - - (define checkout-failure-count 0) - - (define (spawn-fiber-to-destroy-resource resource) - (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)) - #t))) - #:unwind? #t))) - - (if success? - (put-message channel - (list 'remove resource)) - (begin - (sleep 5) - - (loop)))))))) - - (define (spawn-fiber-for-checkout reply-channel - reply-timeout - resource) - (spawn-fiber - (lambda () - (let ((checkout-success? - (perform-operation - (choice-operation - (wrap-operation - (put-operation reply-channel - (cons 'success resource)) - (const #t)) - (wrap-operation (sleep-operation - reply-timeout) - (const #f)))))) - (unless checkout-success? - (put-message - channel - (list 'return-failed-checkout resource))))))) - - (define (destroy-loop resources) - (let loop ((resources resources)) - (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 resources)) - (((and (or 'return - 'return-failed-checkout - 'remove) - return-type) - resource) - (when (and (not (eq? return-type 'remove)) - destructor) - (spawn-fiber-to-destroy-resource resource)) - - (let ((index - (list-index (lambda (x) - (eq? x resource)) - resources))) - (let ((new-resources - (if index - (remove-at-index! resources index) - (begin - (simple-format - (current-error-port) - "resource pool error: unable to remove ~A\n" - resource) - resources)))) - (if (null? new-resources) - (begin - (signal-condition! destroy-condition) - - ;; No loop - *unspecified*) - (loop new-resources))))) - - (('stats reply timeout-time) - (let ((stats - `((resources . ,(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 resources)) - - (('destroy reply) - (loop resources)) - (unknown - (simple-format - (current-error-port) - "unrecognised message to ~A resource pool channel: ~A\n" - name - unknown) - (loop resources))))) - - (define (main-loop) - (let loop ((resources resources) - (available 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 resources - available - waiters)) - (loop resources - 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))) - - ;; 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 reply - reply-timeout - (car available)) - (loop resources - (cdr available) - waiters)) - (loop resources - available - waiters))) - (begin - (put-message reply (cons 'success - (car available))) - - (loop resources - (cdr available) - waiters))))) - - (((and (or 'return - 'return-failed-checkout) - return-type) - resource) - - (when (eq? 'return-failed-checkout - return-type) - (set! checkout-failure-count - (+ 1 checkout-failure-count))) - - (if (q-empty? waiters) - (loop resources - (cons resource available) - waiters) - - (let ((current-internal-time - (get-internal-real-time))) - (with-exception-handler - (lambda (exn) - (if (eq? (exception-kind exn) 'q-empty) - (loop resources - (cons resource available) - waiters) - (raise-exception exn))) - (lambda () - (let waiter-loop ((waiter (deq! waiters))) - (match waiter - ((reply . timeout) - (if (and timeout - (< timeout current-internal-time)) - (waiter-loop (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 reply - reply-timeout - resource)) - (put-message reply (cons 'success - resource)))))))) - #:unwind? #t) - (loop resources - available - waiters)))) - - (('list-resources reply) - (spawn-fiber - (lambda () - (put-message reply (list-copy resources)))) - - (loop resources - available - waiters)) - - (('stats reply timeout-time) - (let ((stats - `((resources . ,(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 resources - available - waiters)) - - (('destroy) - (if (and (null? resources) - (q-empty? waiters)) - (signal-condition! - destroy-condition) - - (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)) - - (if destructor - (begin - (for-each - (lambda (resource) - (spawn-fiber-to-destroy-resource resource)) - available) - (destroy-loop resources)) - (let dl ((resources resources) - (available available)) - (if (null? available) - (if (null? resources) - (signal-condition! - destroy-condition) - (destroy-loop resources)) - (let ((index - (list-index (lambda (x) - (eq? x (car available))) - resources))) - (dl (remove-at-index! resources index) - (cdr available))))))))) - - (unknown - (simple-format - (current-error-port) - "unrecognised message to ~A resource pool channel: ~A\n" - name - unknown) - (loop resources - 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 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 (const #f)) - (duration-logger (const #f)) - destructor - lifetime - scheduler - (name "unnamed") - (add-resources-parallelism 1) - default-checkout-timeout - default-max-waiters) - (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 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 - (unless (resource-pool-destroyed-error? exn) - (raise-exception exn))) - (lambda () - (with-parallelism-limiter - return-new-resource/parallelism-limiter - (let ((max-size - (assq-ref (resource-pool-configuration pool) - 'max-size)) - (size (assq-ref (resource-pool-stats pool #:timeout #f) - 'resources))) - (unless (= 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)))))) - #:unwind? #t))))) - #:unwind? #t)))) - - (define (spawn-fiber-to-destroy-resource resource) - (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)) - #t))) - #:unwind? #t))) - - (if success? - (put-message channel - (list 'remove resource)) - (begin - (sleep 5) - - (loop)))))))) - - (define (spawn-fiber-for-checkout reply-channel - reply-timeout - resource) - (spawn-fiber - (lambda () - (let ((checkout-success? - (perform-operation - (choice-operation - (wrap-operation - (put-operation reply-channel - (cons 'success resource)) - (const #t)) - (wrap-operation (sleep-operation - reply-timeout) - (const #f)))))) - (unless checkout-success? - (put-message - channel - (list 'return-failed-checkout resource))))))) - - (define (destroy-loop resources) - (let loop ((resources resources)) - (match (get-message channel) - (('add-resource resource) - (when destructor - (spawn-fiber-to-destroy-resource resource)) - - (loop resources)) - (('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 resources)) - (((and (or 'return - 'return-failed-checkout - 'remove) - return-type) - resource) - (when (and (not (eq? return-type 'remove)) - destructor) - (spawn-fiber-to-destroy-resource resource)) - - (let ((index - (list-index (lambda (x) - (eq? x resource)) - resources))) - (let ((new-resources - (if index - (remove-at-index! resources index) - (begin - (simple-format - (current-error-port) - "resource pool error: unable to remove ~A\n" - resource) - resources)))) - (if (null? new-resources) - (begin - (and=> return-new-resource/parallelism-limiter - destroy-parallelism-limiter) - - (signal-condition! destroy-condition) - - ;; No loop - *unspecified*) - (loop new-resources))))) - - (('stats reply timeout-time) - (let ((stats - `((resources . ,(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 resources)) - - (('check-for-idle-resources) - (loop resources)) - - (('destroy reply) - (loop resources)) - (unknown - (simple-format - (current-error-port) - "unrecognised message to ~A resource pool channel: ~A\n" - name - unknown) - (loop resources))))) - - (define (main-loop) - (let loop ((resources '()) - (available '()) - (waiters (make-q)) - (resources-last-used '())) - - (match (get-message channel) - (('add-resource resource) - (if (= (length resources) max-size) - (begin - (if destructor - (begin - (spawn-fiber-to-destroy-resource resource) - - (loop (cons resource resources) - available - waiters - (cons (get-internal-real-time) - resources-last-used))) - (loop resources - available - waiters - (cons (get-internal-real-time) - resources-last-used)))) - - (if (q-empty? waiters) - (loop (cons resource resources) - (cons resource available) - waiters - (cons (get-internal-real-time) - resources-last-used)) - - (let ((current-internal-time - (get-internal-real-time))) - (with-exception-handler - (lambda (exn) - (if (eq? (exception-kind exn) 'q-empty) - (loop (cons resource resources) - (cons resource available) - waiters - (cons current-internal-time - resources-last-used)) - (raise-exception exn))) - (lambda () - (let waiter-loop ((waiter (deq! waiters))) - (match waiter - ((reply . timeout) - (if (and timeout - (< timeout current-internal-time)) - (waiter-loop (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 reply - reply-timeout - resource)) - (put-message reply (cons 'success - resource)))))))) - #:unwind? #t) - (loop (cons resource resources) - available - waiters - (cons current-internal-time - resources-last-used)))))) - - (('checkout reply timeout-time max-waiters) - (if (null? available) - (begin - (unless (= (length 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 resources - available - waiters - resources-last-used)) - (loop resources - available - (enq! waiters (cons reply timeout-time)) - resources-last-used)))) - - (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))) - - ;; 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 reply - reply-timeout - (car available)) - (loop resources - (cdr available) - waiters - resources-last-used)) - (loop resources - available - waiters - resources-last-used))) - (begin - (put-message reply (cons 'success - (car available))) - - (loop resources - (cdr available) - waiters - resources-last-used))))) - - (((and (or 'return - 'return-failed-checkout) - return-type) - resource) - - (when (eq? 'return-failed-checkout - return-type) - (set! checkout-failure-count - (+ 1 checkout-failure-count))) - - (if (q-empty? waiters) - (loop resources - (cons resource available) - waiters - (begin - (list-set! - resources-last-used - (list-index (lambda (x) - (eq? x resource)) - resources) - (get-internal-real-time)) - resources-last-used)) - - (let ((current-internal-time - (get-internal-real-time))) - (with-exception-handler - (lambda (exn) - (if (eq? (exception-kind exn) 'q-empty) - (loop resources - (cons resource available) - waiters - (begin - (when (eq? return-type 'return) - (list-set! - resources-last-used - (list-index (lambda (x) - (eq? x resource)) - resources) - current-internal-time)) - resources-last-used)) - (raise-exception exn))) - (lambda () - (let waiter-loop ((waiter (deq! waiters))) - (match waiter - ((reply . timeout) - (if (and timeout - (< timeout current-internal-time)) - (waiter-loop (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 reply - reply-timeout - resource)) - (put-message reply (cons 'success - resource)))))))) - #:unwind? #t) - (loop resources - available - waiters - (begin - (list-set! - resources-last-used - (list-index (lambda (x) - (eq? x resource)) - resources) - current-internal-time) - resources-last-used))))) - - (('remove resource) - (let ((index - (list-index (lambda (x) - (eq? x resource)) - resources))) - (loop (if index - (remove-at-index! resources index) - (begin - (simple-format - (current-error-port) - "resource pool error: unable to remove ~A\n" - resource) - resources)) - available ; resource shouldn't be in this list - waiters - (remove-at-index! - resources-last-used - index)))) - - (('destroy resource) - (spawn-fiber-to-destroy-resource resource) - - (loop resources - available - waiters - resources-last-used)) - - (('list-resources reply) - (spawn-fiber - (lambda () - (put-message reply (list-copy resources)))) - - (loop resources - available - waiters - resources-last-used)) - - (('stats reply timeout-time) - (let ((stats - `((resources . ,(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 resources - available - waiters - resources-last-used)) - - (('check-for-idle-resources) - (let* ((resources-last-used-seconds - (map - (lambda (internal-time) - (/ (- (get-internal-real-time) internal-time) - internal-time-units-per-second)) - resources-last-used)) - (candidate-resources-to-destroy - (filter-map - (lambda (resource last-used-seconds) - (if (and (member resource available) - (> last-used-seconds idle-seconds)) - resource - #f)) - resources - resources-last-used-seconds))) - - (let* ((available-resources-to-destroy - (lset-intersection eq? - available - candidate-resources-to-destroy)) - (max-resources-to-destroy - (max 0 - (- (length resources) - min-size))) - (resources-to-destroy - (take available-resources-to-destroy - (min max-resources-to-destroy - (length available-resources-to-destroy))))) - (when destructor - (for-each - (lambda (resource) - (spawn-fiber-to-destroy-resource resource)) - resources-to-destroy)) - - (loop resources - (lset-difference eq? available resources-to-destroy) - waiters - resources-last-used)))) - - (('destroy) - (if (and (null? resources) - (q-empty? waiters)) - (signal-condition! - destroy-condition) - - (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)) - - (if destructor - (begin - (for-each - (lambda (resource) - (spawn-fiber-to-destroy-resource resource)) - available) - (destroy-loop resources)) - (let dl ((resources resources) - (available available)) - (if (null? available) - (if (null? resources) - (signal-condition! - destroy-condition) - (destroy-loop resources)) - (let ((index - (list-index (lambda (x) - (eq? x (car available))) - resources))) - (dl (remove-at-index! resources index) - (cdr available))))))))) - (unknown - (simple-format - (current-error-port) - "unrecognised message to ~A resource pool channel: ~A\n" - name - unknown) - (loop resources - available - waiters - resources-last-used))))) - - (spawn-fiber - (lambda () - (when idle-seconds - (spawn-fiber - (lambda () - (while #t - (sleep idle-seconds) - (put-message channel '(check-for-idle-resources)))))) - - (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 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) - (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))) - -(define make-resource-pool-timeout-error - (record-constructor &resource-pool-timeout)) - -(define resource-pool-timeout-error? - (exception-predicate &resource-pool-timeout)) - -(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))) - -(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))) - -(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)) - -(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))) - -(define make-resource-pool-destroyed-error - (record-constructor &resource-pool-destroyed)) - -(define resource-pool-destroyed-error? - (exception-predicate &resource-pool-destroyed)) - -(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)) - -(define resource-pool-destroy-resource-exception? - (exception-predicate &resource-pool-destroy-resource)) - -(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)) - "Call PROC with a resource from POOL, blocking until a resource becomes -available. Return the resource once PROC has returned." - - (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)) - - (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) - (call-with-values - (lambda () - (with-exception-handler - (lambda (exn) - ;; Unwind the stack before calling put-message, as - ;; this avoids inconsistent behaviour with - ;; continuation barriers - (put-message - (resource-pool-channel pool) - (list (if (or destroy-resource-on-exception? - (resource-pool-destroy-resource-exception? exn)) - 'destroy - 'return) - resource)) - (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)))) - #:unwind? #t)) - (lambda vals - (put-message (resource-pool-channel pool) - `(return ,resource)) - (apply values vals))))))) - -(define-syntax-rule (with-resource-from-pool pool resource exp ...) - (call-with-resource-from-pool - pool - (lambda (resource) exp ...))) - -(define* (resource-pool-stats pool #:key (timeout 5)) - (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 (resource-pool-channel pool) - `(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 (resource-pool-channel pool) - `(stats ,reply #f)) - (get-message reply)))) - -(define (resource-pool-list-resources pool) - (let ((reply (make-channel))) - (put-message (resource-pool-channel pool) - (list 'list-resources reply)) - (get-message reply))) diff --git a/knots/thread-pool.scm b/knots/thread-pool.scm deleted file mode 100644 index 70d7292..0000000 --- a/knots/thread-pool.scm +++ /dev/null @@ -1,524 +0,0 @@ -;;; 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 - - 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)) - -(define-record-type - (fixed-size-thread-pool channel arguments-parameter current-procedures - default-checkout-timeout) - 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)) - -;; Since both thread pool records have this field, use a procedure -;; than handles the appropriate accessor -(define (thread-pool-arguments-parameter pool) - (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) - (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-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))) - -(define thread-pool-timeout-error? - (exception-predicate &thread-pool-timeout-error)) - -(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) - (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 channel args) - (let loop () - (match (get-message channel) - ('destroy #f) - ((reply sent-time proc) - (when delay-logger - (let ((time-delay - (- (get-internal-real-time) - sent-time))) - (delay-logger (/ time-delay - internal-time-units-per-second) - 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 () - (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))) - - (put-message reply - response) - - (let ((exception? - (match response - (('thread-pool-error duration _) - (when duration-logger - (duration-logger duration proc)) - #t) - ((duration . _) - (when duration-logger - (duration-logger duration proc)) - #f)))) - (if (and exception? - expire-on-exception?) - #t - (loop)))))))) - - (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 channel args))) - #:unwind? #t))) - - (when thread-destructor - (destructor/safe args)) - - (when continue? - (init (if thread-initializer - (initializer/safe) - '())))))))) - - (for-each - (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)) - -(define* (make-thread-pool max-size - #:key - (min-size max-size) - scheduler - thread-initializer - thread-destructor - (delay-logger (lambda _ #f)) - (duration-logger (const #f)) - thread-lifetime - (expire-on-exception? #f) - (name "unnamed") - (use-default-io-waiters? #t) - default-checkout-timeout) - "Return a channel used to offload work to a dedicated thread. ARGS are the -arguments of the thread pool procedure." - (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 - #:thread-lifetime thread-lifetime - #: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 - #:scheduler scheduler - #:duration-logger duration-logger - #:default-checkout-timeout default-checkout-timeout))) - - (thread-pool resource-pool - param))) - -(define* (call-with-thread thread-pool - proc - #:key - duration-logger - checkout-timeout - channel - destroy-thread-on-exception? - (max-waiters 'default)) - "Send PROC to the thread pool through CHANNEL. Return the result of PROC. -If already in the thread pool, call PROC immediately." - (define (handle-proc fixed-size-thread-pool - reply-channel - start-time - timeout) - (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 - start-time - 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))) - - (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) - (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) - (raise-exception - (make-thread-pool-timeout-error thread-pool)))) - (handle-proc fixed-size-thread-pool - reply-channel - start-time - #f))) - #:max-waiters max-waiters - #:timeout checkout-timeout - #:destroy-resource-on-exception? - destroy-thread-on-exception?)))))))) - -(define (destroy-thread-pool pool) - (if (fixed-size-thread-pool? pool) - (put-message - (fixed-size-thread-pool-channel pool) - 'destroy) - (destroy-resource-pool - (thread-pool-resource-pool pool)))) diff --git a/knots/timeout.scm b/knots/timeout.scm deleted file mode 100644 index a65a095..0000000 --- a/knots/timeout.scm +++ /dev/null @@ -1,203 +0,0 @@ -;;; 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) - (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)) - -(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)) - -(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)) - -(define (readable? port) - "Test if PORT is writable." - (= 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)) - (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))) diff --git a/knots/web-server.scm b/knots/web-server.scm deleted file mode 100644 index 4d7240b..0000000 --- a/knots/web-server.scm +++ /dev/null @@ -1,588 +0,0 @@ -;;; 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)) - -(define (request-body-port/knots r) - (cond - ((member '(chunked) (request-transfer-encoding r)) - (make-chunked-input-port (request-port r) - #:keep-alive? #t)) - (else - (let ((content-length - (request-content-length r))) - (make-delimited-input-port - (request-port r) - content-length - (lambda (bytes-read) - (raise-exception - (make-request-body-ended-prematurely-error bytes-read)))))))) - -(define (read-request-body/knots r) - (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)) - ((not body) - (values response #vu8())) - ((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))) - (raise-exception - (make-exception-with-irritants - (list (make-exception-with-message - "unexpected body type") - body)))) - ((and (response-must-not-include-body? response) - body - ;; FIXME make this stricter: even an empty body should be prohibited. - (not (zero? (bytevector-length 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 - (if (procedure? body) - (if (response-content-length response) - response - (extend-response response - 'transfer-encoding - '((chunked)))) - (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)))))) - (if (eq? (request-method request) 'HEAD) - (raise-exception - (make-exception-with-irritants - (list (make-exception-with-message - "unexpected body type") - body))) - 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 "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) - (if (and (exception-with-origin? exn) - (string=? (exception-origin exn) - "fport_write")) - (simple-format - (current-error-port) - "~A ~A: error replying to client\n" - (request-method request) - (uri-path (request-uri request))) - (simple-format - (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 (exception-handler exn request) - (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 error-string - (current-error-port))) - - (values (build-response #:code 500) - ;; TODO Make this configurable - (string->utf8 - "internal server error"))) - -(define* (handle-request handler client - read-request-exception-handler - write-response-exception-handler - buffer-size - #:key post-request-hook) - (let ((request - (with-exception-handler - read-request-exception-handler - (lambda () - (read-request client)) - #: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 - (call-with-escape-continuation - (lambda (return) - (with-exception-handler - (lambda (exn) - (call-with-values - (lambda () - (exception-handler exn request)) - (lambda (response body) - (call-with-values - (lambda () - (sanitize-response request response body)) - return)))) - (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))))))))))))))) - (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? - (if (procedure? body) - (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?)) - (begin - (put-bytevector client body) - #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 - 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 web-server, exception in client loop:\n" - (current-error-port)) - (print-exception - (current-error-port) - #f - '%exception - (list exn))) - #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 - 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)) - -(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 () - (let loop () - (match (accept socket (logior SOCK_NONBLOCK SOCK_CLOEXEC)) - ((client . sockaddr) - (spawn-fiber (lambda () - (client-loop client handler - read-request-exception-handler - write-response-exception-handler - connection-idle-timeout - connection-buffer-size - (post-request-hook/safe - post-request-hook))) - #:parallel? #t) - (loop)))))) - - (make-web-server socket - (vector-ref (getsockname socket) - 2))) ; Not sure what this structure is diff --git a/pre-inst-env.in b/pre-inst-env.in deleted file mode 100644 index ebf1a05..0000000 --- a/pre-inst-env.in +++ /dev/null @@ -1,13 +0,0 @@ -#!/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 "$@" diff --git a/test-env.in b/test-env.in deleted file mode 100644 index 694f93d..0000000 --- a/test-env.in +++ /dev/null @@ -1,13 +0,0 @@ -#!/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 "$@" diff --git a/tests.scm b/tests.scm deleted file mode 100644 index 0cca3b4..0000000 --- a/tests.scm +++ /dev/null @@ -1,33 +0,0 @@ -(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)) diff --git a/tests/non-blocking.scm b/tests/non-blocking.scm deleted file mode 100644 index 25efee8..0000000 --- a/tests/non-blocking.scm +++ /dev/null @@ -1,31 +0,0 @@ -(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") diff --git a/tests/parallelism.scm b/tests/parallelism.scm deleted file mode 100644 index 91b2f3d..0000000 --- a/tests/parallelism.scm +++ /dev/null @@ -1,144 +0,0 @@ -(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") diff --git a/tests/promise.scm b/tests/promise.scm deleted file mode 100644 index 1c0e235..0000000 --- a/tests/promise.scm +++ /dev/null @@ -1,28 +0,0 @@ -(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") diff --git a/tests/queue.scm b/tests/queue.scm deleted file mode 100644 index c80e5fd..0000000 --- a/tests/queue.scm +++ /dev/null @@ -1,22 +0,0 @@ -(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") diff --git a/tests/resource-pool.scm b/tests/resource-pool.scm deleted file mode 100644 index 461d04b..0000000 --- a/tests/resource-pool.scm +++ /dev/null @@ -1,214 +0,0 @@ -(use-modules (tests) - (fibers) - (unit-test) - (knots parallelism) - (knots resource-pool)) - -(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)))) - -(display "resource-pool test finished successfully\n") diff --git a/tests/thread-pool.scm b/tests/thread-pool.scm deleted file mode 100644 index 1c51cb3..0000000 --- a/tests/thread-pool.scm +++ /dev/null @@ -1,88 +0,0 @@ -(use-modules (tests) - (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))))) - -(display "thread-pool test finished successfully\n") diff --git a/tests/timeout.scm b/tests/timeout.scm deleted file mode 100644 index bab39d2..0000000 --- a/tests/timeout.scm +++ /dev/null @@ -1,22 +0,0 @@ -(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") diff --git a/tests/web-server.scm b/tests/web-server.scm deleted file mode 100644 index e456bf3..0000000 --- a/tests/web-server.scm +++ /dev/null @@ -1,236 +0,0 @@ -(use-modules (srfi srfi-71) - (rnrs bytevectors) - (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)))) - -(display "web-server test finished successfully\n")