diff options
| -rw-r--r-- | haunt/jakob/dynamic/capabilities/rsvp-form.scm | 85 | ||||
| -rw-r--r-- | haunt/jakob/dynamic/capabilities/rsvp.scm | 43 |
2 files changed, 120 insertions, 8 deletions
diff --git a/haunt/jakob/dynamic/capabilities/rsvp-form.scm b/haunt/jakob/dynamic/capabilities/rsvp-form.scm new file mode 100644 index 0000000..8c97c58 --- /dev/null +++ b/haunt/jakob/dynamic/capabilities/rsvp-form.scm @@ -0,0 +1,85 @@ +;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <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 theme) + #:use-module (jakob utils sxml) + ;; #:use-module (json) + #:use-module (srfi srfi-1) + ;; #:use-module (srfi srfi-11) + #:use-module (web request) + ;; #:use-module (web response) + #:use-module (web uri) + #:export (get-rsvp-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) + (let ((event-info (event-info-internal invitation-code))) + `((div (@ (id "rsvp")) + (div (@ (id "event-info")) + (h1 ,(assoc-ref event-info 'title)) + ,@(if (assoc-ref event-info 'image) + (list `(img (@ (style "float: right; max-size: 200px; margin: 16px;") + (src ,(format #f "data:image/png;base64,~a" (assoc-ref event-info 'image))))) + '())) + (p ,(assoc-ref event-info 'location)) + (p ,(assoc-ref event-info 'date)) + (p ,(assoc-ref event-info 'description)) + (form (@ (id "rsvp-input")) + (fieldset + (legend "Your Info") + (label (@ (for "name")) "Name:") + (input (@ (type "text") (id "name") (name "name") (required #t) (size 24))) + (label (@ (for "email")) "Email:") + (input (@ (type "text") (id "email") (name "email") (required #t) (size 24)))) + (fieldset + (legend "RSVP Status") + (input (@ (type "radio") (id "attending") (name "rsvp"))) + (label (@ (for "attending")) "Attending") + (input (@ (type "radio") (id "tentative") (name "rsvp"))) + (label (@ (for "tentative")) "Tentative") + (input (@ (type "radio") (id "not-attending") (name "rsvp"))) + (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 "-")))) + (fieldset + (legend "All Set?") + (input (@ (type "button") (id "submit-form") (value "Submit"))))) + (div (@ (id "rsvp-global")))))))) + +(define (get-rsvp-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))) + (values '((content-type . (text/html))) + (sxml->html-string + (theme + #:title (format #f "You've Been Invited to ~a!" (event-name invitation-code)) + #:content form))))) diff --git a/haunt/jakob/dynamic/capabilities/rsvp.scm b/haunt/jakob/dynamic/capabilities/rsvp.scm index 2975e4d..86fc671 100644 --- a/haunt/jakob/dynamic/capabilities/rsvp.scm +++ b/haunt/jakob/dynamic/capabilities/rsvp.scm @@ -29,7 +29,10 @@ #:use-module (web request) #:use-module (web response) #:use-module (web uri) - #:export (get-event-info post-event-rsvp)) + #:export (event-info-internal + + get-event-info + post-event-rsvp)) ;; How many bytes of entropy to use when generating vanity ID's. (define %vanity-length (make-parameter 9)) @@ -186,15 +189,16 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." (lambda (port) (base64-encode (get-bytevector-all port))))) +(define (format-rsvp rsvp) + (match rsvp + ((name email attending guests) + `((name . ,name) + (email . ,email) + (attending . ,attending) + (guests . ,guests))))) + (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)))) @@ -256,3 +260,26 @@ 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 (panic "invalid invitation or receipt code"))))) + +(define (event-info-internal invitation-code) + (unless (valid-invite-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)) + (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) + `((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)))) + '())))))) |