diff options
Diffstat (limited to 'haunt/jakob/dynamic/capabilities/rsvp.scm')
| -rw-r--r-- | haunt/jakob/dynamic/capabilities/rsvp.scm | 241 |
1 files changed, 159 insertions, 82 deletions
diff --git a/haunt/jakob/dynamic/capabilities/rsvp.scm b/haunt/jakob/dynamic/capabilities/rsvp.scm index 856f1f1..5acdc2f 100644 --- a/haunt/jakob/dynamic/capabilities/rsvp.scm +++ b/haunt/jakob/dynamic/capabilities/rsvp.scm @@ -16,23 +16,27 @@ (define-module (jakob dynamic capabilities rsvp) #:use-module (gcrypt base64) + #:use-module (haunt html) #:use-module (ice-9 binary-ports) #:use-module (ice-9 match) #:use-module (jakob dynamic config) #:use-module (jakob dynamic errors) #:use-module (jakob dynamic util) + #:use-module (jakob theme) #:use-module (json) #:use-module (rnrs bytevectors) #:use-module (squee) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (sxml simple) #:use-module (web request) #:use-module (web response) #:use-module (web uri) #:export (get-event-info post-event-rsvp)) ;; How many bytes of entropy to use when generating vanity ID's. -(define %vanity-length (make-parameter 9)) +(define %vanity-length (make-parameter 12)) ;; Path where event header images are stored. (define %event-image-path-fmt (make-parameter "/home/jakob/event-images/~a.png")) @@ -47,12 +51,19 @@ A vanity ID is used in the RSVP system for creating unique URLs for invitations. It is a base64 string, encoding `%vanity-length' bytes of randomness." + (define alphabet + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!@") (call-with-input-file "/dev/urandom" - (lambda (port) (base64-encode (get-bytevector-n port 9))))) + (lambda (port) + (let ((entropy (get-bytevector-n port (%vanity-length)))) + (list->string + (map (lambda (n) + (string-ref alphabet (remainder n (string-length alphabet)))) + (array->list entropy))))))) (define (valid-invite-code invitation) "Check database to see if `invitation' exists." - (and (= (string-length invitation) (base64-length (%vanity-length))) + (and (= (string-length invitation) (%vanity-length)) (positive? (length (exec-query conn "SELECT * FROM invitations WHERE vanity = $1" @@ -60,7 +71,7 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." (define (valid-receipt-code receipt) "Check database to see if `receipt'." - (and (= (string-length receipt) (base64-length (%vanity-length))) + (and (= (string-length receipt) (%vanity-length)) (positive? (length (exec-query conn "SELECT * FROM rsvps WHERE vanity = $1" @@ -80,11 +91,11 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." (define (params->rsvp-create params) "Parse `params', an alist, into a `<rsvp-create>'." (let ((res (make-rsvp-create-parameters))) - (set-rsvp-create-code! res (assoc-ref params "id")) - (set-rsvp-create-name! res (assoc-ref params "name")) - (set-rsvp-create-email! res (assoc-ref params "email")) - (set-rsvp-create-attending! res (assoc-ref params "rsvp")) - (set-rsvp-create-guests! res (assoc-ref params "guests")) + (set-rsvp-create-code! res (assoc-value params "id")) + (set-rsvp-create-name! res (assoc-value params "name")) + (set-rsvp-create-email! res (assoc-value params "email")) + (set-rsvp-create-attending! res (assoc-value params "rsvp")) + (set-rsvp-create-guests! res (assoc-value params "guest-names")) (if (any not (list (rsvp-create-code res) (rsvp-create-name res) @@ -100,6 +111,15 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." (exec-query conn "SELECT event_id, capabilities FROM invitations WHERE vanity = $1" (list vanity-code)))) + + +(define (render-event-rsvp-receipt receipt-code) + (let ((update-url (absolute-url (format #f "apps/rsvp/event-info?r=~a" receipt-code)))) + `(div + (p "Thanks for registering! Please bookmark or save the following link:" + (a (@ (href ,update-url)) ,update-url)) + (p "This will enable you to update your RSVP later.")))) + (define (create-new-event-rsvp params) "Handler for RSVP'ing to an event." (let ((params (params->rsvp-create params))) @@ -118,9 +138,10 @@ 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))) - (scm->json-string - `((receipt . ,receipt-code))))))) + (values '((content-type . (text/html))) + (sxml->html-string + (theme #:title "Thanks for RSVPing!" + #:content (render-event-rsvp-receipt receipt-code))))))) @@ -136,11 +157,11 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." (define (params->rsvp-update params) "Parse `params', an alist, into a `<rsvp-update>'." (let ((res (make-rsvp-update-parameters))) - (set-rsvp-update-code! res (assoc-ref params "update")) - (set-rsvp-update-name! res (assoc-ref params "name")) - (set-rsvp-update-email! res (assoc-ref params "email")) - (set-rsvp-update-attending! res (assoc-ref params "rsvp")) - (set-rsvp-update-guests! res (assoc-ref params "guests")) + (set-rsvp-update-code! res (assoc-value params "update")) + (set-rsvp-update-name! res (assoc-value params "name")) + (set-rsvp-update-email! res (assoc-value params "email")) + (set-rsvp-update-attending! res (assoc-value params "rsvp")) + (set-rsvp-update-guests! res (assoc-value params "guest-names")) (if (any not (list (rsvp-update-code res) (rsvp-update-name res) @@ -165,17 +186,18 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." (rsvp-update-email params) (rsvp-update-attending params) (rsvp-update-guests params))) - (values '((content-type . (application/json))) - (scm->json-string - `((receipt . ,(rsvp-update-code params))))))) + (values '((content-type . (text/html))) + (sxml->html-string + (theme #:title "Thanks for RSVPing!" + #:content (render-event-rsvp-receipt (rsvp-update-code params))))))) (define (post-event-rsvp request body) "Entry point for RSVP create/update. We dispatch on the parameters." - (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)) + (let ((form-data (decode-form body))) + (cond ((assoc-ref form-data "id") (create-new-event-rsvp form-data)) + ((assoc-ref form-data "update") (update-event-rsvp form-data)) (else (panic "invalid invite/update code"))))) @@ -186,62 +208,113 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." (lambda (port) (base64-encode (get-bytevector-all port))))) +(define (render-event-invitation code) + (match-let* ((rsvp (exec-query conn "SELECT invitation_id, fullname, email, attending, guests FROM rsvps WHERE vanity = $1" (list code))) + (((invitation-code name email attending guests)) + (if (not (null? rsvp)) + rsvp + '((#f #f #f #f #f)))) + (invitation-code (or invitation-code code)) + (invitation (invitation->event-id invitation-code)) + (capabilities (cadr invitation)) + (((i_ title description date location)) + (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))))) + (values + "You've been invited to an event!" + `(div (@ (id "rsvp")) + (div (@ (id "event-info")) + (h1 ,title) + (img (@ (src ,(get-event-image invitation)) + (style "float: right; margin: 16px;"))) + (p "Where: " ,location) + (p "When: " ,date) + (p ,@(cdr (xml->sxml (format #f "<div>~a</div>" description))))) + (form (@ (id "rsvp-input") + (action "/apps/rsvp") + (method "POST")) + (input (@ (type "text") + (hidden #t) + (name ,(if (not (null? rsvp)) "update" "id")) + (value ,code))) + (fieldset + (legend "Your Info") + + (label (@ (for "name")) "Name:") + (input (@ (type "text") + (id "name") + (name "name") + (required #t) + (size "24") + ,@(if name `((value ,name)) '()))) + + (label (@ (for "email")) "Email:") + (input (@ (type "text") + (id "email") + (name "email") + (required #t) + (size "24") + ,@(if email `((value ,email)) '())))) + + (fieldset + (legend "RSVP Status") + + (input (@ (type "radio") + (id "attending") + (value "attending") + (name "rsvp") + ,@(if (and attending (string= "attending" attending)) + '((checked ,#t)) + '()))) + (label (@ (for "attending")) "Attending") + + (input (@ (type "radio") + (value "tentative") + (id "tentative") + (name "rsvp") + ,@(if (and attending (string= "tentative" attending)) + '((checked ,#t)) + '()))) + (label (@ (for "tentative")) "Tentative") + + (input (@ (type "radio") + (value "not-attending") + (id "not-attending") + (name "rsvp") + ,@(if (and attending (string= "not-attending" attending)) + '((checked ,#t)) + '()))) + (label (@ (for "not-attending")) "Not Attending")) + + (fieldset + (legend "Guests") + + (label (@ (for "guest-names")) "Names:") + (input (@ (type "text") + (id "guest-names") + (name "guest-names") + (required #t) + (size "24") + ,@(if guests `((value ,guests)) '())))) + + (fieldset + (legend "All Set?") + (input (@ (type "submit") + (id "submit-form") + (value "Submit"))))) + + (h2 "Current RSVPs") + (table + ,@(map (match-lambda + ((name email attending guests) + `(tr (td ,name) (td ,email) (td ,guests) (td ,attending)))) + rsvps)))))) + (define (get-event-invitation invitation-code) "Handler for reading information about an event." - (define (format-rsvp rsvp) - (match rsvp - ((name email attending guests) - `((name . ,name) - (email . ,email) - (attending . ,attending) - (guests . ,guests))))) - (let* ((invitation (invitation->event-id 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))))) - (match (car event) - ((i_ title description date location) - (values '((content-type . (application/json))) - (scm->json-string - `((title . ,title) - (description . ,description) - (image . ,(get-event-image (car invitation))) - (date . ,date) - (location . ,location) - ,@(if (= 1 (logand (string->number capabilities) 1)) - `((rsvps . ,(list->vector (map format-rsvp rsvps)))) - '())))))))) - -(define (get-event-receipt receipt-code) - "Handler for reading information about an event, with receipt info." - (define (format-rsvp rsvp) - (match rsvp - ((name email attending guests) - `((name . ,name) - (email . ,email) - (attending . ,attending) - (guests . ,guests))))) - (let* ((rsvp (exec-query conn "SELECT invitation_id, fullname, email, attending, guests FROM rsvps WHERE vanity = $1" (list receipt-code))) - (invitation (invitation->event-id (caar rsvp))) - (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))))) - (match (car event) - ((i_ title description date location) - (values '((content-type . (application/json))) - (scm->json-string - `((title . ,title) - (description . ,description) - (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)) - ,@(if (= 1 (logand (string->number capabilities) 1)) - `((rsvps . ,(list->vector (map format-rsvp rsvps)))) - '())))))))) + (let-values (((title content) (render-event-invitation invitation-code))) + (values '((content-type . (text/html))) + (sxml->html-string (theme #:title title #:content content))))) (define (get-event-info request body) "Entry point to `get-event-receipt'/`get-event-invitation'." @@ -251,8 +324,12 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." '())) (invitation-code (assoc-ref params "i")) (receipt-code (assoc-ref params "r"))) - (cond ((and receipt-code (valid-receipt-code (car receipt-code))) - (get-event-receipt (car receipt-code))) - ((and invitation-code (valid-invite-code (car invitation-code))) - (get-event-invitation (car invitation-code))) - (else (panic "invalid invitation or receipt code"))))) + (unless (or receipt-code invitation-code) + (panic "missing invitation or receipt code")) + (unless (or (not receipt-code) (valid-receipt-code (car receipt-code))) + (panic "invalid receipt code")) + (unless (or (not invitation-code) (valid-invite-code (car invitation-code))) + (panic "invalid invitation code")) + + (cond (receipt-code (get-event-invitation (car receipt-code))) + (invitation-code (get-event-invitation (car invitation-code)))))) |