diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-13 10:43:33 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-08-13 10:43:33 +0200 |
commit | a902eb51621521d45c648d6a4d06d70d981dfaeb (patch) | |
tree | afc31d4d17fa3939585ad30878b5b690d3b80db3 /module/server/macro.scm | |
parent | Add TODO's (diff) | |
parent | Comment about generalizing. (diff) | |
download | calp-a902eb51621521d45c648d6a4d06d70d981dfaeb.tar.gz calp-a902eb51621521d45c648d6a4d06d70d981dfaeb.tar.xz |
Merge branch 'calchooser' into master
Diffstat (limited to 'module/server/macro.scm')
-rw-r--r-- | module/server/macro.scm | 62 |
1 files changed, 34 insertions, 28 deletions
diff --git a/module/server/macro.scm b/module/server/macro.scm index b6983c7e..2fb87f54 100644 --- a/module/server/macro.scm +++ b/module/server/macro.scm @@ -63,37 +63,43 @@ (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 (request-method request)) - (r:uri (request-uri request)) - (r:version (request-version request)) - (r:headers (request-headers request)) - (r:meta (request-meta request)) - (r:port (request-port request))) - (let ((r:scheme (uri-scheme r:uri)) - (r:userinfo (uri-userinfo r:uri)) - (r:host (or (uri-host r:uri) (request-host request))) - (r:port (or (uri-port r:uri) (request-port request))) - (r:path (uri-path r:uri)) - (r:query (uri-query r:uri)) - (r:fragment (uri-fragment r:uri))) + (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 () - (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) + ((@ (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 (bytevector->string body encoding) - encoding))))))))))) + (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)))))))) |