;;; Weeb --- Web microframework for GNU Guile
;;; Copyright © 2026 Jakob Kreuze <zerodaysfordays@sdf.org>
;;;
;;; This file is part of Weeb.
;;;
;;; Weeb is free software: you can redistribute it and/or modify it
;;; under the terms of the GNU Affero General Public License as
;;; published by the Free Software Foundation, either version 3 of the
;;; License, or (at your option) any later version.
;;;
;;; Weeb 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 Affero General
;;; Public License for more details.
;;;
;;; You should have received a copy of the GNU Affero General Public
;;; License along with Weeb. If not, see <https://www.gnu.org/licenses/>.

(define-module (weeb router)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (srfi srfi-11)
  #:use-module (weeb struct)
  #:export (define-router
             iter-routes))

(define (uri-template->regexp-string template)
  ;; TODO: Assert that the first character is a slash.
  (define trailing-slash? (string-match ".*/$" template))
  (define components
    (map (lambda (component)
           (let ((variable-match (string-match ":(.*):" component)))
             (if variable-match
                 (list (string->symbol (match:substring variable-match 1)) "([^/]+)")
                 (list #f component))))
         (string-split (if (and trailing-slash? (not (string= template "/")))
                           (substring template 1 (- (string-length template) 1))
                           (substring template 1))
                       #\/)))
  (values (string-append "^/"
                         (string-join (map cadr components) "/")
                         (if trailing-slash? "/?" "")
                         "$")
          (filter symbol? (map car components))))

(define (handle-route request route-object)
  (define (ladder-parameters match-object n)
    (map (lambda (n) (match:substring match-object (+ 1 n)))
         (iota n)))
  (with-accessors (request method uri)
    (match route-object
      ((route-regexp route-variables route-methods proc)
       (let ((match-object (regexp-exec route-regexp uri)))
         (if (and (memq method route-methods) match-object)
             ;; Unfortunately can't reflect on procedure names. We *could*, I
             ;; suppose, pass them as keyword arguments, but I think I want to
             ;; rethink this interface in the future.
             (apply proc request (ladder-parameters match-object (length route-variables)))
             #f))))))

(define-syntax %handle-route
  (lambda (stx)
    (syntax-case stx ()
      ((_ (template methods proc))
       #'(let-values (((regexp-string variables) (uri-template->regexp-string template)))
           (let ((regexp (make-regexp regexp-string)))
             (list regexp variables (quote methods) proc)))))))

(define-syntax define-router
  (lambda (stx)
    (syntax-case stx ()
      ((_ name route* ...)
       #'(define name (list (%handle-route route*) ...))))))

(define (default-handler request)
  '(404 "Route not found."))

(define (iter-routes request router)
  (match router
    (() (default-handler request))
    ((route routes ...)
     (or (handle-route request route) (iter-routes request routes)))))