safsaf/safsaf.scm

;; 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)
  #: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)))))))