safsaf/tests/test-router.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/>.

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