[dynamic] Move to `haunt' directory and `jakob' namespace

There will likely be some refactoring later as part of this change, since we can
unify the `util' namespaces.

1 files changed, 0 insertions, 277 deletions

diff --git a/dynamic/capabilities/rsvp.scm b/dynamic/capabilities/rsvp.scm
deleted file mode 100644
index 4ac2eff..0000000
--- a/dynamic/capabilities/rsvp.scm
+++ /dev/null
@@ -1,277 +0,0 @@
-;;; 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)
-                   (scm->json-string
-                    `((success . #f)
-                      (error . "Invalid form data")))))
-          ((not (valid-invite-code (rsvp-create-code params)))
-           (values (build-response #:code 400)
-                   (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)))
-                     (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)
-                   (scm->json-string
-                    `((success . #f)
-                      (error . "Invalid form data")))))
-          ((not (valid-receipt-code (rsvp-update-code params)))
-           (values (build-response #:code 400)
-                   (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)
-                   (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)))
-               (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))))
-                        '()))))))))
-
-(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)
-                   (scm->json-string
-                    `((success . #f)
-                      (error . "Invalid invitation or receipt code"))))))))