6 files changed, 1141 insertions, 0 deletions
diff --git a/jakob/dynamic/capabilities/comment-form.scm b/jakob/dynamic/capabilities/comment-form.scm
new file mode 100644
index 0000000..f7d0491
--- /dev/null
+++ b/jakob/dynamic/capabilities/comment-form.scm
@@ -0,0 +1,119 @@
+;;; 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 comment-form)
+  #:use-module (gcrypt base64)
+  #:use-module (haunt html)
+  #:use-module (ice-9 match)
+  #:use-module (jakob builder blog)
+  #: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 (render-static-comment-form
+            render-dynamic-comment-form
+            get-comment-form))
+
+(define (render-comment-field)
+  `(fieldset (@ (id "comment-content"))
+    (legend "Comment")
+    (label (@ (for "name") (class "required")) "Name:")
+    (input (@ (type "text") (id "name") (name "name") (required #t)))
+    (label (@ (for "email")) "Email:")
+    (input (@ (type "text") (id "email") (name "email")))
+    (label (@ (for "url")) "Webpage URL:")
+    (input (@ (type "text") (id "url") (name "url")))
+    (label (@ (for "subject")) "Subject:")
+    (input (@ (type "text") (id "subject") (name "subject")))
+    (label (@ (for "comment") (class "required")) "Comment :")
+    (textarea (@ (id "coment") (name "comment")))
+    (p "(*) Indicates a required field.")))
+
+(define* (render-comment-captcha-field #:optional (captcha-id "") captcha-image
+                                       #:key hidden)
+  `(fieldset ,(if hidden
+                  '(@ (id "comment-captcha") (hidden "#t"))
+                  '(@ (id "comment-captcha")))
+    (legend "Captcha")
+    (div (@ (id "captcha-challenge-primary"))
+     (label (@ (for "captcha")) "Please evaluate the following definite integral:")
+     (img (@ (id "captcha-image")
+             (src ,(if captcha-image
+                       (format #f "data:image/jpeg;charset=utf-8;base64,~a"
+                               (base64-encode captcha-image))
+                       ""))))
+     (input (@ (type "text") (id "captcha") (name "captcha") (size 24))))
+    (button (@ (id "pow-trigger") (hidden #t))
+            "Too hard? (Or unable to see the challenge?)"
+            (br)
+            "Click here for an alternative captcha.")
+    (input (@ (autocomplete "off") (type "text") (id "captcha-id") (name "captcha-id") (hidden #t) (value ,captcha-id)))
+    (input (@ (autocomplete "off") (type "text") (id "captcha-alt") (name "captcha-alt") (hidden #t)))
+    (input (@ (autocomplete "off") (type "text") (id "captcha-alt-id") (name "captcha-alt-id") (hidden #t)))
+    (input (@ (type "submit") (id "submit-form") (value "Submit")))))
+
+(define (render-static-comment-form slug captcha-id captcha-image)
+  `(div (@ (id "comment-form"))
+     (h1 "Comment form")
+     (form (@ (id "comment-input") (action "/api/comment") (method "post"))
+       (input (@ (type "text") (name "slug") (hidden #t) (value ,slug)))
+       ,(render-comment-field)
+       ,(render-comment-captcha-field captcha-id captcha-image))
+     ,(script "proof-of-work.js")))
+
+(define (render-dynamic-comment-form slug)
+  `(div (@ (id "comment-form"))
+     (h3 (@ (id "comment-form-header")) "Comment form")
+     (form (@ (id "comment-input") (action "/api/comment") (method "post"))
+       (input (@ (autocomplete "off")
+                 (type "text")
+                 (name "slug")
+                 (hidden #t)
+                 (value ,slug)))
+       (input (@ (autocomplete "off")
+                 (type "text")
+                 (name "reply-to")
+                 (id "reply-to")
+                 (hidden #t)
+                 (value "")))
+       ,(render-comment-field)
+       (fieldset (@ (id "captcha-trigger-block"))
+        (legend "Captcha")
+        (label "You need to complete a captcha to write a comment.")
+        (button (@ (id "captcha-challenge-trigger"))
+                "Click here to generate a captcha challenge"))
+       ,(render-comment-captcha-field #:hidden #t))
+     ,(script "dynamic-comment-form.js")
+     ,(script "proof-of-work.js")))
+
+(define (get-comment-form request body)
+  "API endpoint handler for querying for the comments on a particular post
+
+This is a wrapper around `get-comments-by-slug'."
+  (let-values (((captcha-id captcha-image) (new-captcha!)))
+    (let* ((path-encoded (uri-path (request-uri request)))
+           (path (split-and-decode-uri-path path-encoded))
+           (slug (last path))
+           (form (render-static-comment-form slug captcha-id captcha-image)))
+      (values '((content-type . (text/html)))
+              (sxml->html-string
+               (theme #:content form #:title "Comment prompt"))))))
diff --git a/jakob/dynamic/capabilities/comments.scm b/jakob/dynamic/capabilities/comments.scm
new file mode 100644
index 0000000..ee2a52d
--- /dev/null
+++ b/jakob/dynamic/capabilities/comments.scm
@@ -0,0 +1,210 @@
+;;; 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 comments)
+  #:use-module (ice-9 match)
+  #:use-module (jakob dynamic capabilities common)
+  #:use-module (jakob dynamic captcha)
+  #:use-module (jakob dynamic config)
+  #:use-module (jakob dynamic errors)
+  #:use-module (jakob dynamic util)
+  #:use-module (json)
+  #:use-module (squee)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-26)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (get-comments
+            get-comments-by-slug
+
+            put-comment
+            put-reaction))
+
+(define conn (connect-to-postgres-paramstring (paramstring-for-dbname "jakob_comments")))
+
+(define (get-comments-by-slug slug)
+  "Internal function for querying the approved comments on a post
+
+This interface exists for dynamically generating the comment view from Haunt."
+  (define (make-internal-comment~ . args)
+    (let* ((args-needing-processing (take-right args 4))
+           (approved (list-ref args-needing-processing 0))
+           (approved (string->date approved "~Y~m~d ~H~M~S.~N"))
+           (reactions (list-ref args-needing-processing 1))
+           (reactions (if reactions
+                          (with-input-from-string reactions read)
+                          '()))
+           (originating-network (list-ref args-needing-processing 2))
+           (replies (list-ref args-needing-processing 3)))
+      (apply make-internal-comment
+             `(,@(drop-right args 4)
+               ,approved
+               ,reactions
+               ,replies
+               ,originating-network))))
+  (define (order-comments comments)
+    (define seen (make-hash-table))
+    (define (id comment) (first comment))
+    (define (content comment) (drop-right comment 1))
+    (define (parent comment) (last comment))
+    (define (has-children? id remaining)
+      (cond ((null? remaining) #f)
+            ((equal? id (parent (car remaining))) #t)
+            (else (has-children? id (cdr remaining)))))
+    (define (pass cur initial-comments remaining)
+      (cond ((null? initial-comments) (sort-comments (hash-ref seen 'terminal)))
+            ((null? cur) (pass (reverse remaining) (reverse remaining) (list)))
+            ((has-children? (id (car cur)) initial-comments)
+             (pass (cdr cur) initial-comments (cons (car cur) remaining)))
+            (else
+             (let* ((children (or (hash-ref seen (id (car cur))) '()))
+                    (children (sort-comments children))
+                    (parsed (apply make-internal-comment~ (append (content (car cur)) (list children)))))
+               ;; Remove this comment from `seen'.
+               (hash-set! seen (id (car cur)) #f)
+               (if (parent (car cur))
+                   (hash-append! seen (parent (car cur)) parsed)
+                   (hash-append! seen 'terminal parsed))
+               (pass (cdr cur) initial-comments remaining)))))
+    (pass comments comments '()))
+  (let* ((query "SELECT id, name, subject, email, comment, url, approved, reactions, originating_network, reply_to
+                 FROM comments WHERE slug = $1 and approved IS NOT NULL")
+         (result (exec-query conn query (list slug))))
+    (if (positive? (length result))
+        (order-comments result)
+        '())))
+
+(define (get-comments request body)
+  "API endpoint handler for querying for the comments on a particular post
+
+This is a wrapper around `get-comments-by-slug'."
+  (define (normalize-record record)
+    (json-string->scm (internal-comment->json record)))
+  (let* ((query-string (uri-query (request-uri request)))
+         (params (if query-string
+                     (decode-form query-string)
+                     '()))
+         (slug (assoc-ref params "p")))
+    (unless slug (panic "missing `slug' query parameter"))
+    (values '((content-type . (application/json)))
+            (scm->json-string
+             (list->vector
+              (map normalize-record (get-comments-by-slug (car slug))))))))
+
+
+
+(define (put-comment request body)
+  "API endpoint handler for submitting a comment"
+  (define (request-originating-network request)
+    (cond ((from-tor? request) "tor")
+          ((from-i2p? request) "i2p")
+          (else                "clearnet")))
+  (define (valid-comment? form-data)
+    (and (assoc "slug" form-data)
+         (assoc "name" form-data)
+         (assoc "comment" form-data)
+         (or (assoc "captcha" form-data)
+             (and (assoc "captcha-alt" form-data)
+                  (assoc "captcha-alt-id" form-data)))
+         (assoc "captcha-id" form-data)
+         (if (and (string? (assoc-value form-data "captcha-alt"))
+                  (positive? (string-length (assoc-value form-data "captcha-alt"))))
+             (validate-proof-of-work!
+              (assoc-value form-data "captcha-alt")
+              (string->number (assoc-value form-data "captcha-alt-id")))
+             (validate-captcha!
+              (assoc-value form-data "captcha")
+              (string->number (assoc-value form-data "captcha-id"))))))
+  (define (insert-comment form-data)
+    (exec-query conn
+                "INSERT INTO comments (submitted, slug, name, subject, email,
+                                       url, comment, reply_to, originating_network)
+                 VALUES (now(), $1, $2, $3, $4, $5, $6, $7, $8);"
+                (list (assoc-value form-data "slug")
+                      (assoc-value form-data "name")
+                      (assoc-value form-data "subject")
+                      (assoc-value form-data "email")
+                      (assoc-value form-data "url")
+                      (assoc-value form-data "comment")
+                      (if (and (assoc-value form-data "reply-to")
+                               (positive? (string-length (assoc-value form-data "reply-to"))))
+                          (assoc-value form-data "reply-to")
+                          #f)
+                      (request-originating-network request)))
+    (values (build-response
+             #:code 307
+             #:headers '((Location . "https://jakob.space")))
+            (scm->json-string `((success . #t)))))
+  (let ((form-data (decode-form body)))
+    (unless (assoc "slug" form-data)       (panic "missing param `slug'"))
+    (unless (assoc "name" form-data)       (panic "missing param `name'"))
+    (unless (assoc "comment" form-data)    (panic "missing param `comment'"))
+    (unless (assoc "captcha-id" form-data) (panic "missing param `captcha-id'"))
+    (unless (or (assoc "captcha" form-data)
+                (and (assoc "captcha-alt" form-data)
+                     (assoc "captcha-alt-id" form-data)))
+      (panic "missing param `captcha' (or `captcha-alt' and `captcha-alt-id')"))
+    (if (and (string? (assoc-value form-data "captcha-alt"))
+             (positive? (string-length (assoc-value form-data "captcha-alt"))))
+        ;; Alternate captcha fields specified; take the code path that validates
+        ;; a proof-of-work.
+        (unless (validate-proof-of-work!
+                 (assoc-value form-data "captcha-alt")
+                 (string->number (assoc-value form-data "captcha-alt-id")))
+          (panic "proof-of-work not acceptable"))
+        ;; Alternate captcha fields not specified, so take the normal code path
+        ;; where we validate a captcha response.
+        (unless (validate-captcha!
+                 (assoc-value form-data "captcha")
+                 (string->number (assoc-value form-data "captcha-id")))
+          (panic "captcha incorrect")))
+    (insert-comment form-data)))
+
+
+
+(define (add-reaction reactions reaction)
+  (with-output-to-string
+    (lambda ()
+      (let ((parsed (call-with-input-string reactions read)))
+        (write (acons-normalize reaction
+                                (if (assoc reaction parsed) (+ 1 (assoc-value parsed reaction)) 1)
+                                parsed))))))
+
+(define (put-reaction request body)
+  (define (set-reactions id reactions)
+    (exec-query conn "UPDATE comments SET reactions = $1 WHERE id = $2"
+                (list reactions id)))
+  (define (comment-reactions id)
+    (let* ((query "SELECT reactions FROM comments WHERE id = $1")
+           (result (exec-query conn query (list id))))
+      ;; It could be NULL, in which case we want the empty list instead.
+      (if (positive? (length result)) (or (caar result) "()") #f)))
+  (define (valid-reaction? form-data)
+    (and (assoc "id" form-data)
+         (assoc "reaction" form-data)))
+  (let ((form-data (decode-form body)))
+    (unless (assoc "id" form-data)       (panic "missing param `id'"))
+    (unless (assoc "reaction" form-data) (panic "missing param `reaction'"))
+    (let* ((id (assoc-value form-data "id"))
+           (reaction (assoc-value form-data "reaction"))
+           (reactions (comment-reactions id)))
+      (unless id (panic "no such comment"))
+      (unless (emoji? reaction) (panic "invalid reaction"))
+      (set-reactions id (add-reaction reactions reaction))
+      (values '((content-type . (application/json)))
+              (scm->json-string `((success . #t)))))))
diff --git a/jakob/dynamic/capabilities/common.scm b/jakob/dynamic/capabilities/common.scm
new file mode 100644
index 0000000..2bca1a2
--- /dev/null
+++ b/jakob/dynamic/capabilities/common.scm
@@ -0,0 +1,68 @@
+;;; 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 common)
+  #:use-module (jakob dynamic util)
+  #:use-module (json)
+  #:use-module (srfi srfi-19)
+  #:export (json->internal-comment
+            internal-comment->json
+            make-internal-comment
+            internal-comment?
+            internal-comment-id
+            internal-comment-name
+            internal-comment-subject
+            internal-comment-email
+            internal-comment-comment
+            internal-comment-url
+            internal-comment-publish-time
+            internal-comment-reactions
+            internal-comment-replies
+            internal-comment-originating-network
+            sort-comments))
+
+(define-json-mapping <internal-comment>
+  make-internal-comment
+  internal-comment?
+  json->internal-comment <=> internal-comment->json
+  (id        internal-comment-id)
+  (name      internal-comment-name)
+  (subject   internal-comment-subject)
+  (email     internal-comment-email)
+  (comment   internal-comment-comment)
+  (url       internal-comment-url)
+  (publish-time
+   internal-comment-publish-time
+   "publish-time"
+   (lambda (x) (string->date x "~Y~m~d ~H~M~S.~N"))
+   (lambda (x) (date->string x "~Y-~m-~d ~H:~M:~S.~N")))
+  (reactions internal-comment-reactions)
+  (replies
+   internal-comment-replies
+   "replies"
+   (lambda (x) (map (lambda (comment)
+                 (call-with-input-string (scm->json-string comment) json->internal-comment))
+               (vector->list x)))
+   (lambda (x) (list->vector (map (lambda (y)
+                               (json-string->scm (internal-comment->json y)))
+                             x))))
+  (originating-network internal-comment-originating-network))
+
+(define (sort-comments comments)
+  "Sort COMMENTS, a list of `<internal-comment>' chronologically"
+  (sort comments (lambda (c1 c2)
+                   (date<? (internal-comment-publish-time c1)
+                           (internal-comment-publish-time c2)))))
diff --git a/jakob/dynamic/capabilities/gallery.scm b/jakob/dynamic/capabilities/gallery.scm
new file mode 100644
index 0000000..7087149
--- /dev/null
+++ b/jakob/dynamic/capabilities/gallery.scm
@@ -0,0 +1,79 @@
+;;; 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 gallery)
+  #:use-module (haunt html)
+  #: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 (squee)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-11)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (get-gallery get-image))
+
+(define conn (connect-to-postgres-paramstring (paramstring-for-dbname "jakob_gallery")))
+
+;; How many bytes of entropy to use when generating vanity ID's.
+(define %vanity-length (make-parameter 9))
+
+;; Path where gallery images are stored.
+(define %gallery-image-directory (make-parameter "/home/jakob/gallery-images/"))
+
+(define (valid-gallery-code code)
+  "Check database to see if `code' names a nonempty gallery."
+  (and (= (string-length code) (base64-length (%vanity-length)))
+       (positive?
+        (length
+         (exec-query conn "SELECT * FROM images WHERE vanity = $1"
+                     (list code))))))
+
+(define (render-gallery code)
+  (define info
+    (first
+     (exec-query conn "SELECT title, description, datetime FROM galleries WHERE vanity = $1" (list code))))
+  (define images
+    (exec-query conn "SELECT title, filename, thumb_filename, datetime FROM images WHERE vanity = $1" (list code)))
+  (match info
+    ((title description datetime)
+     `(div (@ (id "gallery-container"))
+           (h1 ,title)
+           (h3 ,description)
+           ,(map (lambda (image)
+                   (match image
+                     ((title filename thumbnail datetime)
+                      `(a (@ (href ,(format #f "/static-ext/~a" filename)))
+                          (img (@ (src ,(format #f "/static-ext/~a" thumbnail))
+                                  (alt ,title)
+                                  (title ,(format #f "~a - ~a" title datetime))))))))
+                 images)))))
+
+(define (get-gallery request body)
+  (let* ((query-string (uri-query (request-uri request)))
+         (params (if query-string
+                     (decode-form query-string)
+                     '()))
+         (code (if (assoc-ref params "g")
+                   (car (assoc-ref params "g"))
+                   (panic "no gallery code provided"))))
+    (unless (valid-gallery-code code) (panic "invalid gallery code"))
+    (values '((content-type . (text/html)))
+              (sxml->html-string
+               (theme #:title "Photo Gallery" #:content (render-gallery code))))))
diff --git a/jakob/dynamic/capabilities/poll.scm b/jakob/dynamic/capabilities/poll.scm
new file mode 100644
index 0000000..560a8e3
--- /dev/null
+++ b/jakob/dynamic/capabilities/poll.scm
@@ -0,0 +1,329 @@
+;;; Copyright © 2019 - 2024 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 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 <poll>
+  (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 <poll-response-create>
+  (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 `<poll-response-create>'."
+  (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 <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))))))
diff --git a/jakob/dynamic/capabilities/rsvp.scm b/jakob/dynamic/capabilities/rsvp.scm
new file mode 100644
index 0000000..25f13b8
--- /dev/null
+++ b/jakob/dynamic/capabilities/rsvp.scm
@@ -0,0 +1,336 @@
+;;; 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))))))