199 lines
7.8 KiB
Scheme
199 lines
7.8 KiB
Scheme
;; 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 uri)
|
|
#:use-module (knots)
|
|
#:use-module (logging logger)
|
|
#:autoload (json builder) (scm->json-string)
|
|
#:use-module (safsaf response-helpers)
|
|
#:export (make-exceptions-handler-wrapper
|
|
exceptions-handler-wrapper
|
|
default-render-error
|
|
default-render-html
|
|
default-render-json))
|
|
|
|
;;;
|
|
;;; HTML pages
|
|
;;;
|
|
|
|
(define (dev-error-page method path backtrace-string)
|
|
"Return an SHTML tree for a development-mode error page."
|
|
`(*TOP*
|
|
(*DECL* DOCTYPE html)
|
|
(html
|
|
(head
|
|
(title "500 - Internal Server Error")
|
|
(style "
|
|
body { font-family: monospace; margin: 2em; background: #1a1a2e; color: #e0e0e0; }
|
|
h1 { color: #e74c3c; }
|
|
.request { color: #a0a0a0; margin-bottom: 1em; }
|
|
pre { background: #16213e; padding: 1em; overflow-x: auto;
|
|
border-left: 3px solid #e74c3c; white-space: pre-wrap; }
|
|
@media (prefers-color-scheme: light) {
|
|
body { background: #f8f8f8; color: #1a1a1a; }
|
|
.request { color: #555; }
|
|
pre { background: #fff; border-left-color: #e74c3c; }
|
|
}
|
|
"))
|
|
(body
|
|
(h1 "Internal Server Error")
|
|
(p (@ (class "request"))
|
|
,(symbol->string method) " " ,path)
|
|
(pre ,backtrace-string)))))
|
|
|
|
(define (prod-error-page code message)
|
|
"Return an SHTML tree for a production error page."
|
|
`(*TOP*
|
|
(*DECL* DOCTYPE html)
|
|
(html
|
|
(head (title ,(string-append (number->string code) " - " message)))
|
|
(body
|
|
(h1 ,(number->string code))
|
|
(p ,message)))))
|
|
|
|
;;;
|
|
;;; Default renderers
|
|
;;;
|
|
|
|
(define (default-render-html request code message backtrace-string dev?)
|
|
"Default HTML error renderer. In dev mode, shows a rich backtrace page.
|
|
In production, returns a minimal HTML page."
|
|
(let ((method (request-method request))
|
|
(path (uri-path (request-uri request))))
|
|
(if dev?
|
|
(html-response (dev-error-page method path backtrace-string)
|
|
#:code code)
|
|
(html-response (prod-error-page code message)
|
|
#:code code))))
|
|
|
|
(define (default-render-json _request code message backtrace-string dev?)
|
|
"Default JSON error renderer. In dev mode, includes the backtrace.
|
|
In production, returns only the error message."
|
|
(let ((body (if dev?
|
|
(scm->json-string `((error . ,message)
|
|
(backtrace . ,backtrace-string)))
|
|
(scm->json-string `((error . ,message))))))
|
|
(json-response body #:code code)))
|
|
|
|
;;;
|
|
;;; Default render-error
|
|
;;;
|
|
|
|
(define (default-render-error render-html render-json)
|
|
"Return a render-error procedure that content-negotiates between
|
|
RENDER-HTML and RENDER-JSON based on the request's Accept header."
|
|
(lambda (request code message backtrace-string dev?)
|
|
(case (negotiate-content-type request '(text/html application/json))
|
|
((text/html) (render-html request code message backtrace-string dev?))
|
|
(else (render-json request code message backtrace-string dev?)))))
|
|
|
|
;;;
|
|
;;; Public API
|
|
;;;
|
|
|
|
(define* (make-exceptions-handler-wrapper #:key
|
|
(dev? #f)
|
|
(logger #f)
|
|
(render-html default-render-html)
|
|
(render-json default-render-json)
|
|
(render-error
|
|
(default-render-error
|
|
render-html render-json)))
|
|
"Return a handler wrapper that catches exceptions and returns an error
|
|
response. See exceptions-handler-wrapper for details."
|
|
(lambda (handler)
|
|
(exceptions-handler-wrapper handler
|
|
#:dev? dev?
|
|
#:logger logger
|
|
#:render-error render-error)))
|
|
|
|
(define* (exceptions-handler-wrapper handler
|
|
#:key
|
|
(dev? #f)
|
|
(logger #f)
|
|
(render-html default-render-html)
|
|
(render-json default-render-json)
|
|
(render-error
|
|
(default-render-error
|
|
render-html render-json)))
|
|
"Handler wrapper that catches exceptions from HANDLER and returns an
|
|
error response.
|
|
|
|
The response format is content-negotiated from the request's Accept header,
|
|
choosing between HTML and JSON.
|
|
|
|
When LOGGER is provided, exceptions are logged through it. Otherwise,
|
|
the backtrace is written to the current error port.
|
|
In dev mode (DEV? is #t), the response includes the backtrace and
|
|
exception details. In production mode, a generic error is returned.
|
|
|
|
Rendering can be customised at three levels:
|
|
|
|
#:render-error — full override. A procedure
|
|
(request code message backtrace-string dev?) -> (values response body)
|
|
that bypasses content negotiation entirely.
|
|
|
|
#:render-html — custom HTML rendering. A procedure with the same
|
|
signature, called when content negotiation selects HTML.
|
|
|
|
#:render-json — custom JSON rendering. A procedure with the same
|
|
signature, called when content negotiation selects JSON.
|
|
|
|
The default RENDER-ERROR content-negotiates between RENDER-HTML and
|
|
RENDER-JSON. Providing #:render-html or #:render-json replaces just
|
|
that format; providing #:render-error replaces the entire rendering."
|
|
(lambda (request body-port)
|
|
(let ((method (request-method request))
|
|
(path (uri-path (request-uri request))))
|
|
(with-exception-handler
|
|
(lambda (exn)
|
|
(let ((backtrace-string
|
|
(call-with-output-string
|
|
(lambda (port)
|
|
(print-backtrace-and-exception/knots
|
|
exn
|
|
#:port port)))))
|
|
(if logger
|
|
(log-msg logger 'ERROR
|
|
method " " path " — unhandled exception:\n"
|
|
backtrace-string)
|
|
(format/knots (current-error-port)
|
|
"~a ~a — unhandled exception:\n~a\n"
|
|
method path backtrace-string))
|
|
(render-error request 500 "Internal Server Error"
|
|
backtrace-string dev?)))
|
|
(lambda ()
|
|
(with-exception-handler
|
|
(lambda (exn)
|
|
(let ((stack
|
|
(match (fluid-ref %stacks)
|
|
((_ . prompt-tag)
|
|
(make-stack #t
|
|
0 prompt-tag
|
|
0 (and prompt-tag 1)))
|
|
(_
|
|
(make-stack #t)))))
|
|
(raise-exception
|
|
(make-exception
|
|
exn
|
|
(make-knots-exception stack)))))
|
|
(lambda ()
|
|
(start-stack #t (handler request body-port)))))
|
|
#:unwind? #t))))
|