path: root/haunt/jakob/dynamic/capabilities/rsvp.scm

;;; 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)
  #: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 12))

;; Path where event header images are stored.
(define %event-image-path-fmt (make-parameter "/opt/jakob-dynamic/event-images/~a.png"))

;; Global handle to the RSVP database.
(define conn (connect-to-postgres-paramstring (paramstring-for-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."
  (define alphabet
    "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!@")
  (call-with-input-file "/dev/urandom"
    (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) (%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) (%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-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)
                   (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 (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)))
    (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 <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-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 "<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")
                            (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))))))