[scheme] middleware-ish way of specifying headers

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"))))))))