;;; Copyright © 2019 - 2024 Jakob L. Kreuze ;;; ;;; 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 ;;; . (define-module (jakob dynamic capabilities poll) #: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)) ;; How many bytes of entropy to use when generating vanity ID's. (define %vanity-length (make-parameter 12)) ;; Global handle to the RSVP database. (define conn (connect-to-postgres-paramstring (paramstring-for-dbname "jakob_poll"))) (define-record-type (make-poll title description questions) poll? (title poll-title set-poll-title!) (description poll-description set-poll-description!) (questions poll-questions set-poll-questions!)) (define (valid-invite-code invitation) "Check database to see if `invitation' exists." (and (= (string-length invitation) (%vanity-length)) (positive? (length (exec-query conn "SELECT * FROM invitations WHERE vanity = $1" (list invitation)))))) (define (invite-code->poll-id invitation) (caar (exec-query conn "SELECT poll_id FROM invitations WHERE vanity = $1" (list invitation)))) (define (get-poll id) (define response (car (exec-query conn "SELECT title, description, questions FROM polls WHERE id = $1" (list id)))) (make-poll (first response) (second response) (call-with-input-string (third response) read))) (define (valid-fields invitation) (map car (poll-questions (get-poll (invite-code->poll-id invitation))))) (define-record-type (make-poll-response-create-parameters) poll-response-create-parameters? (invitation-code poll-response-create-code set-poll-response-create-code!) (response poll-response-create-response set-poll-response-create-response!)) (define (assoc-intersect keys alist) "Filter `alist' down to just `keys'." (filter (lambda (x) (member (car x) keys)) alist)) (define (params->poll-response-create params) "Parse `params', an alist, into a `'." (let* ((id (assoc-value params "id")) (valid-fields (valid-fields id)) (res (make-poll-response-create-parameters))) (set-poll-response-create-code! res id) (set-poll-response-create-response! res (assoc-intersect valid-fields params)) (if (or (any not (list (poll-response-create-code res) (poll-response-create-response res))) (not (= (length valid-fields) (length (poll-response-create-response res))))) #f res))) (params->poll-response-create '(("id" "ArVR1jTK2lbo") ("availability-1" "asdf") ("availability-2" "asdf"))) (define (invitation->poll-id vanity-code) "For valid `vanity-code', find the corresponding poll ID." (car (exec-query conn "SELECT poll_id FROM invitations WHERE vanity = $1" (list vanity-code)))) (define (create-new-event-rsvp params) "Handler for responding to the poll." (let ((params (params->rsvp-create params))) (unless params (panic "invalid form data")) (unless (valid-invite-code (rsvp-create-code params)) (panic "invalid invitation code")) (let ((receipt-code (generate-vanity-code)) (event-id (car (invitation->event-id (rsvp-create-code params))))) (exec-query conn "INSERT INTO rsvps (vanity, invitation_id, event_id, fullname, email, attending, guests) VALUES ($1, $2, $3, $4, $5, $6, $7)" (list receipt-code (rsvp-create-code params) event-id (rsvp-create-name params) (rsvp-create-email params) (rsvp-create-attending params) (rsvp-create-guests params))) (values '((content-type . (text/html))) (sxml->html-string (theme #:title "Thanks for RSVPing!" #:content (render-event-rsvp-receipt receipt-code))))))) (define-record-type (make-rsvp-update-parameters) rsvp-update-parameters? (invitation-code rsvp-update-code set-rsvp-update-code!) (name rsvp-update-name set-rsvp-update-name!) (email rsvp-update-email set-rsvp-update-email!) (attending rsvp-update-attending set-rsvp-update-attending!) (guests rsvp-update-guests set-rsvp-update-guests!)) (define (params->rsvp-update params) "Parse `params', an alist, into a `'." (let ((res (make-rsvp-update-parameters))) (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) (rsvp-update-email res) (rsvp-update-attending res) (rsvp-update-guests res))) #f res))) (define (update-event-rsvp params) "Handler for updating an RSVP to an event." (let ((params (params->rsvp-update params))) (unless params (panic "invalid form data")) (unless (valid-receipt-code (rsvp-update-code params)) (panic "invalid recepit code")) (exec-query conn "UPDATE rsvps SET fullname = $2, email = $3, attending = $4, guests = $5 WHERE vanity = $1" (list (rsvp-update-code params) (rsvp-update-name params) (rsvp-update-email params) (rsvp-update-attending params) (rsvp-update-guests 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 ((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"))))) (define (get-event-image event-id) "Return, as base64, the header image for `event-id'." (call-with-input-file (format #f (%event-image-path-fmt) event-id) (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 ,(format #f "data:image/png;base64, ~a" (get-event-image (car invitation)))) (style "float: right; margin: 16px;"))) (p "Where: " ,location) (p "When: " ,date) (p ,@(cdr (xml->sxml (format #f "
~a
" 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") (size "24") ,@(if guests `((value ,guests)) '())))) (fieldset (legend "All Set?") (input (@ (type "submit") (id "submit-form") (value "Submit"))))) ,@(if (equal? capabilities "1") `((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." (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'." (let* ((query-string (uri-query (request-uri request))) (params (if query-string (decode-form query-string) '())) (invitation-code (assoc-ref params "i")) (receipt-code (assoc-ref params "r"))) (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))))))