summaryrefslogtreecommitdiff
path: root/dynamic/capabilities/rsvp.scm
diff options
context:
space:
mode:
Diffstat (limited to 'dynamic/capabilities/rsvp.scm')
-rw-r--r--dynamic/capabilities/rsvp.scm280
1 files changed, 280 insertions, 0 deletions
diff --git a/dynamic/capabilities/rsvp.scm b/dynamic/capabilities/rsvp.scm
new file mode 100644
index 0000000..527f7a1
--- /dev/null
+++ b/dynamic/capabilities/rsvp.scm
@@ -0,0 +1,280 @@
+;;; Copyright © 2019 - 2022 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 (dynamic capabilities rsvp)
+ #:use-module (base64)
+ #:use-module (dynamic util)
+ #:use-module (ice-9 binary-ports)
+ #:use-module (ice-9 match)
+ #:use-module (json)
+ #:use-module (rnrs bytevectors)
+ #:use-module (squee)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
+ #: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))
+
+;; Path where event header images are stored.
+(define %event-image-path-fmt (make-parameter "/home/jakob/event-images/~a.png"))
+
+;; Global handle to the RSVP database.
+(define conn (connect-to-postgres-paramstring "dbname=jakob_rsvp"))
+
+
+
+(define (generate-vanity-code)
+ "Generate a random vanity ID.
+
+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."
+ (call-with-input-file "/dev/urandom"
+ (lambda (port) (base64-encode (get-bytevector-n port 9)))))
+
+(define (valid-invite-code invitation)
+ "Check database to see if `invitation' exists."
+ (and (= (string-length invitation) (base64-length (%vanity-length)))
+ (positive?
+ (length
+ (exec-query conn "SELECT * FROM invitations WHERE vanity = $1"
+ (list invitation))))))
+
+(define (valid-receipt-code receipt)
+ "Check database to see if `receipt'."
+ (and (= (string-length receipt) (base64-length (%vanity-length)))
+ (positive?
+ (length
+ (exec-query conn "SELECT * FROM rsvps WHERE vanity = $1"
+ (list receipt))))))
+
+
+
+(define-record-type <rsvp-create>
+ (make-rsvp-create-parameters)
+ rsvp-create-parameters?
+ (invitation-code rsvp-create-code set-rsvp-create-code!)
+ (name rsvp-create-name set-rsvp-create-name!)
+ (email rsvp-create-email set-rsvp-create-email!)
+ (attending rsvp-create-attending set-rsvp-create-attending!)
+ (guests rsvp-create-guests set-rsvp-create-guests!))
+
+(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"))
+ (if (any not
+ (list (rsvp-create-code res)
+ (rsvp-create-name res)
+ (rsvp-create-email res)
+ (rsvp-create-attending res)
+ (rsvp-create-guests res)))
+ #f
+ res)))
+
+(define (invitation->event-id vanity-code)
+ "For valid `vanity-code', find the corresponding event ID and capabilities."
+ (car
+ (exec-query conn "SELECT event_id, capabilities FROM invitations WHERE vanity = $1"
+ (list vanity-code))))
+
+(define (create-new-event-rsvp params)
+ "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 . "*")))
+ (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 . "*")))
+ (scm->json-string
+ `((success . #f)
+ (error . "Invalid invitation code")))))
+ (else
+ (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 . (application/json))
+ (Access-Control-Allow-Origin . "*"))
+ (scm->json-string
+ `((receipt . ,receipt-code)))))))))
+
+
+
+(define-record-type <rsvp-update>
+ (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 `<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"))
+ (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)))
+ (cond ((not params)
+ (values (build-response #:code 400 #:headers '((Access-Control-Allow-Origin . "*")))
+ (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 . "*")))
+ (scm->json-string
+ `((success . #f)
+ (error . "Invalid receipt code")))))
+ (else
+ (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 . (application/json)))
+ (scm->json-string
+ `((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))
+ (else (values (build-response #:code 400 #:headers '((Access-Control-Allow-Origin . "*")))
+ (scm->json-string
+ `((success . #f)
+ (error . "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 (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))
+ (Access-Control-Allow-Origin . "*"))
+ (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))
+ (Access-Control-Allow-Origin . "*"))
+ (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))))
+ '()))))))))
+
+(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")))
+ (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
+ (values (build-response #:code 400 #:headers '((Access-Control-Allow-Origin . "*")))
+ (scm->json-string
+ `((success . #f)
+ (error . "Invalid invitation or receipt code"))))))))
generated by cgit v1.3 (git 2.53.0) at 2026-08-29 15:39:45 +0000