diff options
| -rw-r--r-- | tests/router.scm | 48 | ||||
| -rw-r--r-- | weeb/main.scm | 27 | ||||
| -rw-r--r-- | weeb/request.scm | 24 | ||||
| -rw-r--r-- | weeb/router.scm | 48 |
4 files changed, 138 insertions, 9 deletions
diff --git a/tests/router.scm b/tests/router.scm index 5bdbd51..6f1ddfb 100644 --- a/tests/router.scm +++ b/tests/router.scm @@ -1,10 +1,14 @@ (use-modules (srfi srfi-11) (srfi srfi-64) - (weeb router)) + (weeb router) + (weeb request) + (weeb struct)) ;; Private imports for testing purposes. (define uri-template->regexp-string (@@ (weeb router) uri-template->regexp-string)) +(define handle-route + (@@ (weeb router) handle-route)) (test-runner-current (test-runner-simple)) @@ -30,4 +34,46 @@ (test-equal "/api/([^/]+)/data" re) (test-equal '(version) vars))) +(test-group "handle route" + (define (handler r id) + (list id)) + (define-router router + ("/user/:id:" (GET) handler)) + (let* ((req (make-struct <request> 'GET "/user/123/" #f #f #f)) + (route-obj (car router))) + (test-equal '("123") (handle-route req route-obj))) + (let ((req (make-struct <request> 'POST "/user/123/" #f #f #f)) + (route-obj (car router))) + (test-eqv #f (handle-route req route-obj)))) + +(test-group "iter-routes 1" + (define (static-handler r) "static") + (define (api-handler r version) (list version)) + (define-router router + ("/static/" (GET) static-handler) + ("/api/:version:/data" (GET) api-handler)) + (let ((req (make-struct <request> 'GET "/api/v1/data" #f #f #f))) + (test-equal '("v1") (iter-routes req router)))) + +(test-group "iter-routes 2" + (define (handler r org_id user_id) (list org_id user_id)) + (define-router router + ("/org/:org_id:/user/:user_id:/" (GET) handler)) + (let ((req (make-struct <request> 'GET "/org/42/user/99/" #f #f #f))) + (test-equal '("42" "99") (iter-routes req router)))) + +(test-group "edge cases 1" + (define (handler request) "ok") + (define-router router + ("/health" (GET) handler)) + (let ((req (make-struct <request> 'GET "/health" #f #f #f))) + (test-equal "ok" (iter-routes req router)))) + +(test-group "edge cases 2" + (define (handler request) "home") + (define-router router + ("/" (GET) handler)) + (let ((req (make-struct <request> 'GET "/" #f #f #f))) + (test-equal "home" (iter-routes req router)))) + (test-end) diff --git a/weeb/main.scm b/weeb/main.scm index 2fc6df1..4c7e69f 100644 --- a/weeb/main.scm +++ b/weeb/main.scm @@ -20,16 +20,18 @@ #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) ;; Temporary, probably #:use-module (weeb fcgi) #:use-module (weeb request) + #:use-module (weeb router) #:use-module (weeb struct) #:export (weeb main)) (define (receive-request) (define string->method (match-lambda - (("GET" 'GET) - ("POST" 'POST)))) + ("GET" 'GET) + ("POST" 'POST))) ;; According to RFC 9110, header names must be treated as case-insensitive. (define headers (filter-map @@ -44,13 +46,26 @@ ,(match:substring match-object 2)) #f))) (environ))) - (let* ((method (getenv "REQUEST_METHOD")) + (let* ((method (string->method (getenv "REQUEST_METHOD"))) (uri (getenv "REQUEST_URI"))) (make-struct <request> method uri '() headers (fcgi-read)))) +(define (show-headers request) + ;; TODO: Return a response object. + (with-accessors (request headers) + (fcgi-display "Content-type: text/html\r\n\r\n") + (fcgi-display (format #f "~a" headers)))) + +(define (show-message request message) + (fcgi-display (format #f "~a" message))) + +(define-router router + ("/headers" (GET) show-headers) + ("/echo/:message:" (GET) show-message)) + (define (run-server) (while (zero? (fcgi-accept)) (let ((request (receive-request))) - (with-accessors (request method uri headers body) - (fcgi-display "Content-type: text/html\r\n\r\n") - (fcgi-display (format #f "~a" headers)))))) + (iter-routes request router)))) + +(run-server) diff --git a/weeb/request.scm b/weeb/request.scm new file mode 100644 index 0000000..42cd933 --- /dev/null +++ b/weeb/request.scm @@ -0,0 +1,24 @@ +;;; 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 request) + #:use-module (weeb struct) + #:export (<request>)) + +(define-struct <request> + method uri parameters headers body) diff --git a/weeb/router.scm b/weeb/router.scm index 8c4b502..575860b 100644 --- a/weeb/router.scm +++ b/weeb/router.scm @@ -17,9 +17,12 @@ ;;; 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)) + #:export (define-router + iter-routes)) (define (uri-template->regexp-string template) ;; TODO: Assert that the first character is a slash. @@ -30,9 +33,50 @@ (if variable-match (list (string->symbol (match:substring variable-match 1)) "([^/]+)") (list #f component)))) - (string-split (if trailing-slash? + (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))))) |