diff options
Diffstat (limited to 'module/web/http/make-routes.scm')
| -rw-r--r-- | module/web/http/make-routes.scm | 121 |
1 files changed, 63 insertions, 58 deletions
diff --git a/module/web/http/make-routes.scm b/module/web/http/make-routes.scm index 7254fcb5..11f7dfb4 100644 --- a/module/web/http/make-routes.scm +++ b/module/web/http/make-routes.scm @@ -2,9 +2,9 @@ :export (make-routes) :use-module (hnh util) :use-module (ice-9 regex) + :use-module (ice-9 curried-definitions) :use-module (srfi srfi-1) - :use-module (web response) - :use-module (web uri)) + ) @@ -34,13 +34,13 @@ (cons (string->symbol (match:substring m 1)) tokens))))))) -(define (generate-case defn) + +(define ((generate-case regex-table) defn) (let* (((method uri param-list . body) defn) - (regex tokens (parse-endpoint-string uri)) + (_ tokens (parse-endpoint-string uri)) (diff intersect (lset-diff+intersection eq? param-list tokens))) `((and (eq? r:method (quote ,method)) - (regexp-exec (make-regexp ,(string-append "^" regex "/?$") regexp/icase) - r:path)) + (regexp-exec ,(car (assoc-ref regex-table uri)) r:path)) => (lambda (match-object) ;; (assert ;; (= (1- (match:count match-object)) @@ -54,60 +54,65 @@ ,@body)) ,@(unless (null? intersect) (map (lambda (i) - `(match:substring match-object ,i)) + `((@ (ice-9 regex) match:substring) match-object ,i)) (cdr (iota (1+ (length intersect))))))))))) (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))) - `(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)) - (r:port ((@ (web request) request-port) request))) - (let ((r:scheme ((@ (web uri) uri-scheme) r:uri)) - (r:userinfo ((@ (web uri) uri-userinfo) r:uri)) - ;; TODO can sometimes be a pair of host and port - ;; '("localhost" . 8080). It shouldn't... - (r:host (or ((@ (web uri) uri-host) r:uri) - ((@ (web request) request-host) - request))) - (r:port (or ((@ (web uri) uri-port) r:uri) - ((@ (web request) request-port) - request))) - (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~%" - (datetime->string (current-datetime)) - r:method r:host 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) - (else (lambda* _ (return (build-response #:code 404) - "404 Not Fonud")))) - (append - ((@ (web query) parse-query) r:query) + `(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) - (let ((content-type (assoc-ref r:headers 'content-type))) - (when content-type - (let ((type (car content-type)) - (args (cdr content-type))) - (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)))))))) + (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))))))))) |