From 3fdede71c41393a948cf05d7b028e1f2b449a895 Mon Sep 17 00:00:00 2001 From: "Jakob L. Kreuze" Date: Sun, 8 May 2022 15:51:15 -0400 Subject: [scheme] middleware-ish way of specifying headers --- dynamic/api.scm | 22 +++++++++++++++++++--- dynamic/capabilities/rsvp.scm | 21 +++++++++------------ 2 files changed, 28 insertions(+), 15 deletions(-) diff --git a/dynamic/api.scm b/dynamic/api.scm index b53be8a..b899dc6 100644 --- a/dynamic/api.scm +++ b/dynamic/api.scm @@ -45,10 +45,26 @@ (define (main-request-handler request body) "Server entry-point; parse `request' and defer to routing system." + (define (wrap-response response) + ;; This is either a response, or an alist of headers. The latter case is + ;; simple to handle, but the former requires us to do a (rather unweildy) + ;; copy of the response to inject our headers. + (if (response? response) + (build-response + #:version (response-version response) + #:code (response-code response) + #:reason-phrase (response-reason-phrase response) + #:headers (cons '(Access-Control-Allow-Origin . "*") + (response-headers response)) + #:port (response-port response) + #:validate-headers? #t) + (cons '(Access-Control-Allow-Origin . "*") response))) (let* ((path-encoded (uri-path (request-uri request))) (path (split-and-decode-uri-path path-encoded))) - (if (string= "api" (first path)) - (handle-api-request request body (drop path 1)) - (not-found request)))) + (define-values (response body) + (if (string= "api" (first path)) + (handle-api-request request body (drop path 1)) + (not-found request))) + (values (wrap-response response) body))) (run-server main-request-handler) diff --git a/dynamic/capabilities/rsvp.scm b/dynamic/capabilities/rsvp.scm index 527f7a1..4ac2eff 100644 --- a/dynamic/capabilities/rsvp.scm +++ b/dynamic/capabilities/rsvp.scm @@ -102,12 +102,12 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." "Handler for RSVP'ing to an event." (let ((params (params->rsvp-create params))) (cond ((not params) - (values (build-response #:code 400 #:headers '((Access-Control-Allow-Origin . "*"))) + (values (build-response #:code 400) (scm->json-string `((success . #f) (error . "Invalid form data"))))) ((not (valid-invite-code (rsvp-create-code params))) - (values (build-response #:code 400 #:headers '((Access-Control-Allow-Origin . "*"))) + (values (build-response #:code 400) (scm->json-string `((success . #f) (error . "Invalid invitation code"))))) @@ -123,8 +123,7 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." (rsvp-create-email params) (rsvp-create-attending params) (rsvp-create-guests params))) - (values '((content-type . (application/json)) - (Access-Control-Allow-Origin . "*")) + (values '((content-type . (application/json))) (scm->json-string `((receipt . ,receipt-code))))))))) @@ -160,12 +159,12 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." "Handler for updating an RSVP to an event." (let ((params (params->rsvp-update params))) (cond ((not params) - (values (build-response #:code 400 #:headers '((Access-Control-Allow-Origin . "*"))) + (values (build-response #:code 400) (scm->json-string `((success . #f) (error . "Invalid form data"))))) ((not (valid-receipt-code (rsvp-update-code params))) - (values (build-response #:code 400 #:headers '((Access-Control-Allow-Origin . "*"))) + (values (build-response #:code 400) (scm->json-string `((success . #f) (error . "Invalid receipt code"))))) @@ -189,7 +188,7 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." (let* ((params (json-string->scm (utf8->string body)))) (cond ((assoc-ref params "id") (create-new-event-rsvp params)) ((assoc-ref params "update") (update-event-rsvp params)) - (else (values (build-response #:code 400 #:headers '((Access-Control-Allow-Origin . "*"))) + (else (values (build-response #:code 400) (scm->json-string `((success . #f) (error . "Invalid invite/update code")))))))) @@ -217,8 +216,7 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." (rsvps (exec-query conn "SELECT fullname, email, attending, guests FROM rsvps WHERE event_id = $1" (list (car invitation))))) (match (car event) ((i_ title description date location) - (values '((content-type . (application/json)) - (Access-Control-Allow-Origin . "*")) + (values '((content-type . (application/json))) (scm->json-string `((title . ,title) (description . ,description) @@ -245,8 +243,7 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." (rsvps (exec-query conn "SELECT fullname, email, attending, guests FROM rsvps WHERE event_id = $1" (list (car invitation))))) (match (car event) ((i_ title description date location) - (values '((content-type . (application/json)) - (Access-Control-Allow-Origin . "*")) + (values '((content-type . (application/json))) (scm->json-string `((title . ,title) (description . ,description) @@ -274,7 +271,7 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." ((and invitation-code (valid-invite-code (car invitation-code))) (get-event-invitation (car invitation-code))) (else - (values (build-response #:code 400 #:headers '((Access-Control-Allow-Origin . "*"))) + (values (build-response #:code 400) (scm->json-string `((success . #f) (error . "Invalid invitation or receipt code")))))))) -- cgit v1.3