diff --git a/.dir-locals.el b/.dir-locals.el deleted file mode 100644 index 4c877b6..0000000 --- a/.dir-locals.el +++ /dev/null @@ -1,23 +0,0 @@ -((scheme-mode - ;; Safsaf forms - (eval . (put 'route-group 'scheme-indent-function 1)) - (eval . (put 'wrap-routes 'scheme-indent-function 1)) - - ;; Safsaf test framework - (eval . (put 'test 'scheme-indent-function 1)) - (eval . (put 'suite 'scheme-indent-function 1)) - (eval . (put 'define-suite 'scheme-indent-function 1)) - - ;; Guile / SRFI - (eval . (put 'parameterize 'scheme-indent-function 1)) - (eval . (put 'with-exception-handler 'scheme-indent-function 2)) - (eval . (put 'call-with-output-string 'scheme-indent-function 0)) - (eval . (put 'call-with-port 'scheme-indent-function 1)) - (eval . (put 'syntax-case 'scheme-indent-function 2)) - - ;; Knots / Fibers - (eval . (put 'run-fibers 'scheme-indent-function 0)) - (eval . (put 'call-with-sigint 'scheme-indent-function 0)) - (eval . (put 'with-resource-from-pool 'scheme-indent-function 2)) - (eval . (put 'fibers-let 'scheme-indent-function 1)) - (eval . (put 'with-fibers-timeout 'scheme-indent-function 1)))) diff --git a/.forgejo/workflows/build-website.yaml b/.forgejo/workflows/build-website.yaml deleted file mode 100644 index e4e7416..0000000 --- a/.forgejo/workflows/build-website.yaml +++ /dev/null @@ -1,29 +0,0 @@ -on: - push: - branches: - - trunk -jobs: - test: - runs-on: host - steps: - - run: git clone --depth=1 https://$FORGEJO_TOKEN@forge.cbaines.net/cbaines/safsaf.git safsaf-trunk - - run: git clone --depth=1 https://$FORGEJO_TOKEN@forge.cbaines.net/cbaines/safsaf.git --branch=pages safsaf-pages - - run: | - cd safsaf-trunk - guix shell -D -f guix-dev.scm -- ./bootstrap.sh - guix shell -D -f guix-dev.scm -- ./configure - guix shell -D -f guix-dev.scm -- make -C doc index.html - - - run: | - cd safsaf-pages - cp ../safsaf-trunk/doc/index.html . - cp ../safsaf-trunk/doc/logo.svg . - 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 bd8864d..0000000 --- a/.gitignore +++ /dev/null @@ -1,28 +0,0 @@ -# Autotools generated files -/aclocal.m4 -/autom4te.cache/ -/build-aux/* -!/build-aux/news-to-texi.scm -/configure -/Makefile -/Makefile.in -/config.log -/config.status -/pre-inst-env -/doc/Makefile -/doc/Makefile.in - -# Compiled Guile files -*.go - -# Test output -*.log -*.trs - -# Generated documentation -/doc/api/ -/doc/*.html -/doc/*.info -/doc/stamp-vti -/doc/version.texi -/doc/version-history.texi diff --git a/AUTHORS b/AUTHORS deleted file mode 100644 index 39a9743..0000000 --- a/AUTHORS +++ /dev/null @@ -1,3 +0,0 @@ -Safsaf was written by: - - Christopher Baines diff --git a/CLAUDE.md b/CLAUDE.md deleted file mode 100644 index 52618c5..0000000 --- a/CLAUDE.md +++ /dev/null @@ -1,88 +0,0 @@ -# CLAUDE.md - -This file provides guidance to Claude Code (claude.ai/code) when working with code in this repository. - -## Project Overview - -Safsaf is a web framework for Guile Scheme, built on Guile Fibers -using the Guile Knots web server. - -## Environment Setup - -The project uses `direnv` with Guix. The `.envrc` runs `use guix -D -f guix-dev.scm`, which pulls in all dependencies: `guile-knots`, `guile-webutils`, `guile-lib`, `guile-json-4`, `guile-squee`, `guile-sqlite3`, `guile-gcrypt`. - -Run `direnv allow` to activate the environment. All Guile dependencies are on `GUILE_LOAD_PATH` via the Guix profile. - -## Key Dependencies - -### Guile Knots -- `(knots web-server)` — `run-knots-web-server`: the HTTP server. Handler signature is `(request body-port) → (values response body)`. `body-port` is the port for reading the request body lazily. -- `(knots resource-pool)` — `with-resource-from-pool`: DB/resource connection pooling. -- `(knots parallelism)` — `fibers-let`, `fibers-parallel`, `fibers-map`: concurrent work in handlers. -- `(knots thread-pool)` — `call-with-thread`: offload blocking/CPU-bound work. -- `(knots timeout)` — `with-fibers-timeout`, `with-port-timeouts`: request and I/O timeouts. -- `(knots web)` — `call-with-connection-cache`: outbound HTTP with connection pooling. -- `(knots)` — `call-with-sigint`, `format/knots`, `spawn-fiber/knots`. -- `(knots web-server)` also exports `make-chunked-output-port/knots`, `sanitize-response`, `request-body-port/knots`, `read-request-body/knots`. - -### Guile Webutils -- `(webutils multipart)` — `parse-request-body`, `` record, `parts-ref`, `parts-ref-string`. -- `(webutils cookie)` — `set-cookie`, `delete-cookie`. Registers `Cookie`/`Set-Cookie` header parsers with `(web http)`. -- `(webutils sessions)` — ``, HMAC-signed cookie sessions. Format: `signature$expires$base64-data`. -- `(webutils date)` — RFC3339 and HTTP date conversions. - -### Guile JSON (v4.7.3) -- `(json)` — Re-exports everything from parser, builder, and record modules. -- `(json parser)` — `json->scm` (from port), `json-string->scm` (from string). Options: `#:null` (default `'null`), `#:ordered` (preserve key order). -- `(json builder)` — `scm->json` (to port), `scm->json-string` (to string). Options: `#:pretty`, `#:unicode`, `#:validate`. -- `(json record)` — `define-json-mapping`: bidirectional SRFI-9 record ↔ JSON conversion. -- Data mapping: objects ↔ alists, arrays ↔ vectors, strings ↔ strings, numbers ↔ numbers, `true`/`false` ↔ `#t`/`#f`, `null` ↔ `'null`. - -### Guile Gcrypt -- `(gcrypt random)` — cryptographic random bytes (used for CSRF token generation). - -### Guile Lib -- `(htmlprag)` — HTML/SHTML parsing and generation. `html->shtml`: parse HTML to SXML. `shtml->html`: render SXML to HTML string. `write-shtml-as-html`: write SXML to port. -- `(logging logger)` — Logging framework. `(logging port-log)` — log to ports. `(logging rotating-log)` — rotating file logs. -- `(md5)` — MD5 hashing. -- `(container async-queue)` — `make-async-queue`, `async-enqueue!`, `async-dequeue!`. -- `(string transform)`, `(string wrap)`, `(string completion)` — String utilities. - -### Guile Standard Library -- `(web request)`, `(web response)`, `(web uri)`, `(web http)` — Guile's built-in HTTP types. -- `(srfi srfi-9)` — Record types. `(srfi srfi-64)` — Test framework. `(srfi srfi-71)` — Extended `let` with multiple values; prefer over `(srfi srfi-11)` `let-values`. - -## Architecture - -Handler signature throughout is `(request body-port) → (values response body)`, using Guile's `` directly. `body-port` is the port for reading the request body lazily. Context is threaded via Guile parameters, not a wrapper record. - -Safsaf wraps `run-knots-web-server` with: - -1. **Parameters for context** — `current-route-params` (alist of matched route bindings), `current-reverse-routes` (for `path-for`). Handler wrappers add their own parameters (e.g. `current-csrf-token`, `current-session`). -2. **Router** — data-driven route table using `(route method pattern handler)`. Patterns are lists of segments: strings (literal match), symbols (capture), or `(predicate name)` pairs. Dotted-tail patterns (e.g. `'("api" . rest)`) capture remaining segments. Routes can be organized with `(route-group prefix ...)`. Named routes support reverse routing via `path-for`. -3. **Handler wrappers** — convention: `(foo-handler-wrapper handler) → handler'`. A handler wrapper transforms the request on the way in and the response/body on the way out. Wrappers that need configuration provide a `(make-foo-handler-wrapper ...)` constructor. Applied to route trees via `wrap-routes`, which accepts one or more wrappers. -4. **Entry point** — `(run-safsaf routes #:key host port method-not-allowed? method-not-allowed-handler connection-buffer-size)` compiles the route table, builds the dispatch handler, and starts the HTTP server via `run-knots-web-server`. When called outside a Fibers scheduler, it wraps everything in `run-fibers` and blocks until Ctrl-C. When called inside an existing scheduler (e.g. within `run-fibers`), it just starts the server and returns immediately. `method-not-allowed?` defaults to `#t`, enabling automatic 405 responses. Handler wrappers are applied to routes via `wrap-routes` before passing to `run-safsaf`. - -## Finding Guile Library Sources - -To read source code for Guile dependencies, look them up via `GUILE_LOAD_PATH`. The first entry is the project's Guix profile directory containing all dependencies. Do **not** search `/gnu/store` directly — it is slow and noisy. - -A Guile module path like `(knots web-server)` maps to the file `knots/web-server.scm` under a load path directory. To find it: - -``` -ls "$GUILE_LOAD_PATH" | head # see what's available -cat "$(echo $GUILE_LOAD_PATH | cut -d: -f1)/knots/web-server.scm" # read a specific module -``` - -Or use the Read/Glob tools directly against the first `GUILE_LOAD_PATH` entry (e.g. `/gnu/store/...-profile/share/guile/site/3.0/`). Module path segments map to directories, with the final segment as `.scm`. For example: - -- `(json parser)` → `json/parser.scm` -- `(webutils multipart)` → `webutils/multipart.scm` -- `(srfi srfi-9)` → `srfi/srfi-9.scm` - -## Guile Conventions - -- Predicates end with `?`. Setters use `set-` prefix. Constructors use `make-`. -- Records defined with `define-record-type` from `(srfi srfi-9)`. -- Modules use `define-module` with `#:use-module` and `#:export`. -- Use `values` for multiple return values, `call-with-values` or `receive` to consume them. diff --git a/COPYING b/COPYING deleted file mode 100644 index f288702..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/COPYING.LESSER b/COPYING.LESSER deleted file mode 100644 index 0a04128..0000000 --- a/COPYING.LESSER +++ /dev/null @@ -1,165 +0,0 @@ - GNU LESSER 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. - - - This version of the GNU Lesser General Public License incorporates -the terms and conditions of version 3 of the GNU General Public -License, supplemented by the additional permissions listed below. - - 0. Additional Definitions. - - As used herein, "this License" refers to version 3 of the GNU Lesser -General Public License, and the "GNU GPL" refers to version 3 of the GNU -General Public License. - - "The Library" refers to a covered work governed by this License, -other than an Application or a Combined Work as defined below. - - An "Application" is any work that makes use of an interface provided -by the Library, but which is not otherwise based on the Library. -Defining a subclass of a class defined by the Library is deemed a mode -of using an interface provided by the Library. - - A "Combined Work" is a work produced by combining or linking an -Application with the Library. The particular version of the Library -with which the Combined Work was made is also called the "Linked -Version". - - The "Minimal Corresponding Source" for a Combined Work means the -Corresponding Source for the Combined Work, excluding any source code -for portions of the Combined Work that, considered in isolation, are -based on the Application, and not on the Linked Version. - - The "Corresponding Application Code" for a Combined Work means the -object code and/or source code for the Application, including any data -and utility programs needed for reproducing the Combined Work from the -Application, but excluding the System Libraries of the Combined Work. - - 1. Exception to Section 3 of the GNU GPL. - - You may convey a covered work under sections 3 and 4 of this License -without being bound by section 3 of the GNU GPL. - - 2. Conveying Modified Versions. - - If you modify a copy of the Library, and, in your modifications, a -facility refers to a function or data to be supplied by an Application -that uses the facility (other than as an argument passed when the -facility is invoked), then you may convey a copy of the modified -version: - - a) under this License, provided that you make a good faith effort to - ensure that, in the event an Application does not supply the - function or data, the facility still operates, and performs - whatever part of its purpose remains meaningful, or - - b) under the GNU GPL, with none of the additional permissions of - this License applicable to that copy. - - 3. Object Code Incorporating Material from Library Header Files. - - The object code form of an Application may incorporate material from -a header file that is part of the Library. You may convey such object -code under terms of your choice, provided that, if the incorporated -material is not limited to numerical parameters, data structure -layouts and accessors, or small macros, inline functions and templates -(ten or fewer lines in length), you do both of the following: - - a) Give prominent notice with each copy of the object code that the - Library is used in it and that the Library and its use are - covered by this License. - - b) Accompany the object code with a copy of the GNU GPL and this license - document. - - 4. Combined Works. - - You may convey a Combined Work under terms of your choice that, -taken together, effectively do not restrict modification of the -portions of the Library contained in the Combined Work and reverse -engineering for debugging such modifications, if you also do each of -the following: - - a) Give prominent notice with each copy of the Combined Work that - the Library is used in it and that the Library and its use are - covered by this License. - - b) Accompany the Combined Work with a copy of the GNU GPL and this license - document. - - c) For a Combined Work that displays copyright notices during - execution, include the copyright notice for the Library among - these notices, as well as a reference directing the user to the - copies of the GNU GPL and this license document. - - d) Do one of the following: - - 0) Convey the Minimal Corresponding Source under the terms of this - License, and the Corresponding Application Code in a form - suitable for, and under terms that permit, the user to - recombine or relink the Application with a modified version of - the Linked Version to produce a modified Combined Work, in the - manner specified by section 6 of the GNU GPL for conveying - Corresponding Source. - - 1) Use a suitable shared library mechanism for linking with the - Library. A suitable mechanism is one that (a) uses at run time - a copy of the Library already present on the user's computer - system, and (b) will operate properly with a modified version - of the Library that is interface-compatible with the Linked - Version. - - e) Provide Installation Information, but only if you would otherwise - be required to provide such information under section 6 of the - GNU GPL, and only to the extent that such information is - necessary to install and execute a modified version of the - Combined Work produced by recombining or relinking the - Application with a modified version of the Linked Version. (If - you use option 4d0, the Installation Information must accompany - the Minimal Corresponding Source and Corresponding Application - Code. If you use option 4d1, you must provide the Installation - Information in the manner specified by section 6 of the GNU GPL - for conveying Corresponding Source.) - - 5. Combined Libraries. - - You may place library facilities that are a work based on the -Library side by side in a single library together with other library -facilities that are not Applications and are not covered by this -License, and convey such a combined library under terms of your -choice, if you do both of the following: - - a) Accompany the combined library with a copy of the same work based - on the Library, uncombined with any other library facilities, - conveyed under the terms of this License. - - b) Give prominent notice with the combined library that part of it - is a work based on the Library, and explaining where to find the - accompanying uncombined form of the same work. - - 6. Revised Versions of the GNU Lesser General Public License. - - The Free Software Foundation may publish revised and/or new versions -of the GNU Lesser 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 -Library as you received it specifies that a certain numbered version -of the GNU Lesser General Public License "or any later version" -applies to it, you have the option of following the terms and -conditions either of that published version or of any later version -published by the Free Software Foundation. If the Library as you -received it does not specify a version number of the GNU Lesser -General Public License, you may choose any version of the GNU Lesser -General Public License ever published by the Free Software Foundation. - - If the Library as you received it specifies that a proxy can decide -whether future versions of the GNU Lesser General Public License shall -apply, that proxy's public statement of acceptance of any version is -permanent authorization for you to choose that version for the -Library. diff --git a/Makefile.am b/Makefile.am deleted file mode 100644 index 5a7c166..0000000 --- a/Makefile.am +++ /dev/null @@ -1,81 +0,0 @@ -# Safsaf, a Guile web framework -# Copyright (C) 2026 Christopher Baines -# -# This program 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 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 -# 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 -# . - -include guile.am - -SOURCES = \ - safsaf.scm \ - safsaf/utils.scm \ - safsaf/templating.scm \ - safsaf/response-helpers.scm \ - safsaf/params.scm \ - safsaf/handler-wrappers/logging.scm \ - safsaf/handler-wrappers/security-headers.scm \ - safsaf/handler-wrappers/cors.scm \ - safsaf/handler-wrappers/csrf.scm \ - safsaf/handler-wrappers/exceptions.scm \ - safsaf/handler-wrappers/sessions.scm \ - safsaf/handler-wrappers/trailing-slash.scm \ - safsaf/handler-wrappers/max-body-size.scm \ - safsaf/router.scm - -SUBDIRS = doc - -TEST_EXTENSIONS = .scm -SCM_LOG_COMPILER = $(top_builddir)/pre-inst-env $(GUILE) -TESTS = \ - tests/test-router.scm \ - tests/test-csrf-validation.scm \ - tests/test-handler-wrappers.scm \ - tests/test-params.scm \ - tests/test-response-helpers.scm \ - tests/test-templating.scm \ - tests/test-utils.scm \ - tests/test-exceptions.scm \ - tests/test-integration.scm - -EXTRA_DIST += \ - AUTHORS \ - NEWS \ - README.md \ - VERSION \ - COPYING.LESSER \ - bootstrap.sh \ - build-aux/news-to-texi.scm \ - pre-inst-env.in \ - tests/support.scm \ - $(TESTS) \ - examples/blog-site/README \ - examples/blog-site/blog-site.scm \ - examples/blog-site/model.scm \ - examples/blog-site/views.scm \ - examples/blog-site/static/style.css \ - examples/paste-bin/paste-bin.scm - -format: - @for f in $(SOURCES) $(TESTS) tests/support.scm; do \ - echo "Formatting $$f"; \ - emacs --batch \ - --eval '(setq enable-local-variables :all)' \ - --eval '(setq backup-inhibited t)' \ - --visit "$$f" \ - --eval '(indent-region (point-min) (point-max))' \ - --eval '(delete-trailing-whitespace)' \ - --eval '(save-buffer)'; \ - done - -.PHONY: format diff --git a/NEWS b/NEWS deleted file mode 100644 index fcbf9a5..0000000 --- a/NEWS +++ /dev/null @@ -1,8 +0,0 @@ -Safsaf NEWS - -Version 0.1 - - * Initial release. - * Built on the code of the Guix Data Serivce, plus other web - services like the Guix Build Coordinator and Nar Herder. - * Written using Claude Opus 4.6 using Claude Code. diff --git a/README.md b/README.md deleted file mode 100644 index 13bd389..0000000 --- a/README.md +++ /dev/null @@ -1,80 +0,0 @@ -# Safsaf - -

- Safsaf -

