Finalize capabilityfeature/static-rsvp-form

2 files changed, 127 insertions, 27 deletions

diff --git a/haunt/jakob/dynamic/capabilities/rsvp-form.scm b/haunt/jakob/dynamic/capabilities/rsvp-form.scm
index 8c97c58..853fa60 100644
--- a/haunt/jakob/dynamic/capabilities/rsvp-form.scm
+++ b/haunt/jakob/dynamic/capabilities/rsvp-form.scm
@@ -15,27 +15,28 @@
 ;;; <http://www.gnu.org/licenses/>.
 
 (define-module (jakob dynamic capabilities rsvp-form)
-  ;; #:use-module (gcrypt base64)
   #:use-module (haunt html)
-  ;; #:use-module (ice-9 match)
   #:use-module (jakob dynamic capabilities rsvp)
-  ;; #:use-module (jakob dynamic captcha)
-  ;; #:use-module (jakob dynamic util)
+  #:use-module (jakob dynamic util)
   #:use-module (jakob theme)
   #:use-module (jakob utils sxml)
-  ;; #:use-module (json)
+  #:use-module (json)
+  #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
-  ;; #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-11)
+  #:use-module (sxml simple)
   #:use-module (web request)
-  ;; #:use-module (web response)
   #:use-module (web uri)
-  #:export (get-rsvp-form))
+  #:export (get-rsvp-form
+            get-rsvp-edit-form
+            post-rsvp-form
+            post-rsvp-edit-form))
 
 (define (event-name invitation-code)
   (let ((event-info (event-info-internal invitation-code)))
     (assoc-ref event-info 'title)))
 
-(define (render-rsvp-form invitation-code)
+(define* (render-rsvp-form invitation-code #:optional edit)
   (let ((event-info (event-info-internal invitation-code)))
     `((div (@ (id "rsvp"))
        (div (@ (id "event-info"))
@@ -46,31 +47,86 @@
                         '()))
             (p ,(assoc-ref event-info 'location))
             (p ,(assoc-ref event-info 'date))
-            (p ,(assoc-ref event-info 'description))
-       (form (@ (id "rsvp-input"))
+            ,@(drop (call-with-input-string (assoc-ref event-info 'description) xml->sxml) 1)
+       (form (@ (id "rsvp-input")
+                (method "post")
+                (action ,(if edit
+                             (format #f "/api/event/edit/~a" invitation-code)
+                             (format #f "/api/event/~a" invitation-code))))
         (fieldset
+         ,@(if edit
+               `((input (@ (hidden #t) (name "update") (value ,invitation-code))))
+               `((input (@ (hidden #t) (name "id") (value ,invitation-code)))))
          (legend "Your Info")
          (label (@ (for "name")) "Name:")
-         (input (@ (type "text") (id "name") (name "name") (required #t) (size 24)))
+         (input (@ (type "text")
+                   (id "name")
+                   (name "name")
+                   (value ,(if (and edit (assoc-ref event-info 'name))
+                               (assoc-ref event-info 'name)
+                               ""))
+                   (required #t)
+                   (size 24)))
          (label (@ (for "email")) "Email:")
-         (input (@ (type "text") (id "email") (name "email") (required #t) (size 24))))
+         (input (@ (type "text")
+                   (id "email")
+                   (name "email")
+                   (value ,(if (and edit (assoc-ref event-info 'email))
+                               (assoc-ref event-info 'email)
+                               ""))
+                   (required #t)
+                   (size 24))))
         (fieldset
          (legend "RSVP Status")
-         (input (@ (type "radio") (id "attending") (name "rsvp")))
+         (input (@ (type "radio")
+                   (id "attending")
+                   (name "rsvp")
+                   (value "attending")
+                   ,@(if (and edit
+                              (assoc-ref event-info 'attending)
+                              (string= "attending" (assoc-ref event-info 'attending)))
+                         '((checked #t))
+                         '())))
          (label (@ (for "attending")) "Attending")
-         (input (@ (type "radio") (id "tentative") (name "rsvp")))
+         (input (@ (type "radio")
+                   (id "tentative")
+                   (name "rsvp")
+                   (value "tentative")
+                   ,@(if (and edit
+                              (assoc-ref event-info 'attending)
+                              (string= "tentative" (assoc-ref event-info 'attending)))
+                         '((checked #t))
+                         '())))
          (label (@ (for "tentative")) "Tentative")
-         (input (@ (type "radio") (id "not-attending") (name "rsvp")))
+         (input (@ (type "radio")
+                   (id "not-attending")
+                   (name "rsvp")
+                   (value "not-attending")
+                   ,@(if (and edit
+                              (assoc-ref event-info 'attending)
+                              (string= "not-attending" (assoc-ref event-info 'attending)))
+                         '((checked #t))
+                         '())))
          (label (@ (for "not-attending")) "Not Attending"))
         (fieldset
          (legend "Guests")
-         (div (@ (id "guest-view")))
-         (input (@ (type "button") (id "add-entry") (value "+")))
-         (input (@ (type "button") (id "remove-entry") (value "-"))))
+         (div (@ (id "guest-view"))
+          (input (@ (type "text") (id "guest-list") (name "guests"))))
+         (input (@ (type "button") (id "add-entry") (value "+") (hidden #t)))
+         (input (@ (type "button") (id "remove-entry") (value "-") (hidden #t))))
         (fieldset
          (legend "All Set?")
-         (input (@ (type "button") (id "submit-form") (value "Submit")))))
-       (div (@ (id "rsvp-global"))))))))
+         (input (@ (type "submit") (id "submit-form") (value "Submit")))))
+       ,(script "rsvp-min.js"))))))
+
+(define* (render-receipt params)
+  (let ((receipt-url (format #f "https://jakob.space/api/event/edit/~a"
+                             (assoc-ref params "receipt"))))
+    `((div (@ (id "rsvp"))
+       (p "Thanks for registering! Please bookmark or save the following link: "
+          ,(hyperlink receipt-url receipt-url)
+          ".")
+       (p "This will enable you to edit your RSVP later.")))))
 
 (define (get-rsvp-form request body)
   ;; TODO
@@ -83,3 +139,40 @@
              (theme
               #:title (format #f "You've Been Invited to ~a!" (event-name invitation-code))
               #:content form)))))
+
+(define (get-rsvp-edit-form request body)
+  ;; TODO
+  (let* ((path-encoded (uri-path (request-uri request)))
+         (path (split-and-decode-uri-path path-encoded))
+         (invitation-code (last path))
+         (form (render-rsvp-form invitation-code #t)))
+    (values '((content-type . (text/html)))
+            (sxml->html-string
+             (theme
+              #:title (format #f "Edit Your Invitation to ~a" (event-name invitation-code))
+              #:content form)))))
+
+(define (formdata->alist params)
+  (map (lambda (pair)
+         (cons (car pair) (cadr pair)))
+       params))
+
+(define (post-rsvp-form request body)
+  ;; TODO
+  (let* ((params (formdata->alist (decode-form (utf8->string body)))))
+    (let-values (((_ json) (create-new-event-rsvp params)))
+      (values '((content-type . (text/html)))
+              (sxml->html-string
+               (theme
+                #:title (format #f "Thank you!")
+                #:content (render-receipt (json-string->scm json))))))))
+
+(define (post-rsvp-edit-form request body)
+  ;; TODO
+  (let* ((params (formdata->alist (decode-form (utf8->string body)))))
+    (let-values (((_ json) (update-event-rsvp params)))
+      (values '((content-type . (text/html)))
+              (sxml->html-string
+               (theme
+                #:title (format #f "Thank you!")
+                #:content (render-receipt (json-string->scm json))))))))
diff --git a/haunt/jakob/dynamic/capabilities/rsvp.scm b/haunt/jakob/dynamic/capabilities/rsvp.scm
index 86fc671..60625a0 100644
--- a/haunt/jakob/dynamic/capabilities/rsvp.scm
+++ b/haunt/jakob/dynamic/capabilities/rsvp.scm
@@ -30,6 +30,8 @@
   #:use-module (web response)
   #:use-module (web uri)
   #:export (event-info-internal
+            create-new-event-rsvp
+            update-event-rsvp
 
             get-event-info
             post-event-rsvp))
@@ -262,10 +264,15 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness."
           (else (panic "invalid invitation or receipt code")))))
 
 (define (event-info-internal invitation-code)
-  (unless (valid-invite-code invitation-code)
+  (unless (or (valid-invite-code invitation-code)
+              (valid-receipt-code invitation-code))
     (panic "invalid invite or receipt code"))
   (let* ((rsvp (exec-query conn "SELECT invitation_id, fullname, email, attending, guests FROM rsvps WHERE vanity = $1" (list invitation-code)))
-         (invitation (invitation->event-id invitation-code))
+         ;; If `invitation-code' specifies a valid receipt, use it as such.
+         ;; Otherwise, treat it as an invitation code.
+         (invitation (invitation->event-id (if (positive? (length rsvp))
+                                               (caar rsvp)
+                                               invitation-code)))
          (capabilities (cadr invitation))
          (event (exec-query conn "SELECT * FROM events WHERE id = $1" (list (car invitation))))
          (rsvps (exec-query conn "SELECT fullname, email, attending, guests FROM rsvps WHERE event_id = $1" (list (car invitation)))))
@@ -276,10 +283,10 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness."
          (image . ,(get-event-image (car invitation)))
          (date . ,date)
          (location . ,location)
-         (name . ,(list-ref (car rsvp) 1))
-         (email . ,(list-ref (car rsvp) 2))
-         (attending . ,(list-ref (car rsvp) 3))
-         (guests . ,(list-ref (car rsvp) 4))
+         (name . ,(and (positive? (length rsvp)) (list-ref (car rsvp) 1)))
+         (email . ,(and (positive? (length rsvp)) (list-ref (car rsvp) 2)))
+         (attending . ,(and (positive? (length rsvp)) (list-ref (car rsvp) 3)))
+         (guests . ,(and (positive? (length rsvp)) (list-ref (car rsvp) 4)))
          ,@(if (= 1 (logand (string->number capabilities) 1))
                `((rsvps . ,(list->vector (map format-rsvp rsvps))))
                '()))))))