cbaines/safsaf
cbaines/safsaf
1
Fork 0
Code Issues Pull requests Projects Releases Activity Actions

Initial commit
All checks were successful
/ test (push) Successful in 9s
Details

Browse source 
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.
This commit is contained in:
Christopher Baines 2026-04-13 14:24:19 +03:00
commit 5b0e6397dc
53 changed files with 7427 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

107
safsaf/handler-wrappers/cors.scm Normal file
View file

@ -0,0 +1,107 @@
;; Safsaf, a Guile web framework
;; Copyright (C) 2026 Christopher Baines <mail@cbaines.net>
;; 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
;; <https://www.gnu.org/licenses/>.
(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))))))))

78
safsaf/handler-wrappers/csrf.scm Normal file
View file

@ -0,0 +1,78 @@
;; Safsaf, a Guile web framework
;; Copyright (C) 2026 Christopher Baines <mail@cbaines.net>
;; 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
;; <https://www.gnu.org/licenses/>.
(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) "")))))

201
safsaf/handler-wrappers/exceptions.scm Normal file
View file

@ -0,0 +1,201 @@
;; Safsaf, a Guile web framework
;; Copyright (C) 2026 Christopher Baines <mail@cbaines.net>
;; 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
;; <https://www.gnu.org/licenses/>.
(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))))

48
safsaf/handler-wrappers/logging.scm Normal file
View file

@ -0,0 +1,48 @@
;; Safsaf, a Guile web framework
;; Copyright (C) 2026 Christopher Baines <mail@cbaines.net>
;; 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
;; <https://www.gnu.org/licenses/>.
(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))))

41
safsaf/handler-wrappers/max-body-size.scm Normal file
View file

@ -0,0 +1,41 @@
;; Safsaf, a Guile web framework
;; Copyright (C) 2026 Christopher Baines <mail@cbaines.net>
;; 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
;; <https://www.gnu.org/licenses/>.
(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))))))

66
safsaf/handler-wrappers/security-headers.scm Normal file
View file

@ -0,0 +1,66 @@
;; Safsaf, a Guile web framework
;; Copyright (C) 2026 Christopher Baines <mail@cbaines.net>
;; 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
;; <https://www.gnu.org/licenses/>.
(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)))))

81
safsaf/handler-wrappers/sessions.scm Normal file
View file

@ -0,0 +1,81 @@
;; Safsaf, a Guile web framework
;; Copyright (C) 2026 Christopher Baines <mail@cbaines.net>
;; 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
;; <https://www.gnu.org/licenses/>.
(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))

88
safsaf/handler-wrappers/trailing-slash.scm Normal file
View file

@ -0,0 +1,88 @@
;; Safsaf, a Guile web framework
;; Copyright (C) 2026 Christopher Baines <mail@cbaines.net>
;; 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
;; <https://www.gnu.org/licenses/>.
(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))))
"")))

318
safsaf/params.scm Normal file
View file

@ -0,0 +1,318 @@
;; Safsaf, a Guile web framework
;; Copyright (C) 2026 Christopher Baines <mail@cbaines.net>
;; 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
;; <https://www.gnu.org/licenses/>.
(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 (<invalid-param>
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 <invalid-param>
(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 | <invalid-param>.
;;; 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 | <invalid-param>), and the rest are keyword options:
(name processor) ; optional
(name processor #:required) ; must be present
(name processor #:default value) ; fallback
(name processor #:multi-value) ; collect all occurrences
(name processor #:multi-value #:default value) ; multi-value with fallback
(name processor #:no-default-when (fields) #:default value) ; conditional default
Returns an alist of (symbol . value) pairs. Values that fail validation
appear as <invalid-param> records inline. Missing optional params without
defaults are omitted."
(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 <invalid-param> 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 <invalid-param> 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)
"&"))

370
safsaf/response-helpers.scm Normal file
View file

@ -0,0 +1,370 @@
;; Safsaf, a Guile web framework
;; Copyright (C) 2026 Christopher Baines <mail@cbaines.net>
;; 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
;; <https://www.gnu.org/licenses/>.
(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)))))))))

650
safsaf/router.scm Normal file
View file

@ -0,0 +1,650 @@
;; Safsaf, a Guile web framework
;; Copyright (C) 2026 Christopher Baines <mail@cbaines.net>
;; 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
;; <https://www.gnu.org/licenses/>.
(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 <route>
(%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 <route-group>
(%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{<route>}.")
(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{<route-group>}.")
(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 <compiled-route>
(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 <reverse-routes>
(make-reverse-routes group-table)
reverse-routes?
(group-table reverse-routes-group-table))
(define-record-type <group-scope>
(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 <compiled-route> records ready for matching.
2. A <reverse-routes> record for use with path-for.
The last route must be a catch-all ('* pattern with a rest parameter)
so that every request is handled."
;; group-table: alist of (route-group . <group-scope>), 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)
"&"))

129
safsaf/templating.scm Normal file
View file

@ -0,0 +1,129 @@
;; Safsaf, a Guile web framework
;; Copyright (C) 2026 Christopher Baines <mail@cbaines.net>
;; 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
;; <https://www.gnu.org/licenses/>.
(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 "<!-- " %slot-prefix (number->string index) " -->"))
(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))))

93
safsaf/utils.scm Normal file
View file

@ -0,0 +1,93 @@
;; Safsaf, a Guile web framework
;; Copyright (C) 2026 Christopher Baines <mail@cbaines.net>
;; 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
;; <https://www.gnu.org/licenses/>.
(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 <part> 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)))