From b7cee3dba696e30eb737568c19decfb1b659beb3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Sun, 28 Aug 2022 22:04:24 +0200 Subject: Rewrote make-routes to use define-syntax. This is the first step into adding extra functionallity, since I now want have to worry about how namespace pollution works. --- module/calp/repl.scm | 1 + module/calp/server/routes.scm | 3 +- module/web/http/make-routes.scm | 197 ++++++++++++++++++++++++---------------- tests/test/annoying-events.scm | 9 +- 4 files changed, 123 insertions(+), 87 deletions(-) diff --git a/module/calp/repl.scm b/module/calp/repl.scm index 7beee560..aaa1061c 100644 --- a/module/calp/repl.scm +++ b/module/calp/repl.scm @@ -5,6 +5,7 @@ (define-module (calp repl) :use-module (system repl server) :use-module (ice-9 regex) + :use-module (ice-9 format) :use-module ((calp util hooks) :select (shutdown-hook)) :use-module ((hnh util exceptions) :select (warning)) :use-module (calp translation) diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index ed2c1b2d..6701d8b4 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -163,8 +163,7 @@ next-start: (lambda (d) (date+ d (date day: 7))) prev-start: (lambda (d) (date- d (date day: 7))) render-calendar: (@ (calp html view calendar week) render-calendar) - intervaltype: 'week - ))))))) + intervaltype: 'week))))))) (GET "/month/:start-date.html" (start-date html) (let ((start-date (start-of-month (parse-iso-date start-date)))) diff --git a/module/web/http/make-routes.scm b/module/web/http/make-routes.scm index aa3be1ed..c3d8b997 100644 --- a/module/web/http/make-routes.scm +++ b/module/web/http/make-routes.scm @@ -3,15 +3,28 @@ :use-module (ice-9 regex) :use-module (ice-9 match) :use-module (ice-9 curried-definitions) + :use-module (ice-9 control) :use-module (srfi srfi-1) :use-module (srfi srfi-71) :use-module (srfi srfi-88) + :use-module ((web query) :select (parse-query)) + :use-module ((web response) :select (build-response)) + :use-module ((ice-9 iconv) :select (bytevector->string)) :export (parse-endpoint-string make-routes) ) +;; Parses an endpoint description, and returns two values: +;; - a regex string which matches the rule +;; - the list of symbols embedded int the string +;; An endpoint string looks like +;; /calendar/:uid{.*}.ics +;; Where "/calendar/" matches literally +;; followed by something matching ".*" +;; followed by something literally matching ".ics" +;; and '(uid) would be the second return (define (parse-endpoint-string str) (let ((rx (make-regexp ":([^/.]+)(\\{([^}]+)\\})?([.])?"))) (let loop ((str str) @@ -38,87 +51,113 @@ (cons (string->symbol (match:substring m 1)) tokens))))))) - -(define ((generate-case regex-table) defn) - (match defn +(define ((generate-case regexes r:method r:path) stx) + (syntax-case stx () ((method uri param-list body ...) - (let* ((_ tokens (parse-endpoint-string uri)) - (diff intersect (lset-diff+intersection eq? param-list tokens))) - `((and (eq? r:method (quote ,method)) - (regexp-exec ,(car (assoc-ref regex-table uri)) r:path)) - => (lambda (match-object) - ;; (assert - ;; (= (1- (match:count match-object)) - ;; (length intersect))) + (let* ((regex tokens (parse-endpoint-string (syntax->datum #'uri))) + (diff intersect (lset-diff+intersection eq? (syntax->datum #'param-list) + tokens)) + (argument-list (if (null? diff) + #'() #`(key: #,@(map (lambda (x) (datum->syntax stx x)) diff) + allow-other-keys: rest: rest))) + (intersect-list (map (lambda (x) (datum->syntax stx x)) intersect)) + (rx-var (list-ref (assoc regex regexes) 1))) + #`((and (eq? #,r:method (quote method)) + (regexp-exec #,rx-var #,r:path)) + => (lambda (match-object) + ;; Those parameters which were present in the template uri + ((lambda #,intersect-list + ;; Those that only are in the query string + (lambda* #,argument-list body ...)) + #,@(unless (null? intersect) + (map (lambda (i) #`(match:substring match-object #,i)) + (cdr (iota (1+ (length intersect))))))))))))) + + +(define-syntax (make-routes stx) + (syntax-case stx () + ((_ routes ...) + (with-syntax ((r:method (datum->syntax stx 'r:method)) + (r:uri (datum->syntax stx 'r:uri)) + (r:version (datum->syntax stx 'r:version)) + (r:headers (datum->syntax stx 'r:headers)) + (r:meta (datum->syntax stx 'r:meta)) + (r:scheme (datum->syntax stx 'r:scheme)) + (r:userinfo (datum->syntax stx 'r:userinfo)) + (r:host (datum->syntax stx 'r:host)) + (r:port (datum->syntax stx 'r:port)) + (r:path (datum->syntax stx 'r:path)) + (r:query (datum->syntax stx 'r:query)) + (r:fragment (datum->syntax stx 'r:fragment)) + + (return (datum->syntax stx 'return)) + (request (datum->syntax stx 'request)) + (body (datum->syntax stx 'body)) + (state (datum->syntax stx 'state)) + ) + + ;; Ensures that all regexes are only compiled once. + ;; Given (GET "/today/" (view date) body ...) + ;; returns ("/today/" #'*random-symbol* #'(make-regexp "^/today//?$" regexp/icase)) + (define routes-regexes + (map (lambda (stx-1) + (syntax-case stx-1 () + ((%fst uri %rest ...) + (let ((regex _ (parse-endpoint-string (syntax->datum #'uri)))) + (list regex (datum->syntax stx (gensym "rx-")) + #`(make-regexp #,(string-append "^" regex "/?$") regexp/icase)))))) + #'(routes ...))) + + #`(let #,(map cdr routes-regexes) + (lambda* (request body optional: state) + ;; (format (current-error-port) "~a~%" request) + ;; All these bindings generate compile time warnings since the expansion + ;; of the macro might not use them. This isn't really a problem. + (let ((r:method ((@ (web request) request-method) request)) + (r:uri ((@ (web request) request-uri) request)) + (r:version ((@ (web request) request-version) request)) + (r:headers ((@ (web request) request-headers) request)) + (r:meta ((@ (web request) request-meta) request))) + (let ((r:scheme ((@ (web uri) uri-scheme) r:uri)) + (r:userinfo ((@ (web uri) uri-userinfo) r:uri)) + ;; uri-{host,port} is (probably) not set when we are a server, + ;; fetch them from the request instead + (r:host (or ((@ (web uri) uri-host) r:uri) + (and=> ((@ (web request) request-host) request) car))) + (r:port (or ((@ (web uri) uri-port) r:uri) + (and=> ((@ (web request) request-host) request) cdr))) + (r:path ((@ (web uri) uri-path) r:uri)) + (r:query ((@ (web uri) uri-query) r:uri)) + (r:fragment ((@ (web uri) uri-fragment) r:uri))) + + ;; TODO propper logging + (display (format #f "[~a] ~a ~a:~a~a?~a~%" + (datetime->string (current-datetime)) + r:method r:host r:port r:path (or r:query "")) + (current-error-port)) - ;; Those parameters which were present in the template uri - ((lambda ,intersect - ;; Those that only are in the query string - (lambda* (,@(unless (null? diff) `(key: ,@diff allow-other-keys:)) - rest: rest) - ,@body)) - ,@(unless (null? intersect) - (map (lambda (i) - `((@ (ice-9 regex) match:substring) match-object ,i)) - (cdr (iota (1+ (length intersect))))))))))))) + (call-with-values + (lambda () + (call/ec + (lambda (return) + (apply + (cond #,@(map (generate-case routes-regexes #'r:method #'r:path) #'(routes ...)) + (else (lambda* _ (return (build-response code: 404) + "404 Not Fonud")))) + (append + (parse-query r:query) -(define-macro (make-routes . routes) - ;; Ensures that all regexes are only compiled once. - (define routes-regexes - (map (lambda (uri) - (define-values (regex _) (parse-endpoint-string uri)) - (list uri (gensym) `(make-regexp ,(string-append "^" regex "/?$") regexp/icase))) - (map cadr routes))) + ;; When content-type is application/x-www-form-urlencoded, + ;; decode them, and add it to the argument list + (let ((content-type (assoc-ref r:headers 'content-type))) + (when content-type + (let ((type args (car+cdr content-type))) + (when (eq? type 'application/x-www-form-urlencoded) + (let ((encoding (or (assoc-ref args 'encoding) "UTF-8"))) + (parse-query (bytevector->string body encoding) + encoding))))))))))) - `(let ,(map cdr routes-regexes) - (lambda* (request body optional: state) - ;; (format (current-error-port) "~a~%" request) - ;; All these bindings generate compile time warnings since the expansion - ;; of the macro might not use them. This isn't really a problem. - (let ((r:method ((@ (web request) request-method) request)) - (r:uri ((@ (web request) request-uri) request)) - (r:version ((@ (web request) request-version) request)) - (r:headers ((@ (web request) request-headers) request)) - (r:meta ((@ (web request) request-meta) request))) - (let ((r:scheme ((@ (web uri) uri-scheme) r:uri)) - (r:userinfo ((@ (web uri) uri-userinfo) r:uri)) - ;; uri-{host,port} is (probably) not set when we are a server, - ;; fetch them from the request instead - (r:host (or ((@ (web uri) uri-host) r:uri) - (and=> ((@ (web request) request-host) request) car))) - (r:port (or ((@ (web uri) uri-port) r:uri) - (and=> ((@ (web request) request-host) request) cdr))) - (r:path ((@ (web uri) uri-path) r:uri)) - (r:query ((@ (web uri) uri-query) r:uri)) - (r:fragment ((@ (web uri) uri-fragment) r:uri))) - ;; TODO propper logging - (display (format #f "[~a] ~a ~a:~a~a?~a~%" - (datetime->string (current-datetime)) - r:method r:host r:port r:path (or r:query "")) - (current-error-port)) - (call-with-values - (lambda () - ((@ (ice-9 control) call/ec) - (lambda (return) - (apply - (cond ,@(map (generate-case routes-regexes) routes) - (else (lambda* _ (return ((@ (web response) build-response) code: 404) - "404 Not Fonud")))) - (append - ((@ (web query) parse-query) r:query) + (case-lambda ((headers body new-state) (values headers body new-state)) + ((headers body) (values headers body state)) + ((headers) (values headers "" state)))))))))))) - ;; TODO what's happening here? - (let ((content-type (assoc-ref r:headers 'content-type))) - ((@ (hnh util) when) content-type - (let ((type (car content-type)) - (args (cdr content-type))) - ((@ (hnh util) when) - (eq? type 'application/x-www-form-urlencoded) - (let ((encoding (or (assoc-ref args 'encoding) "UTF-8"))) - ((@ (web query) parse-query) - ((@ (ice-9 iconv) bytevector->string) - body encoding) - encoding))))))))))) - (case-lambda ((headers body new-state) (values headers body new-state)) - ((headers body) (values headers body state)) - ((headers) (values headers "" state))))))))) diff --git a/tests/test/annoying-events.scm b/tests/test/annoying-events.scm index 673a4b49..4e5aa07d 100644 --- a/tests/test/annoying-events.scm +++ b/tests/test/annoying-events.scm @@ -17,12 +17,9 @@ ;; TODO remove this (define* (event key: summary dtstart dtend) (define ev (make-vcomponent 'VEVENT)) - (set! (prop ev 'SUMMARY) - summary - (prop ev 'DTSTART) - dtstart - (prop ev 'DTEND) - dtend) + (set! (prop ev 'SUMMARY) summary + (prop ev 'DTSTART) dtstart + (prop ev 'DTEND) dtend) ev) (define start -- cgit v1.2.3