blob: 575860b82a84d9d066fea23385308b399800721e (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
|
;;; 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) "/"))
(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*) ...))))))
(use-modules (weeb fcgi))
(define (default-handler request)
(fcgi-display "Status: 404 Not Found\r\n")
(fcgi-display "Content-type: text/html\r\n\r\n")
(fcgi-display "Route not found.\n"))
(define (iter-routes request router)
(match router
(() (default-handler request))
((route routes ...)
(or (handle-route request route) (iter-routes request routes)))))
|
© 2015 - 2026 Jakob L. Kreuze
