commit 5b0e6397dce1ffb487cbb6bb3d0358e6b6836d3e Author: Christopher Baines Date: Mon Apr 13 14:24:19 2026 +0300 Initial commit Safsaf is a Guile web framework, written using Claude Code running Claude Opus 4.6, based off of the Guix Data Service, Nar Herder and Guix Build Coordinator codebases. diff --git a/.dir-locals.el b/.dir-locals.el new file mode 100644 index 0000000..4c877b6 --- /dev/null +++ b/.dir-locals.el @@ -0,0 +1,23 @@ +((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 new file mode 100644 index 0000000..9792607 --- /dev/null +++ b/.forgejo/workflows/build-website.yaml @@ -0,0 +1,28 @@ +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 . + 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 new file mode 100644 index 0000000..bd8864d --- /dev/null +++ b/.gitignore @@ -0,0 +1,28 @@ +# 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 new file mode 100644 index 0000000..39a9743 --- /dev/null +++ b/AUTHORS @@ -0,0 +1,3 @@ +Safsaf was written by: + + Christopher Baines diff --git a/CLAUDE.md b/CLAUDE.md new file mode 100644 index 0000000..52618c5 --- /dev/null +++ b/CLAUDE.md @@ -0,0 +1,88 @@ +# 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 new file mode 100644 index 0000000..f288702 --- /dev/null +++ b/COPYING @@ -0,0 +1,674 @@ + 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 new file mode 100644 index 0000000..0a04128 --- /dev/null +++ b/COPYING.LESSER @@ -0,0 +1,165 @@ + 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 new file mode 100644 index 0000000..5a7c166 --- /dev/null +++ b/Makefile.am @@ -0,0 +1,81 @@ +# 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 new file mode 100644 index 0000000..fcbf9a5 --- /dev/null +++ b/NEWS @@ -0,0 +1,8 @@ +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 new file mode 100644 index 0000000..13bd389 --- /dev/null +++ b/README.md @@ -0,0 +1,80 @@ +# 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 new file mode 100644 index 0000000..a9bd0f7 --- /dev/null +++ b/STYLE.md @@ -0,0 +1,187 @@ +# 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 new file mode 100644 index 0000000..49d5957 --- /dev/null +++ b/VERSION @@ -0,0 +1 @@ +0.1 diff --git a/bootstrap.sh b/bootstrap.sh new file mode 100755 index 0000000..9438d00 --- /dev/null +++ b/bootstrap.sh @@ -0,0 +1,19 @@ +#! /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 new file mode 100644 index 0000000..b2a95d4 --- /dev/null +++ b/build-aux/news-to-texi.scm @@ -0,0 +1,73 @@ +;;; 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 new file mode 100644 index 0000000..1333d81 --- /dev/null +++ b/configure.ac @@ -0,0 +1,58 @@ +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 new file mode 100644 index 0000000..fd46fc1 --- /dev/null +++ b/doc/Makefile.am @@ -0,0 +1,55 @@ +# 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) + $(AM_V_GEN)$(top_builddir)/pre-inst-env \ + $(DOCUMENTA) api -d $(srcdir)/api \ + $(top_srcdir)/safsaf.scm $(top_srcdir)/safsaf/ +endif diff --git a/doc/guidance.texi b/doc/guidance.texi new file mode 100644 index 0000000..716e703 --- /dev/null +++ b/doc/guidance.texi @@ -0,0 +1,424 @@ +@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 new file mode 100644 index 0000000..59b8c42 --- /dev/null +++ b/doc/index.texi @@ -0,0 +1,102 @@ +\input texinfo +@setfilename safsaf.info + +@dircategory The Algorithmic Language Scheme +@direntry +* Safsaf: (safsaf). A web framework for Guile Scheme. +@end direntry + +@html +
+Safsaf +
+@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/doc/logo.svg b/doc/logo.svg new file mode 100644 index 0000000..81bab60 --- /dev/null +++ b/doc/logo.svg @@ -0,0 +1,42 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/examples/blog-site/README b/examples/blog-site/README new file mode 100644 index 0000000..d7f8c92 --- /dev/null +++ b/examples/blog-site/README @@ -0,0 +1,23 @@ +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 new file mode 100644 index 0000000..b5d60d7 --- /dev/null +++ b/examples/blog-site/blog-site.scm @@ -0,0 +1,54 @@ +(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. +(define pool (make-db "/tmp/blog-site.db")) + +;; Initialise the schema. +(db-init! pool) + +;; Session manager — in production, use a proper secret. +(define session-manager + (make-session-config "change-me-in-production" + #:cookie-name "blog-session")) + +;; Build the blog component — handles both HTML and JSON via content negotiation. +(define blog-routes (make-blog-component pool session-manager)) + +;; Static file serving. +(define static-routes + (route-group '("static") + (route 'GET '(. path) + (make-static-handler "./static" + #:cache-control '((max-age . 3600)))))) + +;; Apply handler wrappers and add a catch-all 404 route. +(define all-routes + (wrap-routes (list blog-routes + static-routes + (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)) + +;; Start the server. +(let ((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 new file mode 100644 index 0000000..2382291 --- /dev/null +++ b/examples/blog-site/model.scm @@ -0,0 +1,144 @@ +(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") + (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! pool) + "Create the schema if it doesn't exist." + (call-with-db pool + (lambda (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 (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 new file mode 100644 index 0000000..34cf9d9 --- /dev/null +++ b/examples/blog-site/static/style.css @@ -0,0 +1,30 @@ +* { 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 new file mode 100644 index 0000000..11b26c2 --- /dev/null +++ b/examples/blog-site/views.scm @@ -0,0 +1,466 @@ +(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 (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 (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 (parse-multipart-body request body-port)) + (form (multipart-text-fields parts)) + (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 new file mode 100644 index 0000000..0d790ef --- /dev/null +++ b/examples/paste-bin/paste-bin.scm @@ -0,0 +1,107 @@ +(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 new file mode 100644 index 0000000..b2cf0be --- /dev/null +++ b/guile.am @@ -0,0 +1,39 @@ +# 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 new file mode 100644 index 0000000..08eabf3 --- /dev/null +++ b/guix-dev.scm @@ -0,0 +1,57 @@ +;; 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/pre-inst-env.in b/pre-inst-env.in new file mode 100644 index 0000000..8245438 --- /dev/null +++ b/pre-inst-env.in @@ -0,0 +1,29 @@ +#!/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 new file mode 100644 index 0000000..d2f5b51 --- /dev/null +++ b/safsaf.scm @@ -0,0 +1,161 @@ +;; 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 new file mode 100644 index 0000000..0cfaa57 --- /dev/null +++ b/safsaf/handler-wrappers/cors.scm @@ -0,0 +1,107 @@ +;; 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 (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 new file mode 100644 index 0000000..ef0ae8d --- /dev/null +++ b/safsaf/handler-wrappers/csrf.scm @@ -0,0 +1,78 @@ +;; 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 (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 new file mode 100644 index 0000000..215f7d5 --- /dev/null +++ b/safsaf/handler-wrappers/exceptions.scm @@ -0,0 +1,201 @@ +;; 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 response) + #:use-module (web uri) + #:use-module (knots) + #:use-module (knots backtraces) + #: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 new file mode 100644 index 0000000..d863a15 --- /dev/null +++ b/safsaf/handler-wrappers/logging.scm @@ -0,0 +1,48 @@ +;; 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 new file mode 100644 index 0000000..1411ca6 --- /dev/null +++ b/safsaf/handler-wrappers/max-body-size.scm @@ -0,0 +1,41 @@ +;; 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 new file mode 100644 index 0000000..ca03054 --- /dev/null +++ b/safsaf/handler-wrappers/security-headers.scm @@ -0,0 +1,66 @@ +;; 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 new file mode 100644 index 0000000..e0897f6 --- /dev/null +++ b/safsaf/handler-wrappers/sessions.scm @@ -0,0 +1,81 @@ +;; 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 new file mode 100644 index 0000000..301ce33 --- /dev/null +++ b/safsaf/handler-wrappers/trailing-slash.scm @@ -0,0 +1,88 @@ +;; 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 new file mode 100644 index 0000000..64b54a3 --- /dev/null +++ b/safsaf/params.scm @@ -0,0 +1,318 @@ +;; 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 (ice-9 regex) + #: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 new file mode 100644 index 0000000..3846b0d --- /dev/null +++ b/safsaf/response-helpers.scm @@ -0,0 +1,370 @@ +;; 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 new file mode 100644 index 0000000..7332c7c --- /dev/null +++ b/safsaf/router.scm @@ -0,0 +1,650 @@ +;; 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 new file mode 100644 index 0000000..c8e0c78 --- /dev/null +++ b/safsaf/templating.scm @@ -0,0 +1,129 @@ +;; 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 new file mode 100644 index 0000000..9e9eafd --- /dev/null +++ b/safsaf/utils.scm @@ -0,0 +1,93 @@ +;; 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 (json parser) (json->scm) + #: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 new file mode 100644 index 0000000..8e05229 --- /dev/null +++ b/tests/CLAUDE.md @@ -0,0 +1,73 @@ +# 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 new file mode 100644 index 0000000..dcba5f7 --- /dev/null +++ b/tests/support.scm @@ -0,0 +1,243 @@ +;; 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 new file mode 100644 index 0000000..90e36d4 --- /dev/null +++ b/tests/test-csrf-validation.scm @@ -0,0 +1,65 @@ +;; 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 new file mode 100644 index 0000000..67f65b8 --- /dev/null +++ b/tests/test-exceptions.scm @@ -0,0 +1,146 @@ +;; 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 new file mode 100644 index 0000000..8d60e9f --- /dev/null +++ b/tests/test-handler-wrappers.scm @@ -0,0 +1,274 @@ +;; 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 new file mode 100644 index 0000000..66a3f32 --- /dev/null +++ b/tests/test-integration.scm @@ -0,0 +1,273 @@ +;; 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 new file mode 100644 index 0000000..35e0268 --- /dev/null +++ b/tests/test-params.scm @@ -0,0 +1,307 @@ +;; 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 new file mode 100644 index 0000000..552a633 --- /dev/null +++ b/tests/test-response-helpers.scm @@ -0,0 +1,152 @@ +;; 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 new file mode 100644 index 0000000..61246a8 --- /dev/null +++ b/tests/test-router.scm @@ -0,0 +1,188 @@ +;; 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 new file mode 100644 index 0000000..5a632c1 --- /dev/null +++ b/tests/test-templating.scm @@ -0,0 +1,102 @@ +;; 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 new file mode 100644 index 0000000..3748a5d --- /dev/null +++ b/tests/test-utils.scm @@ -0,0 +1,85 @@ +;; 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)