- -A web framework for [GNU Guile](https://www.gnu.org/software/guile/), -using [Guile Fibers](https://codeberg.org/guile/fibers) and the [Guile -Knots](https://cbaines.codeberg.page/guile-knots/) web server. - -Developed based off of the Guix Data Service and Nar Herder codebases, -written using Claude Code running Claude Opus 4.6. - -## Quick Example - -```scheme -(use-modules (safsaf) - (safsaf router) - (safsaf response-helpers)) - -(define routes - (list - (route 'GET '() (lambda (request body-port) - (text-response "Hello, world!"))) - (route '* '* (lambda (request body-port) - (not-found-response))))) - -(run-safsaf routes #:port 8080) -``` - -## Design - -Safsaf aims for functional over imperitive configuration and to be -minimal but very extensible. - -Suspendable ports in Guile plus Guile Fibers is used both for Safsaf -internals, but should also be used for user applications where -possible and suitable. - -## Features - -- **Request router** with parameterised segments, wildcards, nested - groups, and reverse routing (`path-for`) -- **Handler wrappers** (middleware) applied per-route or per-group via - `wrap-routes` -- **Included handler wrappers**: logging, CORS, CSRF protection, - sessions (signed cookies), security headers, trailing-slash - normalization, exception handling -- **Request helpers**: form body parsing, multipart parsing, query - strings, cookies -- **Response helpers**: HTML/SXML, JSON, redirects, plain text, static - files with `Last-Modified` / `Cache-Control` -- **Parameter parsing**: declarative param specs with built-in - processors, CSRF integration, and error inspection - -### Wishlist - -- Internationalization support -- Server sent events (SSE) support -- WebSockets support - -## Other Guile web frameworks - -- **GNU Artanis** https://artanis.dev/ -- **schingle** https://github.com/petelliott/schingle - -## Dependencies - -- GNU Guile 3.0+ -- [Guile Knots](https://forge.cbaines.net/cbaines/guile-knots) (web server, resource pools) -- Guile Webutils (multipart, cookies, sessions) -- [Guile JSON](https://github.com/aconchillo/guile-json) 4.x -- [Guile Lib](https://www.nongnu.org/guile-lib/) (htmlprag, logging) - -A Guix development environment is provided via `guix-dev.scm` and -`.envrc` (direnv). - -## License - -LGPL-3.0-or-later diff --git a/STYLE.md b/STYLE.md deleted file mode 100644 index a9bd0f7..0000000 --- a/STYLE.md +++ /dev/null @@ -1,187 +0,0 @@ -# Guile Style Guide for Safsaf - -This guide draws on -[Riastradh's Lisp Style Rules](https://mumble.net/~campbell/scheme/style.txt), -the [Guix Coding Style](https://guix.gnu.org/manual/1.5.0/en/html_node/Coding-Style.html). - ---- - -## Formatting - -### Indentation - -Use **2-space indentation**, no tabs. When a subform follows the -operator on the same line, align subsequent subforms to that column. -When the first subform is on the next line, align it with the operator. -Special forms (`define`, `let`, `lambda`, `if`, `cond`, `match`, etc.) -follow standard Scheme indentation. - -### Line Length - -Do not exceed **80 columns**. - -### Parentheses - -Never place closing parentheses on their own line. Do not put spaces -after opening parentheses or before closing ones. - -### Blank Lines - -Separate top-level forms with a single blank line. Do not place blank -lines in procedure bodies except to separate internal definitions from -the body. - -### Square Brackets - -Do not use square brackets. They are non-standard and non-portable. - - -## Naming - -Write names with **English words separated by hyphens**. No underscores, -camelCase, or abbreviations. - -- **`?` (predicates):** Boolean-returning questions. E.g., `route?`, - `logged-in?`. -- **`!` (mutation):** Procedures whose primary purpose is destructive - update. E.g., `set-route-handler!`. Do not append to every procedure - with side effects. -- **`%` (private):** Module-private bindings. E.g., `%make-route`, - `%email-rx`. -- **`*` (variants):** Variations on a theme (`let*`, `define*`). - -### Records - -```scheme -(define-record-type - (%make-route method pattern handler name) ; internal constructor - route? ; predicate - (method route-method) ; accessor - (handler route-handler set-route-handler!)) ; accessor + setter -``` - -- `make-foo` for public constructors, `%make-foo` for raw constructors. -- `foo?` for predicates, `foo-field` for accessors, `set-foo-field!` - for setters. - -### Parameters and Dynamic State - -- Guile parameters use the **`current-`** prefix: `current-session`, - `current-csrf-token`. -- **`with-`** establishes dynamic state and calls a thunk. -- **`call-with-`** calls a procedure with arguments, managing resources - or continuations. - -### Local Variables - -Use meaningful names. Single-letter names only for unambiguous index -variables in tight loops. - - -## Comments - -```scheme -;;;; file-heading.scm — File Heading - -;;; -;;; Section Heading -;;; - -;;; Top-level explanatory comment. - -(define (fnord zarquon) - ;; Fragment comment before code. - (quux zot mumble ;margin note - frotz)) -``` - -- **`;;;;`** — File headings. -- **`;;;`** — Section headings (use the sandwich: `;;;` / `;;; Title` / - `;;;`) and top-level explanations. -- **`;;`** — Fragment comments, before the code they describe. -- **`;`** — Margin comments, after code on the same line. - -Write comments only where the code cannot explain itself. - - -## Docstrings - -All public procedures must carry a docstring. Place it as the first -expression after the parameter list. Describe what the procedure does, -its parameters, and return values: - -```scheme -(define* (route method pattern handler #:key (name #f)) - "Create a route. METHOD is a symbol, list of symbols, or '* for any. -HANDLER is a procedure (request body-port) -> (values response body). -NAME is an optional symbol used for reverse routing with path-for." - ...) -``` - -For parameters, use `set-procedure-property!` with `'documentation`. - - -## Module Definitions - -Use `define-module` with `#:use-module` and `#:export`. Group imports: - -1. **Standard library** — `(ice-9 ...)`, `(web ...)` -2. **SRFIs** — `(srfi srfi-1)`, `(srfi srfi-9)`, etc. -3. **External dependencies** — `(knots ...)`, `(webutils ...)`, `(json ...)` -4. **Internal modules** — `(safsaf ...)` - -Prefer `#:use-module`; use `#:autoload` for heavy or circular deps. -Standalone scripts may use `use-modules` instead of `define-module`. - - -## Procedures - -- No more than **four positional parameters**. Use keyword arguments - (via `define*`) beyond that. -- Keep procedures under roughly **21 lines** (excluding docstring). - Break long procedures into meaningfully named helpers. -- Prefer **purely functional** code. Use mutation only for I/O, - performance, and low-level utilities. -- Avoid point-free style and functional combinators. Use explicit - `lambda`. Reserve `compose` for cases where composition is genuinely - the idea being expressed. - - -## Data Types - -- Prefer **records** (`define-record-type` from `(srfi srfi-9)`) over - ad-hoc lists. Do not browse data with `car`/`cdr`/`cadr`. -- Do not export record type descriptors (e.g., ``). Export only - predicates, constructors, and accessors. -- Use `(ice-9 match)` for pattern matching. -- Use **alists** for lightweight key-value data (route params, headers, - config). - - -## Multiple Return Values - -Use `values` for multiple return values. Prefer `(srfi srfi-71)` extended -`let` over `(srfi srfi-11)` `let-values`: - -```scheme -(let ((response body (handler request body-port))) - (values response body)) -``` - - -## Error Handling - -Use `(ice-9 exceptions)` functionality. - - -## File Organization - -- Keep files under **512 lines**. Do not exceed 1024. -- Minimize module dependencies. -- Structure files with `;;;` section headings. - - -## Testing - -Tests use `define-suite`, `suite`, `test`, and `is`. Keep test files -under `tests/`. diff --git a/VERSION b/VERSION deleted file mode 100644 index 49d5957..0000000 --- a/VERSION +++ /dev/null @@ -1 +0,0 @@ -0.1 diff --git a/bootstrap.sh b/bootstrap.sh deleted file mode 100755 index 9438d00..0000000 --- a/bootstrap.sh +++ /dev/null @@ -1,19 +0,0 @@ -#! /bin/sh -# Safsaf, a Guile web framework -# Copyright (C) 2026 Christopher Baines -# -# This program 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 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 -# 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 -# . - -autoreconf --verbose --install --force diff --git a/build-aux/news-to-texi.scm b/build-aux/news-to-texi.scm deleted file mode 100644 index b2a95d4..0000000 --- a/build-aux/news-to-texi.scm +++ /dev/null @@ -1,73 +0,0 @@ -;;; news-to-texi.scm — Convert a GNU-style NEWS file to Texinfo -;;; -;;; Usage: guile news-to-texi.scm NEWS > version-history.texi -;;; -;;; The NEWS format is: -;;; -;;; Version X.Y (date) -;;; -;;; * First item. -;;; * Second item, possibly -;;; continued on the next line. -;;; -;;; Lines before the first "Version" heading (title, copyright notice) -;;; are skipped. - -(use-modules (ice-9 rdelim) - (ice-9 regex) - (ice-9 match)) - -(define (news->texi port out) - (let loop ((line (read-line port)) - (in-version? #f) - (in-item? #f)) - (cond - ((eof-object? line) - ;; Close any open item/version. - (when in-item? - (display "\n" out)) - (when in-version? - (format out "@end itemize~%~%"))) - - ;; Version heading: "Version X.Y ..." - ((string-match "^Version " line) - ;; Close previous version if open. - (when in-item? - (display "\n" out)) - (when in-version? - (format out "@end itemize~%~%")) - (format out "@item ~a~%" line) - (format out "@itemize~%" ) - (loop (read-line port) #t #f)) - - ;; Bullet item: " * text" - ((string-match "^ \\* (.+)" line) - => - (lambda (m) - ;; Close previous item if open. - (when in-item? - (display "\n" out)) - (format out "@item~%") - (display (match:substring m 1) out) - (loop (read-line port) in-version? #t))) - - ;; Continuation line: " text" (indented, no bullet) - ((and in-item? (string-match "^ (.+)" line)) - => - (lambda (m) - (display "\n" out) - (display (match:substring m 1) out) - (loop (read-line port) in-version? #t))) - - ;; Blank or preamble line — skip. - (else - (loop (read-line port) in-version? in-item?))))) - -(match (command-line) - ((_ news-file) - (call-with-input-file news-file - (lambda (in) - (news->texi in (current-output-port))))) - ((_ . _) - (format (current-error-port) "Usage: guile news-to-texi.scm NEWS~%") - (exit 1))) diff --git a/configure.ac b/configure.ac deleted file mode 100644 index 1333d81..0000000 --- a/configure.ac +++ /dev/null @@ -1,58 +0,0 @@ -dnl Safsaf, a Guile web framework -dnl Copyright (C) 2026 Christopher Baines -dnl -dnl This program is free software: you can redistribute it and/or -dnl modify it under the terms of the GNU Lesser General Public License -dnl as published by the Free Software Foundation, either version 3 of -dnl the License, or (at your option) any later version. -dnl -dnl This program is distributed in the hope that it will be useful, but -dnl WITHOUT ANY WARRANTY; without even the implied warranty of -dnl MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -dnl Lesser General Public License for more details. -dnl -dnl You should have received a copy of the GNU Lesser General Public -dnl License along with this program. If not, see -dnl . - -AC_INIT([safsaf], [m4_translit(m4_esyscmd([cat VERSION]),m4_newline)]) -AC_CONFIG_AUX_DIR([build-aux]) -AM_INIT_AUTOMAKE([gnu color-tests -Wall -Wno-portability 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.x installation.]) -fi - -if test "$cross_compiling" != no; then - GUILE_TARGET="--target=$host_alias" - AC_SUBST([GUILE_TARGET]) -fi - -dnl Check for Guile Knots. -GUILE_MODULE_AVAILABLE([have_guile_knots], [(knots web-server)]) -if test "x$have_guile_knots" != "xyes"; then - AC_MSG_ERROR([Guile Knots is missing; please install it.]) -fi - -dnl Check for Guile Webutils. -GUILE_MODULE_AVAILABLE([have_guile_webutils], [(webutils sessions)]) -if test "x$have_guile_webutils" != "xyes"; then - AC_MSG_ERROR([Guile Webutils is missing; please install it.]) -fi - -dnl Check for Guile-lib. -GUILE_MODULE_AVAILABLE([have_guile_lib], [(logging logger)]) -if test "x$have_guile_lib" != "xyes"; then - AC_MSG_ERROR([Guile-lib is missing; please install it.]) -fi - -dnl Check for Guile Documentá (optional, for API doc generation). -AC_PATH_PROG([DOCUMENTA], [documenta]) -AM_CONDITIONAL([HAVE_DOCUMENTA], [test "x$DOCUMENTA" != "x"]) - -AC_CONFIG_FILES([Makefile doc/Makefile]) -AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env]) - -AC_OUTPUT diff --git a/doc/Makefile.am b/doc/Makefile.am deleted file mode 100644 index d261473..0000000 --- a/doc/Makefile.am +++ /dev/null @@ -1,54 +0,0 @@ -# Safsaf, a Guile web framework -# Copyright (C) 2026 Christopher Baines -# -# This program 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 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 -# 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 -# . - -info_TEXINFOS = index.texi -index_TEXINFOS = guidance.texi api/index.texi version-history.texi - -version-history.texi: $(top_srcdir)/NEWS - $(AM_V_GEN)$(GUILE) $(top_srcdir)/build-aux/news-to-texi.scm $< > $@ - -API_SOURCES = \ - $(top_srcdir)/safsaf.scm \ - $(top_srcdir)/safsaf/utils.scm \ - $(top_srcdir)/safsaf/templating.scm \ - $(top_srcdir)/safsaf/response-helpers.scm \ - $(top_srcdir)/safsaf/params.scm \ - $(top_srcdir)/safsaf/handler-wrappers/logging.scm \ - $(top_srcdir)/safsaf/handler-wrappers/security-headers.scm \ - $(top_srcdir)/safsaf/handler-wrappers/cors.scm \ - $(top_srcdir)/safsaf/handler-wrappers/csrf.scm \ - $(top_srcdir)/safsaf/handler-wrappers/exceptions.scm \ - $(top_srcdir)/safsaf/handler-wrappers/sessions.scm \ - $(top_srcdir)/safsaf/handler-wrappers/trailing-slash.scm \ - $(top_srcdir)/safsaf/handler-wrappers/max-body-size.scm \ - $(top_srcdir)/safsaf/router.scm - -html-local: index.html - -index.html: index.texi $(index_TEXINFOS) - $(AM_V_GEN)$(MAKEINFO) --css-ref=https://luis-felipe.gitlab.io/texinfo-css/static/css/texinfo-7.css \ - --no-split --html -c SHOW_TITLE=true -o $@ $(srcdir)/index.texi - -EXTRA_DIST = logo.svg - -CLEANFILES = index.html - -if HAVE_DOCUMENTA -api/index.texi: $(API_SOURCES) - cd $(top_srcdir) && ./pre-inst-env \ - $(DOCUMENTA) api "safsaf.scm safsaf/" -endif diff --git a/doc/guidance.texi b/doc/guidance.texi deleted file mode 100644 index 716e703..0000000 --- a/doc/guidance.texi +++ /dev/null @@ -1,424 +0,0 @@ -@node Guidance -@chapter Guidance - -This chapter explains how the pieces of Safsaf fit together. Each -section covers one concept with a short code example. For the full -list of parameters and options, see @ref{API}. - -@menu -* Getting Started:: A minimal runnable server. -* Routing:: Route patterns, groups, and reverse routing. -* Handler Wrappers:: Composing middleware via wrap-routes. -* Responses:: HTML, JSON, text, redirects, and errors. -* Request Parsing:: Forms, query strings, multipart, cookies. -* Parameter Parsing:: Declarative param specs with validation. -* Sessions:: Signed cookie sessions. -* Templating:: Streaming HTML with dynamic slots. -* Static Files:: Serving files from disk. -@end menu - - -@node Getting Started -@section Getting Started - -A Safsaf application is a list of routes passed to @code{run-safsaf}. -Each route binds an HTTP method and URL pattern to a handler procedure. -The handler receives a Guile @code{} and a body port, and -returns two values: a response and a body. - -@lisp -(use-modules (safsaf) - (safsaf router) - (safsaf response-helpers)) - -(define routes - (list - (route 'GET '() index-page - #:name 'index) - (route 'GET '("hello" name) hello-page) - (route '* '* (lambda (request body-port) - (not-found-response))))) - -(define (index-page request body-port) - (html-response '(h1 "Welcome"))) - -(define (hello-page request body-port) - (let ((name (assoc-ref (current-route-params) 'name))) - (text-response (string-append "Hello, " name "!")))) - -(run-safsaf routes #:port 8080) -@end lisp - -The last route should be a catch-all (@code{'*} method, @code{'*} -pattern) so that every request is handled. @code{run-safsaf} sets up -a Fibers scheduler, starts the HTTP server, and blocks until Ctrl-C. - - -@node Routing -@section Routing - -@subheading Patterns - -Route patterns are lists of segments. A string matches literally, a -symbol captures that segment into @code{current-route-params}, and a -two-element list @code{(predicate name)} captures only when -@var{predicate} returns true. A dotted tail captures the remaining -path. - -@lisp -;; Literal: /about -(route 'GET '("about") about-handler) - -;; Capture: /users/:id -(route 'GET '("users" id) show-user) - -;; Predicate: /posts/:id where id is numeric -(route 'GET '("posts" (,string->number id)) show-post) - -;; Wildcard (rest): /files/* — captures remaining segments -(route 'GET '("files" . path) serve-file) -@end lisp - -@subheading Route groups - -@code{route-group} nests routes under a shared prefix: - -@lisp -(route-group '("api" "v1") - (route 'GET '("users") api-list-users) - (route 'GET '("users" id) api-show-user)) -@end lisp - -This matches @code{/api/v1/users} and @code{/api/v1/users/:id}. - -@subheading Named routes and path-for - -Give a route a @code{#:name} and use @code{path-for} to generate its -URL, so paths are never hard-coded. The first argument is always a -route group: - -@lisp -(define my-routes - (route-group '() - (route 'GET '("posts" id) show-post #:name 'show-post))) - -(define all-routes - (list my-routes - (route '* '* (lambda (r b) (not-found-response))))) - -;; In a handler or template: -(path-for my-routes 'show-post '((id . "42"))) -;; => "/posts/42" -@end lisp - -@code{path-for} also accepts @code{#:query} and @code{#:fragment} -keyword arguments. - - -@node Handler Wrappers -@section Handler Wrappers - -A handler wrapper is a procedure that takes a handler and returns a -new handler. It can transform the request on the way in and the -response on the way out. Apply wrappers to a route tree with -@code{wrap-routes}. - -@lisp -(wrap-routes routes - (make-exceptions-handler-wrapper #:dev? #t) - logging-handler-wrapper) -@end lisp - -When multiple wrappers are given, the first wraps outermost — it runs -first on the request and last on the response. In the example above, -exceptions catches errors from the logging wrapper and the inner -handler. - -@subheading Per-group wrappers - -Apply wrappers to part of the route tree by wrapping a group -separately: - -@lisp -(define api-routes - (wrap-routes - (route-group '("api") - (route 'GET '("items") api-list-items)) - cors-handler-wrapper)) - -(define all-routes - (wrap-routes - (list api-routes - (route 'GET '() index-page) - (route '* '* (lambda (r b) (not-found-response)))) - logging-handler-wrapper)) -@end lisp - -Here CORS headers are added only to @code{/api/*} routes, while -logging applies to everything. - -@subheading Security headers - -@code{security-headers-handler-wrapper} @emph{appends} its headers to -the response rather than replacing existing ones. If a handler sets -@code{X-Frame-Options} itself, both values will appear in the response. -To avoid duplication, either omit the header from the wrapper (pass -@code{#:frame-options #f}) or do not set it in the handler. - -@subheading Max body size - -@code{make-max-body-size-handler-wrapper} checks the -@code{Content-Length} header and rejects requests that exceed the -limit with a 413 response. However, it does @emph{not} limit chunked -transfer-encoded requests that lack @code{Content-Length}. For -untrusted networks, use a reverse proxy (e.g.@: Nginx's -@code{client_max_body_size}) to enforce size limits at the transport -level. - - -@node Responses -@section Responses - -Safsaf provides helpers that return @code{(values response body)} -directly: - -@lisp -;; HTML — streams an SXML tree -(html-response '(div (h1 "Hello") (p "world"))) - -;; JSON — takes a JSON string -(json-response (scm->json-string '(("ok" . #t)))) - -;; Plain text -(text-response "pong") - -;; Redirect (default 303 See Other) -(redirect-response "/login") -(redirect-response "/new-item" #:code 302) - -;; Error responses -(not-found-response) -(bad-request-response "Missing field") -(forbidden-response) -@end lisp - -@code{html-response}, @code{json-response}, @code{text-response}, and -@code{redirect-response} accept @code{#:code} and @code{#:headers} for -overrides. The error helpers (@code{not-found-response}, etc.)@: accept -@code{#:headers} but have a fixed status code. - -For content negotiation, use @code{negotiate-content-type}: - -@lisp -(define (show-item request body-port) - (let ((item (fetch-item (assoc-ref (current-route-params) 'id)))) - (case (negotiate-content-type request - '(text/html application/json)) - ((application/json) - (json-response (scm->json-string (item->alist item)))) - (else - (html-response `(div (h1 ,(item-title item)))))))) -@end lisp - - -@node Request Parsing -@section Request Parsing - -@subheading Form bodies - -@code{parse-form-body} reads a URL-encoded POST body and returns an -alist of string pairs: - -@lisp -(define (handle-login request body-port) - (let* ((form (parse-form-body request body-port)) - (username (assoc-ref form "username")) - (password (assoc-ref form "password"))) - (if (valid-credentials? username password) - (redirect-response "/dashboard") - (text-response "Invalid login" #:code 401)))) -@end lisp - -@subheading Query strings - -@code{parse-query-string} extracts query parameters from the request -URL: - -@lisp -(let ((qs (parse-query-string request))) - (assoc-ref qs "page")) ;; => "2" or #f -@end lisp - -@subheading Multipart - -For file uploads, use @code{parse-multipart-body}: - -@lisp -(let* ((parts (parse-multipart-body request body-port)) - (form (multipart-text-fields parts)) - (file (parts-ref parts "avatar"))) - ;; form is an alist of text fields - ;; file is a record — read its body with (part-body file) - ...) -@end lisp - -@subheading Cookies - -Read cookies with @code{request-cookie-ref} or -@code{request-cookies}. Set them via response headers with -@code{set-cookie-header} and @code{delete-cookie-header}: - -@lisp -(request-cookie-ref request "theme") ;; => "dark" or #f - -(text-response "ok" - #:headers (list (set-cookie-header "theme" "dark" - #:path "/" - #:http-only #t))) -@end lisp - - -@node Parameter Parsing -@section Parameter Parsing - -@code{parse-params} validates and transforms raw form or query data -according to a declarative spec. Each spec entry names a parameter, -a processor (a procedure that converts a string or returns an -@code{}), and options like @code{#:required} or -@code{#:default}. - -@lisp -(let ((params (parse-params - `((page ,as-integer #:default 1) - (per-page ,as-integer #:default 20) - (q ,as-string)) - (parse-query-string request)))) - (assq-ref params 'page)) ;; => 1 (integer, not string) -@end lisp - -Built-in processors: @code{as-string}, @code{as-integer}, -@code{as-number}, @code{as-checkbox}, @code{as-one-of}, -@code{as-matching}, @code{as-predicate}. - -@subheading Form params with CSRF - -For POST forms, use @code{parse-form-params} instead — it -automatically checks the CSRF token (from -@code{csrf-handler-wrapper}) before parsing: - -@lisp -(let* ((form (parse-form-body request body-port)) - (params (parse-form-params - `((title ,as-string #:required) - (body ,as-string #:required)) - form))) - (if (any-invalid-params? params) - ;; Re-render the form with errors - (render-form (field-errors params 'title) - (field-errors params 'body)) - ;; Proceed - (create-item! (assq-ref params 'title) - (assq-ref params 'body)))) -@end lisp - -@code{any-invalid-params?} returns @code{#t} if any value failed -validation. @code{field-errors} returns a list of error message -strings for a given field, suitable for rendering next to form inputs. - - -@node Sessions -@section Sessions - -Sessions use HMAC-signed cookies via @code{(webutils sessions)}. -Set up a session config and apply the wrapper: - -@lisp -(define session-mgr - (make-session-config "my-secret-key" - #:cookie-name "my-session")) - -(define routes - (wrap-routes my-routes - (make-session-handler-wrapper session-mgr))) -@end lisp - -Inside a handler, @code{(current-session)} returns the session data -(an alist) or @code{#f} if no valid session exists. - -To set session data, include a @code{session-set} header in the -response. To delete, use @code{session-delete}: - -@lisp -;; Set session -(redirect-response "/" - #:headers (list (session-set session-mgr - '((user-id . 42))))) - -;; Read session -(let ((user-id (and (current-session) - (assoc-ref (current-session) 'user-id)))) - ...) - -;; Delete session -(redirect-response "/" - #:headers (list (session-delete session-mgr))) -@end lisp - - -@node Templating -@section Templating - -@code{write-shtml-as-html/streaming} works like htmlprag's -@code{write-shtml-as-html}, but any procedure in the SHTML tree is -called as @code{(proc port)} and can write dynamic content directly. - -@code{streaming-html-response} wraps this into a response: give it an -SHTML tree (with optional procedure slots) and it returns -@code{(values response body)} ready for a handler. - -@lisp -(define (base-layout title content-proc) - `(*TOP* - (*DECL* DOCTYPE html) - (html - (head (title ,title)) - (body - (nav (a (@@ (href "/")) "Home")) - (main ,content-proc) - (footer (p "Footer")))))) -@end lisp - -The layout is plain SHTML with a procedure in the @var{content-proc} -position. Use @code{streaming-html-response} to send it: - -@lisp -(define (index-page request body-port) - (streaming-html-response - (base-layout "Home" - (lambda (port) - (write-shtml-as-html - `(div (h1 "Welcome") - (p "Content goes here.")) - port))))) -@end lisp - -You can also call @code{write-shtml-as-html/streaming} directly when -you need to write SHTML with procedure slots to an arbitrary port. - - -@node Static Files -@section Static Files - -@code{make-static-handler} returns a handler that serves files from a -directory. Pair it with a wildcard route: - -@lisp -(route-group '("static") - (route 'GET '(. path) - (make-static-handler "./public" - #:cache-control '((max-age . 3600))))) -@end lisp - -This serves @code{/static/css/style.css} from -@code{./public/css/style.css}. The handler supports -@code{If-Modified-Since} for 304 responses. diff --git a/doc/index.texi b/doc/index.texi deleted file mode 100644 index ea2ea00..0000000 --- a/doc/index.texi +++ /dev/null @@ -1,102 +0,0 @@ -\input texinfo -@setfilename safsaf.info - -@dircategory The Algorithmic Language Scheme -@direntry -* Safsaf: (safsaf). A web framework for Guile Scheme. -@end direntry - -@html -
- -
-@end html - -@c HEADER -@settitle Safsaf -@documentlanguage en -@documentencoding UTF-8 -@afourpaper -@c END HEADER - -@c MASTER MENU -@node Top -@top Overview - -Safsaf is a web framework for Guile Scheme, built on -@url{https://codeberg.org/guile/fibers, Guile Fibers} using the -@url{https://cbaines.codeberg.page/guile-knots/, Guile Knots} web -server. - -@c END MASTER MENU - - -@c TABLE OF CONTENTS -@contents -@c END TABLE OF CONTENTS - - -@c CHAPTER: GUIDANCE -@include guidance.texi -@c END CHAPTER: GUIDANCE - - -@c CHAPTER: API -@include api/index.texi -@c END CHAPTER: API - - - -@c APPENDICES -@node Version History -@appendix Version History - -@table @dfn - -@include version-history.texi - -@end table - - - -@node Copying Information -@appendix Copying Information - -Copyright @copyright{} 2026 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/examples/blog-site/README.md b/examples/blog-site/README.md deleted file mode 100644 index d7f8c92..0000000 --- a/examples/blog-site/README.md +++ /dev/null @@ -1,23 +0,0 @@ -Blog Site Example -================= - -A small blog application demonstrating Safsaf's routing, handler -wrappers, sessions, CSRF protection, and content negotiation. Uses -SQLite for storage. - -Running -------- - -From the repository root: - - ./pre-inst-env guile -L examples/blog-site examples/blog-site/blog-site.scm - -Or from the example directory: - - cd examples/blog-site - ../../pre-inst-env guile -L . blog-site.scm - -The server listens on http://localhost:8082. - -The session secret and database path are hard-coded for demonstration -purposes — do not use these values in production. diff --git a/examples/blog-site/blog-site.scm b/examples/blog-site/blog-site.scm deleted file mode 100644 index c4113c7..0000000 --- a/examples/blog-site/blog-site.scm +++ /dev/null @@ -1,45 +0,0 @@ -(use-modules (model) - (views) - (safsaf) - (safsaf handler-wrappers csrf) - (safsaf handler-wrappers exceptions) - (safsaf handler-wrappers logging) - (safsaf handler-wrappers security-headers) - (safsaf handler-wrappers sessions) - (safsaf response-helpers) - (safsaf router)) - -(unless (file-exists? "static/style.css") - (format (current-error-port) - "error: run this from the examples/blog-site/ directory~%") - (exit 1)) - -;; Create a shared database thread pool. -(let* ((db-pool (make-db "/tmp/blog-site.db")) - - ;; Session manager — in production, use a proper secret. - (session-manager - (make-session-config "change-me-in-production" - #:cookie-name "blog-session")) - - (all-routes - (wrap-routes - (list (make-blog-component db-pool session-manager) - (route-group '("static") - (route 'GET '(. path) - (make-static-handler - "./static" - #:cache-control '((max-age . 3600))))) - (route '* '* (lambda (request body-port) - (not-found-response)))) - (make-exceptions-handler-wrapper #:dev? #t) - logging-handler-wrapper - security-headers-handler-wrapper - (make-session-handler-wrapper session-manager) - csrf-handler-wrapper)) - - (port 8082)) - - (format #t "Listening on http://localhost:~a~%" port) - (force-output) - (run-safsaf all-routes #:port port)) diff --git a/examples/blog-site/model.scm b/examples/blog-site/model.scm deleted file mode 100644 index 194b6d9..0000000 --- a/examples/blog-site/model.scm +++ /dev/null @@ -1,152 +0,0 @@ -(define-module (model) - #:use-module (knots thread-pool) - #:use-module (sqlite3) - #:export (make-db - call-with-db - db-init! - db-list-posts - db-get-post - db-create-post! - db-update-post! - db-delete-post!)) - -;;; -;;; Connection pool -;;; - -(define* (make-db database-file #:key (pool-size 4)) - "Create a thread pool where each thread holds an open SQLite -connection to DATABASE-FILE." - (make-fixed-size-thread-pool - pool-size - #:name "sqlite" - #:thread-initializer - (lambda () - (let ((db (sqlite-open database-file - (logior SQLITE_OPEN_READWRITE - SQLITE_OPEN_CREATE)))) - (sqlite-busy-timeout db 5000) - (sqlite-exec db "PRAGMA journal_mode=WAL") - (sqlite-exec db "PRAGMA foreign_keys=ON") - - (db-init! db) - - (list db))) - #:thread-destructor - (lambda (db) - (sqlite-close db)))) - -(define (call-with-db pool proc) - "Run (PROC db) on a thread from POOL, where DB is the thread's -SQLite connection. Returns whatever PROC returns." - (call-with-thread pool - (lambda (db) - (proc db)))) - -;;; -;;; Schema -;;; - -(define (db-init! db) - (sqlite-exec db " -CREATE TABLE IF NOT EXISTS posts ( - id INTEGER PRIMARY KEY AUTOINCREMENT, - title TEXT NOT NULL, - body TEXT NOT NULL, - image_url TEXT, - created_at TEXT NOT NULL DEFAULT (datetime('now')) -)")) - -;;; -;;; Row conversions -;;; - -(define (row->post-summary row) - "Convert a list-view row (vector) to an alist." - `((id . ,(vector-ref row 0)) - (title . ,(vector-ref row 1)) - (created-at . ,(vector-ref row 2)))) - -(define (row->post row) - "Convert a detail-view row (vector) to an alist." - `((id . ,(vector-ref row 0)) - (title . ,(vector-ref row 1)) - (body . ,(vector-ref row 2)) - (image-url . ,(vector-ref row 3)) - (created-at . ,(vector-ref row 4)))) - -;;; -;;; Queries -;;; - -(define (db-list-posts pool) - "Return all posts as a list of alists (id, title, created-at), -newest first." - (call-with-db pool - (lambda (db) - (let ((stmt (sqlite-prepare db - "SELECT id, title, created_at FROM posts ORDER BY id DESC"))) - (let ((rows (sqlite-map row->post-summary stmt))) - (sqlite-finalize stmt) - rows))))) - -(define (db-get-post pool id) - "Return the post with ID as an alist, or #f if not found." - (call-with-db pool - (lambda (db) - (let ((stmt (sqlite-prepare db - "SELECT id, title, body, image_url, created_at - FROM posts WHERE id = ?"))) - (sqlite-bind stmt 1 id) - (let ((row (sqlite-step stmt))) - (sqlite-finalize stmt) - (and row (row->post row))))))) - -(define (db-create-post! pool title body image-url) - "Insert a new post and return its ID." - (call-with-db pool - (lambda (db) - (let ((stmt (sqlite-prepare db - "INSERT INTO posts (title, body, image_url) VALUES (?, ?, ?)"))) - (sqlite-bind stmt 1 title) - (sqlite-bind stmt 2 body) - (sqlite-bind stmt 3 image-url) - (sqlite-step stmt) - (sqlite-finalize stmt) - (let ((stmt (sqlite-prepare db "SELECT last_insert_rowid()"))) - (let ((row (sqlite-step stmt))) - (sqlite-finalize stmt) - (vector-ref row 0))))))) - -(define (sqlite-changes db) - "Return the number of rows changed by the most recent INSERT, UPDATE, -or DELETE statement on DB." - (let ((stmt (sqlite-prepare db "SELECT changes()"))) - (let ((row (sqlite-step stmt))) - (sqlite-finalize stmt) - (vector-ref row 0)))) - -(define (db-update-post! pool id title body image-url) - "Update the post with ID. Returns #t if a row was changed, #f otherwise." - (call-with-db pool - (lambda (db) - (let ((stmt (sqlite-prepare db - "UPDATE posts SET title = ?, body = ?, image_url = ? - WHERE id = ?"))) - (sqlite-bind stmt 1 title) - (sqlite-bind stmt 2 body) - (sqlite-bind stmt 3 image-url) - (sqlite-bind stmt 4 id) - (sqlite-step stmt) - (sqlite-finalize stmt) - (> (sqlite-changes db) 0))))) - -(define (db-delete-post! pool id) - "Delete the post with ID. Returns #t if a row was deleted, #f otherwise." - (call-with-db pool - (lambda (db) - (let ((stmt (sqlite-prepare db "DELETE FROM posts WHERE id = ?"))) - (sqlite-bind stmt 1 id) - (sqlite-step stmt) - (sqlite-finalize stmt) - (> (sqlite-changes db) 0))))) diff --git a/examples/blog-site/static/style.css b/examples/blog-site/static/style.css deleted file mode 100644 index 34cf9d9..0000000 --- a/examples/blog-site/static/style.css +++ /dev/null @@ -1,30 +0,0 @@ -* { margin: 0; padding: 0; box-sizing: border-box; } -body { font-family: system-ui, sans-serif; line-height: 1.6; max-width: 48rem; margin: 0 auto; padding: 1rem; color: #222; } -nav { border-bottom: 1px solid #ddd; padding: 0.75rem 0; margin-bottom: 1.5rem; } -nav a { text-decoration: none; color: #444; margin-right: 1rem; } -nav a:hover { color: #000; } -h1 { margin-bottom: 0.75rem; } -h1 a { text-decoration: none; color: inherit; } -p, ul, pre { margin-bottom: 1rem; } -ul { padding-left: 1.5rem; } -a { color: #1a6; } -pre { background: #f5f5f5; padding: 1rem; overflow-x: auto; white-space: pre-wrap; } -form label { display: block; margin-bottom: 0.25rem; font-weight: 600; } -form input[type="text"], form textarea { width: 100%; padding: 0.4rem; border: 1px solid #ccc; border-radius: 3px; font-family: inherit; font-size: inherit; } -form textarea { resize: vertical; } -form button { margin-top: 0.5rem; padding: 0.4rem 1.2rem; background: #1a6; color: #fff; border: none; border-radius: 3px; cursor: pointer; } -form button:hover { background: #158; } -.field { margin-bottom: 1rem; } -.error { color: #c33; font-size: 0.9rem; margin-top: 0.2rem; } -.post-meta { color: #888; font-size: 0.9rem; margin-bottom: 1rem; } -.header-image { width: 100%; max-height: 20rem; object-fit: cover; border-radius: 4px; margin-bottom: 1rem; } -.nav-form { display: inline; } -.nav-link { background: none; border: none; color: #444; cursor: pointer; font: inherit; padding: 0; margin-right: 1rem; } -.nav-link:hover { color: #000; } -form input[type="file"] { margin-top: 0.25rem; } -.post-actions { margin-bottom: 1rem; } -.post-actions a { margin-right: 0.5rem; } -.inline-form { display: inline; } -.danger { background: #c33; color: #fff; border: none; border-radius: 3px; padding: 0.2rem 0.6rem; cursor: pointer; font-size: 0.9rem; } -.danger:hover { background: #a22; } -footer { border-top: 1px solid #ddd; padding-top: 0.75rem; margin-top: 2rem; color: #888; font-size: 0.9rem; } diff --git a/examples/blog-site/views.scm b/examples/blog-site/views.scm deleted file mode 100644 index d87b24f..0000000 --- a/examples/blog-site/views.scm +++ /dev/null @@ -1,475 +0,0 @@ -(define-module (views) - #:use-module (htmlprag) - #:use-module (ice-9 binary-ports) - #:use-module (ice-9 match) - #:use-module (json) - #:use-module (model) - #:use-module (safsaf handler-wrappers csrf) - #:use-module (safsaf handler-wrappers sessions) - #:use-module (safsaf response-helpers) - #:use-module (safsaf router) - #:use-module (safsaf templating) - #:use-module (safsaf utils) - #:use-module (safsaf params) - #:use-module (srfi srfi-71) - #:use-module (web request) - #:use-module (webutils multipart) - #:export (make-blog-component)) - -(define %demo-username "admin") -(define %demo-password "password") - -(define %pool #f) -(define %session-manager #f) -(define %routes #f) - -;;; -;;; JSON helpers -;;; - -(define (post->json-alist post) - (match post - ((('id . id) ('title . title) ('body . body) - ('image-url . image-url) ('created-at . created-at)) - `(("id" . ,id) - ("title" . ,title) - ("body" . ,body) - ("image_url" . ,(or image-url 'null)) - ("created_at" . ,created-at))))) - -(define (post-summary->json-alist post) - (match post - ((('id . id) ('title . title) ('created-at . created-at)) - `(("id" . ,id) - ("title" . ,title) - ("created_at" . ,created-at))))) - -;;; -;;; View helpers -;;; - -(define (render-field label name type value errors) - `(div (@ (class "field")) - (label ,label - ,(if (string=? type "textarea") - `(textarea (@ (name ,name) (rows "15") (cols "60")) - ,value) - `(input (@ (name ,name) (type ,type) (value ,value))))) - ,@(map (lambda (err) `(p (@ (class "error")) ,err)) - errors))) - -(define (form-errors params field-name) - (if params - (field-errors params field-name) - '())) - -(define (wants-json? request) - (eq? 'application/json - (negotiate-content-type request '(text/html application/json)))) - -;;; -;;; File upload helpers -;;; - -(define upload-dir "./static/uploads") - -(define (ensure-upload-dir!) - (unless (file-exists? upload-dir) - (mkdir upload-dir))) - -(define (save-upload part) - (let* ((params (part-content-disposition-params part)) - (filename (assoc-ref params 'filename))) - (if (or (not filename) (string-null? filename)) - #f - (let* ((ext (let ((dot (string-rindex filename #\.))) - (if dot (substring filename dot) ""))) - (unique-name (string-append - (number->string (current-time)) - "-" - (number->string (random 1000000000)) - ext)) - (file-path (string-append upload-dir "/" unique-name)) - (url-path (string-append "/static/uploads/" unique-name))) - (ensure-upload-dir!) - (call-with-output-file file-path - (lambda (out) - (let ((body (part-body part))) - (let loop () - (let ((bv (get-bytevector-some body))) - (unless (eof-object? bv) - (put-bytevector out bv) - (loop))))))) - url-path)))) - -;;; -;;; Layout -;;; - -(define (logged-in?) - (and (current-session) #t)) - -(define (base-layout title content-proc) - (let ((signed-in? (logged-in?))) - `(*TOP* - (*DECL* DOCTYPE html) - (html - (head - (meta (@ (charset "utf-8"))) - (meta (@ (name "viewport") - (content "width=device-width, initial-scale=1"))) - (title ,title " — Blog") - (link (@ (rel "stylesheet") (href "/static/style.css")))) - (body - (nav - (a (@ (href ,(path-for %routes 'index))) "Blog") - ,@(if signed-in? - `((a (@ (href ,(path-for %routes 'new-post))) "New Post")) - '()) - ,@(if signed-in? - `((form (@ (method "POST") (action ,(path-for %routes 'logout)) - (class "nav-form")) - ,(csrf-token-field) - (button (@ (type "submit") (class "nav-link")) "Log out"))) - `((a (@ (href ,(path-for %routes 'login))) "Log in")))) - (main ,content-proc) - (footer - (p "Safsaf blog example"))))))) - -(define (page title shtml) - (streaming-html-response - (base-layout title - (lambda (port) (write-shtml-as-html shtml port))))) - -;;; -;;; Auth -;;; - -(define (require-login handler) - (lambda (request body-port) - (if (logged-in?) - (handler request body-port) - (if (wants-json? request) - (json-response (scm->json-string '(("error" . "unauthorized"))) - #:code 401) - (redirect-response (path-for %routes 'login)))))) - -(define (login-page request body-port) - (if (logged-in?) - (redirect-response (path-for %routes 'index)) - (login-form-page #f))) - -(define (login-form-page error) - (page "Log in" - `(div - (h1 "Log in") - ,@(if error - `((p (@ (class "error")) ,error)) - '()) - (form (@ (method "POST") (action ,(path-for %routes 'login-submit))) - ,(csrf-token-field) - ,(render-field "Username" "username" "text" "" '()) - ,(render-field "Password" "password" "password" "" '()) - (button (@ (type "submit")) "Log in")) - (p (@ (class "post-meta")) - "Demo credentials: admin / password")))) - -(define (handle-login request body-port) - (let* ((form (parse-form-body request body-port)) - (params (parse-form-params - `((username ,as-string #:required) - (password ,as-string #:required)) - form))) - (if (any-invalid-params? params) - (login-form-page "Please fill in all fields") - (let ((username (assq-ref params 'username)) - (password (assq-ref params 'password))) - (if (and (string=? username %demo-username) - (string=? password %demo-password)) - (redirect-response (path-for %routes 'index) - #:headers (list (session-set %session-manager - `((username . ,username))))) - (login-form-page "Invalid username or password")))))) - -(define (handle-logout request body-port) - (redirect-response (path-for %routes 'index) - #:headers (list (session-delete %session-manager)))) - -;;; -;;; Blog views — content-negotiated -;;; - -(define (post-list-item post) - (match post - ((('id . id) ('title . title) ('created-at . date)) - `(li (a (@ (href ,(path-for %routes 'show-post - `((id . ,(number->string id)))))) - ,title) - " " - (span (@ (class "post-meta")) ,date))))) - -(define (list-posts request body-port) - (let ((posts (db-list-posts %pool))) - (if (wants-json? request) - (json-response - (scm->json-string (list->vector (map post-summary->json-alist posts)))) - (page "Posts" - `(div - (h1 "Blog") - ,(if (null? posts) - '(p "No posts yet.") - `(ul ,@(map post-list-item posts)))))))) - -(define (show-post request body-port) - (let* ((id-str (assoc-ref (current-route-params) 'id)) - (id (and id-str (string->number id-str))) - (post (and id (db-get-post %pool id)))) - (if (not post) - (if (wants-json? request) - (json-response (scm->json-string '(("error" . "not found"))) - #:code 404) - (not-found-response "Post not found")) - (if (wants-json? request) - (json-response (scm->json-string (post->json-alist post))) - (match post - ((('id . _) ('title . title) ('body . body) - ('image-url . image-url) ('created-at . date)) - (page title - `(div - (h1 ,title) - (p (@ (class "post-meta")) ,date) - ,@(if (and image-url (string? image-url)) - `((img (@ (src ,image-url) - (alt ,title) - (class "header-image")))) - '()) - (pre ,body) - ,@(if (logged-in?) - `((div (@ (class "post-actions")) - (a (@ (href ,(path-for %routes 'edit-post - `((id . ,id-str))))) - "Edit") - " " - (form (@ (method "POST") - (action ,(path-for %routes 'post-actions - `((id . ,id-str)))) - (class "inline-form")) - ,(csrf-token-field) - (input (@ (type "hidden") - (name "_method") (value "DELETE"))) - (button (@ (type "submit") (class "danger")) - "Delete")))) - '()) - (p (a (@ (href ,(path-for %routes 'index))) - "Back to posts")))))))))) - -;;; -;;; Create -;;; - -(define (new-post-form-page result title-val body-val) - (page "New Post" - `(div - (h1 "New Post") - (form (@ (method "POST") (action ,(path-for %routes 'create-post)) - (enctype "multipart/form-data")) - ,(csrf-token-field) - ,(render-field "Title" "title" "text" - title-val (form-errors result 'title)) - ,(render-field "Body" "body" "textarea" - body-val (form-errors result 'body)) - (div (@ (class "field")) - (label "Header Image" - (input (@ (name "image") (type "file") - (accept "image/*"))))) - (button (@ (type "submit")) "Create")) - (p (a (@ (href ,(path-for %routes 'index))) "Back"))))) - -(define (new-post-form request body-port) - (new-post-form-page #f "" "")) - -(define (create-post request body-port) - (let* ((parts (parse-multipart-body request body-port)) - (form (multipart-text-fields parts)) - (params (parse-form-params - `((title ,as-string #:required) - (body ,as-string #:required)) - form))) - (if (any-invalid-params? params) - (new-post-form-page params - (or (assoc-ref form "title") "") - (or (assoc-ref form "body") "")) - (let* ((title (assq-ref params 'title)) - (body (assq-ref params 'body)) - (image-part (parts-ref parts "image")) - (image-url (and image-part (save-upload image-part))) - (id (db-create-post! %pool title body image-url))) - (redirect-response - (path-for %routes 'show-post - `((id . ,(number->string id))))))))) - -;;; -;;; Edit / Update -;;; - -(define (edit-post-form request body-port) - (let* ((id-str (assoc-ref (current-route-params) 'id)) - (id (and id-str (string->number id-str))) - (post (and id (db-get-post %pool id)))) - (if (not post) - (not-found-response "Post not found") - (match post - ((('id . _) ('title . title) ('body . body) - ('image-url . image-url) ('created-at . _)) - (edit-post-form-page id-str #f title body)))))) - -(define (edit-post-form-page id-str result title-val body-val) - (page "Edit Post" - `(div - (h1 "Edit Post") - (form (@ (method "POST") - (action ,(path-for %routes 'post-actions - `((id . ,id-str)))) - (enctype "multipart/form-data")) - ,(csrf-token-field) - (input (@ (type "hidden") (name "_method") (value "PUT"))) - ,(render-field "Title" "title" "text" - title-val (form-errors result 'title)) - ,(render-field "Body" "body" "textarea" - body-val (form-errors result 'body)) - (div (@ (class "field")) - (label "Header Image" - (input (@ (name "image") (type "file") - (accept "image/*"))))) - (button (@ (type "submit")) "Update")) - (p (a (@ (href ,(path-for %routes 'show-post - `((id . ,id-str))))) - "Back"))))) - -;;; -;;; Update / Delete — core operations -;;; -;;; These take parsed data, not body-port. Both the direct route handlers -;;; (PUT, DELETE) and the _method dispatcher call these, so body reading -;;; happens in exactly one place per request path. -;;; - -(define (do-update-post request parts form) - "Validate and update the post identified by current-route-params. -PARTS and FORM are already-parsed multipart data." - (let* ((id-str (assoc-ref (current-route-params) 'id)) - (id (and id-str (string->number id-str))) - (post (and id (db-get-post %pool id)))) - (if (not post) - (if (wants-json? request) - (json-response (scm->json-string '(("error" . "not found"))) - #:code 404) - (not-found-response "Post not found")) - (let ((params (parse-form-params - `((title ,as-string #:required) - (body ,as-string #:required)) - form))) - (if (any-invalid-params? params) - (edit-post-form-page id-str params - (or (assoc-ref form "title") "") - (or (assoc-ref form "body") "")) - (let* ((title (assq-ref params 'title)) - (body (assq-ref params 'body)) - (image-part (and parts (parts-ref parts "image"))) - (new-image-url (and image-part (save-upload image-part))) - (image-url (or new-image-url - (assoc-ref post 'image-url)))) - (db-update-post! %pool id title body image-url) - (if (wants-json? request) - (json-response - (scm->json-string (post->json-alist - (db-get-post %pool id)))) - (redirect-response - (path-for %routes 'show-post - `((id . ,id-str))))))))))) - -(define (do-delete-post request) - "Delete the post identified by current-route-params." - (let* ((id-str (assoc-ref (current-route-params) 'id)) - (id (and id-str (string->number id-str))) - (deleted? (and id (db-delete-post! %pool id)))) - (if (wants-json? request) - (if deleted? - (json-response (scm->json-string '(("deleted" . #t)))) - (json-response (scm->json-string '(("error" . "not found"))) - #:code 404)) - (if deleted? - (redirect-response (path-for %routes 'index)) - (not-found-response "Post not found"))))) - -;;; -;;; Route handlers — each reads the body (if needed) then calls the core operation. -;;; - -(define (update-post request body-port) - "PUT /posts/{id} — direct update for API clients and form submissions." - (let* ((parts (parse-multipart-body request body-port)) - (form (multipart-text-fields parts))) - (do-update-post request parts form))) - -(define (delete-post request body-port) - "DELETE /posts/{id} — direct delete for API clients." - (do-delete-post request)) - -;;; -;;; _method dispatch — HTML forms POST here with a hidden _method field -;;; to simulate PUT and DELETE. -;;; - -(define (request-content-type-is-multipart? request) - "Return #t if REQUEST has a multipart/form-data content type." - (let ((ct (request-content-type request))) - (and ct (eq? (car ct) 'multipart/form-data)))) - -(define (post-actions request body-port) - "Handle POST /posts/{id} — dispatches on _method form field. -HTML forms cannot send PUT or DELETE directly, so they POST with a -hidden _method field. This handler reads the body once, then delegates -to the appropriate core operation. API clients should use PUT/DELETE -directly instead." - (let ((parts form (if (request-content-type-is-multipart? request) - (let* ((parts (parse-multipart-body request body-port)) - (form (multipart-text-fields parts))) - (values parts form)) - (values #f (parse-form-body request body-port))))) - (let ((method (assoc-ref form "_method"))) - (cond - ((equal? method "PUT") (do-update-post request parts form)) - ((equal? method "DELETE") (do-delete-post request)) - (else (bad-request-response)))))) - -;;; -;;; Component constructor -;;; - -(define (make-blog-component pool session-manager) - (set! %pool pool) - (set! %session-manager session-manager) - (set! %routes (make-route-group '())) - - (route-group-add-children! %routes - (list (route 'GET '() list-posts #:name 'index) - (route 'GET '("login") login-page #:name 'login) - (route 'POST '("login") handle-login #:name 'login-submit) - (route 'POST '("logout") handle-logout #:name 'logout) - (route 'GET '("posts" "new") (require-login new-post-form) - #:name 'new-post) - (route 'POST '("posts") (require-login create-post) - #:name 'create-post) - (route 'GET '("posts" id) show-post #:name 'show-post) - (route 'GET '("posts" id "edit") (require-login edit-post-form) - #:name 'edit-post) - ;; _method dispatch: HTML forms POST here with _method=PUT or DELETE. - (route 'POST '("posts" id) (require-login post-actions) - #:name 'post-actions) - ;; Direct HTTP methods for API clients. - (route 'PUT '("posts" id) (require-login update-post) - #:name 'update-post) - (route 'DELETE '("posts" id) (require-login delete-post) - #:name 'delete-post))) - %routes) diff --git a/examples/paste-bin/paste-bin.scm b/examples/paste-bin/paste-bin.scm deleted file mode 100644 index 0d790ef..0000000 --- a/examples/paste-bin/paste-bin.scm +++ /dev/null @@ -1,107 +0,0 @@ -(use-modules (htmlprag) - (logging logger) - (logging port-log) - ((oop goops) #:select (make)) - (safsaf) - (safsaf handler-wrappers csrf) - (safsaf handler-wrappers logging) - (safsaf response-helpers) - (safsaf router) - (safsaf utils) - (safsaf params)) - -;;; -;;; Paste storage (in-memory) -;;; - -(define %pastes (make-hash-table)) -(define %next-id 0) - -(define (store-paste! content) - "Store CONTENT and return its integer ID." - (let ((id %next-id)) - (set! %next-id (1+ id)) - (hashv-set! %pastes id content) - id)) - -(define (fetch-paste id) - "Return the paste content for integer ID, or #f." - (hashv-ref %pastes id)) - -;;; -;;; Handlers -;;; - -(define (paste-form-page errors content-val) - "Render the paste form, optionally with validation errors and prior input." - (html-response - `(div - (h1 "Paste Bin") - (form (@ (method "POST") (action "/pastes")) - ,(csrf-token-field) - ,@(map (lambda (err) `(p (@ (style "color: #c33")) ,err)) - errors) - (textarea (@ (name "content") (rows "20") (cols "80")) - ,content-val) - (br) - (button (@ (type "submit")) "Create Paste"))))) - -(define (index-page request body-port) - (paste-form-page '() "")) - -(define (create-paste request body-port) - (let* ((form (parse-form-body request body-port)) - (params (parse-form-params - `((content ,as-string #:required)) - form))) - (if (any-invalid-params? params) - (paste-form-page - (field-errors params 'content) - (or (assoc-ref form "content") "")) - (let ((id (store-paste! (assq-ref params 'content)))) - (redirect-response (string-append "/pastes/" (number->string id))))))) - -(define (show-paste request body-port) - (let* ((params (current-route-params)) - (id-str (assoc-ref params 'id)) - (id (string->number id-str)) - (content (and id (fetch-paste id)))) - (if content - (html-response - `(div - (h1 "Paste " ,id-str) - (pre ,content) - (p (a (@ (href "/")) "New paste")))) - (not-found-response "Paste not found")))) - -;;; -;;; Logging setup -;;; - -(define (setup-logging) - (let ((lgr (make )) - (handler (make #:port (current-error-port)))) - (add-handler! lgr handler) - (set-default-logger! lgr) - (open-log! lgr))) - -(setup-logging) - -;;; -;;; Routes and entry point -;;; - -(define %port 8081) - -(define paste-routes - (wrap-routes - (list - (route 'GET '() index-page) - (route 'POST '("pastes") create-paste) - (route 'GET '("pastes" id) show-paste) - (route '* '* (lambda (request body-port) (not-found-response)))) - logging-handler-wrapper - csrf-handler-wrapper)) - -(format #t "Paste Bin listening on port ~a~%" %port) -(run-safsaf paste-routes #:port %port) diff --git a/guile.am b/guile.am deleted file mode 100644 index b2cf0be..0000000 --- a/guile.am +++ /dev/null @@ -1,39 +0,0 @@ -# Safsaf, a Guile web framework -# Copyright (C) 2026 Christopher Baines -# -# This program 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 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 -# 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 -# . - -moddir=$(datadir)/guile/site/$(GUILE_EFFECTIVE_VERSION) -godir=$(libdir)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache - -GOBJECTS = $(SOURCES:%.scm=%.go) - -nobase_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_modDATA - -CLEANFILES = $(GOBJECTS) -EXTRA_DIST = $(SOURCES) $(NOCOMP_SOURCES) -GUILE_WARNINGS = -Wunbound-variable -Warity-mismatch -Wformat -SUFFIXES = .scm .go -.scm.go: - $(AM_V_GEN)$(top_builddir)/pre-inst-env $(GUILE_TOOLS) compile -W3 $(GUILE_TARGET) $(GUILE_WARNINGS) -o "$@" "$<" diff --git a/guix-dev.scm b/guix-dev.scm deleted file mode 100644 index 08eabf3..0000000 --- a/guix-dev.scm +++ /dev/null @@ -1,57 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 -;; . - -(use-modules ((guix licenses) #:prefix license:) - (guix packages) - (guix git-download) - (guix build-system gnu) - (gnu packages autotools) - (gnu packages guile) - (gnu packages gnupg) - (gnu packages guile-xyz) - (gnu packages databases) - (gnu packages emacs) - (gnu packages pkg-config) - (gnu packages texinfo) - (gnu packages version-control)) - -(package - (name "safsaf") - (version "0") - (source #f) - (build-system gnu-build-system) - (inputs - (list guile-next - guile-knots - guile-webutils - guile-lib - guile-json-4 - guile-sqlite3 - guile-squee - guile-gcrypt)) - (native-inputs - (list autoconf - automake - pkg-config - emacs-minimal - guile-documenta - texinfo - git)) - (synopsis "Web framework for Guile Scheme") - (description "Web framework for Guile Scheme built on Guile Knots.") - (home-page "") - (license license:lgpl3+)) diff --git a/index.html b/index.html new file mode 100644 index 0000000..093193f --- /dev/null +++ b/index.html @@ -0,0 +1,2428 @@ + + + + + +Safsaf + + + + + + + + + + + + + + + + + + + +

Safsaf

+ + +
+ +
+ + +
+
+

+Next:   [Contents][Index]

+
+

Overview

+ +

Safsaf is a web framework for Guile Scheme, built on +Guile Fibers using the +Guile Knots web +server. +

+ + + + + +
+
+
+

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

+
+

1 Guidance

+ +

This chapter explains how the pieces of Safsaf fit together. Each +section covers one concept with a short code example. For the full +list of parameters and options, see API. +

+ + + +
+
+
+

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

+
+

1.1 Getting Started

+ +

A Safsaf application is a list of routes passed to run-safsaf. +Each route binds an HTTP method and URL pattern to a handler procedure. +The handler receives a Guile <request> and a body port, and +returns two values: a response and a body. +

+
+
(use-modules (safsaf)
+             (safsaf router)
+             (safsaf response-helpers))
+
+(define routes
+  (list
+   (route 'GET '() index-page
+          #:name 'index)
+   (route 'GET '("hello" name) hello-page)
+   (route '* '* (lambda (request body-port)
+                  (not-found-response)))))
+
+(define (index-page request body-port)
+  (html-response '(h1 "Welcome")))
+
+(define (hello-page request body-port)
+  (let ((name (assoc-ref (current-route-params) 'name)))
+    (text-response (string-append "Hello, " name "!"))))
+
+(run-safsaf routes #:port 8080)
+
+ +

The last route should be a catch-all ('* method, '* +pattern) so that every request is handled. run-safsaf sets up +a Fibers scheduler, starts the HTTP server, and blocks until Ctrl-C. +

+ +
+
+
+
+

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

+
+

1.2 Routing

+ +

Patterns

+ +

Route patterns are lists of segments. A string matches literally, a +symbol captures that segment into current-route-params, and a +two-element list (predicate name) captures only when +predicate returns true. A dotted tail captures the remaining +path. +

+
+
;; Literal:          /about
+(route 'GET '("about") about-handler)
+
+;; Capture:          /users/:id
+(route 'GET '("users" id) show-user)
+
+;; Predicate:        /posts/:id where id is numeric
+(route 'GET '("posts" (,string->number id)) show-post)
+
+;; Wildcard (rest):  /files/* — captures remaining segments
+(route 'GET '("files" . path) serve-file)
+
+ +

Route groups

+ +

route-group nests routes under a shared prefix: +

+
+
(route-group '("api" "v1")
+  (route 'GET '("users") api-list-users)
+  (route 'GET '("users" id) api-show-user))
+
+ +

This matches /api/v1/users and /api/v1/users/:id. +

+

Named routes and path-for

+ +

Give a route a #:name and use path-for to generate its +URL, so paths are never hard-coded. The first argument is always a +route group: +

+
+
(define my-routes
+  (route-group '()
+   (route 'GET '("posts" id) show-post #:name 'show-post)))
+
+(define all-routes
+  (list my-routes
+        (route '* '* (lambda (r b) (not-found-response)))))
+
+;; In a handler or template:
+(path-for my-routes 'show-post '((id . "42")))
+;; => "/posts/42"
+
+ +

path-for also accepts #:query and #:fragment +keyword arguments. +

+ +
+
+
+
+

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

+
+

1.3 Handler Wrappers

+ +

A handler wrapper is a procedure that takes a handler and returns a +new handler. It can transform the request on the way in and the +response on the way out. Apply wrappers to a route tree with +wrap-routes. +

+
+
(wrap-routes routes
+  (make-exceptions-handler-wrapper #:dev? #t)
+  logging-handler-wrapper)
+
+ +

When multiple wrappers are given, the first wraps outermost — it runs +first on the request and last on the response. In the example above, +exceptions catches errors from the logging wrapper and the inner +handler. +

+

Per-group wrappers

+ +

Apply wrappers to part of the route tree by wrapping a group +separately: +

+
+
(define api-routes
+  (wrap-routes
+   (route-group '("api")
+     (route 'GET '("items") api-list-items))
+   cors-handler-wrapper))
+
+(define all-routes
+  (wrap-routes
+   (list api-routes
+         (route 'GET '() index-page)
+         (route '* '* (lambda (r b) (not-found-response))))
+   logging-handler-wrapper))
+
+ +

Here CORS headers are added only to /api/* routes, while +logging applies to everything. +

+

Security headers

+ +

security-headers-handler-wrapper appends its headers to +the response rather than replacing existing ones. If a handler sets +X-Frame-Options itself, both values will appear in the response. +To avoid duplication, either omit the header from the wrapper (pass +#:frame-options #f) or do not set it in the handler. +

+

Max body size

+ +

make-max-body-size-handler-wrapper checks the +Content-Length header and rejects requests that exceed the +limit with a 413 response. However, it does not limit chunked +transfer-encoded requests that lack Content-Length. For +untrusted networks, use a reverse proxy (e.g. Nginx’s +client_max_body_size) to enforce size limits at the transport +level. +

+ +
+
+
+
+

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

+
+

1.4 Responses

+ +

Safsaf provides helpers that return (values response body) +directly: +

+
+
;; HTML — streams an SXML tree
+(html-response '(div (h1 "Hello") (p "world")))
+
+;; JSON — takes a JSON string
+(json-response (scm->json-string '(("ok" . #t))))
+
+;; Plain text
+(text-response "pong")
+
+;; Redirect (default 303 See Other)
+(redirect-response "/login")
+(redirect-response "/new-item" #:code 302)
+
+;; Error responses
+(not-found-response)
+(bad-request-response "Missing field")
+(forbidden-response)
+
+ +

html-response, json-response, text-response, and +redirect-response accept #:code and #:headers for +overrides. The error helpers (not-found-response, etc.) accept +#:headers but have a fixed status code. +

+

For content negotiation, use negotiate-content-type: +

+
+
(define (show-item request body-port)
+  (let ((item (fetch-item (assoc-ref (current-route-params) 'id))))
+    (case (negotiate-content-type request
+                                  '(text/html application/json))
+      ((application/json)
+       (json-response (scm->json-string (item->alist item))))
+      (else
+       (html-response `(div (h1 ,(item-title item))))))))
+
+ + +
+
+
+
+

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

+
+

1.5 Request Parsing

+ +

Form bodies

+ +

parse-form-body reads a URL-encoded POST body and returns an +alist of string pairs: +

+
+
(define (handle-login request body-port)
+  (let* ((form (parse-form-body request body-port))
+         (username (assoc-ref form "username"))
+         (password (assoc-ref form "password")))
+    (if (valid-credentials? username password)
+        (redirect-response "/dashboard")
+        (text-response "Invalid login" #:code 401))))
+
+ +

Query strings

+ +

parse-query-string extracts query parameters from the request +URL: +

+
+
(let ((qs (parse-query-string request)))
+  (assoc-ref qs "page"))  ;; => "2" or #f
+
+ +

Multipart

+ +

For file uploads, use parse-multipart-body: +

+
+
(let* ((parts (parse-multipart-body request body-port))
+       (form (multipart-text-fields parts))
+       (file (parts-ref parts "avatar")))
+  ;; form is an alist of text fields
+  ;; file is a <part> record — read its body with (part-body file)
+  ...)
+
+ +

Cookies

+ +

Read cookies with request-cookie-ref or +request-cookies. Set them via response headers with +set-cookie-header and delete-cookie-header: +

+
+
(request-cookie-ref request "theme")  ;; => "dark" or #f
+
+(text-response "ok"
+  #:headers (list (set-cookie-header "theme" "dark"
+                                     #:path "/"
+                                     #:http-only #t)))
+
+ + +
+
+
+
+

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

+
+

1.6 Parameter Parsing

+ +

parse-params validates and transforms raw form or query data +according to a declarative spec. Each spec entry names a parameter, +a processor (a procedure that converts a string or returns an +<invalid-param>), and options like #:required or +#:default. +

+
+
(let ((params (parse-params
+                `((page    ,as-integer #:default 1)
+                  (per-page ,as-integer #:default 20)
+                  (q       ,as-string))
+                (parse-query-string request))))
+  (assq-ref params 'page))    ;; => 1 (integer, not string)
+
+ +

Built-in processors: as-string, as-integer, +as-number, as-checkbox, as-one-of, +as-matching, as-predicate. +

+

Form params with CSRF

+ +

For POST forms, use parse-form-params instead — it +automatically checks the CSRF token (from +csrf-handler-wrapper) before parsing: +

+
+
(let* ((form   (parse-form-body request body-port))
+       (params (parse-form-params
+                 `((title ,as-string #:required)
+                   (body  ,as-string #:required))
+                 form)))
+  (if (any-invalid-params? params)
+      ;; Re-render the form with errors
+      (render-form (field-errors params 'title)
+                   (field-errors params 'body))
+      ;; Proceed
+      (create-item! (assq-ref params 'title)
+                    (assq-ref params 'body))))
+
+ +

any-invalid-params? returns #t if any value failed +validation. field-errors returns a list of error message +strings for a given field, suitable for rendering next to form inputs. +

+ +
+
+
+
+

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

+
+

1.7 Sessions

+ +

Sessions use HMAC-signed cookies via (webutils sessions). +Set up a session config and apply the wrapper: +

+
+
(define session-mgr
+  (make-session-config "my-secret-key"
+                       #:cookie-name "my-session"))
+
+(define routes
+  (wrap-routes my-routes
+    (make-session-handler-wrapper session-mgr)))
+
+ +

Inside a handler, (current-session) returns the session data +(an alist) or #f if no valid session exists. +

+

To set session data, include a session-set header in the +response. To delete, use session-delete: +

+
+
;; Set session
+(redirect-response "/"
+  #:headers (list (session-set session-mgr
+                               '((user-id . 42)))))
+
+;; Read session
+(let ((user-id (and (current-session)
+                    (assoc-ref (current-session) 'user-id))))
+  ...)
+
+;; Delete session
+(redirect-response "/"
+  #:headers (list (session-delete session-mgr)))
+
+ + +
+
+
+
+

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

+
+

1.8 Templating

+ +

write-shtml-as-html/streaming works like htmlprag’s +write-shtml-as-html, but any procedure in the SHTML tree is +called as (proc port) and can write dynamic content directly. +

+

streaming-html-response wraps this into a response: give it an +SHTML tree (with optional procedure slots) and it returns +(values response body) ready for a handler. +

+
+
(define (base-layout title content-proc)
+  `(*TOP*
+    (*DECL* DOCTYPE html)
+    (html
+     (head (title ,title))
+     (body
+      (nav (a (@ (href "/")) "Home"))
+      (main ,content-proc)
+      (footer (p "Footer"))))))
+
+ +

The layout is plain SHTML with a procedure in the content-proc +position. Use streaming-html-response to send it: +

+
+
(define (index-page request body-port)
+  (streaming-html-response
+   (base-layout "Home"
+     (lambda (port)
+       (write-shtml-as-html
+        `(div (h1 "Welcome")
+              (p "Content goes here."))
+        port)))))
+
+ +

You can also call write-shtml-as-html/streaming directly when +you need to write SHTML with procedure slots to an arbitrary port. +

+ +
+
+
+
+

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

+
+

1.9 Static Files

+ +

make-static-handler returns a handler that serves files from a +directory. Pair it with a wildcard route: +

+
+
(route-group '("static")
+  (route 'GET '(. path)
+         (make-static-handler "./public"
+                              #:cache-control '((max-age . 3600)))))
+
+ +

This serves /static/css/style.css from +./public/css/style.css. The handler supports +If-Modified-Since for 304 responses. +

+ + + +
+
+
+
+
+

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

+
+

2 API

+

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

+ + + +
+
+
+

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

+
+

2.1 (safsaf)

+ + + + + + +
+

2.1.1 Procedures

+ + +
+
Procedure: default-method-not-allowed-handler request allowed-methods
+

Return a 405 Method Not Allowed response with an Allow header listing +ALLOWED-METHODS. +

+
+ + + + +
+
Procedure: run-safsaf routes KEY: #:host #:port #:method-not-allowed? #:method-not-allowed-handler #:connection-buffer-size
+

Start a Safsaf web server. +

+

ROUTES is a list of routes and route-groups (as returned by component +constructors). The last route must be a catch-all so that every request +is handled. +

+

HEAD requests are handled automatically: when no explicit HEAD route +matches, the matching GET handler runs and its response body is +discarded. Explicit HEAD routes always take precedence. +

+

When METHOD-NOT-ALLOWED? is #t (the default), requests that match a +route’s path but not its method receive a 405 response with an Allow +header. METHOD-NOT-ALLOWED-HANDLER is a procedure (request +allowed-methods) -> (values response body) that produces the 405 +response; the default returns plain text. +

+

When called outside a Fibers scheduler, sets up a scheduler, starts the +HTTP server, and blocks until Ctrl-C. When called inside an existing +scheduler (e.g. within run-fibers), just starts the HTTP server and +returns immediately — the caller manages the lifecycle. +

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

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

+
+

2.2 (safsaf handler-wrappers cors)

+ + + + + + +
+

2.2.1 Procedures

+ + +
+
Procedure: cors-handler-wrapper handler KEY: #:origins #:methods #:headers #:max-age #:allow-credentials? #:expose-headers
+

Handler wrapper that adds CORS (Cross-Origin Resource Sharing) headers +to responses. +

+

Browsers enforce the Same-Origin Policy: scripts on one origin (scheme + +host + port) cannot read responses from a different origin. CORS +relaxes this by letting the server declare which origins, methods, and +headers are permitted. +

+

For “simple” requests the browser sends the request and checks the +response headers. For non-simple requests (e.g. PUT/DELETE, custom +headers, or JSON Content-Type) the browser sends a preflight OPTIONS +request first. This wrapper handles both cases. +

+

ORIGINS is a list of allowed origin strings, or ’("*") for any. METHODS +is a list of allowed method symbols. HEADERS is a list of allowed +request header name strings. MAX-AGE is the preflight cache duration in +seconds. ALLOW-CREDENTIALS? controls whether credentials (cookies, +auth) are allowed cross-origin. Note: cannot be #t when origins is +’("*"). EXPOSE-HEADERS is a list of response header name strings the +browser may read from JavaScript. +

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

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

+
+

2.3 (safsaf handler-wrappers csrf)

+ + + + + + +
+

2.3.1 Parameters

+ + +
+
Parameter: current-csrf-token
+

Default value: +

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

2.3.2 Procedures

+ + +
+
Procedure: csrf-handler-wrapper handler KEY: #:cookie-name
+

CSRF token handler wrapper. +

+

Ensures a CSRF token cookie is present on every response (generates one +if the request has none). The token is bound to current-csrf-token so +handlers and templates can read it via (current-csrf-token). +

+

Token validation is NOT done here — it belongs in the form processing +layer. Use parse-form-params from (safsaf params), which automatically +checks the submitted token against the cookie token. +

+
+ + + + +
+
Procedure: csrf-token-field
+

Return an SXML hidden input element for the CSRF token. Use in forms: +(csrf-token-field) ⇒ (input (@ (type "hidden") +...)). +

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

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

+
+

2.4 (safsaf handler-wrappers exceptions)

+ + + + + + +
+

2.4.1 Procedures

+ + +
+
Procedure: default-render-error render-html render-json
+

Return a render-error procedure that content-negotiates between +RENDER-HTML and RENDER-JSON based on the request’s Accept header. +

+
+ + + + +
+
Procedure: default-render-html request code message backtrace-string dev?
+

Default HTML error renderer. In dev mode, shows a rich backtrace page. +In production, returns a minimal HTML page. +

+
+ + + + +
+
Procedure: default-render-json _request code message backtrace-string dev?
+

Default JSON error renderer. In dev mode, includes the backtrace. In +production, returns only the error message. +

+
+ + + + +
+
Procedure: exceptions-handler-wrapper handler KEY: #:dev? #:logger #:render-html #:render-json #:render-error
+

Handler wrapper that catches exceptions from HANDLER and returns an +error response. +

+

The response format is content-negotiated from the request’s Accept +header, choosing between HTML and JSON. +

+

When LOGGER is provided, exceptions are logged through it. Otherwise, +the backtrace is written to the current error port. In dev mode (DEV? +is #t), the response includes the backtrace and exception details. In +production mode, a generic error is returned. +

+

Rendering can be customised at three levels: +

+

#:render-error — full override. A procedure (request code message +backtrace-string dev?) -> (values response body) that bypasses content +negotiation entirely. +

+

#:render-html — custom HTML rendering. A procedure with the same +signature, called when content negotiation selects HTML. +

+

#:render-json — custom JSON rendering. A procedure with the same +signature, called when content negotiation selects JSON. +

+

The default RENDER-ERROR content-negotiates between RENDER-HTML and +RENDER-JSON. Providing #:render-html or #:render-json replaces just +that format; providing #:render-error replaces the entire rendering. +

+
+ + + + +
+
Procedure: make-exceptions-handler-wrapper KEY: #:dev? #:logger #:render-html #:render-json #:render-error
+

Return a handler wrapper that catches exceptions and returns an error +response. See exceptions-handler-wrapper for details. +

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

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

+
+

2.5 (safsaf handler-wrappers logging)

+ + + + + + +
+

2.5.1 Procedures

+ + +
+
Procedure: logging-handler-wrapper handler KEY: #:logger #:level
+

Handler wrapper that logs each request and response. +

+

Logs at LEVEL (default ’INFO) with method, path, status code, and +duration in milliseconds. If LOGGER is given, logs to that logger; +otherwise uses the default logger set via set-default-logger!. +

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

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

+
+

2.6 (safsaf handler-wrappers max-body-size)

+ + + + + + +
+

2.6.1 Procedures

+ + +
+
Procedure: make-max-body-size-handler-wrapper max-bytes KEY: #:handler-413
+

Return a handler wrapper that rejects requests whose Content-Length +exceeds MAX-BYTES with a 413 Payload Too Large response. +

+

HANDLER-413 is a handler (request body-port) -> (values response body) +called when the limit is exceeded; the default returns plain text. +

+

Note: this checks the Content-Length header only. Chunked transfers +without Content-Length are not limited by this wrapper. +

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

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

+
+

2.7 (safsaf handler-wrappers security-headers)

+ + + + + + +
+

2.7.1 Procedures

+ + +
+
Procedure: security-headers-handler-wrapper handler KEY: #:content-type-options #:frame-options #:strict-transport-security #:referrer-policy #:cross-origin-opener-policy #:permissions-policy #:content-security-policy #:content-security-policy-report-only
+

Handler wrapper that adds security headers to every response. +

+

All headers are optional and configurable. Pass #f to disable a header. +Defaults: X-Content-Type-Options: nosniff X-Frame-Options: DENY +Referrer-Policy: strict-origin-when-cross-origin +

+

Not set by default (enable explicitly): Strict-Transport-Security (e.g. +"max-age=63072000; includeSubDomains") Cross-Origin-Opener-Policy (e.g. +"same-origin") Permissions-Policy (e.g. "camera=(), microphone=()") +Content-Security-Policy (e.g. "default-src ’self’; script-src ’self’") +Content-Security-Policy-Report-Only — same syntax, for testing policies +without enforcing them +

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

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

+
+

2.8 (safsaf handler-wrappers sessions)

+ + + + + + +
+

2.8.1 Parameters

+ + +
+
Parameter: current-session
+

Default value: +

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

2.8.2 Procedures

+ + +
+
Procedure: make-session-config secret-key KEY: #:cookie-name #:expire-delta #:algorithm
+

Create a session manager for use with session-handler-wrapper. +

+

SECRET-KEY is the HMAC signing key (a string). EXPIRE-DELTA is (days +hours minutes), default 30 days. ALGORITHM is the HMAC algorithm, +default sha512. +

+
+ + + + +
+
Procedure: make-session-handler-wrapper session-manager
+

Return a handler wrapper that binds session data from SESSION-MANAGER. +See session-handler-wrapper for details. +

+
+ + + + +
+
Procedure: session-delete session-manager
+

Return a Set-Cookie header that expires the session cookie. Include in +a response headers list: (redirect-response "/" #:headers (list +(session-delete manager))) +

+
+ + + + +
+
Procedure: session-handler-wrapper handler session-manager
+

Session handler wrapper using signed cookies via (webutils sessions). +

+

Reads the session cookie from the request, verifies the HMAC signature, +and binds current-session for the duration of the handler. If no valid +session cookie is present, current-session is #f. +

+

Handlers read session data via: (current-session) → session data or #f +

+

To set or delete the session, handlers include the appropriate header in +their response using session-set and session-delete: +

+

(redirect-response "/" #:headers (list (session-set manager data))) +(redirect-response "/" #:headers (list (session-delete manager))) +

+
+ + + + +
+
Procedure: session-set session-manager data
+

Return a Set-Cookie header that stores signed DATA in the session +cookie. DATA can be any Scheme value that can be written and read back. +Include in a response headers list: (redirect-response "/" #:headers +(list (session-set manager ’((user-id . 42))))) +

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

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

+
+

2.9 (safsaf handler-wrappers trailing-slash)

+ + + + + + +
+

2.9.1 Procedures

+ + +
+
Procedure: make-trailing-slash-handler-wrapper KEY: #:mode #:code
+

Return a handler wrapper that normalizes trailing slashes. +

+

MODE is either ’strip (default) or ’append: ’strip — redirect /foo/ to +/foo ’append — redirect /foo to /foo/ +

+

The root path / is always left alone. +

+

CODE is the HTTP status code for the redirect (default 301). +

+

Use with wrap-routes: (wrap-routes routes +(make-trailing-slash-handler-wrapper #:mode ’append)) +

+
+ + + + +
+
Procedure: trailing-slash-handler-wrapper handler KEY: #:mode #:code
+

Handler wrapper that normalizes trailing slashes in request paths. +

+

MODE is either ’strip (default) or ’append: ’strip — redirect /foo/ to +/foo ’append — redirect /foo to /foo/ +

+

The root path / is always left alone. +

+

CODE is the HTTP status code for the redirect (default 301). +

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

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

+
+

2.10 (safsaf params)

+ + + + + + +
+

2.10.1 Macros

+ + +
+
Macro: invalid-param-message x
+

Undocumented macro. +

+
+ + + + +
+
Macro: invalid-param-value x
+

Undocumented macro. +

+
+ + + + +
+
Macro: invalid-param? x
+

Undocumented macro. +

+
+ + + + +
+
Macro: make-invalid-param x
+

Undocumented macro. +

+
+ + + + + +
+
+

2.10.2 Procedures

+ + +
+
Procedure: any-invalid-params? parsed-params
+

Return #t if any values in PARSED-PARAMS are invalid. +

+
+ + + + +
+
Procedure: as-checkbox s
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: as-integer s
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: as-matching regex KEY: #:message
+

Return a processor that accepts values matching REGEX. +

+
+ + + + +
+
Procedure: as-number s
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: as-one-of choices KEY: #:message
+

Return a processor that accepts only values in CHOICES (a list of +strings). +

+
+ + + + +
+
Procedure: as-predicate pred KEY: #:message
+

Return a processor that accepts values for which PRED returns true. +

+
+ + + + +
+
Procedure: as-string x
+

Undocumented procedure. +

+
+ + + + +
+
Procedure: field-errors parsed-params name
+

Return a list of error message strings for NAME, or ’(). Convenient for +rendering form fields with per-field errors. +

+
+ + + + +
+
Procedure: guard-against-mutually-exclusive-params parsed-params groups
+

Check PARSED-PARAMS for mutually exclusive parameter groups. GROUPS is +a list of lists of symbols, e.g. ’((limit_results all_results)). If +parameters from the same group co-occur, the later ones are replaced +with <invalid-param> records. +

+
+ + + + +
+
Procedure: invalid-param-ref parsed-params name
+

Return the <invalid-param> record for NAME, or #f if valid or absent. +

+
+ + + + +
+
Procedure: params->query-string parsed-params
+

Serialize PARSED-PARAMS back to a URI query string. Skips invalid +params. Handles multi-value (list) entries. Useful for building +pagination links that preserve current filters. +

+
+ + + + +
+
Procedure: parse-form-params param-specs raw-params KEY: #:csrf-field
+

Like parse-params but prepends a CSRF token check. Uses +current-csrf-token from (safsaf handler-wrappers csrf). +

+
+ + + + +
+
Procedure: parse-params param-specs raw-params
+

Parse and transform parameters from RAW-PARAMS according to PARAM-SPECS. +

+

RAW-PARAMS is an alist of (string . string) pairs, as returned by +parse-query-string or parse-form-body. +

+

PARAM-SPECS is a list of specifications. Each spec is a list whose +first element is the parameter name (a symbol), second is a processor +procedure (string -> value | <invalid-param>), and the rest are keyword +options: +

+

(name processor) ; optional (name processor #:required) ; must be +present (name processor #:default value) ; fallback (name processor +#:multi-value) ; collect all occurrences (name processor #:multi-value +#:default value) ; multi-value with fallback (name processor +#:no-default-when (fields) #:default value) ; conditional default +

+

Returns an alist of (symbol . value) pairs. Values that fail +validation appear as <invalid-param> records inline. Missing optional +params without defaults are omitted. +

+
+ + + + + +
+
+

2.10.3 Record Types

+ + +
+
Record type: <invalid-param>
+

This record type has the following fields: +

+
    +
  • value
  • message
+ +
+ + + + + + +
+
+
+
+
+

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

+
+

2.11 (safsaf response-helpers)

+ + + + + + +
+

2.11.1 Procedures

+ + +
+
Procedure: bad-request-response OPT: body KEY: #:headers
+

Return a 400 Bad Request response. +

+
+ + + + +
+
Procedure: build-response/inherit response KEY: #:headers
+

Build a new response based on RESPONSE, preserving its version, status +code, and reason phrase. HEADERS defaults to the existing headers; +override it to modify them. +

+

Use this in handler wrappers that need to adjust headers on an inner +handler’s response without losing any response fields. +

+
+ + + + +
+
Procedure: delete-cookie-header name
+

Return a Set-Cookie header pair that expires cookie NAME. Wraps +(webutils cookie) delete-cookie. +

+
+ + + + +
+
Procedure: forbidden-response OPT: body KEY: #:headers
+

Return a 403 Forbidden response. +

+
+ + + + +
+
Procedure: html-response shtml KEY: #:code #:headers #:charset
+

Return an HTML response by streaming SHTML to the client. SHTML is an +SXML/SHTML tree as accepted by write-shtml-as-html. CHARSET defaults to +"utf-8". +

+
+ + + + +
+
Procedure: internal-server-error-response OPT: body KEY: #:headers
+

Return a 500 Internal Server Error response. +

+
+ + + + +
+
Procedure: json-response str KEY: #:code #:headers
+

Return a JSON response. STR is the JSON string to send. +

+
+ + + + +
+
Procedure: list->streaming-json-array proc lst port KEY: #:unicode
+

Write LST as a JSON array to PORT, applying PROC to each element to +produce a JSON-serializable value. Each element is written individually +via scm->json so the entire array need not be held in memory. +

+
+ + + + +
+
Procedure: make-static-handler root-dir KEY: #:cache-control
+

Return a handler that serves static files from ROOT-DIR. +

+

The handler expects route params to contain a wildcard capture (the file +path segments). Use with a wildcard route: +

+

(route ’GET ’(. path) (make-static-handler "/path/to/public")) +

+

Supports If-Modified-Since for 304 responses. CACHE-CONTROL, if given, +is a Cache-Control value in Guile’s header format — an alist, e.g. +’((max-age . 3600)) or ’((no-cache)). +

+

Works with /gnu/store paths: files with a very low mtime (as produced by +the store’s timestamp normalization) use the process start time as +Last-Modified instead, so that conditional requests behave sensibly. +

+
+ + + + +
+
Procedure: negotiate-content-type request OPT: supported KEY: #:extensions
+

Return the most appropriate MIME type symbol for REQUEST from SUPPORTED. +

+

Checks the URL path extension first (.json, .html, .txt) — if present +and the implied type is in SUPPORTED, it wins. Otherwise, walks the +Accept header and returns the first type that appears in SUPPORTED. +Falls back to the first element of SUPPORTED if nothing matches. +

+

EXTENSIONS is an alist mapping file extension strings to MIME type +symbols, used for path-based negotiation. Defaults to +%negotiation-extensions. +

+
+ + + + +
+
Procedure: not-found-response OPT: body KEY: #:headers
+

Return a 404 Not Found response. +

+
+ + + + +
+
Procedure: payload-too-large-response OPT: body KEY: #:headers
+

Return a 413 Payload Too Large response. +

+
+ + + + +
+
Procedure: redirect-response path KEY: #:code #:headers
+

Return a redirect response to PATH (a string). +

+
+ + + + +
+
Procedure: scm-alist->streaming-json alist port KEY: #:unicode
+

Write ALIST as a JSON object to PORT, streaming each value as it is +produced. If a value in the alist is a procedure, it is called with +PORT so it can write its own JSON representation directly. Otherwise +the value is serialized via scm->json. +

+
+ + + + +
+
Procedure: set-cookie-header name value KEY: #:path #:domain #:max-age #:secure #:http-only #:expires
+

Return a Set-Cookie header pair suitable for inclusion in a response +headers alist. Wraps (webutils cookie) set-cookie. +

+

Example: (values (build-response #:headers (list (set-cookie-header +"session" token #:path "/" #:http-only #t #:secure #t))) "ok") +

+
+ + + + +
+
Procedure: streaming-json-response thunk KEY: #:code #:headers
+

Return a JSON response whose body is written incrementally by THUNK. +THUNK is a procedure of one argument (the output port). Use +scm-alist->streaming-json and list->streaming-json-array inside THUNK to +write JSON without materializing the entire response in memory. +

+
+ + + + +
+
Procedure: text-response str KEY: #:code #:headers
+

Return a plain text response. STR is the text string to send. +

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

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

+
+

2.12 (safsaf router)

+ + + + + + +
+

2.12.1 Macros

+ + +
+
Macro: compiled-route-handler x
+

Undocumented macro. +

+
+ + + + +
+
Macro: route-group-children x
+

Return the list of child routes and groups of ROUTE-GROUP. +

+
+ + + + +
+
Macro: route-group-name x
+

Return the name of ROUTE-GROUP, or #f if unnamed. +

+
+ + + + +
+
Macro: route-group-prefix x
+

Return the prefix pattern of ROUTE-GROUP. +

+
+ + + + +
+
Macro: route-group? x
+

Return #t if OBJ is a <route-group>. +

+
+ + + + +
+
Macro: route-handler x
+

Return the handler procedure of ROUTE. +

+
+ + + + +
+
Macro: route-method x
+

Return the HTTP method of ROUTE. +

+
+ + + + +
+
Macro: route-name x
+

Return the name of ROUTE, or #f if unnamed. +

+
+ + + + +
+
Macro: route-pattern x
+

Return the URL pattern of ROUTE. +

+
+ + + + +
+
Macro: route? x
+

Return #t if OBJ is a <route>. +

+
+ + + + + +
+
+

2.12.2 Parameters

+ + +
+
Parameter: current-reverse-routes
+

Default value: +

+
#f
+
+
+ + + + +
+
Parameter: current-route-params
+

Default value: +

+
()
+
+
+ + + + + +
+
+

2.12.3 Procedures

+ + +
+
Procedure: compile-routes routes
+

Compile a route tree (route, route-group, or list) into two values: 1. +An ordered list of <compiled-route> records ready for matching. 2. A +<reverse-routes> record for use with path-for. +

+

The last route must be a catch-all (’* pattern with a rest parameter) so +that every request is handled. +

+
+ + + + +
+
Procedure: find-allowed-methods compiled-routes path-segments
+

Scan COMPILED-ROUTES for routes whose path matches PATH-SEGMENTS, +collecting their HTTP methods. The last route (the catch-all) is +excluded. Returns a deduplicated list of method symbols, or ’() if no +route’s path matches. +

+
+ + + + +
+
Procedure: make-route-group prefix KEY: #:name
+

Create an empty route group with PREFIX. Children can be added later +with route-group-add-children!. +

+
+ + + + +
+
Procedure: match-route compiled-routes method path-segments
+

Find the first matching route for METHOD and PATH-SEGMENTS. Returns +(values handler bindings) on match, or (values #f #f) on no match. +

+
+ + + + +
+
Procedure: path-for group name OPT: params KEY: #:query #:fragment #:relative?
+

Generate a URL path for a named route within GROUP. +

+

GROUP is a route-group value. NAME is either a symbol naming a route +within GROUP, or a list of symbols for nested lookup where the last +element is the route name and preceding elements are child group names. +

+

(path-for routes ’users) (path-for routes ’user ’((id . "42"))) +(path-for routes ’(api items) ’((id . "7"))) +

+

PARAMS is an alist mapping capture symbols to string values, or to a +list of strings for rest parameters. +

+

Optional keyword arguments: #:query — alist of query parameters ((key . +value) ...) #:fragment — fragment string (without the leading #) +#:relative? — if #t, omit the leading / +

+
+ + + + +
+
Procedure: route method pattern handler KEY: #:name
+

Create a route. METHOD is a symbol, list of symbols, or ’* for any. +PATTERN is a list of segments: strings (literal), symbols (capture), +two-element lists (predicate capture: (proc name)), with optional dotted +tail (wildcard capture). HANDLER is a procedure (request body-port) -> +(values response body). NAME is an optional symbol used for reverse +routing with path-for. +

+
+ + + + +
+
Procedure: route-group prefix KEY: #:name . children
+

Create a route group. PREFIX is a pattern list (same syntax as route +patterns). CHILDREN is an ordered list of routes and route-groups. NAME +is an optional symbol for nested path-for lookups. +

+
+ + + + +
+
Procedure: route-group-add-children! group new-children
+

Append NEW-CHILDREN to GROUP’s child list. +

+
+ + + + +
+
Procedure: wrap-routes routes . wrappers
+

Apply WRAPPERS to every handler in ROUTES, which may be a route, +route-group, or list of either. Returns a new structure with wrapped +handlers. When multiple wrappers are given, the first wrapper in the +list wraps outermost (runs first on the request, last on the response). +

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

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

+
+

2.13 (safsaf templating)

+ + + + + + +
+

2.13.1 Procedures

+ + +
+
Procedure: streaming-html-response shtml KEY: #:code #:headers #:charset
+

Return an HTML response that streams SHTML to the client. +

+

SHTML is an SHTML tree that may contain procedures. Each procedure is +called as (proc port) during output and should write HTML to the +port. Static parts are rendered via htmlprag. +

+
+
  (streaming-response
+   `(*TOP*
+     (*DECL* DOCTYPE html)
+     (html (head (title "My Page"))
+           (body (h1 "Hello")
+                 ,(lambda (port)
+                    (write-shtml-as-html '(p "dynamic") port))))))
+
+ +
+ + + + +
+
Procedure: write-shtml-as-html/streaming shtml port
+

Write SHTML to PORT, like write-shtml-as-html from htmlprag, but +any procedure encountered in the tree is called as (proc port) +and may write directly to PORT. +

+

This allows mixing static SHTML with dynamic streaming sections: +

+
+
  (write-shtml-as-html/streaming
+   `(html (body (h1 "Title")
+                ,(lambda (port) (display "dynamic" port))
+                (footer "bye")))
+   port)
+
+ +

Static parts are rendered via htmlprag’s shtml->html, then +interleaved with procedure calls at output time. +

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

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

+
+

2.14 (safsaf utils)

+ + + + + + +
+

2.14.1 Procedures

+ + +
+
Procedure: multipart-text-fields parts
+

Extract text fields from multipart PARTS as an alist of (name . value). +File upload parts (those with a filename parameter) are excluded. +

+
+ + + + +
+
Procedure: parse-form-body request body-port
+

Read and parse a URL-encoded form body from REQUEST. Returns an alist +of string key-value pairs. +

+
+ + + + +
+
Procedure: parse-multipart-body request body-port
+

Read and parse a multipart/form-data body from REQUEST. Returns a list +of <part> records from (webutils multipart). Use parts-ref, +parts-ref-string, part-body, etc. to access parts. +

+
+ + + + +
+
Procedure: parse-query-string request
+

Parse the query string from REQUEST. Returns an alist of string +key-value pairs, or ’() if no query string. +

+
+ + + + +
+
Procedure: request-cookie-ref request name OPT: default
+

Return the value of cookie NAME from REQUEST, or DEFAULT if not found. +

+
+ + + + +
+
Procedure: request-cookies request
+

Return the cookies from REQUEST as an alist of (name . value) pairs. +Returns ’() if no Cookie header is present. Importing (webutils cookie) +registers the Cookie header parser with (web http). +

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

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

+
+

Appendix A Version History

+ +
+
Version 0.1
+
    +
  • Initial release. +
  • Built on the code of the Guix Data Serivce, plus other web +services like the Guix Build Coordinator and Nar Herder. +
  • Written using Claude Opus 4.6 using Claude Code. +
+ + +
+
+ + + +
+
+
+
+

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

+
+

Appendix B Copying Information

+ +

Copyright © 2026 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]

+
+

Data Type Index

+ +
Jump to:   < +
+ + + + + + +
Index Entry  Section
<
<invalid-param>: safsaf_params
+
Jump to:   < +
+ + +
+
+
+
+

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

+
+

Procedure Index

+ +
Jump to:   A +   +B +   +C +   +D +   +E +   +F +   +G +   +H +   +I +   +J +   +L +   +M +   +N +   +P +   +R +   +S +   +T +   +W +   +
+ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + +
Index Entry  Section
A
any-invalid-params?: safsaf_params
as-checkbox: safsaf_params
as-integer: safsaf_params
as-matching: safsaf_params
as-number: safsaf_params
as-one-of: safsaf_params
as-predicate: safsaf_params
as-string: safsaf_params
B
bad-request-response: safsaf_response-helpers
build-response/inherit: safsaf_response-helpers
C
compile-routes: safsaf_router
compiled-route-handler: safsaf_router
cors-handler-wrapper: safsaf_handler-wrappers_cors
csrf-handler-wrapper: safsaf_handler-wrappers_csrf
csrf-token-field: safsaf_handler-wrappers_csrf
D
default-method-not-allowed-handler: safsaf
default-render-error: safsaf_handler-wrappers_exceptions
default-render-html: safsaf_handler-wrappers_exceptions
default-render-json: safsaf_handler-wrappers_exceptions
delete-cookie-header: safsaf_response-helpers
E
exceptions-handler-wrapper: safsaf_handler-wrappers_exceptions
F
field-errors: safsaf_params
find-allowed-methods: safsaf_router
forbidden-response: safsaf_response-helpers
G
guard-against-mutually-exclusive-params: safsaf_params
H
html-response: safsaf_response-helpers
I
internal-server-error-response: safsaf_response-helpers
invalid-param-message: safsaf_params
invalid-param-ref: safsaf_params
invalid-param-value: safsaf_params
invalid-param?: safsaf_params
J
json-response: safsaf_response-helpers
L
list->streaming-json-array: safsaf_response-helpers
logging-handler-wrapper: safsaf_handler-wrappers_logging
M
make-exceptions-handler-wrapper: safsaf_handler-wrappers_exceptions
make-invalid-param: safsaf_params
make-max-body-size-handler-wrapper: safsaf_handler-wrappers_max-body-size
make-route-group: safsaf_router
make-session-config: safsaf_handler-wrappers_sessions
make-session-handler-wrapper: safsaf_handler-wrappers_sessions
make-static-handler: safsaf_response-helpers
make-trailing-slash-handler-wrapper: safsaf_handler-wrappers_trailing-slash
match-route: safsaf_router
multipart-text-fields: safsaf_utils
N
negotiate-content-type: safsaf_response-helpers
not-found-response: safsaf_response-helpers
P
params->query-string: safsaf_params
parse-form-body: safsaf_utils
parse-form-params: safsaf_params
parse-multipart-body: safsaf_utils
parse-params: safsaf_params
parse-query-string: safsaf_utils
path-for: safsaf_router
payload-too-large-response: safsaf_response-helpers
R
redirect-response: safsaf_response-helpers
request-cookie-ref: safsaf_utils
request-cookies: safsaf_utils
route: safsaf_router
route-group: safsaf_router
route-group-add-children!: safsaf_router
route-group-children: safsaf_router
route-group-name: safsaf_router
route-group-prefix: safsaf_router
route-group?: safsaf_router
route-handler: safsaf_router
route-method: safsaf_router
route-name: safsaf_router
route-pattern: safsaf_router
route?: safsaf_router
run-safsaf: safsaf
S
scm-alist->streaming-json: safsaf_response-helpers
security-headers-handler-wrapper: safsaf_handler-wrappers_security-headers
session-delete: safsaf_handler-wrappers_sessions
session-handler-wrapper: safsaf_handler-wrappers_sessions
session-set: safsaf_handler-wrappers_sessions
set-cookie-header: safsaf_response-helpers
streaming-html-response: safsaf_templating
streaming-json-response: safsaf_response-helpers
T
text-response: safsaf_response-helpers
trailing-slash-handler-wrapper: safsaf_handler-wrappers_trailing-slash
W
wrap-routes: safsaf_router
write-shtml-as-html/streaming: safsaf_templating
+
Jump to:   A +   +B +   +C +   +D +   +E +   +F +   +G +   +H +   +I +   +J +   +L +   +M +   +N +   +P +   +R +   +S +   +T +   +W +   +
+ + +
+
+
+
+

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

+
+

Variable Index

+ +
Jump to:   C +   +
+ + + + + + + + + +
Index Entry  Section
C
current-csrf-token: safsaf_handler-wrappers_csrf
current-reverse-routes: safsaf_router
current-route-params: safsaf_router
current-session: safsaf_handler-wrappers_sessions
+
Jump to:   C +   +
+ + +
+
+ + + + + diff --git a/doc/logo.svg b/logo.svg similarity index 100% rename from doc/logo.svg rename to logo.svg diff --git a/pre-inst-env.in b/pre-inst-env.in deleted file mode 100644 index 8245438..0000000 --- a/pre-inst-env.in +++ /dev/null @@ -1,29 +0,0 @@ -#!/bin/sh -# Safsaf, a Guile web framework -# Copyright (C) 2026 Christopher Baines -# -# This program 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 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 -# 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 -# . - -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/safsaf.scm b/safsaf.scm deleted file mode 100644 index d2f5b51..0000000 --- a/safsaf.scm +++ /dev/null @@ -1,161 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 (safsaf) - #:use-module (web request) - #:use-module (web response) - #:use-module (web uri) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-71) - #:use-module (fibers) - #:use-module (fibers conditions) - #:use-module (fibers scheduler) - #:use-module (knots) - #:use-module (knots web-server) - #:use-module (safsaf router) - #:export (run-safsaf - default-method-not-allowed-handler)) - -(define (default-method-not-allowed-handler request allowed-methods) - "Return a 405 Method Not Allowed response with an Allow header listing -ALLOWED-METHODS." - (values (build-response - #:code 405 - #:headers `((allow . ,allowed-methods) - (content-type text/plain))) - "Method Not Allowed")) - -(define* (make-handler compiled-routes reverse-routes - #:key - method-not-allowed? - method-not-allowed-handler) - "Build a handler that dispatches to the matching route. -Handler signature: (request body-port) -> (values response body). - -HEAD requests that have no explicit route are automatically handled by -dispatching to the matching GET handler and discarding the response body. - -When METHOD-NOT-ALLOWED? is true, requests whose path matches a route but -whose method does not receive a 405 response via METHOD-NOT-ALLOWED-HANDLER." - (let ((catch-all-handler (compiled-route-handler - (last compiled-routes)))) - - (define (run-handler handler bindings request body-port) - (parameterize ((current-route-params bindings) - (current-reverse-routes reverse-routes)) - (handler request body-port))) - - (define (check-405-or-catch-all handler bindings - path-segments request body-port) - (if method-not-allowed? - (let* ((allowed (find-allowed-methods compiled-routes - path-segments)) - ;; GET implies HEAD via auto-HEAD handling. - (allowed (if (and (memq 'GET allowed) - (not (memq 'HEAD allowed))) - (cons 'HEAD allowed) - allowed))) - (if (null? allowed) - (run-handler handler bindings request body-port) - (method-not-allowed-handler request allowed))) - (run-handler handler bindings request body-port))) - - (lambda (request body-port) - (let* ((method (request-method request)) - (path-segments (split-and-decode-uri-path - (uri-path (request-uri request)))) - (handler bindings (match-route compiled-routes - method path-segments))) - (cond - ;; Direct match — dispatch normally. - ((not (eq? handler catch-all-handler)) - (run-handler handler bindings request body-port)) - - ;; HEAD with no explicit route — try GET, discard body. - ((eq? method 'HEAD) - (let ((get-handler get-bindings - (match-route compiled-routes - 'GET path-segments))) - (if (eq? get-handler catch-all-handler) - ;; No GET route either — 405 or catch-all. - (check-405-or-catch-all handler bindings - path-segments request body-port) - ;; Run GET handler, keep response headers, discard body. - (let ((response _body - (run-handler get-handler get-bindings - request body-port))) - (values response ""))))) - - ;; Catch-all matched — check for 405. - (else - (check-405-or-catch-all handler bindings - path-segments request body-port))))))) - -(define* (run-safsaf routes - #:key - (host #f) - (port 8080) - (method-not-allowed? #t) - (method-not-allowed-handler - default-method-not-allowed-handler) - (connection-buffer-size #f)) - "Start a Safsaf web server. - -ROUTES is a list of routes and route-groups (as returned by component -constructors). The last route must be a catch-all so that every -request is handled. - -HEAD requests are handled automatically: when no explicit HEAD route -matches, the matching GET handler runs and its response body is -discarded. Explicit HEAD routes always take precedence. - -When METHOD-NOT-ALLOWED? is #t (the default), requests that match a -route's path but not its method receive a 405 response with an Allow -header. METHOD-NOT-ALLOWED-HANDLER is a procedure -(request allowed-methods) -> (values response body) that produces the -405 response; the default returns plain text. - -When called outside a Fibers scheduler, sets up a scheduler, starts -the HTTP server, and blocks until Ctrl-C. When called inside an -existing scheduler (e.g. within run-fibers), just starts the HTTP -server and returns immediately — the caller manages the lifecycle." - (let* ((compiled reverse-routes (compile-routes routes)) - (handler (make-handler compiled reverse-routes - #:method-not-allowed? method-not-allowed? - #:method-not-allowed-handler - method-not-allowed-handler))) - (define (start-server) - (apply run-knots-web-server - handler - #:host host - #:port port - #:call-handler-with-body-port? #t - (if connection-buffer-size - (list #:connection-buffer-size connection-buffer-size) - '()))) - - (if (current-scheduler) - ;; Already inside run-fibers — just start the server. - (start-server) - ;; Standalone — manage the full lifecycle. - (run-fibers - (lambda () - (start-server) - (let ((quit-cvar (make-condition))) - (call-with-sigint - (lambda () (wait quit-cvar)) - quit-cvar))))))) diff --git a/safsaf/handler-wrappers/cors.scm b/safsaf/handler-wrappers/cors.scm deleted file mode 100644 index 327a610..0000000 --- a/safsaf/handler-wrappers/cors.scm +++ /dev/null @@ -1,108 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 (safsaf handler-wrappers cors) - #:use-module (ice-9 exceptions) - #:use-module (web request) - #:use-module (web response) - #:use-module (srfi srfi-71) - #:use-module (safsaf response-helpers) - #:export (cors-handler-wrapper)) - -(define* (cors-handler-wrapper handler - #:key - (origins '("*")) - (methods '(GET POST PUT DELETE PATCH)) - (headers '("Content-Type" "Authorization")) - (max-age 86400) - (allow-credentials? #f) - (expose-headers '())) - "Handler wrapper that adds CORS (Cross-Origin Resource Sharing) -headers to responses. - -Browsers enforce the Same-Origin Policy: scripts on one origin -(scheme + host + port) cannot read responses from a different origin. -CORS relaxes this by letting the server declare which origins, methods, -and headers are permitted. - -For ``simple'' requests the browser sends the request and checks the -response headers. For non-simple requests (e.g. PUT/DELETE, custom -headers, or JSON Content-Type) the browser sends a preflight OPTIONS -request first. This wrapper handles both cases. - -ORIGINS is a list of allowed origin strings, or '(\"*\") for any. -METHODS is a list of allowed method symbols. -HEADERS is a list of allowed request header name strings. -MAX-AGE is the preflight cache duration in seconds. -ALLOW-CREDENTIALS? controls whether credentials (cookies, auth) are - allowed cross-origin. Note: cannot be #t when origins is '(\"*\"). -EXPOSE-HEADERS is a list of response header name strings the browser - may read from JavaScript." - (let ((methods-str (string-join (map symbol->string methods) ", ")) - (headers-str (string-join headers ", ")) - (max-age-str (number->string max-age)) - (expose-str (string-join expose-headers ", ")) - (any-origin? (member "*" origins))) - (when (and allow-credentials? any-origin?) - (raise-exception - (make-exception-with-message - "cors-handler-wrapper: allow-credentials? cannot be #t when origins includes \"*\""))) - (define (allowed-origin? request-origin) - (or any-origin? - (member request-origin origins))) - - (define (cors-headers request-origin) - (let* ((origin-val (if any-origin? "*" request-origin)) - (hdrs `((access-control-allow-origin . ,origin-val) - (access-control-allow-methods . ,methods-str) - (access-control-allow-headers . ,headers-str) - (access-control-max-age . ,max-age-str))) - (hdrs (if allow-credentials? - (cons '(access-control-allow-credentials . "true") - hdrs) - hdrs)) - (hdrs (if (string-null? expose-str) - hdrs - (cons `(access-control-expose-headers . ,expose-str) - hdrs)))) - hdrs)) - - (lambda (request body-port) - (let ((request-origin (assoc-ref (request-headers request) 'origin))) - (cond - ;; No Origin header — not a cross-origin request, pass through. - ((not request-origin) - (handler request body-port)) - - ;; Origin not allowed — pass through without CORS headers. - ((not (allowed-origin? request-origin)) - (handler request body-port)) - - ;; Preflight OPTIONS request — respond immediately. - ((eq? (request-method request) 'OPTIONS) - (values (build-response - #:code 204 - #:headers (cors-headers request-origin)) - #f)) - - ;; Normal request from allowed origin — call handler, add headers. - (else - (let ((response body (handler request body-port))) - (values (build-response/inherit response - #:headers (append (cors-headers request-origin) - (response-headers response))) - body)))))))) diff --git a/safsaf/handler-wrappers/csrf.scm b/safsaf/handler-wrappers/csrf.scm deleted file mode 100644 index 17a8795..0000000 --- a/safsaf/handler-wrappers/csrf.scm +++ /dev/null @@ -1,79 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 (safsaf handler-wrappers csrf) - #:use-module (ice-9 format) - #:use-module (rnrs bytevectors) - #:use-module (srfi srfi-71) - #:use-module (gcrypt random) - #:use-module (web response) - #:use-module (webutils cookie) - #:use-module (safsaf response-helpers) - #:use-module (safsaf utils) - #:export (csrf-handler-wrapper - current-csrf-token - csrf-token-field)) - -(define (generate-csrf-token) - "Generate a 32-byte hex-encoded CSRF token." - (let* ((bv (gen-random-bv 32)) - (len (bytevector-length bv))) - (string-concatenate - (map (lambda (i) - (format #f "~2,'0x" (bytevector-u8-ref bv i))) - (iota len))))) - -(define current-csrf-token - (make-parameter #f)) - -(define* (csrf-handler-wrapper handler - #:key - (cookie-name "csrf-token")) - "CSRF token handler wrapper. - -Ensures a CSRF token cookie is present on every response (generates one -if the request has none). The token is bound to current-csrf-token so -handlers and templates can read it via (current-csrf-token). - -Token validation is NOT done here — it belongs in the form processing -layer. Use parse-form-params from (safsaf params), which automatically -checks the submitted token against the cookie token." - (lambda (request body-port) - (let* ((existing-token (request-cookie-ref request cookie-name)) - (token (or existing-token (generate-csrf-token)))) - (let ((response body (parameterize ((current-csrf-token token)) - (handler request body-port)))) - (if existing-token - (values response body) - (values (add-csrf-cookie response token cookie-name) - body)))))) - -(define (add-csrf-cookie response token cookie-name) - "Add a Set-Cookie header for the CSRF token to RESPONSE." - (let ((cookie (set-cookie cookie-name token - #:path "/" - #:extensions '(("SameSite" . "Strict"))))) - (build-response/inherit response - #:headers (append (response-headers response) (list cookie))))) - -(define (csrf-token-field) - "Return an SXML hidden input element for the CSRF token. -Use in forms: @code{(csrf-token-field)} @result{} @code{(input (@@ -(type \"hidden\") ...))}." - `(input (@ (type "hidden") - (name "csrf-token") - (value ,(or (current-csrf-token) ""))))) diff --git a/safsaf/handler-wrappers/exceptions.scm b/safsaf/handler-wrappers/exceptions.scm deleted file mode 100644 index e859804..0000000 --- a/safsaf/handler-wrappers/exceptions.scm +++ /dev/null @@ -1,199 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 (safsaf handler-wrappers exceptions) - #:use-module (ice-9 match) - #:use-module (web request) - #:use-module (web uri) - #:use-module (knots) - #:use-module (logging logger) - #:autoload (json builder) (scm->json-string) - #:use-module (safsaf response-helpers) - #:export (make-exceptions-handler-wrapper - exceptions-handler-wrapper - default-render-error - default-render-html - default-render-json)) - -;;; -;;; HTML pages -;;; - -(define (dev-error-page method path backtrace-string) - "Return an SHTML tree for a development-mode error page." - `(*TOP* - (*DECL* DOCTYPE html) - (html - (head - (title "500 - Internal Server Error") - (style " -body { font-family: monospace; margin: 2em; background: #1a1a2e; color: #e0e0e0; } -h1 { color: #e74c3c; } -.request { color: #a0a0a0; margin-bottom: 1em; } -pre { background: #16213e; padding: 1em; overflow-x: auto; - border-left: 3px solid #e74c3c; white-space: pre-wrap; } -@media (prefers-color-scheme: light) { - body { background: #f8f8f8; color: #1a1a1a; } - .request { color: #555; } - pre { background: #fff; border-left-color: #e74c3c; } -} -")) - (body - (h1 "Internal Server Error") - (p (@ (class "request")) - ,(symbol->string method) " " ,path) - (pre ,backtrace-string))))) - -(define (prod-error-page code message) - "Return an SHTML tree for a production error page." - `(*TOP* - (*DECL* DOCTYPE html) - (html - (head (title ,(string-append (number->string code) " - " message))) - (body - (h1 ,(number->string code)) - (p ,message))))) - -;;; -;;; Default renderers -;;; - -(define (default-render-html request code message backtrace-string dev?) - "Default HTML error renderer. In dev mode, shows a rich backtrace page. -In production, returns a minimal HTML page." - (let ((method (request-method request)) - (path (uri-path (request-uri request)))) - (if dev? - (html-response (dev-error-page method path backtrace-string) - #:code code) - (html-response (prod-error-page code message) - #:code code)))) - -(define (default-render-json _request code message backtrace-string dev?) - "Default JSON error renderer. In dev mode, includes the backtrace. -In production, returns only the error message." - (let ((body (if dev? - (scm->json-string `((error . ,message) - (backtrace . ,backtrace-string))) - (scm->json-string `((error . ,message)))))) - (json-response body #:code code))) - -;;; -;;; Default render-error -;;; - -(define (default-render-error render-html render-json) - "Return a render-error procedure that content-negotiates between -RENDER-HTML and RENDER-JSON based on the request's Accept header." - (lambda (request code message backtrace-string dev?) - (case (negotiate-content-type request '(text/html application/json)) - ((text/html) (render-html request code message backtrace-string dev?)) - (else (render-json request code message backtrace-string dev?))))) - -;;; -;;; Public API -;;; - -(define* (make-exceptions-handler-wrapper #:key - (dev? #f) - (logger #f) - (render-html default-render-html) - (render-json default-render-json) - (render-error - (default-render-error - render-html render-json))) - "Return a handler wrapper that catches exceptions and returns an error -response. See exceptions-handler-wrapper for details." - (lambda (handler) - (exceptions-handler-wrapper handler - #:dev? dev? - #:logger logger - #:render-error render-error))) - -(define* (exceptions-handler-wrapper handler - #:key - (dev? #f) - (logger #f) - (render-html default-render-html) - (render-json default-render-json) - (render-error - (default-render-error - render-html render-json))) - "Handler wrapper that catches exceptions from HANDLER and returns an -error response. - -The response format is content-negotiated from the request's Accept header, -choosing between HTML and JSON. - -When LOGGER is provided, exceptions are logged through it. Otherwise, -the backtrace is written to the current error port. -In dev mode (DEV? is #t), the response includes the backtrace and -exception details. In production mode, a generic error is returned. - -Rendering can be customised at three levels: - - #:render-error — full override. A procedure - (request code message backtrace-string dev?) -> (values response body) - that bypasses content negotiation entirely. - - #:render-html — custom HTML rendering. A procedure with the same - signature, called when content negotiation selects HTML. - - #:render-json — custom JSON rendering. A procedure with the same - signature, called when content negotiation selects JSON. - -The default RENDER-ERROR content-negotiates between RENDER-HTML and -RENDER-JSON. Providing #:render-html or #:render-json replaces just -that format; providing #:render-error replaces the entire rendering." - (lambda (request body-port) - (let ((method (request-method request)) - (path (uri-path (request-uri request)))) - (with-exception-handler - (lambda (exn) - (let ((backtrace-string - (call-with-output-string - (lambda (port) - (print-backtrace-and-exception/knots - exn - #:port port))))) - (if logger - (log-msg logger 'ERROR - method " " path " — unhandled exception:\n" - backtrace-string) - (format/knots (current-error-port) - "~a ~a — unhandled exception:\n~a\n" - method path backtrace-string)) - (render-error request 500 "Internal Server Error" - backtrace-string dev?))) - (lambda () - (with-exception-handler - (lambda (exn) - (let ((stack - (match (fluid-ref %stacks) - ((_ . prompt-tag) - (make-stack #t - 0 prompt-tag - 0 (and prompt-tag 1))) - (_ - (make-stack #t))))) - (raise-exception - (make-exception - exn - (make-knots-exception stack))))) - (lambda () - (start-stack #t (handler request body-port))))) - #:unwind? #t)))) diff --git a/safsaf/handler-wrappers/logging.scm b/safsaf/handler-wrappers/logging.scm deleted file mode 100644 index d863a15..0000000 --- a/safsaf/handler-wrappers/logging.scm +++ /dev/null @@ -1,48 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 (safsaf handler-wrappers logging) - #:use-module (web request) - #:use-module (web response) - #:use-module (web uri) - #:use-module (srfi srfi-71) - #:use-module (logging logger) - #:export (logging-handler-wrapper)) - -(define* (logging-handler-wrapper handler #:key (logger #f) (level 'INFO)) - "Handler wrapper that logs each request and response. - -Logs at LEVEL (default 'INFO) with method, path, status code, and -duration in milliseconds. If LOGGER is given, logs to that logger; -otherwise uses the default logger set via set-default-logger!." - (lambda (request body-port) - (let* ((start (get-internal-real-time)) - (method (request-method request)) - (path (uri-path (request-uri request))) - (response body (handler request body-port)) - (duration-ms (inexact->exact - (round - (* 1000 - (/ (- (get-internal-real-time) start) - internal-time-units-per-second))))) - (code (response-code response))) - (if logger - (log-msg logger level - method " " path " " code " " duration-ms "ms") - (log-msg level - method " " path " " code " " duration-ms "ms")) - (values response body)))) diff --git a/safsaf/handler-wrappers/max-body-size.scm b/safsaf/handler-wrappers/max-body-size.scm deleted file mode 100644 index 1411ca6..0000000 --- a/safsaf/handler-wrappers/max-body-size.scm +++ /dev/null @@ -1,41 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 (safsaf handler-wrappers max-body-size) - #:use-module (safsaf response-helpers) - #:use-module (web request) - #:export (make-max-body-size-handler-wrapper)) - -(define* (make-max-body-size-handler-wrapper max-bytes - #:key - (handler-413 - (lambda (request body-port) - (payload-too-large-response)))) - "Return a handler wrapper that rejects requests whose Content-Length -exceeds MAX-BYTES with a 413 Payload Too Large response. - -HANDLER-413 is a handler (request body-port) -> (values response body) -called when the limit is exceeded; the default returns plain text. - -Note: this checks the Content-Length header only. Chunked transfers -without Content-Length are not limited by this wrapper." - (lambda (handler) - (lambda (request body-port) - (let ((content-length (request-content-length request))) - (if (and content-length (> content-length max-bytes)) - (handler-413 request body-port) - (handler request body-port)))))) diff --git a/safsaf/handler-wrappers/security-headers.scm b/safsaf/handler-wrappers/security-headers.scm deleted file mode 100644 index ca03054..0000000 --- a/safsaf/handler-wrappers/security-headers.scm +++ /dev/null @@ -1,66 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 (safsaf handler-wrappers security-headers) - #:use-module (srfi srfi-71) - #:use-module (web response) - #:use-module (safsaf response-helpers) - #:export (security-headers-handler-wrapper)) - -(define* (security-headers-handler-wrapper handler - #:key - (content-type-options "nosniff") - (frame-options "DENY") - (strict-transport-security #f) - (referrer-policy - "strict-origin-when-cross-origin") - (cross-origin-opener-policy #f) - (permissions-policy #f) - (content-security-policy #f) - (content-security-policy-report-only #f)) - "Handler wrapper that adds security headers to every response. - -All headers are optional and configurable. Pass #f to disable a header. -Defaults: - X-Content-Type-Options: nosniff - X-Frame-Options: DENY - Referrer-Policy: strict-origin-when-cross-origin - -Not set by default (enable explicitly): - Strict-Transport-Security (e.g. \"max-age=63072000; includeSubDomains\") - Cross-Origin-Opener-Policy (e.g. \"same-origin\") - Permissions-Policy (e.g. \"camera=(), microphone=()\") - Content-Security-Policy (e.g. \"default-src 'self'; script-src 'self'\") - Content-Security-Policy-Report-Only — same syntax, for testing policies - without enforcing them" - (let ((security-headers - (filter cdr - `((x-content-type-options . ,content-type-options) - (x-frame-options . ,frame-options) - (strict-transport-security . ,strict-transport-security) - (referrer-policy . ,referrer-policy) - (cross-origin-opener-policy . ,cross-origin-opener-policy) - (permissions-policy . ,permissions-policy) - (content-security-policy . ,content-security-policy) - (content-security-policy-report-only - . ,content-security-policy-report-only))))) - (lambda (request body-port) - (let ((response body (handler request body-port))) - (values (build-response/inherit response - #:headers (append (response-headers response) - security-headers)) - body))))) diff --git a/safsaf/handler-wrappers/sessions.scm b/safsaf/handler-wrappers/sessions.scm deleted file mode 100644 index e0897f6..0000000 --- a/safsaf/handler-wrappers/sessions.scm +++ /dev/null @@ -1,81 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 (safsaf handler-wrappers sessions) - #:use-module (webutils sessions) - #:export (make-session-config - make-session-handler-wrapper - session-handler-wrapper - current-session - session-set - session-delete)) - -(define* (make-session-config secret-key - #:key - (cookie-name "session") - (expire-delta '(30 0 0)) - (algorithm 'sha512)) - "Create a session manager for use with session-handler-wrapper. - -SECRET-KEY is the HMAC signing key (a string). -EXPIRE-DELTA is (days hours minutes), default 30 days. -ALGORITHM is the HMAC algorithm, default sha512." - (make-session-manager secret-key - #:cookie-name cookie-name - #:expire-delta expire-delta - #:algorithm algorithm)) - -(define current-session - (make-parameter #f)) - -(define (make-session-handler-wrapper session-manager) - "Return a handler wrapper that binds session data from SESSION-MANAGER. -See session-handler-wrapper for details." - (lambda (handler) (session-handler-wrapper handler session-manager))) - -(define* (session-handler-wrapper handler session-manager) - "Session handler wrapper using signed cookies via (webutils sessions). - -Reads the session cookie from the request, verifies the HMAC signature, -and binds current-session for the duration of the handler. If no -valid session cookie is present, current-session is #f. - -Handlers read session data via: - (current-session) → session data or #f - -To set or delete the session, handlers include the appropriate header -in their response using session-set and session-delete: - - (redirect-response \"/\" #:headers (list (session-set manager data))) - (redirect-response \"/\" #:headers (list (session-delete manager)))" - (lambda (request body-port) - (let ((data (session-data session-manager request))) - (parameterize ((current-session data)) - (handler request body-port))))) - -(define (session-set session-manager data) - "Return a Set-Cookie header that stores signed DATA in the session cookie. -DATA can be any Scheme value that can be written and read back. -Include in a response headers list: - (redirect-response \"/\" #:headers (list (session-set manager '((user-id . 42)))))" - (set-session session-manager data)) - -(define (session-delete session-manager) - "Return a Set-Cookie header that expires the session cookie. -Include in a response headers list: - (redirect-response \"/\" #:headers (list (session-delete manager)))" - (delete-session session-manager)) diff --git a/safsaf/handler-wrappers/trailing-slash.scm b/safsaf/handler-wrappers/trailing-slash.scm deleted file mode 100644 index 301ce33..0000000 --- a/safsaf/handler-wrappers/trailing-slash.scm +++ /dev/null @@ -1,88 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 (safsaf handler-wrappers trailing-slash) - #:use-module (web request) - #:use-module (web response) - #:use-module (web uri) - #:export (make-trailing-slash-handler-wrapper - trailing-slash-handler-wrapper)) - -(define* (make-trailing-slash-handler-wrapper #:key (mode 'strip) (code 301)) - "Return a handler wrapper that normalizes trailing slashes. - -MODE is either 'strip (default) or 'append: - 'strip — redirect /foo/ to /foo - 'append — redirect /foo to /foo/ - -The root path / is always left alone. - -CODE is the HTTP status code for the redirect (default 301). - -Use with wrap-routes: - (wrap-routes routes (make-trailing-slash-handler-wrapper #:mode 'append))" - (lambda (handler) - (trailing-slash-handler-wrapper handler #:mode mode #:code code))) - -(define* (trailing-slash-handler-wrapper handler - #:key (mode 'strip) (code 301)) - "Handler wrapper that normalizes trailing slashes in request paths. - -MODE is either 'strip (default) or 'append: - 'strip — redirect /foo/ to /foo - 'append — redirect /foo to /foo/ - -The root path / is always left alone. - -CODE is the HTTP status code for the redirect (default 301)." - (lambda (request body-port) - (let* ((uri (request-uri request)) - (path (uri-path uri))) - (cond - ;; Root path — always pass through - ((string=? path "/") - (handler request body-port)) - ;; Strip mode: redirect if path ends with / - ((and (eq? mode 'strip) - (string-suffix? "/" path)) - (let ((new-path (string-trim-right path #\/))) - (redirect request uri - (if (string-null? new-path) "/" new-path) - code))) - ;; Append mode: redirect if path does not end with / - ((and (eq? mode 'append) - (not (string-suffix? "/" path))) - (redirect request uri (string-append path "/") code)) - ;; No normalization needed - (else - (handler request body-port)))))) - -(define (redirect request uri new-path code) - "Build a redirect response to NEW-PATH, preserving query and fragment." - (let* ((query (uri-query uri)) - (fragment (uri-fragment uri)) - (target (string-append new-path - (if query - (string-append "?" query) - "") - (if fragment - (string-append "#" fragment) - "")))) - (values (build-response - #:code code - #:headers `((location . ,(string->uri-reference target)))) - ""))) diff --git a/safsaf/params.scm b/safsaf/params.scm deleted file mode 100644 index 5c90b3f..0000000 --- a/safsaf/params.scm +++ /dev/null @@ -1,317 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 (safsaf params) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9 gnu) - #:use-module (web uri) - #:autoload (safsaf handler-wrappers csrf) (current-csrf-token) - #:export ( - make-invalid-param - invalid-param? - invalid-param-value - invalid-param-message - - parse-params - parse-form-params - any-invalid-params? - invalid-param-ref - field-errors - params->query-string - guard-against-mutually-exclusive-params - - ;; Built-in processors - as-string - as-integer - as-number - as-checkbox - as-one-of - as-matching - as-predicate)) - -;;; -;;; Error record — appears inline as a value in the result alist -;;; - -(define-immutable-record-type - (make-invalid-param value message) - invalid-param? - (value invalid-param-value) - (message invalid-param-message)) - -;;; -;;; Built-in processors -;;; -;;; A processor is a procedure: string → value | . -;;; It both validates and transforms the input string. -;;; - -(define as-string identity) - -(define (as-integer s) - (let ((n (string->number s))) - (if (and n (exact-integer? n)) - n - (make-invalid-param s "Must be a whole number")))) - -(define (as-number s) - (let ((n (string->number s))) - (if n - n - (make-invalid-param s "Must be a number")))) - -(define (as-checkbox s) - (string=? s "on")) - -(define* (as-one-of choices #:key (message #f)) - "Return a processor that accepts only values in CHOICES (a list of strings)." - (lambda (s) - (if (member s choices) - s - (make-invalid-param - s (or message - (string-append "Must be one of: " - (string-join choices ", "))))))) - -(define* (as-matching regex #:key (message "Invalid format")) - "Return a processor that accepts values matching REGEX." - (let ((rx (if (string? regex) (make-regexp regex) regex))) - (lambda (s) - (if (regexp-exec rx s) - s - (make-invalid-param s message))))) - -(define* (as-predicate pred #:key (message "Invalid value")) - "Return a processor that accepts values for which PRED returns true." - (lambda (s) - (if (pred s) - s - (make-invalid-param s message)))) - -;;; -;;; Core parsing -;;; - -(define (parse-params param-specs raw-params) - "Parse and transform parameters from RAW-PARAMS according to PARAM-SPECS. - -RAW-PARAMS is an alist of (string . string) pairs, as returned by -parse-query-string or parse-form-body. - -PARAM-SPECS is a list of specifications. Each spec is a list whose first -element is the parameter name (a symbol), second is a processor procedure -(string -> value | ), and the rest are keyword options: - - (name processor) ; optional - (name processor #:required) ; must be present - (name processor #:default value) ; fallback - (name processor #:multi-value) ; collect all occurrences - (name processor #:multi-value #:default value) ; multi-value with fallback - (name processor #:no-default-when (fields) #:default value) ; conditional default - -Returns an alist of (symbol . value) pairs. Values that fail validation -appear as records inline. Missing optional params without -defaults are omitted." - (let ((sym-params (map (match-lambda - ((name . value) - (cons (if (symbol? name) name (string->symbol name)) - value))) - raw-params))) - (filter-map - (match-lambda - ((name processor) - (match (assq name sym-params) - (#f #f) - ((_ . "") #f) - ((_ . value) (cons name (processor value))))) - - ((name processor #:required) - (match (assq name sym-params) - (#f (cons name (make-invalid-param #f "This field is required"))) - ((_ . "") (cons name (make-invalid-param "" "This field is required"))) - ((_ . value) (cons name (processor value))))) - - ((name processor #:multi-value) - (match (filter-map - (match-lambda - ((k . value) - (and (eq? k name) - (match value - (#f #f) - ("" #f) - (v (processor v)))))) - sym-params) - (() #f) - (x (cons name x)))) - - ((name processor #:multi-value #:default default) - (match (filter-map - (match-lambda - ((k . value) - (and (eq? k name) - (match value - (#f #f) - ("" #f) - (v (processor v)))))) - sym-params) - (() (cons name default)) - (x (cons name x)))) - - ((name processor #:no-default-when fields #:default default) - (let ((use-default? - (every (lambda (field) - (not (assq field sym-params))) - fields))) - (match (assq name sym-params) - (#f (if use-default? - (cons name default) - #f)) - ((_ . "") (if use-default? - (cons name default) - #f)) - ((_ . value) (cons name (processor value)))))) - - ((name processor #:default default) - (match (assq name sym-params) - (#f (cons name default)) - ((_ . "") (cons name default)) - ((_ . value) (cons name (processor value)))))) - param-specs))) - -;;; -;;; CSRF integration -;;; - -(define (csrf-processor s) - (let ((expected (current-csrf-token))) - (if (and expected s (string? s) (string=? s expected)) - #t - (make-invalid-param s "Invalid CSRF token")))) - -(define* (parse-form-params param-specs raw-params - #:key (csrf-field 'csrf-token)) - "Like parse-params but prepends a CSRF token check. -Uses current-csrf-token from (safsaf handler-wrappers csrf)." - (parse-params (cons (list csrf-field csrf-processor #:required) - param-specs) - raw-params)) - -;;; -;;; Result inspection -;;; - -(define (any-invalid-params? parsed-params) - "Return #t if any values in PARSED-PARAMS are invalid." - (any (match-lambda - ((_ . value) - (if (list? value) - (any invalid-param? value) - (invalid-param? value)))) - parsed-params)) - -(define (invalid-param-ref parsed-params name) - "Return the record for NAME, or #f if valid or absent." - (let ((v (assq-ref parsed-params name))) - (and (invalid-param? v) v))) - -(define (field-errors parsed-params name) - "Return a list of error message strings for NAME, or '(). -Convenient for rendering form fields with per-field errors." - (let ((v (assq-ref parsed-params name))) - (cond - ((invalid-param? v) - (let ((msg (invalid-param-message v))) - (if msg (list msg) '()))) - ((and (list? v) (any invalid-param? v)) - (filter-map (lambda (x) - (and (invalid-param? x) (invalid-param-message x))) - v)) - (else '())))) - -;;; -;;; Mutual exclusion -;;; - -(define (guard-against-mutually-exclusive-params parsed-params groups) - "Check PARSED-PARAMS for mutually exclusive parameter groups. -GROUPS is a list of lists of symbols, e.g. '((limit_results all_results)). -If parameters from the same group co-occur, the later ones are replaced -with records." - (map (match-lambda - ((name . value) - (if (invalid-param? value) - (cons name value) - (or - (any (lambda (group) - (if (memq name group) - (let ((other-names - (filter (lambda (other-name) - (and (not (eq? name other-name)) - (assq other-name parsed-params))) - group))) - (if (not (null? other-names)) - (cons - name - (make-invalid-param - value - (string-append - "cannot be specified along with " - (string-join (map symbol->string - other-names) - ", ")))) - #f)) - #f)) - groups) - (cons name value))))) - parsed-params)) - -;;; -;;; Serialization -;;; - -(define (params->query-string parsed-params) - "Serialize PARSED-PARAMS back to a URI query string. -Skips invalid params. Handles multi-value (list) entries. -Useful for building pagination links that preserve current filters." - (define (value->text value) - (cond - ((eq? value #f) "") - ((eq? value #t) "on") - ((number? value) (number->string value)) - ((string? value) value) - (else (object->string value)))) - - (string-join - (append-map - (match-lambda - ((_ . (? invalid-param?)) '()) - ((key . value) - (if (list? value) - (filter-map - (lambda (v) - (if (invalid-param? v) - #f - (string-append (uri-encode (symbol->string key)) - "=" - (uri-encode (value->text v))))) - value) - (list (string-append (uri-encode (symbol->string key)) - "=" - (uri-encode (value->text value))))))) - parsed-params) - "&")) diff --git a/safsaf/response-helpers.scm b/safsaf/response-helpers.scm deleted file mode 100644 index 3846b0d..0000000 --- a/safsaf/response-helpers.scm +++ /dev/null @@ -1,370 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 (safsaf response-helpers) - #:use-module (ice-9 match) - #:use-module (web request) - #:use-module (web response) - #:use-module (web uri) - #:use-module (srfi srfi-1) - #:use-module (htmlprag) - #:autoload (ice-9 binary-ports) (get-bytevector-n put-bytevector) - #:autoload (ice-9 textual-ports) (put-string) - #:autoload (srfi srfi-19) (current-time time-utc->date make-time time-utc - date->time-utc time<=?) - #:autoload (json builder) (scm->json) - #:autoload (webutils cookie) (set-cookie delete-cookie) - #:use-module (safsaf router) - #:export (build-response/inherit - negotiate-content-type - html-response - redirect-response - json-response - streaming-json-response - scm-alist->streaming-json - list->streaming-json-array - text-response - not-found-response - forbidden-response - bad-request-response - payload-too-large-response - internal-server-error-response - set-cookie-header - delete-cookie-header - make-static-handler)) - -;;; -;;; Response rebuilding -;;; - -(define* (build-response/inherit response #:key - (headers (response-headers response))) - "Build a new response based on RESPONSE, preserving its version, status -code, and reason phrase. HEADERS defaults to the existing headers; -override it to modify them. - -Use this in handler wrappers that need to adjust headers on an inner -handler's response without losing any response fields." - (build-response - #:version (response-version response) - #:code (response-code response) - #:reason-phrase (response-reason-phrase response) - #:headers headers)) - -;;; -;;; Content negotiation -;;; - -(define %negotiation-extensions - '(("json" . application/json) - ("html" . text/html) - ("txt" . text/plain))) - -(define (path-extension request) - "Return the file extension of the last segment of REQUEST's URI path, -or #f if there is none." - (let* ((path (uri-path (request-uri request))) - (segments (split-and-decode-uri-path path))) - (and (pair? segments) - (let* ((last-seg (last segments)) - (dot (string-rindex last-seg #\.))) - (and dot (substring last-seg (1+ dot))))))) - -(define* (negotiate-content-type request - #:optional - (supported '(text/html application/json)) - #:key - (extensions %negotiation-extensions)) - "Return the most appropriate MIME type symbol for REQUEST from SUPPORTED. - -Checks the URL path extension first (.json, .html, .txt) — if present and -the implied type is in SUPPORTED, it wins. Otherwise, walks the Accept -header and returns the first type that appears in SUPPORTED. Falls back -to the first element of SUPPORTED if nothing matches. - -EXTENSIONS is an alist mapping file extension strings to MIME type symbols, -used for path-based negotiation. Defaults to %negotiation-extensions." - (let* ((ext (path-extension request)) - (ext-type (and ext (assoc-ref extensions - (string-downcase ext)))) - (accept-types (map car (request-accept request))) - (preferred (if ext-type - (cons ext-type accept-types) - accept-types))) - (or (find (lambda (type) (memq type supported)) - preferred) - (first supported)))) - -;;; -;;; Response helpers -;;; - -(define* (html-response shtml #:key (code 200) (headers '()) (charset "utf-8")) - "Return an HTML response by streaming SHTML to the client. -SHTML is an SXML/SHTML tree as accepted by write-shtml-as-html. -CHARSET defaults to \"utf-8\"." - (values (build-response - #:code code - #:headers (append `((content-type text/html (charset . ,charset))) headers)) - (lambda (port) - (write-shtml-as-html shtml port)))) - -(define* (redirect-response path #:key (code 303) (headers '())) - "Return a redirect response to PATH (a string)." - (values (build-response - #:code code - #:headers (append `((location . ,(string->uri-reference path))) - headers)) - "")) - -(define* (json-response str #:key (code 200) (headers '())) - "Return a JSON response. STR is the JSON string to send." - (values (build-response - #:code code - #:headers (append '((content-type application/json)) headers)) - str)) - -;; Charset? -(define* (streaming-json-response thunk #:key (code 200) (headers '())) - "Return a JSON response whose body is written incrementally by THUNK. -THUNK is a procedure of one argument (the output port). Use -scm-alist->streaming-json and list->streaming-json-array inside THUNK -to write JSON without materializing the entire response in memory." - (values (build-response - #:code code - #:headers (append '((content-type application/json)) headers)) - (lambda (port) - (thunk port)))) - -(define* (scm-alist->streaming-json alist port #:key (unicode #t)) - "Write ALIST as a JSON object to PORT, streaming each value as it is -produced. If a value in the alist is a procedure, it is called with PORT -so it can write its own JSON representation directly. Otherwise the value -is serialized via scm->json." - (put-string port "{") - (pair-for-each - (lambda (pair) - (match (car pair) - ((k . v) - (scm->json (if (string? k) k (symbol->string k)) port) - (put-string port ":") - (if (procedure? v) - (v port) - (scm->json v port #:unicode unicode)))) - (unless (null? (cdr pair)) - (put-string port ","))) - alist) - (put-string port "}")) - -(define* (list->streaming-json-array proc lst port #:key (unicode #t)) - "Write LST as a JSON array to PORT, applying PROC to each element to -produce a JSON-serializable value. Each element is written individually -via scm->json so the entire array need not be held in memory." - (put-string port "[") - (pair-for-each - (lambda (pair) - (scm->json (proc (car pair)) port #:unicode unicode) - (unless (null? (cdr pair)) - (put-string port ","))) - lst) - (put-string port "]")) - -;; Charset? -(define* (text-response str #:key (code 200) (headers '())) - "Return a plain text response. STR is the text string to send." - (values (build-response - #:code code - #:headers (append '((content-type text/plain)) headers)) - str)) - -(define* (not-found-response #:optional (body "Not Found") #:key (headers '())) - "Return a 404 Not Found response." - (values (build-response - #:code 404 - #:headers (append '((content-type text/plain)) headers)) - body)) - -(define* (forbidden-response #:optional (body "Forbidden") #:key (headers '())) - "Return a 403 Forbidden response." - (values (build-response - #:code 403 - #:headers (append '((content-type text/plain)) headers)) - body)) - -(define* (bad-request-response #:optional (body "Bad Request") #:key (headers '())) - "Return a 400 Bad Request response." - (values (build-response - #:code 400 - #:headers (append '((content-type text/plain)) headers)) - body)) - -(define* (payload-too-large-response #:optional (body "Payload Too Large") - #:key (headers '())) - "Return a 413 Payload Too Large response." - (values (build-response - #:code 413 - #:headers (append '((content-type text/plain)) headers)) - body)) - -(define* (internal-server-error-response #:optional (body "Internal Server Error") - #:key (headers '())) - "Return a 500 Internal Server Error response." - (values (build-response - #:code 500 - #:headers (append '((content-type text/plain)) headers)) - body)) - -;;; -;;; Cookie helpers -;;; - -(define* (set-cookie-header name value - #:key path domain max-age - secure http-only expires) - "Return a Set-Cookie header pair suitable for inclusion in a -response headers alist. Wraps (webutils cookie) set-cookie. - -Example: - (values (build-response #:headers (list (set-cookie-header \"session\" token - #:path \"/\" #:http-only #t - #:secure #t))) - \"ok\")" - (set-cookie name value - #:path path #:domain domain - #:max-age max-age #:secure secure - #:http-only http-only #:expires expires)) - -(define (delete-cookie-header name) - "Return a Set-Cookie header pair that expires cookie NAME. -Wraps (webutils cookie) delete-cookie." - (delete-cookie name)) - -;;; -;;; Static file serving -;;; - -(define %mime-types - '(("html" . (text/html)) - ("htm" . (text/html)) - ("css" . (text/css)) - ("js" . (application/javascript)) - ("json" . (application/json)) - ("xml" . (application/xml)) - ("svg" . (image/svg+xml)) - ("png" . (image/png)) - ("jpg" . (image/jpeg)) - ("jpeg" . (image/jpeg)) - ("gif" . (image/gif)) - ("webp" . (image/webp)) - ("ico" . (image/x-icon)) - ("woff" . (font/woff)) - ("woff2" . (font/woff2)) - ("ttf" . (font/ttf)) - ("otf" . (font/otf)) - ("pdf" . (application/pdf)) - ("txt" . (text/plain)) - ("csv" . (text/csv)) - ("wasm" . (application/wasm)))) - -(define (file-extension path) - "Return the file extension of PATH (without the dot), or #f." - (let ((dot (string-rindex path #\.))) - (and dot (substring path (1+ dot))))) - -(define (extension->content-type ext) - "Return a content-type value for file extension EXT, or -application/octet-stream as default." - (or (and ext (assoc-ref %mime-types (string-downcase ext))) - '(application/octet-stream))) - -(define (path-safe? segments) - "Return #t if the path segments contain no traversal attempts." - (not (member ".." segments))) - -(define (mtime->date mtime) - "Convert a Unix timestamp to an SRFI-19 date in UTC." - (time-utc->date (make-time time-utc 0 mtime) 0)) - -(define* (make-static-handler root-dir #:key (cache-control #f)) - "Return a handler that serves static files from ROOT-DIR. - -The handler expects route params to contain a wildcard capture (the -file path segments). Use with a wildcard route: - - (route 'GET '(. path) (make-static-handler \"/path/to/public\")) - -Supports If-Modified-Since for 304 responses. CACHE-CONTROL, if -given, is a Cache-Control value in Guile's header format — an alist, -e.g. '((max-age . 3600)) or '((no-cache)). - -Works with /gnu/store paths: files with a very low mtime (as produced -by the store's timestamp normalization) use the process start time as -Last-Modified instead, so that conditional requests behave sensibly." - (let ((root (if (string-suffix? "/" root-dir) - (substring root-dir 0 (1- (string-length root-dir))) - root-dir)) - (start-date (time-utc->date (current-time time-utc) 0))) - (lambda (request body-port) - (let* ((params (current-route-params)) - (segments (assoc-ref params 'path))) - (cond - ;; No path captured or traversal attempt. - ((or (not segments) (null? segments) (not (path-safe? segments))) - (not-found-response)) - - (else - (let* ((file-path (string-append root "/" - (string-join segments "/"))) - (st (catch 'system-error - (lambda () (stat file-path)) - (lambda _ #f)))) - (if (and st (eq? 'regular (stat:type st))) - (let* ((mtime (stat:mtime st)) - (mtime-date (if (<= mtime 1) - start-date - (mtime->date mtime))) - (ims (assoc-ref (request-headers request) - 'if-modified-since)) - (ext (file-extension file-path)) - (content-type (extension->content-type ext)) - (not-modified? - (and ims - (catch #t - (lambda () - (time<=? (date->time-utc mtime-date) - (date->time-utc ims))) - (lambda _ #f))))) - (if not-modified? - ;; Not modified. - (values (build-response #:code 304) #f) - ;; Serve the file. - (let ((hdrs `((content-type . ,content-type) - (last-modified . ,mtime-date) - ,@(if cache-control - `((cache-control . ,cache-control)) - '())))) - (values (build-response #:code 200 #:headers hdrs) - (lambda (port) - (call-with-input-file file-path - (lambda (in) - (let loop () - (let ((buf (get-bytevector-n in 8192))) - (unless (eof-object? buf) - (put-bytevector port buf) - (loop))))))))))) - ;; File not found or not a regular file. - (not-found-response))))))))) diff --git a/safsaf/router.scm b/safsaf/router.scm deleted file mode 100644 index 7332c7c..0000000 --- a/safsaf/router.scm +++ /dev/null @@ -1,650 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 (safsaf router) - #:use-module (ice-9 match) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-71) - #:use-module (web uri) - #:export (route - route? - route-method - route-pattern - route-handler - route-name - - route-group - make-route-group - route-group? - route-group-prefix - route-group-children - route-group-add-children! - route-group-name - - wrap-routes - - current-route-params - current-reverse-routes - - compile-routes - match-route - compiled-route-handler - find-allowed-methods - - path-for)) - -(define current-route-params - (make-parameter '())) - -(set-procedure-property! current-route-params 'documentation - "Alist of matched route parameter bindings for the current request. -Each entry is @code{(name . value)} where @var{name} is the capture -symbol from the route pattern.") - -(define current-reverse-routes - (make-parameter #f)) - -(set-procedure-property! current-reverse-routes 'documentation - "The reverse-routes table for the current server, used by -@code{path-for} to generate URLs from route names.") - -;;; -;;; Route and route-group records -;;; - -(define-record-type - (%make-route method pattern handler name) - route? - (method route-method) - (pattern route-pattern) - (handler route-handler set-route-handler!) - (name route-name)) - -(define-record-type - (%make-route-group prefix children name) - route-group? - (prefix route-group-prefix) - (children route-group-children set-route-group-children!) - (name route-group-name)) - -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'route?)) - 'documentation - "Return @code{#t} if OBJ is a @code{}.") - -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'route-method)) - 'documentation - "Return the HTTP method of ROUTE.") - -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'route-pattern)) - 'documentation - "Return the URL pattern of ROUTE.") - -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'route-handler)) - 'documentation - "Return the handler procedure of ROUTE.") - -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'route-name)) - 'documentation - "Return the name of ROUTE, or @code{#f} if unnamed.") - -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'route-group?)) - 'documentation - "Return @code{#t} if OBJ is a @code{}.") - -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'route-group-prefix)) - 'documentation - "Return the prefix pattern of ROUTE-GROUP.") - -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'route-group-children)) - 'documentation - "Return the list of child routes and groups of ROUTE-GROUP.") - -(set-procedure-property! - (macro-transformer (module-ref (current-module) 'route-group-name)) - 'documentation - "Return the name of ROUTE-GROUP, or @code{#f} if unnamed.") - -(define* (make-route-group prefix #:key (name #f)) - "Create an empty route group with PREFIX. Children can be added later -with route-group-add-children!." - (%make-route-group prefix '() name)) - -(define (route-group-add-children! group new-children) - "Append NEW-CHILDREN to GROUP's child list." - (set-route-group-children! group - (append (route-group-children group) - new-children))) - -(define* (route method pattern handler #:key (name #f)) - "Create a route. METHOD is a symbol, list of symbols, or '* for any. -PATTERN is a list of segments: strings (literal), symbols (capture), -two-element lists (predicate capture: (proc name)), with optional -dotted tail (wildcard capture). -HANDLER is a procedure (request body-port) -> (values response body). -NAME is an optional symbol used for reverse routing with path-for." - (%make-route method pattern handler name)) - -(define* (route-group prefix #:key (name #f) #:rest children) - "Create a route group. PREFIX is a pattern list (same syntax as route -patterns). CHILDREN is an ordered list of routes and route-groups. -NAME is an optional symbol for nested path-for lookups." - (let ((filtered-children (filter (lambda (child) - (not (keyword? child))) - (strip-keyword-args children)))) - (%make-route-group prefix filtered-children name))) - -(define (strip-keyword-args args) - "Remove #:key value pairs from ARGS, returning the positional rest." - (let loop ((args args) - (acc '())) - (cond - ((null? args) - (reverse acc)) - ((keyword? (car args)) - ;; Skip the keyword and its value - (loop (if (and (pair? (cdr args)) - (not (keyword? (cadr args)))) - (cddr args) - (cdr args)) - acc)) - (else - (loop (cdr args) (cons (car args) acc)))))) - -;;; -;;; Applying a handler wrapper across a route tree -;;; - -(define (wrap-routes routes . wrappers) - "Apply WRAPPERS to every handler in ROUTES, which may be a route, -route-group, or list of either. Returns a new structure with wrapped -handlers. When multiple wrappers are given, the first wrapper in the -list wraps outermost (runs first on the request, last on the response)." - (let ((composed (compose-wrappers wrappers))) - (apply-wrapper routes composed))) - -(define (compose-wrappers wrappers) - "Compose WRAPPERS into a single (handler -> handler) procedure. -The first wrapper in the list wraps outermost." - (lambda (handler) - (fold (lambda (w h) (w h)) handler (reverse wrappers)))) - -(define (apply-wrapper routes wrapper) - "Apply a single WRAPPER to every handler in ROUTES. -Mutates route handlers and route-group children in place so that the -original objects preserve their eq? identity for path-for lookups." - (cond - ((route? routes) - (set-route-handler! routes (wrapper (route-handler routes))) - routes) - ((route-group? routes) - (for-each (lambda (child) (apply-wrapper child wrapper)) - (route-group-children routes)) - routes) - ((list? routes) - (for-each (lambda (child) (apply-wrapper child wrapper)) - routes) - routes) - (else - (error "wrap-routes: expected route, route-group, or list" routes)))) - -;;; -;;; Pattern compilation and flattening -;;; - -;; A compiled route is a flat, optimised representation for matching. -(define-record-type - (make-compiled-route method method-pred segments has-rest? rest-name handler) - compiled-route? - (method compiled-route-method) - (method-pred compiled-route-method-pred) - (segments compiled-route-segments) - (has-rest? compiled-route-has-rest?) - (rest-name compiled-route-rest-name) - (handler compiled-route-handler)) - -;; A compiled segment is one of: -;; (literal . "string") — exact match -;; (capture . symbol) — match any, bind to symbol -;; (capture-predicate name . proc) — match if (proc segment) is true, bind to name - -(define (compile-pattern-segments pattern) - "Compile a route pattern into a list of compiled segments and a rest flag. -Returns (values segments has-rest? rest-name)." - (let loop ((pat pattern) - (acc '())) - (cond - ;; End of proper list - ((null? pat) - (values (reverse acc) #f #f)) - ;; Dotted tail — wildcard capture - ((symbol? pat) - (values (reverse acc) #t pat)) - ;; Pair — process the car - ((pair? pat) - (let ((seg (car pat))) - (loop (cdr pat) - (cons (compile-segment seg) acc)))) - (else - (error "compile-pattern-segments: invalid pattern element" pat))))) - -(define (compile-segment seg) - "Compile a single pattern segment into a tagged pair. -SEG is one of: a string (literal), a symbol (capture), or a two-element -list (predicate capture) where the first element is a procedure and the -second is a symbol name to bind the matched value to." - (cond - ((string? seg) (cons 'literal seg)) - ((symbol? seg) (cons 'capture seg)) - ((and (pair? seg) (procedure? (car seg)) (pair? (cdr seg)) - (symbol? (cadr seg)) (null? (cddr seg))) - (cons 'capture-predicate (cons (cadr seg) (car seg)))) - (else - (error "compile-segment: invalid segment — expected string, symbol, \ -or (predicate name) list" seg)))) - -(define (append-patterns prefix suffix) - "Append two patterns, handling dotted tails correctly. -A dotted tail in PREFIX is an error (group prefixes must not have rest params)." - (let loop ((pat prefix)) - (cond - ((null? pat) suffix) - ((pair? pat) (cons (car pat) (loop (cdr pat)))) - (else - (error "append-patterns: route-group prefix must not have a rest param" - prefix))))) - -(define (catch-all-route? cr) - "Return #t if CR is a compiled route that matches any method and any path." - (and (eq? (compiled-route-method cr) '*) - (null? (compiled-route-segments cr)) - (compiled-route-has-rest? cr))) - -;;; The reverse-routes structure holds two tables: -;;; -;;; group-table: maps route-group identity tokens to scope records. -;;; Each scope contains a local alist of (route-name . full-pattern) -;;; and a children alist of (group-name . identity) for nested lookups. - -(define-record-type - (make-reverse-routes group-table) - reverse-routes? - (group-table reverse-routes-group-table)) - -(define-record-type - (make-group-scope routes children) - group-scope? - (routes group-scope-routes) - (children group-scope-children)) - -(define (compile-routes routes) - "Compile a route tree (route, route-group, or list) into two values: -1. An ordered list of records ready for matching. -2. A record for use with path-for. - -The last route must be a catch-all ('* pattern with a rest parameter) -so that every request is handled." - ;; group-table: alist of (route-group . ), keyed by eq? - (define group-table '()) - - (define (register-group! group local-routes child-groups) - "Add a group scope to the group table, keyed by the route-group object." - (set! group-table - (cons (cons group (make-group-scope local-routes - child-groups)) - group-table))) - - (define (flatten entry prefix) - "Flatten ENTRY into compiled routes, collecting reverse-routing data. -Returns (values compiled-routes local-named-routes local-child-groups)." - (cond - ((route? entry) - (let ((full-pattern (append-patterns prefix (route-pattern entry)))) - (let ((local-routes - (if (route-name entry) - (list (cons (route-name entry) full-pattern)) - '()))) - (let ((segments has-rest? rest-name - (compile-pattern-segments full-pattern))) - (values - (list (make-compiled-route - (route-method entry) - (compile-method (route-method entry)) - segments has-rest? rest-name - (route-handler entry))) - local-routes - '()))))) - - ((route-group? entry) - (let ((new-prefix (append-patterns prefix - (route-group-prefix entry)))) - (let ((compiled local-routes local-children - (flatten-children (route-group-children entry) - new-prefix))) - ;; Register this group's scope. - (register-group! entry local-routes local-children) - ;; Bubble up: our local routes become parent's local routes, - ;; and we add ourselves as a named child if we have a name. - (let ((child-entry - (if (route-group-name entry) - (list (cons (route-group-name entry) entry)) - '()))) - (values compiled local-routes - (append child-entry local-children)))))) - - ((list? entry) - (flatten-children entry prefix)) - - (else - (error "compile-routes: expected route, route-group, or list" entry)))) - - (define (flatten-children children prefix) - "Flatten a list of children, merging their results. -Returns (values compiled-routes local-routes child-groups)." - (let loop ((children children) - (compiled-acc '()) - (routes-acc '()) - (children-acc '())) - (if (null? children) - (values (reverse compiled-acc) routes-acc children-acc) - (let ((compiled local-routes local-children - (flatten (car children) prefix))) - (loop (cdr children) - (append (reverse compiled) compiled-acc) - (append routes-acc local-routes) - (append children-acc local-children)))))) - - (let ((compiled _local-routes _local-children (flatten routes '()))) - (when (or (null? compiled) - (not (catch-all-route? (last compiled)))) - (error "compile-routes: last route must be a catch-all (* method, rest pattern)")) - (values compiled - (make-reverse-routes group-table)))) - -;;; -;;; Method matching -;;; - -(define (compile-method method) - "Return a predicate that tests whether a request method matches." - (cond - ((eq? method '*) (lambda (_) #t)) - ((symbol? method) (lambda (m) (eq? m method))) - ((list? method) (lambda (m) (memq m method))) - (else - (error "compile-method: invalid method spec" method)))) - -;;; -;;; Route matching -;;; - -(define (match-segments compiled-segs path-segs has-rest? rest-name) - "Try to match COMPILED-SEGS against PATH-SEGS. -Returns an alist of bindings on success, or #f on failure." - (let loop ((segs compiled-segs) - (path path-segs) - (bindings '())) - (cond - ;; Both exhausted — exact match - ((and (null? segs) (null? path)) - bindings) - ;; Pattern exhausted but path remains — check for rest capture - ((null? segs) - (if has-rest? - (acons rest-name path bindings) - #f)) - ;; Path exhausted but pattern remains — no match - ((null? path) - #f) - ;; Match current segment - (else - (let ((seg (car segs)) - (path-seg (car path))) - (case (car seg) - ((literal) - (if (string=? (cdr seg) path-seg) - (loop (cdr segs) (cdr path) bindings) - #f)) - ((capture) - (loop (cdr segs) (cdr path) - (acons (cdr seg) path-seg bindings))) - ((capture-predicate) - (let ((name (cadr seg)) - (pred (cddr seg))) - (if (pred path-seg) - (loop (cdr segs) (cdr path) - (acons name path-seg bindings)) - #f))) - (else - (error "match-segments: unknown segment type" (car seg))))))))) - -(define (match-route compiled-routes method path-segments) - "Find the first matching route for METHOD and PATH-SEGMENTS. -Returns (values handler bindings) on match, or (values #f #f) on no match." - (let loop ((routes compiled-routes)) - (if (null? routes) - (values #f #f) - (let* ((cr (car routes)) - (bindings (and ((compiled-route-method-pred cr) method) - (match-segments - (compiled-route-segments cr) - path-segments - (compiled-route-has-rest? cr) - (compiled-route-rest-name cr))))) - (if bindings - (values (compiled-route-handler cr) bindings) - (loop (cdr routes))))))) - -(define (find-allowed-methods compiled-routes path-segments) - "Scan COMPILED-ROUTES for routes whose path matches PATH-SEGMENTS, -collecting their HTTP methods. The last route (the catch-all) is excluded. -Returns a deduplicated list of method symbols, or '() if no route's path -matches." - (let loop ((routes (drop-right compiled-routes 1)) - (methods '())) - (if (null? routes) - methods - (let* ((cr (car routes)) - (bindings (match-segments - (compiled-route-segments cr) - path-segments - (compiled-route-has-rest? cr) - (compiled-route-rest-name cr)))) - (if bindings - (loop (cdr routes) - (adjoin-methods (compiled-route-method cr) methods)) - (loop (cdr routes) methods)))))) - -(define (adjoin-methods method-spec methods) - "Add methods from METHOD-SPEC to METHODS list, avoiding duplicates." - (cond - ((eq? method-spec '*) methods) - ((symbol? method-spec) - (if (memq method-spec methods) methods (cons method-spec methods))) - ((list? method-spec) - (fold (lambda (m acc) (if (memq m acc) acc (cons m acc))) - methods method-spec)) - (else methods))) - -;;; -;;; Reverse routing -;;; - -(define* (path-for group name #:optional (params '()) - #:key (query '()) (fragment #f) (relative? #f)) - "Generate a URL path for a named route within GROUP. - -GROUP is a route-group value. NAME is either a symbol naming a route -within GROUP, or a list of symbols for nested lookup where the last -element is the route name and preceding elements are child group names. - - (path-for routes 'users) - (path-for routes 'user '((id . \"42\"))) - (path-for routes '(api items) '((id . \"7\"))) - -PARAMS is an alist mapping capture symbols to string values, or to a -list of strings for rest parameters. - -Optional keyword arguments: - #:query — alist of query parameters ((key . value) ...) - #:fragment — fragment string (without the leading #) - #:relative? — if #t, omit the leading /" - (let* ((rr (current-reverse-routes)) - (_ (unless rr - (error "path-for: no reverse routes available — \ -is this being called inside a request handler?"))) - (_ (unless (route-group? group) - (error "path-for: first argument must be a route-group" group))) - (pattern - (cond - ;; (path-for group 'name) or (path-for group 'name params) - ((symbol? name) - (lookup-scoped rr group name)) - ;; (path-for group '(child ... route-name)) - ;; or (path-for group '(child ... route-name) params) - ((and (pair? name) (every symbol? name)) - (lookup-nested rr group name)) - (else - (error "path-for: expected symbol or list of symbols as \ -name argument" name))))) - (build-path-string pattern params relative? query fragment))) - -(define (lookup-group-scope rr group) - "Find the scope for GROUP in the reverse-routes group table." - (let loop ((table (reverse-routes-group-table rr))) - (cond - ((null? table) - (error "path-for: route-group not found in reverse table — \ -was it included in the route tree passed to compile-routes?" group)) - ((eq? (caar table) group) - (cdar table)) - (else - (loop (cdr table)))))) - -(define (lookup-scoped rr group name) - "Look up NAME in GROUP's local scope." - (let* ((scope (lookup-group-scope rr group)) - (entry (assq name (group-scope-routes scope)))) - (unless entry - (error "path-for: unknown route name in group" name group)) - (cdr entry))) - -(define (lookup-nested rr group name-path) - "Look up a route via a nested name path starting from GROUP. -NAME-PATH is a list of symbols: zero or more child group names followed -by a route name." - (let ((scope (lookup-group-scope rr group))) - (resolve-name-path rr scope name-path))) - -(define (resolve-name-path rr scope name-path) - "Recurse into SCOPE following NAME-PATH." - (if (= (length name-path) 1) - ;; Last element — look up as a route name - (let ((entry (assq (car name-path) (group-scope-routes scope)))) - (unless entry - (error "path-for: unknown route name at end of path" - (car name-path))) - (cdr entry)) - ;; First element is a child group name — find it and recurse - (let ((child-entry (assq (car name-path) - (group-scope-children scope)))) - (unless child-entry - (error "path-for: unknown child group in path" - (car name-path))) - (let ((child-scope (lookup-group-scope rr (cdr child-entry)))) - (resolve-name-path rr child-scope (cdr name-path)))))) - -(define (build-path-string pattern params relative? query fragment) - "Build a URL path string from PATTERN and PARAMS." - (let* ((segments _rest-name (expand-pattern pattern params)) - (path-str (string-join segments "/")) - (path-str (if relative? - path-str - (string-append "/" path-str))) - (path-str (if (null? query) - path-str - (string-append path-str "?" - (encode-query-string query)))) - (path-str (if fragment - (string-append path-str "#" - (uri-encode fragment)) - path-str))) - path-str)) - -(define (expand-pattern pattern params) - "Walk PATTERN, substituting captures from PARAMS. -Returns (values segment-strings rest-name-or-#f)." - (let loop ((pat pattern) - (acc '())) - (cond - ;; End of proper list - ((null? pat) - (values (reverse acc) #f)) - ;; Dotted tail — rest param - ((symbol? pat) - (let ((val (assq pat params))) - (unless val - (error "path-for: missing rest parameter" pat)) - (unless (list? (cdr val)) - (error "path-for: rest parameter must be a list of strings" - pat (cdr val))) - (values (append (reverse acc) - (map uri-encode (cdr val))) - pat))) - ;; Pair — process the car - ((pair? pat) - (let ((seg (car pat))) - (cond - ((string? seg) - (loop (cdr pat) (cons (uri-encode seg) acc))) - ((symbol? seg) - (let ((val (assq seg params))) - (unless val - (error "path-for: missing parameter" seg)) - (loop (cdr pat) (cons (uri-encode (cdr val)) acc)))) - ((and (pair? seg) (procedure? (car seg)) (symbol? (cadr seg))) - ;; Capturing predicate — reverse using the bound name. - (let* ((name (cadr seg)) - (val (assq name params))) - (unless val - (error "path-for: missing parameter for capturing predicate" name)) - (loop (cdr pat) (cons (uri-encode (cdr val)) acc)))) - (else - (error "path-for: invalid pattern element" seg))))) - (else - (error "path-for: invalid pattern" pat))))) - -(define (encode-query-string params) - "Encode an alist of query parameters into a query string." - (string-join - (map (match-lambda - ((key . value) - (string-append (uri-encode (if (symbol? key) - (symbol->string key) - key)) - "=" - (uri-encode value)))) - params) - "&")) diff --git a/safsaf/templating.scm b/safsaf/templating.scm deleted file mode 100644 index c8e0c78..0000000 --- a/safsaf/templating.scm +++ /dev/null @@ -1,129 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 (safsaf templating) - #:use-module (web response) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-71) - #:use-module (htmlprag) - #:export (write-shtml-as-html/streaming - streaming-html-response)) - -(define %slot-prefix "SAFSAF-SLOT-") - -(define (slot-comment index) - "Return an SHTML comment node for slot INDEX." - `(*COMMENT* ,(string-append %slot-prefix (number->string index)))) - -(define (slot-marker index) - "Return the HTML comment string for slot INDEX." - (string-append "")) - -(define (replace-procs shtml) - "Walk SHTML, replacing procedures with numbered comment placeholders. -Returns (values new-shtml procs-vector) where procs-vector contains the -procedures in slot order." - (let ((procs '()) - (counter 0)) - (define (walk node) - (cond - ((procedure? node) - (let ((index counter)) - (set! counter (1+ counter)) - (set! procs (cons (cons index node) procs)) - (slot-comment index))) - ((list? node) - (map walk node)) - (else node))) - (let ((new-tree (walk shtml))) - (values new-tree - (list->vector - (map cdr (sort procs - (lambda (a b) (< (car a) (car b)))))))))) - -(define (split-on-slots html-string num-slots) - "Split HTML-STRING on the slot comment markers. -Returns a list of strings, one more than the number of slots." - (if (zero? num-slots) - (list html-string) - (let loop ((remaining html-string) - (index 0) - (chunks '())) - (if (= index num-slots) - (reverse (cons remaining chunks)) - (let ((marker (slot-marker index))) - (let ((pos (string-contains remaining marker))) - (if pos - (loop (substring remaining - (+ pos (string-length marker))) - (1+ index) - (cons (substring remaining 0 pos) chunks)) - ;; Marker not found — shouldn't happen, but be safe. - (reverse (cons remaining chunks))))))))) - -(define (write-shtml-as-html/streaming shtml port) - "Write SHTML to PORT, like @code{write-shtml-as-html} from htmlprag, -but any procedure encountered in the tree is called as @code{(proc port)} -and may write directly to PORT. - -This allows mixing static SHTML with dynamic streaming sections: - -@example - (write-shtml-as-html/streaming - `(html (body (h1 \"Title\") - ,(lambda (port) (display \"dynamic\" port)) - (footer \"bye\"))) - port) -@end example - -Static parts are rendered via htmlprag's @code{shtml->html}, then -interleaved with procedure calls at output time." - (let ((tree procs (replace-procs shtml))) - (let* ((html-string (shtml->html tree)) - (num-slots (vector-length procs)) - (chunks (split-on-slots html-string num-slots))) - (let loop ((chunks chunks) - (index 0)) - (when (pair? chunks) - (display (car chunks) port) - (when (< index num-slots) - ((vector-ref procs index) port) - (loop (cdr chunks) (1+ index)))))))) - -(define* (streaming-html-response shtml #:key (code 200) (headers '()) - (charset "utf-8")) - "Return an HTML response that streams SHTML to the client. - -SHTML is an SHTML tree that may contain procedures. Each procedure is -called as @code{(proc port)} during output and should write HTML to the -port. Static parts are rendered via htmlprag. - -@example - (streaming-response - `(*TOP* - (*DECL* DOCTYPE html) - (html (head (title \"My Page\")) - (body (h1 \"Hello\") - ,(lambda (port) - (write-shtml-as-html '(p \"dynamic\") port)))))) -@end example" - (values (build-response - #:code code - #:headers (append `((content-type text/html (charset . ,charset))) - headers)) - (lambda (port) - (write-shtml-as-html/streaming shtml port)))) diff --git a/safsaf/utils.scm b/safsaf/utils.scm deleted file mode 100644 index 38b9499..0000000 --- a/safsaf/utils.scm +++ /dev/null @@ -1,92 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 (safsaf utils) - #:use-module (rnrs bytevectors) - #:use-module (web request) - #:use-module (web uri) - #:use-module (srfi srfi-1) - #:use-module (knots web-server) - #:use-module (webutils cookie) - #:autoload (webutils multipart) (parse-request-body - part-content-disposition-params - part-name parts-ref-string) - #:export (parse-form-body - parse-multipart-body - multipart-text-fields - parse-query-string - request-cookies - request-cookie-ref)) - -(define (parse-key-value-pairs str) - "Parse a URL-encoded key=value&key=value string into an alist." - (map (lambda (pair) - (let ((eq-pos (string-index pair #\=))) - (if eq-pos - (cons (uri-decode (substring pair 0 eq-pos)) - (uri-decode (substring pair (1+ eq-pos)))) - (cons (uri-decode pair) "")))) - (string-split str #\&))) - -(define (parse-form-body request body-port) - "Read and parse a URL-encoded form body from REQUEST. -Returns an alist of string key-value pairs." - (let* ((body (read-request-body/knots request body-port)) - (str (if body (utf8->string body) ""))) - (if (string-null? str) - '() - (parse-key-value-pairs str)))) - -(define (parse-multipart-body request body-port) - "Read and parse a multipart/form-data body from REQUEST. -Returns a list of records from (webutils multipart). -Use parts-ref, parts-ref-string, part-body, etc. to access parts." - (let ((body (read-request-body/knots request body-port))) - (if body - (parse-request-body request body) - '()))) - -(define (multipart-text-fields parts) - "Extract text fields from multipart PARTS as an alist of (name . value). -File upload parts (those with a filename parameter) are excluded." - (filter-map - (lambda (p) - (let ((params (part-content-disposition-params p))) - (and (not (assoc-ref params 'filename)) - (cons (part-name p) - (parts-ref-string parts (part-name p)))))) - parts)) - -(define (parse-query-string request) - "Parse the query string from REQUEST. -Returns an alist of string key-value pairs, or '() if no query string." - (let ((query (uri-query (request-uri request)))) - (if (or (not query) (string-null? query)) - '() - (parse-key-value-pairs query)))) - -(define (request-cookies request) - "Return the cookies from REQUEST as an alist of (name . value) pairs. -Returns '() if no Cookie header is present. Importing (webutils cookie) -registers the Cookie header parser with (web http)." - (let ((cookies (assoc-ref (request-headers request) 'cookie))) - (or cookies '()))) - -(define* (request-cookie-ref request name #:optional default) - "Return the value of cookie NAME from REQUEST, or DEFAULT if not found." - (let ((pair (assoc name (request-cookies request)))) - (if pair (cdr pair) default))) diff --git a/tests/CLAUDE.md b/tests/CLAUDE.md deleted file mode 100644 index 8e05229..0000000 --- a/tests/CLAUDE.md +++ /dev/null @@ -1,73 +0,0 @@ -# Testing - -## Framework - -Tests use a minimal SRFI-269 implementation in `(tests support)`. Three -primitives — `is`, `test`, `suite` — build first-class test entities and -deliver them to a pluggable runner. Definition is separated from execution. - -## Running tests - -All tests (via Automake): - - make check - -Single file: - - ./pre-inst-env guile tests/test-router.scm - -## Writing tests - -```scheme -(use-modules (tests support) - (safsaf router)) ; module under test - -(define-suite router-tests - (suite "route construction" - (test "creates route with method and pattern" - (let ((r (route 'GET '("users") identity))) - (is (route? r)) - (is (eq? 'GET (route-method r)))))) - - (suite "matching" - (test "exact path match" - ...))) - -(run-tests router-tests) -``` - -Key points: - -- `(is expr)` — assert expr is truthy. Returns the value on success. -- `(is (pred arg ...))` — predicate form; on failure shows evaluated args. -- `(test "desc" body ...)` — a single test case with one or more assertions. -- `(suite "desc" body ...)` — group tests and nested suites. -- `(define-suite name body ...)` — bind a suite-thunk to a variable. -- `(run-tests thunk)` — run with the simple runner, print summary, exit. -- Tests should be self-contained: don't depend on ordering or side effects - from other tests. -- Use `define` inside `test` bodies for local setup. - -## Synthetic requests - -Many tests need Guile `` objects without a real HTTP server. -Build them with `build-request` from `(web request)`: - -```scheme -(use-modules (web request) (web uri)) - -(define* (make-request method path #:optional (headers '())) - (build-request (build-uri 'http #:host "localhost" #:path path) - #:method method - #:headers headers)) -``` - -Handler signature is `(request body-port) → (values response body)`. When -calling handlers or wrapped handlers in tests, pass `#f` as the body-port: - -```scheme -(let ((resp body (wrapped (make-request 'GET "/" '()) #f))) - (is (= 200 (response-code resp)))) -``` - -For handlers that read `current-route-params`, `parameterize` it directly. diff --git a/tests/support.scm b/tests/support.scm deleted file mode 100644 index dcba5f7..0000000 --- a/tests/support.scm +++ /dev/null @@ -1,243 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 (tests support) - #:use-module (ice-9 format) - #:use-module (srfi srfi-1) - #:export (is - test - suite - suite-thunk - define-suite - test-runner* - test? - suite? - suite-thunk? - run-tests)) - -;;; -;;; Minimal SRFI-269 implementation for Guile. -;;; -;;; Three definition primitives — is, test, suite — construct first-class -;;; entities (alists) and deliver them to a pluggable test runner via -;;; message passing. Definition is separated from execution: the runner -;;; decides when and how to run things. -;;; - -;;; --- Parameter --- - -(define test-runner* (make-parameter #f)) - -;;; --- Predicates --- - -(define (test? obj) - (and (pair? obj) - (assq 'test/body-thunk obj) - (assq 'test/description obj) - #t)) - -(define (suite? obj) - (and (pair? obj) - (assq 'suite/body-thunk obj) - (assq 'suite/description obj) - #t)) - -(define (suite-thunk? obj) - (procedure? obj)) - -;;; --- is --- - -(define-syntax is - (lambda (x) - (syntax-case x () - ;; Predicate form: (is (pred arg ...)) - ((_ (pred arg ...)) - (with-syntax ((src (datum->syntax x (syntax-source x)))) - #'(%run-assert - (lambda () (pred arg ...)) - '(pred arg ...) - 'src - (lambda () (list arg ...))))) - ;; Simple form: (is expr) - ((_ expr) - (with-syntax ((src (datum->syntax x (syntax-source x)))) - #'(%run-assert - (lambda () expr) - 'expr - 'src - #f)))))) - -(define (%run-assert body-thunk body-datum source args-thunk) - (let* ((entity `((assert/body-thunk . ,body-thunk) - (assert/body . ,body-datum) - (assert/location . ,source) - ,@(if args-thunk - `((assert/args-thunk . ,args-thunk)) - '())))) - ((test-runner*) - `((type . runner/run-assert) - (assert . ,entity))))) - -;;; --- test --- - -(define-syntax test - (syntax-rules (quote) - ((_ desc (quote metadata) meta body ...) - (%load-test desc 'meta (lambda () body ... (values)))) - ((_ desc body ...) - (%load-test desc '() (lambda () body ... (values)))))) - -(define (%load-test description metadata body-thunk) - ((test-runner*) - `((type . runner/load-test) - (test . ((test/body-thunk . ,body-thunk) - (test/description . ,description) - (test/metadata . ,metadata)))))) - -;;; --- suite --- - -(define-syntax suite - (syntax-rules (quote) - ((_ desc (quote metadata) meta body ...) - (%load-suite desc 'meta (lambda () body ... (values)))) - ((_ desc body ...) - (%load-suite desc '() (lambda () body ... (values)))))) - -(define (%load-suite description metadata body-thunk) - ((test-runner*) - `((type . runner/load-suite) - (suite . ((suite/body-thunk . ,body-thunk) - (suite/description . ,description) - (suite/metadata . ,metadata)))))) - -;;; --- suite-thunk --- - -(define-syntax suite-thunk - (syntax-rules (quote) - ((_ desc (quote metadata) meta body ...) - (lambda () - (%load-suite desc 'meta (lambda () body ... (values))))) - ((_ desc body ...) - (lambda () - (%load-suite desc '() (lambda () body ... (values))))))) - -;;; --- define-suite --- - -(define-syntax define-suite - (syntax-rules (quote) - ((_ name (quote metadata) meta body ...) - (define name - (suite-thunk (symbol->string 'name) (quote metadata) meta body ...))) - ((_ name body ...) - (define name - (suite-thunk (symbol->string 'name) body ...))))) - - -;;; -;;; Simple immediate-execution test runner. -;;; - -(define %depth 0) -(define %pass-count 0) -(define %fail-count 0) -(define %error-count 0) -(define %test-failed? #f) - -(define (indent) - (make-string (* 2 %depth) #\space)) - -(define (format-location loc) - "Return a string like \"file.scm:42\" from a source location alist, -or #f if location info is unavailable." - (and loc - (let ((file (assq-ref loc 'filename)) - (line (assq-ref loc 'line))) - (and file line - (format #f "~a:~a" file (+ line 1)))))) - -(define (simple-test-runner message) - (let ((type (assq-ref message 'type))) - (case type - - ((runner/load-suite) - (let* ((s (assq-ref message 'suite)) - (desc (assq-ref s 'suite/description)) - (body (assq-ref s 'suite/body-thunk))) - (format #t "~a~a~%" (indent) desc) - (set! %depth (+ %depth 1)) - (body) - (set! %depth (- %depth 1)))) - - ((runner/load-test) - (let* ((t (assq-ref message 'test)) - (desc (assq-ref t 'test/description)) - (body (assq-ref t 'test/body-thunk))) - (set! %test-failed? #f) - (with-exception-handler - (lambda (exn) - (set! %error-count (+ %error-count 1)) - (format #t "~aERROR ~a~%" (indent) desc) - (format #t "~a ~a~%" (indent) exn)) - (lambda () - (body) - (if %test-failed? - (begin - (set! %fail-count (+ %fail-count 1)) - (format #t "~aFAIL ~a~%" (indent) desc)) - (begin - (set! %pass-count (+ %pass-count 1)) - (format #t "~aok ~a~%" (indent) desc)))) - #:unwind? #t))) - - ((runner/run-assert) - (let* ((a (assq-ref message 'assert)) - (body-thunk (assq-ref a 'assert/body-thunk)) - (body-datum (assq-ref a 'assert/body)) - (loc (assq-ref a 'assert/location))) - (let ((result (body-thunk))) - (unless result - (set! %test-failed? #t) - (format #t "~a FAIL: ~s" (indent) body-datum) - (let ((loc-str (format-location loc))) - (when loc-str - (format #t " at ~a" loc-str))) - (newline) - ;; Show evaluated arguments for predicate assertions. - (let ((args-thunk (assq-ref a 'assert/args-thunk))) - (when args-thunk - (with-exception-handler - (lambda (_) #f) - (lambda () - (let ((args (args-thunk))) - (format #t "~a args: ~s~%" (indent) args))) - #:unwind? #t)))) - result)))))) - -(define (run-tests thunk) - "Set up the simple test runner, call THUNK (typically a suite-thunk), -print a summary, and exit with 0 on success or 1 on failure." - (set! %depth 0) - (set! %pass-count 0) - (set! %fail-count 0) - (set! %error-count 0) - (parameterize ((test-runner* simple-test-runner)) - (thunk)) - (newline) - (let ((total (+ %pass-count %fail-count %error-count))) - (format #t "~a passed, ~a failed, ~a errors (of ~a)~%" - %pass-count %fail-count %error-count total) - (exit (if (and (zero? %fail-count) (zero? %error-count)) 0 1)))) diff --git a/tests/test-csrf-validation.scm b/tests/test-csrf-validation.scm deleted file mode 100644 index 90e36d4..0000000 --- a/tests/test-csrf-validation.scm +++ /dev/null @@ -1,65 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 -;; . - -;;; test-csrf-validation.scm — Tests for CSRF integration in (safsaf params) -;;; and (safsaf handler-wrappers csrf) - -(use-modules (tests support) - (safsaf params) - (safsaf handler-wrappers csrf)) - -(define-suite csrf-validation-tests - - (suite "csrf" - - (test "csrf-token-field produces sxml" - (parameterize ((current-csrf-token "abc123")) - (let ((field (csrf-token-field))) - (is (pair? field)) - (is (eq? 'input (car field)))))) - - (test "parse-form-params checks csrf" - (parameterize ((current-csrf-token "tok123")) - (let ((result (parse-form-params '() - '(("csrf-token" . "tok123"))))) - (is (not (any-invalid-params? result)))) - (let ((result (parse-form-params '() - '(("csrf-token" . "wrong"))))) - (is (any-invalid-params? result))))) - - (test "parse-form-params csrf missing" - (parameterize ((current-csrf-token "tok123")) - (let ((result (parse-form-params '() '()))) - (is (any-invalid-params? result))))) - - (test "parse-form-params validates other fields too" - (parameterize ((current-csrf-token "tok123")) - (let ((result (parse-form-params - `((name ,as-string #:required)) - '(("csrf-token" . "tok123") ("name" . "Alice"))))) - (is (not (any-invalid-params? result))) - (is (equal? "Alice" (assq-ref result 'name)))))) - - (test "parse-form-params field errors with valid csrf" - (parameterize ((current-csrf-token "tok123")) - (let ((result (parse-form-params - `((name ,as-string #:required)) - '(("csrf-token" . "tok123"))))) - (is (any-invalid-params? result)) - (is (invalid-param? (assq-ref result 'name)))))))) - -(run-tests csrf-validation-tests) diff --git a/tests/test-exceptions.scm b/tests/test-exceptions.scm deleted file mode 100644 index 67f65b8..0000000 --- a/tests/test-exceptions.scm +++ /dev/null @@ -1,146 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 -;; . - -;;; test-exceptions.scm — Tests for (safsaf handler-wrappers exceptions) - -(use-modules (tests support) - (safsaf handler-wrappers exceptions) - (srfi srfi-71) - (web request) - (web response) - (web uri)) - -(define (make-request method path headers) - (build-request (build-uri 'http #:host "localhost" #:path path) - #:method method - #:headers headers)) - -(define (failing-handler request body-port) - (error "test explosion")) - -(define (ok-handler request body-port) - (values (build-response #:code 200) "ok")) - -(define html-request - (make-request 'GET "/" '((accept . ((text/html)))))) - -(define json-request - (make-request 'GET "/" '((accept . ((application/json)))))) - -(define-suite exceptions-tests - - (suite "passthrough" - - (test "successful handler passes through unchanged" - (define wrapped (exceptions-handler-wrapper ok-handler)) - (let ((resp body (wrapped html-request #f))) - (is (= 200 (response-code resp))) - (is (equal? "ok" body))))) - - (suite "production mode" - - (test "returns 500 for HTML client" - (define wrapped (exceptions-handler-wrapper failing-handler)) - (let ((resp body (wrapped html-request #f))) - (is (= 500 (response-code resp))) - ;; Body is a streaming procedure from html-response. - (is (procedure? body)))) - - (test "returns 500 JSON for JSON client" - (define wrapped (exceptions-handler-wrapper failing-handler)) - (let ((resp body (wrapped json-request #f))) - (is (= 500 (response-code resp))) - (is (string? body)) - ;; Should contain error key but not backtrace. - (is (string-contains body "Internal Server Error")) - (is (not (string-contains body "test explosion")))))) - - (suite "dev mode" - - (test "returns 500 with backtrace for HTML client" - (define wrapped (exceptions-handler-wrapper failing-handler - #:dev? #t)) - (let ((resp body (wrapped html-request #f))) - (is (= 500 (response-code resp))) - ;; Body is a streaming procedure containing backtrace. - (is (procedure? body)))) - - (test "returns 500 JSON with backtrace for JSON client" - (define wrapped (exceptions-handler-wrapper failing-handler - #:dev? #t)) - (let ((resp body (wrapped json-request #f))) - (is (= 500 (response-code resp))) - (is (string? body)) - (is (string-contains body "backtrace")) - (is (string-contains body "test explosion"))))) - - (suite "custom renderers" - - (test "render-error overrides everything" - (define wrapped - (exceptions-handler-wrapper - failing-handler - #:render-error - (lambda (request code message bt dev?) - (values (build-response #:code code) "custom error")))) - (let ((resp body (wrapped html-request #f))) - (is (= 500 (response-code resp))) - (is (equal? "custom error" body)))) - - (test "render-html overrides only HTML" - (define wrapped - (exceptions-handler-wrapper - failing-handler - #:render-html - (lambda (request code message bt dev?) - (values (build-response #:code code - #:headers '((content-type text/html))) - "custom html")))) - ;; HTML request gets custom renderer. - (let ((resp body (wrapped html-request #f))) - (is (equal? "custom html" body))) - ;; JSON request gets default JSON renderer. - (let ((resp body (wrapped json-request #f))) - (is (string? body)) - (is (string-contains body "Internal Server Error")))) - - (test "render-json overrides only JSON" - (define wrapped - (exceptions-handler-wrapper - failing-handler - #:render-json - (lambda (request code message bt dev?) - (values (build-response #:code code - #:headers '((content-type application/json))) - "{\"err\":\"custom\"}")))) - ;; JSON request gets custom renderer. - (let ((resp body (wrapped json-request #f))) - (is (equal? "{\"err\":\"custom\"}" body))) - ;; HTML request gets default HTML renderer. - (let ((resp body (wrapped html-request #f))) - (is (procedure? body))))) - - (suite "make-exceptions-handler-wrapper" - - (test "factory returns a working wrapper" - (define wrapper (make-exceptions-handler-wrapper #:dev? #t)) - (define wrapped (wrapper failing-handler)) - (let ((resp body (wrapped json-request #f))) - (is (= 500 (response-code resp))) - (is (string-contains body "test explosion")))))) - -(run-tests exceptions-tests) diff --git a/tests/test-handler-wrappers.scm b/tests/test-handler-wrappers.scm deleted file mode 100644 index 8d60e9f..0000000 --- a/tests/test-handler-wrappers.scm +++ /dev/null @@ -1,274 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 -;; . - -;;; test-handler-wrappers.scm — Tests for standalone handler wrappers - -(use-modules (tests support) - (safsaf handler-wrappers security-headers) - (safsaf handler-wrappers cors) - (safsaf handler-wrappers max-body-size) - (safsaf handler-wrappers sessions) - (safsaf handler-wrappers trailing-slash) - (srfi srfi-71) - (web request) - (web response) - (web uri) - (webutils cookie)) ; registers Cookie header parser - -;; A handler that returns a plain 200 response. -(define (ok-handler request body-port) - (values (build-response #:code 200) "ok")) - -(define* (make-request method path headers #:key (validate? #t)) - (build-request (build-uri 'http #:host "localhost" #:path path) - #:method method - #:headers headers - #:validate-headers? validate?)) - -(define-suite handler-wrappers-tests - - (suite "security-headers" - - (test "adds default headers" - (define wrapped (security-headers-handler-wrapper ok-handler)) - (let ((resp _body (wrapped (make-request 'GET "/" '()) #f))) - (is (equal? "nosniff" - (assq-ref (response-headers resp) - 'x-content-type-options))) - (is (equal? "DENY" - (assq-ref (response-headers resp) - 'x-frame-options))))) - - (test "disabling a header with #f" - (define wrapped - (security-headers-handler-wrapper ok-handler - #:frame-options #f)) - (let ((resp _body (wrapped (make-request 'GET "/" '()) #f))) - (is (not (assq-ref (response-headers resp) - 'x-frame-options))))) - - (test "content-security-policy header" - (define wrapped - (security-headers-handler-wrapper ok-handler - #:content-security-policy "default-src 'self'; script-src 'self'")) - (let ((resp _body (wrapped (make-request 'GET "/" '()) #f))) - (is (equal? "default-src 'self'; script-src 'self'" - (assq-ref (response-headers resp) - 'content-security-policy))))) - - (test "content-security-policy-report-only header" - (define wrapped - (security-headers-handler-wrapper ok-handler - #:content-security-policy-report-only "default-src 'self'")) - (let ((resp _body (wrapped (make-request 'GET "/" '()) #f))) - (is (equal? "default-src 'self'" - (assq-ref (response-headers resp) - 'content-security-policy-report-only))) - ;; Enforcing header should not be set. - (is (not (assq-ref (response-headers resp) - 'content-security-policy)))))) - - (suite "cors" - - (test "no origin header passes through" - (define wrapped (cors-handler-wrapper ok-handler)) - (let ((resp _body (wrapped (make-request 'GET "/" '()) #f))) - (is (= 200 (response-code resp))) - (is (not (assq-ref (response-headers resp) - 'access-control-allow-origin))))) - - (test "preflight returns 204" - (define wrapped (cors-handler-wrapper ok-handler)) - (let ((resp _body - (wrapped (make-request 'OPTIONS "/" - '((origin . "http://example.com"))) - #f))) - (is (= 204 (response-code resp))) - (is (equal? "*" (assq-ref (response-headers resp) - 'access-control-allow-origin))))) - - (test "normal request with origin adds cors headers" - (define wrapped (cors-handler-wrapper ok-handler)) - (let ((resp _body - (wrapped (make-request 'GET "/" - '((origin . "http://example.com"))) - #f))) - (is (= 200 (response-code resp))) - (is (assq-ref (response-headers resp) - 'access-control-allow-origin)))) - - (test "disallowed origin gets no cors headers" - (define wrapped - (cors-handler-wrapper ok-handler - #:origins '("http://allowed.com"))) - (let ((resp _body - (wrapped (make-request 'GET "/" - '((origin . "http://evil.com"))) - #f))) - (is (= 200 (response-code resp))) - (is (not (assq-ref (response-headers resp) - 'access-control-allow-origin)))))) - - (suite "sessions" - - (test "round-trip set and read" - (define mgr (make-session-config "test-secret-key-1234")) - (define wrapper (make-session-handler-wrapper mgr)) - ;; Set a session and extract the cookie name=value. - (let* ((cookie-hdr (session-set mgr '((user . "alice")))) - ;; cdr is (name value attrs...) — build parsed cookie alist - (cookie-name (car (cdr cookie-hdr))) - (cookie-value (cadr (cdr cookie-hdr))) - (cookie-alist (list (cons cookie-name cookie-value)))) - ;; Now make a request with that cookie and read it back. - (define reading-handler - (lambda (request body-port) (values (build-response #:code 200) - (current-session)))) - (define wrapped (wrapper reading-handler)) - (let ((_resp body - (wrapped (make-request 'GET "/" - `((cookie . ,cookie-alist)) - #:validate? #f) - #f))) - (is (pair? body)) - (is (equal? "alice" (assq-ref body 'user)))))) - - (test "missing session yields #f" - (define mgr (make-session-config "test-secret-key-1234")) - (define reading-handler - (lambda (request body-port) (values (build-response #:code 200) - (current-session)))) - (define wrapped ((make-session-handler-wrapper mgr) reading-handler)) - (let ((_resp body (wrapped (make-request 'GET "/" '()) #f))) - (is (not body))))) - - (suite "max-body-size" - - (test "allows request under limit" - (define wrapper (make-max-body-size-handler-wrapper 1024)) - (define wrapped (wrapper ok-handler)) - (let ((resp _body - (wrapped (make-request 'GET "/" - '((content-length . 512))) - #f))) - (is (= 200 (response-code resp))))) - - (test "rejects request over limit with 413" - (define wrapper (make-max-body-size-handler-wrapper 1024)) - (define wrapped (wrapper ok-handler)) - (let ((resp _body - (wrapped (make-request 'GET "/" - '((content-length . 2048))) - #f))) - (is (= 413 (response-code resp))))) - - (test "passes through when no content-length" - (define wrapper (make-max-body-size-handler-wrapper 1024)) - (define wrapped (wrapper ok-handler)) - (let ((resp _body (wrapped (make-request 'GET "/" '()) #f))) - (is (= 200 (response-code resp))))) - - (test "custom 413 handler" - (define wrapper - (make-max-body-size-handler-wrapper - 100 - #:handler-413 - (lambda (request body-port) - (values (build-response #:code 413) "too big")))) - (define wrapped (wrapper ok-handler)) - (let ((resp body - (wrapped (make-request 'GET "/" - '((content-length . 200))) - #f))) - (is (= 413 (response-code resp))) - (is (equal? "too big" body))))) - - (suite "trailing-slash" - - (test "strip mode redirects trailing slash" - (define wrapped - (trailing-slash-handler-wrapper ok-handler #:mode 'strip)) - (let ((resp _body (wrapped (make-request 'GET "/foo/" '()) #f))) - (is (= 301 (response-code resp))) - (is (equal? "/foo" - (uri->string - (assq-ref (response-headers resp) 'location)))))) - - (test "strip mode passes through without trailing slash" - (define wrapped - (trailing-slash-handler-wrapper ok-handler #:mode 'strip)) - (let ((resp _body (wrapped (make-request 'GET "/foo" '()) #f))) - (is (= 200 (response-code resp))))) - - (test "append mode redirects missing trailing slash" - (define wrapped - (trailing-slash-handler-wrapper ok-handler #:mode 'append)) - (let ((resp _body (wrapped (make-request 'GET "/foo" '()) #f))) - (is (= 301 (response-code resp))) - (is (equal? "/foo/" - (uri->string - (assq-ref (response-headers resp) 'location)))))) - - (test "append mode passes through with trailing slash" - (define wrapped - (trailing-slash-handler-wrapper ok-handler #:mode 'append)) - (let ((resp _body (wrapped (make-request 'GET "/foo/" '()) #f))) - (is (= 200 (response-code resp))))) - - (test "root path passes through in strip mode" - (define wrapped - (trailing-slash-handler-wrapper ok-handler #:mode 'strip)) - (let ((resp _body (wrapped (make-request 'GET "/" '()) #f))) - (is (= 200 (response-code resp))))) - - (test "root path passes through in append mode" - (define wrapped - (trailing-slash-handler-wrapper ok-handler #:mode 'append)) - (let ((resp _body (wrapped (make-request 'GET "/" '()) #f))) - (is (= 200 (response-code resp))))) - - (test "preserves query string" - (define wrapped - (trailing-slash-handler-wrapper ok-handler #:mode 'strip)) - (let* ((req (build-request - (build-uri 'http #:host "localhost" - #:path "/foo/" #:query "bar=1") - #:method 'GET #:headers '())) - (resp _body (wrapped req #f))) - (is (= 301 (response-code resp))) - (is (equal? "/foo?bar=1" - (uri->string - (assq-ref (response-headers resp) 'location)))))) - - (test "custom status code" - (define wrapped - (trailing-slash-handler-wrapper ok-handler - #:mode 'strip #:code 302)) - (let ((resp _body (wrapped (make-request 'GET "/foo/" '()) #f))) - (is (= 302 (response-code resp))))) - - (test "make-trailing-slash-handler-wrapper factory" - (define wrapper - (make-trailing-slash-handler-wrapper #:mode 'append #:code 308)) - (define wrapped (wrapper ok-handler)) - (let ((resp _body (wrapped (make-request 'GET "/foo" '()) #f))) - (is (= 308 (response-code resp))) - (is (equal? "/foo/" - (uri->string - (assq-ref (response-headers resp) 'location)))))))) - -(run-tests handler-wrappers-tests) diff --git a/tests/test-integration.scm b/tests/test-integration.scm deleted file mode 100644 index 66a3f32..0000000 --- a/tests/test-integration.scm +++ /dev/null @@ -1,273 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 -;; . - -;;; test-integration.scm — Full-stack integration tests -;;; -;;; Starts a real HTTP server inside run-fibers and makes requests -;;; via a thread pool (Guile's (web client) uses blocking I/O that -;;; does not cooperate with the fibers scheduler). - -(use-modules (tests support) - (fibers) - (knots web-server) - (knots thread-pool) - (safsaf) - (safsaf router) - (safsaf response-helpers) - (safsaf utils) - (srfi srfi-71) - (rnrs bytevectors) - (web client) - (web request) - (web response) - (web uri)) - -(define test-port 8399) -(define test-base (string-append "http://127.0.0.1:" - (number->string test-port))) - -;;; -;;; Test handlers -;;; - -(define (echo-form-handler request body-port) - "Parse a URL-encoded form body and echo each field as key=value lines." - (let ((fields (parse-form-body request body-port))) - (text-response - (string-join (map (lambda (pair) - (string-append (car pair) "=" (cdr pair))) - fields) - "\n")))) - -(define (echo-multipart-handler request body-port) - "Parse a multipart body, extract text fields, echo as key=value lines." - (let* ((parts (parse-multipart-body request body-port)) - (fields (multipart-text-fields parts))) - (text-response - (string-join (map (lambda (pair) - (string-append (car pair) "=" (cdr pair))) - fields) - "\n")))) - -(define (greet-handler request body-port) - (text-response "hello")) - -(define (catch-all-handler request body-port) - (not-found-response)) - -;;; -;;; Route table -;;; - -(define test-routes - (list - (route 'GET '("greet") greet-handler) - (route 'POST '("form") echo-form-handler) - (route 'POST '("multipart") echo-multipart-handler) - (route '* '(. rest) catch-all-handler))) - -;;; -;;; Multipart body construction -;;; - -(define (make-multipart-body boundary fields) - "Build a multipart/form-data body bytevector from FIELDS, -an alist of (name . value) string pairs." - (let ((parts - (string-join - (map (lambda (pair) - (string-append - "--" boundary "\r\n" - "Content-Disposition: form-data; name=\"" - (car pair) "\"\r\n" - "\r\n" - (cdr pair))) - fields) - "\r\n"))) - (string->utf8 - (string-append parts "\r\n" - "--" boundary "--\r\n")))) - -;;; -;;; Test runner -;;; - -(define %pass 0) -(define %fail 0) - -(define (check desc ok?) - (if ok? - (begin - (set! %pass (1+ %pass)) - (format #t " ok ~a~%" desc)) - (begin - (set! %fail (1+ %fail)) - (format #t " FAIL ~a~%" desc))) - (force-output)) - -;;; HTTP client helper — runs requests on a thread pool because -;;; Guile's (web client) uses blocking I/O incompatible with fibers. -(define http-pool (make-fixed-size-thread-pool 1)) - -(define (test-post path headers body) - "POST to the test server. Returns (values response body-string)." - (call-with-thread - http-pool - (lambda () - (http-post (string-append test-base path) - #:headers headers - #:body body)))) - -(define (test-get path) - "GET from the test server. Returns (values response body-string)." - (call-with-thread - http-pool - (lambda () - (http-get (string-append test-base path))))) - -(define (test-head path) - "HEAD to the test server. Returns (values response body-string)." - (call-with-thread - http-pool - (lambda () - (http-head (string-append test-base path))))) - -(define (test-delete path) - "DELETE to the test server. Returns (values response body-string)." - (call-with-thread - http-pool - (lambda () - (http-delete (string-append test-base path))))) - -;;; -;;; Run everything inside a single run-fibers. -;;; - -(run-fibers - (lambda () - (run-safsaf test-routes - #:host "127.0.0.1" - #:port test-port) - - (sleep 1) - - (with-exception-handler - (lambda (exn) - (format (current-error-port) "~%Test error: ~a~%" exn) - (force-output (current-error-port)) - (primitive-_exit 1)) - (lambda () - - (format #t "parse-form-body via HTTP~%") - - ;; Test 1: basic url-encoded fields - (let ((resp body - (test-post "/form" - '((content-type - . (application/x-www-form-urlencoded))) - "name=Alice&age=30"))) - (check "basic url-encoded fields" - (and (= 200 (response-code resp)) - (string-contains body "name=Alice") - (string-contains body "age=30")))) - - ;; Test 2: plus signs decoded as spaces - (let ((resp body - (test-post "/form" - '((content-type - . (application/x-www-form-urlencoded))) - "greeting=hello+world"))) - (check "plus signs decoded as spaces" - (and (= 200 (response-code resp)) - (string-contains body "greeting=hello world")))) - - ;; Test 3: percent-encoded values - (let ((resp body - (test-post "/form" - '((content-type - . (application/x-www-form-urlencoded))) - "msg=caf%C3%A9"))) - (check "percent-encoded values" - (and (= 200 (response-code resp)) - (string-contains body "msg=café")))) - - (format #t "~%parse-multipart-body via HTTP~%") - - ;; Test 4: basic multipart text fields - (let* ((boundary "----TestBoundary12345") - (body-bv (make-multipart-body boundary - '(("title" . "Hello") - ("body" . "World"))))) - (let ((resp body - (test-post "/multipart" - `((content-type - . (multipart/form-data - (boundary . ,boundary)))) - body-bv))) - (check "basic multipart text fields" - (and (= 200 (response-code resp)) - (string-contains body "title=Hello") - (string-contains body "body=World"))))) - - (format #t "~%405 Method Not Allowed~%") - - ;; Test 5: POST to a GET-only route returns 405 - (let ((resp body (test-post "/greet" '() ""))) - (check "POST to GET-only route returns 405" - (= 405 (response-code resp))) - (check "405 response includes Allow header with GET and HEAD" - (let ((allowed (assq-ref (response-headers resp) - 'allow))) - (and (memq 'GET allowed) - (memq 'HEAD allowed))))) - - ;; Test 6: DELETE to a GET-only route returns 405 - (let ((resp _body (test-delete "/greet"))) - (check "DELETE to GET-only route returns 405" - (= 405 (response-code resp)))) - - (format #t "~%Automatic HEAD handling~%") - - ;; Test 7: HEAD to a GET route returns 200 with empty body - (let ((resp body (test-head "/greet"))) - (check "HEAD to GET route returns 200" - (= 200 (response-code resp))) - (check "HEAD response has empty body" - (or (not body) - (and (string? body) (string-null? body))))) - - ;; Test 8: HEAD to a non-existent path falls through to catch-all - (let ((resp _body (test-head "/no-such-path"))) - (check "HEAD to unknown path returns 404" - (= 404 (response-code resp)))) - - ;; Test 9: GET to the greet route works normally - (let ((resp body (test-get "/greet"))) - (check "GET to greet route returns 200" - (= 200 (response-code resp))) - (check "GET to greet route returns body" - (string-contains body "hello"))) - - ;; Summary and exit. - (newline) - (let ((total (+ %pass %fail))) - (format #t "~a passed, ~a failed (of ~a)~%" - %pass %fail total) - (force-output) - (primitive-_exit (if (zero? %fail) 0 1)))) - #:unwind? #t)) - #:drain? #f) diff --git a/tests/test-params.scm b/tests/test-params.scm deleted file mode 100644 index 35e0268..0000000 --- a/tests/test-params.scm +++ /dev/null @@ -1,307 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 -;; . - -(use-modules (tests support) - (safsaf params) - (safsaf handler-wrappers csrf)) - -(define-suite params-tests - - (suite "processors" - - (test "as-string passes through" - (is (equal? "hello" (as-string "hello")))) - - (test "as-integer parses integers" - (is (equal? 42 (as-integer "42"))) - (is (equal? -3 (as-integer "-3"))) - (is (equal? 0 (as-integer "0")))) - - (test "as-integer rejects non-integers" - (is (invalid-param? (as-integer "3.14"))) - (is (invalid-param? (as-integer "abc"))) - (is (invalid-param? (as-integer "")))) - - (test "as-number parses numbers" - (is (equal? 42 (as-number "42"))) - (is (equal? 3.14 (as-number "3.14"))) - (is (equal? -1 (as-number "-1")))) - - (test "as-number rejects non-numbers" - (is (invalid-param? (as-number "abc"))) - (is (invalid-param? (as-number "")))) - - (test "as-checkbox" - (is (eq? #t (as-checkbox "on"))) - (is (eq? #f (as-checkbox "off"))) - (is (eq? #f (as-checkbox "")))) - - (test "as-one-of accepts valid choices" - (define proc (as-one-of '("red" "green" "blue"))) - (is (equal? "red" (proc "red"))) - (is (equal? "blue" (proc "blue")))) - - (test "as-one-of rejects invalid choices" - (define proc (as-one-of '("red" "green" "blue"))) - (is (invalid-param? (proc "yellow")))) - - (test "as-one-of custom message" - (define proc (as-one-of '("a") #:message "nope")) - (is (equal? "nope" (invalid-param-message (proc "z"))))) - - (test "as-matching accepts matching values" - (define proc (as-matching "^[0-9]+$")) - (is (equal? "123" (proc "123")))) - - (test "as-matching rejects non-matching values" - (define proc (as-matching "^[0-9]+$")) - (is (invalid-param? (proc "abc")))) - - (test "as-predicate" - (define proc (as-predicate (lambda (s) (> (string-length s) 3)))) - (is (equal? "hello" (proc "hello"))) - (is (invalid-param? (proc "hi"))))) - - (suite "parse-params" - - (test "basic optional param" - (define result - (parse-params `((name ,as-string)) - '(("name" . "Alice")))) - (is (equal? "Alice" (assq-ref result 'name)))) - - (test "missing optional param omitted" - (define result - (parse-params `((name ,as-string)) - '())) - (is (not (assq-ref result 'name)))) - - (test "empty string treated as absent for optional" - (define result - (parse-params `((name ,as-string)) - '(("name" . "")))) - (is (not (assq-ref result 'name)))) - - (test "required param present" - (define result - (parse-params `((name ,as-string #:required)) - '(("name" . "Bob")))) - (is (equal? "Bob" (assq-ref result 'name)))) - - (test "required param missing" - (define result - (parse-params `((name ,as-string #:required)) - '())) - (is (invalid-param? (assq-ref result 'name)))) - - (test "required param empty" - (define result - (parse-params `((name ,as-string #:required)) - '(("name" . "")))) - (is (invalid-param? (assq-ref result 'name)))) - - (test "default used when absent" - (define result - (parse-params `((limit ,as-integer #:default 50)) - '())) - (is (equal? 50 (assq-ref result 'limit)))) - - (test "default not used when present" - (define result - (parse-params `((limit ,as-integer #:default 50)) - '(("limit" . "10")))) - (is (equal? 10 (assq-ref result 'limit)))) - - (test "default used when empty string" - (define result - (parse-params `((limit ,as-integer #:default 50)) - '(("limit" . "")))) - (is (equal? 50 (assq-ref result 'limit)))) - - (test "multi-value collects all" - (define result - (parse-params `((color ,as-string #:multi-value)) - '(("color" . "red") ("color" . "blue")))) - (is (equal? '("red" "blue") (assq-ref result 'color)))) - - (test "multi-value empty omitted" - (define result - (parse-params `((color ,as-string #:multi-value)) - '())) - (is (not (assq-ref result 'color)))) - - (test "multi-value skips empty strings" - (define result - (parse-params `((color ,as-string #:multi-value)) - '(("color" . "red") ("color" . "") ("color" . "blue")))) - (is (equal? '("red" "blue") (assq-ref result 'color)))) - - (test "multi-value with default" - (define result - (parse-params `((color ,as-string #:multi-value #:default ("red"))) - '())) - (is (equal? '("red") (assq-ref result 'color)))) - - (test "no-default-when suppresses default" - (define result - (parse-params `((limit ,as-integer - #:no-default-when (all_results) #:default 50) - (all_results ,as-checkbox)) - '(("all_results" . "on")))) - (is (not (assq-ref result 'limit))) - (is (eq? #t (assq-ref result 'all_results)))) - - (test "no-default-when uses default when condition absent" - (define result - (parse-params `((limit ,as-integer - #:no-default-when (all_results) #:default 50)) - '())) - (is (equal? 50 (assq-ref result 'limit)))) - - (test "processor transforms value" - (define result - (parse-params `((count ,as-integer)) - '(("count" . "42")))) - (is (equal? 42 (assq-ref result 'count)))) - - (test "processor error appears inline" - (define result - (parse-params `((count ,as-integer)) - '(("count" . "abc")))) - (is (invalid-param? (assq-ref result 'count)))) - - (test "multiple params parsed together" - (define result - (parse-params `((name ,as-string #:required) - (age ,as-integer #:default 0) - (active ,as-checkbox)) - '(("name" . "Alice") ("active" . "on")))) - (is (equal? "Alice" (assq-ref result 'name))) - (is (equal? 0 (assq-ref result 'age))) - (is (eq? #t (assq-ref result 'active))))) - - (suite "any-invalid-params?" - - (test "no errors" - (is (not (any-invalid-params? - '((name . "Alice") (age . 30)))))) - - (test "with error" - (is (any-invalid-params? - `((name . ,(make-invalid-param #f "required")))))) - - (test "error in multi-value list" - (is (any-invalid-params? - `((colors . ("red" ,(make-invalid-param "x" "bad")))))))) - - (suite "invalid-param-ref" - - (test "returns record when invalid" - (define params `((name . ,(make-invalid-param "" "required")))) - (is (invalid-param? (invalid-param-ref params 'name)))) - - (test "returns #f when valid" - (is (not (invalid-param-ref '((name . "Alice")) 'name)))) - - (test "returns #f when absent" - (is (not (invalid-param-ref '() 'name))))) - - (suite "field-errors" - - (test "returns error messages" - (define params `((name . ,(make-invalid-param "" "required")))) - (is (equal? '("required") (field-errors params 'name)))) - - (test "returns empty for valid field" - (is (equal? '() (field-errors '((name . "Alice")) 'name)))) - - (test "returns empty for absent field" - (is (equal? '() (field-errors '() 'name))))) - - (suite "guard-against-mutually-exclusive-params" - - (test "no conflict" - (define result - (guard-against-mutually-exclusive-params - '((limit . 50)) - '((limit all_results)))) - (is (equal? 50 (assq-ref result 'limit)))) - - (test "conflict marks both invalid" - (define result - (guard-against-mutually-exclusive-params - '((limit . 50) (all_results . #t)) - '((limit all_results)))) - (is (invalid-param? (assq-ref result 'limit))) - (is (invalid-param? (assq-ref result 'all_results)))) - - (test "preserves existing errors" - (define result - (guard-against-mutually-exclusive-params - `((name . ,(make-invalid-param #f "bad"))) - '((name other)))) - (is (invalid-param? (assq-ref result 'name))))) - - (suite "params->query-string" - - (test "simple params" - (is (equal? "name=Alice&age=30" - (params->query-string '((name . "Alice") (age . 30)))))) - - (test "boolean params" - (is (equal? "active=on" - (params->query-string '((active . #t)))))) - - (test "multi-value params" - (is (equal? "color=red&color=blue" - (params->query-string '((color . ("red" "blue"))))))) - - (test "skips invalid params" - (is (equal? "name=Alice" - (params->query-string - `((name . "Alice") - (bad . ,(make-invalid-param "x" "err"))))))) - - (test "empty result" - (is (equal? "" (params->query-string '()))))) - - (suite "parse-form-params" - - (test "csrf pass" - (parameterize ((current-csrf-token "tok123")) - (define result - (parse-form-params - `((name ,as-string #:required)) - '(("csrf-token" . "tok123") ("name" . "Alice")))) - (is (not (any-invalid-params? result))) - (is (equal? "Alice" (assq-ref result 'name))))) - - (test "csrf fail" - (parameterize ((current-csrf-token "tok123")) - (define result - (parse-form-params - `((name ,as-string)) - '(("csrf-token" . "wrong")))) - (is (any-invalid-params? result)))) - - (test "csrf missing" - (parameterize ((current-csrf-token "tok123")) - (define result - (parse-form-params `() '())) - (is (any-invalid-params? result)))))) - -(run-tests params-tests) diff --git a/tests/test-response-helpers.scm b/tests/test-response-helpers.scm deleted file mode 100644 index 552a633..0000000 --- a/tests/test-response-helpers.scm +++ /dev/null @@ -1,152 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 -;; . - -;;; test-response-helpers.scm — Tests for (safsaf response-helpers) - -(use-modules (tests support) - (safsaf response-helpers) - (safsaf router) - (srfi srfi-71) - (web response) - (web request) - (web uri)) - -(define (body->string body) - "Capture a body (string or writer procedure) as a string." - (if (procedure? body) - (call-with-output-string body) - body)) - -(define (make-request method path headers) - (build-request (build-uri 'http #:host "localhost" #:path path) - #:method method - #:headers headers)) - -(define-suite response-helpers-tests - - (suite "response constructors" - - (test "html-response" - (let ((resp body (html-response '(p "hello")))) - (is (= 200 (response-code resp))) - (is (equal? '(text/html (charset . "utf-8")) - (assq-ref (response-headers resp) 'content-type))) - (is (string-contains (body->string body) "hello")))) - - (test "json-response" - (let ((resp body (json-response "{\"a\":1}"))) - (is (= 200 (response-code resp))) - (is (equal? '(application/json) - (assq-ref (response-headers resp) 'content-type))) - (is (equal? "{\"a\":1}" body)))) - - (test "text-response" - (let ((resp body (text-response "hi"))) - (is (= 200 (response-code resp))) - (is (equal? "hi" body)))) - - (test "redirect-response" - (let ((resp _body (redirect-response "/foo"))) - (is (= 303 (response-code resp))) - (is (response-headers resp)))) - - (test "custom code" - (let ((resp _body (text-response "x" #:code 201))) - (is (= 201 (response-code resp)))))) - - (suite "error responses" - - (test "status codes" - (let ((r1 _b1 (not-found-response)) - (r2 _b2 (forbidden-response)) - (r3 _b3 (bad-request-response)) - (r4 _b4 (internal-server-error-response))) - (is (= 404 (response-code r1))) - (is (= 403 (response-code r2))) - (is (= 400 (response-code r3))) - (is (= 500 (response-code r4)))))) - - (suite "streaming json" - - (test "scm-alist->streaming-json" - (let ((out (call-with-output-string - (lambda (port) - (scm-alist->streaming-json - '(("name" . "Alice") ("age" . 30)) - port))))) - (is (string-contains out "\"name\":\"Alice\"")) - (is (string-contains out "\"age\":30")))) - - (test "list->streaming-json-array" - (let ((out (call-with-output-string - (lambda (port) - (list->streaming-json-array - identity '(1 2 3) port))))) - (is (equal? "[1,2,3]" out))))) - - (suite "content negotiation" - - (test "path extension takes priority over accept header" - (let ((req (make-request 'GET "/things.json" - '((accept . ((text/html))))))) - (is (eq? 'application/json - (negotiate-content-type req '(text/html application/json)))))) - - (test "falls back to accept header without extension" - (let ((req (make-request 'GET "/things" - '((accept . ((application/json))))))) - (is (eq? 'application/json - (negotiate-content-type req '(text/html application/json)))))) - - (test "ignores extension not in supported list" - (let ((req (make-request 'GET "/things.txt" - '((accept . ((text/html))))))) - (is (eq? 'text/html - (negotiate-content-type req '(text/html application/json)))))) - - (test "defaults to first supported when nothing matches" - (let ((req (make-request 'GET "/things" - '((accept . ((image/png))))))) - (is (eq? 'text/html - (negotiate-content-type req '(text/html application/json))))))) - - (suite "static handler" - - (test "serves file and rejects traversal" - (let* ((tmp (tmpnam)) - (_ (mkdir tmp)) - (f (string-append tmp "/test.txt")) - (_ (call-with-output-file f - (lambda (p) (display "content" p)))) - (handler (make-static-handler tmp))) - ;; Serve existing file. - (parameterize ((current-route-params `((path . ("test.txt"))))) - (let ((resp body (handler (make-request 'GET "/test.txt" '()) #f))) - (is (= 200 (response-code resp))) - (is (equal? "content" (body->string body))))) - ;; Traversal rejected. - (parameterize ((current-route-params `((path . (".." "etc" "passwd"))))) - (let ((resp _body (handler (make-request 'GET "/../etc/passwd" '()) #f))) - (is (= 404 (response-code resp))))) - ;; Missing file. - (parameterize ((current-route-params `((path . ("nope.txt"))))) - (let ((resp _body (handler (make-request 'GET "/nope.txt" '()) #f))) - (is (= 404 (response-code resp))))) - (delete-file f) - (rmdir tmp))))) - -(run-tests response-helpers-tests) diff --git a/tests/test-router.scm b/tests/test-router.scm deleted file mode 100644 index 61246a8..0000000 --- a/tests/test-router.scm +++ /dev/null @@ -1,188 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 -;; . - -;;; test-router.scm — Tests for (safsaf router) - -(use-modules (tests support) - (safsaf router) - (srfi srfi-71)) - -;; Every compile-routes call needs a catch-all as the last route. -(define catch-all - (route '* '(. rest) (lambda (r) (values 'not-found #f)))) - -(define (match-path routes method path) - "Compile ROUTES (appending catch-all), match METHOD and PATH segments." - (let ((compiled _rr (compile-routes (append routes (list catch-all))))) - (let ((handler bindings (match-route compiled method path))) - (values handler bindings)))) - -(define-suite router-tests - - (suite "match-route" - - (test "literal path" - (define h (lambda (r) 'ok)) - (define routes (list (route 'GET '("users" "list") h))) - (let ((handler bindings (match-path routes 'GET '("users" "list")))) - (is (eq? h handler)) - (is (equal? '() bindings)))) - - (test "no match falls through to catch-all" - (define h (lambda (r) 'ok)) - (define routes (list (route 'GET '("users") h))) - (let ((handler _bindings (match-path routes 'GET '("other")))) - (is (not (eq? h handler))))) - - (test "capture segment" - (define h (lambda (r) 'ok)) - (define routes (list (route 'GET '("users" id) h))) - (let ((_handler bindings (match-path routes 'GET '("users" "42")))) - (is (equal? "42" (assq-ref bindings 'id))))) - - (test "wildcard rest" - (define h (lambda (r) 'ok)) - (define routes (list (route 'GET '("files" . path) h))) - (let ((_handler bindings (match-path routes 'GET '("files" "a" "b")))) - (is (equal? '("a" "b") (assq-ref bindings 'path))))) - - (test "predicate segment" - (define h (lambda (r) 'ok)) - (define routes - (list (route 'GET `("items" (,string->number id)) h))) - (let ((handler _b (match-path routes 'GET '("items" "99")))) - (is (eq? h handler))) - (let ((handler _b (match-path routes 'GET '("items" "abc")))) - (is (not (eq? h handler))))) - - (test "method filtering" - (define h-get (lambda (r) 'get)) - (define h-post (lambda (r) 'post)) - (define routes (list (route 'GET '("x") h-get) - (route 'POST '("x") h-post))) - (let ((handler _b (match-path routes 'GET '("x")))) - (is (eq? h-get handler))) - (let ((handler _b (match-path routes 'POST '("x")))) - (is (eq? h-post handler)))) - - (test "multi-method route" - (define h (lambda (r) 'ok)) - (define routes (list (route '(GET HEAD) '("x") h))) - (let ((handler _b (match-path routes 'GET '("x")))) - (is (eq? h handler))) - (let ((handler _b (match-path routes 'HEAD '("x")))) - (is (eq? h handler))) - (let ((handler _b (match-path routes 'POST '("x")))) - (is (not (eq? h handler)))))) - - (suite "route-group" - - (test "prefix nesting" - (define h (lambda (r) 'ok)) - (define routes - (list (route-group '("api") - (route 'GET '("users") h #:name 'api-users)))) - (let ((handler _b (match-path routes 'GET '("api" "users")))) - (is (eq? h handler))) - (let ((handler _b (match-path routes 'GET '("users")))) - (is (not (eq? h handler)))))) - - (suite "wrap-routes" - - (test "wrapper ordering" - ;; First wrapper = outermost = runs first on request. - ;; We verify by building a call log. - (define log '()) - (define (make-wrapper tag) - (lambda (handler) - (lambda (request) - (set! log (append log (list tag))) - (handler request)))) - (define h (lambda (r) (set! log (append log '(handler))) 'ok)) - (define r (route 'GET '("x") h)) - (wrap-routes (list r) (make-wrapper 'a) (make-wrapper 'b)) - ((route-handler r) 'fake-request) - (is (equal? '(a b handler) log)))) - - (suite "find-allowed-methods" - - (test "returns methods for path-matched routes" - (define routes - (list (route 'GET '("users") identity) - (route 'POST '("users") identity))) - (let ((compiled _rr (compile-routes (append routes (list catch-all))))) - (is (equal? '(POST GET) - (find-allowed-methods compiled '("users")))))) - - (test "returns empty for unmatched path" - (define routes (list (route 'GET '("users") identity))) - (let ((compiled _rr (compile-routes (append routes (list catch-all))))) - (is (equal? '() (find-allowed-methods compiled '("other")))))) - - (test "collects from multi-method routes" - (define routes (list (route '(GET HEAD) '("x") identity) - (route 'POST '("x") identity))) - (let ((compiled _rr (compile-routes (append routes (list catch-all))))) - (is (equal? '(POST HEAD GET) - (find-allowed-methods compiled '("x")))))) - - (test "deduplicates methods" - (define routes (list (route 'GET '("x") identity) - (route 'GET '("x") identity))) - (let ((compiled _rr (compile-routes (append routes (list catch-all))))) - (is (equal? '(GET) - (find-allowed-methods compiled '("x")))))) - - (test "excludes catch-all from scan" - (let ((compiled _rr (compile-routes (list catch-all)))) - (is (equal? '() (find-allowed-methods compiled '("anything"))))))) - - (suite "path-for" - - (test "simple and parameterised" - (define grp - (route-group '() - (route 'GET '("users") identity #:name 'users) - (route 'GET '("users" id) identity #:name 'user))) - (let ((_compiled rr - (compile-routes (list grp catch-all)))) - (parameterize ((current-reverse-routes rr)) - (is (equal? "/users" (path-for grp 'users))) - (is (equal? "/users/42" (path-for grp 'user '((id . "42")))))))) - - (test "query and fragment" - (define grp - (route-group '() - (route 'GET '("search") identity #:name 'search))) - (let ((_compiled rr - (compile-routes (list grp catch-all)))) - (parameterize ((current-reverse-routes rr)) - (is (equal? "/search?q=hello" - (path-for grp 'search '() #:query '((q . "hello"))))) - (is (equal? "/search#top" - (path-for grp 'search '() #:fragment "top")))))) - - (test "scoped lookup in group" - (define grp - (route-group '("api") #:name 'api - (route 'GET '("items") identity #:name 'items))) - (let ((_compiled rr - (compile-routes (list grp catch-all)))) - (parameterize ((current-reverse-routes rr)) - (is (equal? "/api/items" (path-for grp 'items)))))))) - -(run-tests router-tests) diff --git a/tests/test-templating.scm b/tests/test-templating.scm deleted file mode 100644 index 5a632c1..0000000 --- a/tests/test-templating.scm +++ /dev/null @@ -1,102 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 -;; . - -;;; test-templating.scm — Tests for (safsaf templating) - -(use-modules (tests support) - (safsaf templating) - (htmlprag) - (srfi srfi-71) - (web response)) - -(define (render shtml) - "Write SHTML via write-shtml-as-html/streaming and capture as a string." - (call-with-output-string - (lambda (port) (write-shtml-as-html/streaming shtml port)))) - -(define-suite templating-tests - - (suite "write-shtml-as-html/streaming" - - (test "pure static shtml" - (let ((out (render '(p "hello")))) - (is (string-contains out "

hello

")))) - - (test "single proc slot" - (let ((out (render - `(div ,(lambda (port) (display "dynamic" port)))))) - (is (string-contains out "dynamic")))) - - (test "multiple slots in order" - (let ((out (render - `(div ,(lambda (port) (display "AAA" port)) - ,(lambda (port) (display "BBB" port)))))) - (let ((a (string-contains out "AAA")) - (b (string-contains out "BBB"))) - (is a) - (is b) - (is (< a b))))) - - (test "static content between slots preserved" - (let ((out (render - `(div ,(lambda (port) (display "X" port)) - (hr) - ,(lambda (port) (display "Y" port)))))) - (is (string-contains out "inner")))) - - (test "attributes preserved" - (let ((out (render - `(div (@ (class "box")) - ,(lambda (port) (display "content" port)))))) - (is (string-contains out "class=\"box\"")) - (is (string-contains out "content")))) - - (test "*TOP* with procs" - (let ((out (render - `(*TOP* - (*DECL* DOCTYPE html) - (html (body ,(lambda (port) (display "hi" port)))))))) - (is (string-contains out "")) - (is (string-contains out "hi")))) - - (test "proc can write shtml via htmlprag" - (let ((out (render - `(div ,(lambda (port) - (write-shtml-as-html '(p "from-proc") port)))))) - (is (string-contains out "

from-proc

"))))) - - (suite "streaming-html-response" - - (test "returns response and writer" - (let ((resp body (streaming-html-response '(p "hi")))) - (is (= 200 (response-code resp))) - (is (procedure? body)) - (is (equal? '(text/html (charset . "utf-8")) - (assq-ref (response-headers resp) 'content-type))))) - - (test "body writes shtml with procs" - (let ((resp body (streaming-html-response - `(div ,(lambda (port) (display "streamed" port)))))) - (let ((out (call-with-output-string body))) - (is (string-contains out "streamed"))))))) - -(run-tests templating-tests) diff --git a/tests/test-utils.scm b/tests/test-utils.scm deleted file mode 100644 index 3748a5d..0000000 --- a/tests/test-utils.scm +++ /dev/null @@ -1,85 +0,0 @@ -;; Safsaf, a Guile web framework -;; Copyright (C) 2026 Christopher Baines - -;; This program 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 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 -;; 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 -;; . - -;;; test-utils.scm — Tests for (safsaf utils) - -(use-modules (tests support) - (safsaf utils) - (web request) - (web uri)) - -(define* (make-request method path #:key (headers '())) - (build-request (string->uri (string-append "http://localhost" path)) - #:method method - #:headers headers)) - -(define-suite utils-tests - (suite "parse-query-string" - (test "parses key=value pairs" - (let* ((req (make-request 'GET "/?foo=bar&baz=qux")) - (qs (parse-query-string req))) - (is (equal? '(("foo" . "bar") ("baz" . "qux")) qs)))) - - (test "returns empty list when no query string" - (let* ((req (make-request 'GET "/")) - (qs (parse-query-string req))) - (is (null? qs)))) - - (test "decodes URL-encoded values" - (let* ((req (make-request 'GET "/?name=hello%20world")) - (qs (parse-query-string req))) - (is (equal? "hello world" (assoc-ref qs "name"))))) - - (test "handles key without value" - (let* ((req (make-request 'GET "/?flag")) - (qs (parse-query-string req))) - (is (equal? '(("flag" . "")) qs)))) - - (test "handles multiple values for same key" - (let* ((req (make-request 'GET "/?x=1&x=2")) - (qs (parse-query-string req))) - (is (= 2 (length qs))) - (is (equal? "1" (assoc-ref qs "x")))))) - - (suite "request-cookies" - (test "parses cookie header" - (let* ((req (make-request 'GET "/" - #:headers '((cookie . (("a" . "1") - ("b" . "2")))))) - (cookies (request-cookies req))) - (is (equal? '(("a" . "1") ("b" . "2")) cookies)))) - - (test "returns empty list when no cookie header" - (let* ((req (make-request 'GET "/")) - (cookies (request-cookies req))) - (is (null? cookies))))) - - (suite "request-cookie-ref" - (test "returns cookie value by name" - (let ((req (make-request 'GET "/" - #:headers '((cookie . (("sid" . "abc123"))))))) - (is (equal? "abc123" (request-cookie-ref req "sid"))))) - - (test "returns #f when cookie not found" - (let ((req (make-request 'GET "/"))) - (is (not (request-cookie-ref req "missing"))))) - - (test "returns default when cookie not found" - (let ((req (make-request 'GET "/"))) - (is (equal? "fallback" (request-cookie-ref req "missing" "fallback"))))))) - -(run-tests utils-tests)