From 5b8c3a4af483deab668af3aff12f6f3d19556841 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Mon, 17 Aug 2020 19:22:57 +0200 Subject: fixes. --- module/calp/entry-points/server.scm | 2 +- module/calp/server/routes.scm | 2 +- module/calp/server/server.scm | 4 +- module/web/http/macro.scm | 105 ----------------------------------- module/web/http/make-routes.scm | 106 ++++++++++++++++++++++++++++++++++++ 5 files changed, 110 insertions(+), 109 deletions(-) delete mode 100644 module/web/http/macro.scm create mode 100644 module/web/http/make-routes.scm diff --git a/module/calp/entry-points/server.scm b/module/calp/entry-points/server.scm index 97397e5d..443892f3 100644 --- a/module/calp/entry-points/server.scm +++ b/module/calp/entry-points/server.scm @@ -8,7 +8,7 @@ :use-module (ice-9 getopt-long) ;; :use-module (ice-9 regex) #| regex here due to bad macros |# - :use-module ((server server) :select (start-server)) + :use-module ((calp server server) :select (start-server)) :export (main)) diff --git a/module/calp/server/routes.scm b/module/calp/server/routes.scm index afca2d7d..697f2e50 100644 --- a/module/calp/server/routes.scm +++ b/module/calp/server/routes.scm @@ -1,4 +1,4 @@ -(define-module (server routes) +(define-module (calp server routes) :use-module (util) :use-module (util options) :use-module (util exceptions) diff --git a/module/calp/server/server.scm b/module/calp/server/server.scm index 9c857b6d..1ad700f1 100644 --- a/module/calp/server/server.scm +++ b/module/calp/server/server.scm @@ -1,7 +1,7 @@ -(define-module (server server) +(define-module (calp server server) :use-module (util) :use-module (web server) - :use-module ((server routes) :select (make-make-routes)) + :use-module ((calp server routes) :select (make-make-routes)) :use-module (ice-9 threads)) ;; NOTE The default make-default-socket is broken for IPv6. diff --git a/module/web/http/macro.scm b/module/web/http/macro.scm deleted file mode 100644 index a0113f46..00000000 --- a/module/web/http/macro.scm +++ /dev/null @@ -1,105 +0,0 @@ -(define-module (web http make-routes) - :export (make-routes) - :use-module (util) - :use-module (ice-9 regex) - :use-module (srfi srfi-1) - :use-module (web response) - :use-module (web uri)) - - - -(define-public (parse-endpoint-string str) - (let ((rx (make-regexp ":([^/.]+)(\\{([^}]+)\\})?([.])?"))) - (let loop ((str str) - (string "") - (tokens '())) - (let ((m (regexp-exec rx str 0))) - (if (not m) - ;; done - (values (string-append string str) (reverse tokens)) - - (loop (match:suffix m) - (string-append string (match:prefix m) - (aif (match:substring m 3) - (string-append "(" it ")") - "([^/.]+)") - ;; period directly following matched variable. - ;; since many variables break on period, we often - ;; want to match a literal period directly after them. - ;; Ideally all periods outside of pattern should be - ;; matched literally, but that's harder to implement. - (regexp-quote - (aif (match:substring m 4) - "." ""))) - (cons (string->symbol (match:substring m 1)) - tokens))))))) - -(define (generate-case defn) - (let* (((method uri param-list . body) defn) - (regex 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)) - => (lambda (match-object) - ;; (assert - ;; (= (1- (match:count match-object)) - ;; (length intersect))) - - ;; 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) - `(match:substring match-object ,i)) - (cdr (iota (1+ (length intersect))))))))))) - -(define-macro (make-routes . 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)) - (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))) - (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 - (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"))) - (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/module/web/http/make-routes.scm b/module/web/http/make-routes.scm new file mode 100644 index 00000000..c725513d --- /dev/null +++ b/module/web/http/make-routes.scm @@ -0,0 +1,106 @@ +(define-module (web http make-routes) + :export (make-routes) + :use-module (util) + :use-module (ice-9 regex) + :use-module (srfi srfi-1) + :use-module (web response) + :use-module (web uri)) + + + +(define-public (parse-endpoint-string str) + (let ((rx (make-regexp ":([^/.]+)(\\{([^}]+)\\})?([.])?"))) + (let loop ((str str) + (string "") + (tokens '())) + (let ((m (regexp-exec rx str 0))) + (if (not m) + ;; done + (values (string-append string str) (reverse tokens)) + + (loop (match:suffix m) + (string-append string (match:prefix m) + (aif (match:substring m 3) + (string-append "(" it ")") + "([^/.]+)") + ;; period directly following matched variable. + ;; since many variables break on period, we often + ;; want to match a literal period directly after them. + ;; Ideally all periods outside of pattern should be + ;; matched literally, but that's harder to implement. + (regexp-quote + (aif (match:substring m 4) + "." ""))) + (cons (string->symbol (match:substring m 1)) + tokens))))))) + +(define (generate-case defn) + (let* (((method uri param-list . body) defn) + (regex 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)) + => (lambda (match-object) + ;; (assert + ;; (= (1- (match:count match-object)) + ;; (length intersect))) + + ;; 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) + `(match:substring match-object ,i)) + (cdr (iota (1+ (length intersect))))))))))) + +(define-macro (make-routes . 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)) + (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))) + (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 ((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)))))))) -- cgit v1.2.3