[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.

18 files changed, 1762 insertions, 11 deletions

diff --git a/haunt/api.scm b/haunt/api.scm
new file mode 100644
index 0000000..e9c5642
--- /dev/null
+++ b/haunt/api.scm
@@ -0,0 +1,74 @@
+;;; 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/>.
+
+(use-modules (ice-9 match)
+             (jakob dynamic capabilities gallery)
+             (jakob dynamic capabilities rsvp)
+             (jakob dynamic logging)
+             (srfi srfi-1)
+             (web request)
+             (web response)
+             (web server)
+             (web uri))
+
+(define (not-found request)
+  "Build a (somewhat) descriptive response for a non-existent resource."
+  (values (build-response #:code 404)
+          (string-append "Resource not found: "
+                         (uri->string (request-uri request)))))
+
+(define (handle-api-request request body endpoint)
+  "Route handler for the API server."
+  (let ((method (request-method request))
+        (originating-ip (assoc-ref (request-headers request) 'X-Forwarded-For))
+        (args (uri-query (request-uri request))))
+    (log-append! 'info (format #f "~a ~a (~a) (~a)" method endpoint args originating-ip)))
+  ((match (cons (request-method request) endpoint)
+     ;; ('(GET "challenge") make-challenge)
+     ;; ('(GET "comments") get-comments)
+     ;; ('(POST "comment") put-comment)
+     ('(GET "gallery") get-gallery)
+     ('(GET "gallery" "image") get-image)
+     ('(GET "rsvp" "event-info") get-event-info)
+     ('(POST "rsvp") post-event-rsvp)
+     (_ (lambda (. args) (not-found request))))
+   request body))
+
+(define (main-request-handler request body)
+  "Server entry-point; parse `request' and defer to routing system."
+  (define (wrap-response response)
+    ;; This is either a response, or an alist of headers. The latter case is
+    ;; simple to handle, but the former requires us to do a (rather unweildy)
+    ;; copy of the response to inject our headers.
+    (if (response? response)
+        (build-response
+         #:version           (response-version       response)
+         #:code              (response-code          response)
+         #:reason-phrase     (response-reason-phrase response)
+         #:headers           (cons '(Access-Control-Allow-Origin . "*")
+                                    (response-headers response))
+         #:port              (response-port          response)
+         #:validate-headers? #t)
+        (cons '(Access-Control-Allow-Origin . "*") response)))
+  (let* ((path-encoded (uri-path (request-uri request)))
+         (path (split-and-decode-uri-path path-encoded)))
+    (define-values (response resp-body)
+      (if (string= "api" (first path))
+          (handle-api-request request body (drop path 1))
+          (not-found request)))
+    (values (wrap-response response) resp-body)))
+
+(run-server main-request-handler)
diff --git a/haunt/jakob/dynamic/README.md b/haunt/jakob/dynamic/README.md
new file mode 100644
index 0000000..0f64827
--- /dev/null
+++ b/haunt/jakob/dynamic/README.md
@@ -0,0 +1,16 @@
+# Dynamic API for jakob.space
+
+This is a Guile back-end for all dynamic capabilities on jakob.space. It is
+assumed that the web server proxies all requests matching a `/api` prefix to
+this server.
+
+## Dependencies
+
+Depending on who you ask, the package management situation for Guile is either
+disappointing, or a pleasant reminder of simpler times. This module leverages
+two Guile modules which, to my knowledge, are not packaged in the typical Guile
+extension fashion. The respective `.scm` files will need to be downloaded and
+added to Guile load path.
+
+- [base64 from guile-lib](https://github.com/jacobrec/guile-lib/blob/master/base64.scm)
+- [squee](https://notabug.org/cwebber/guile-squee/)
diff --git a/haunt/jakob/dynamic/base64.scm b/haunt/jakob/dynamic/base64.scm
new file mode 100644
index 0000000..149f7ba
--- /dev/null
+++ b/haunt/jakob/dynamic/base64.scm
@@ -0,0 +1,353 @@
+;; -*- mode: scheme; coding: utf-8 -*-
+;;
+;; This module was renamed from (weinholt text base64 (1 0 20100612)) to
+;; (guix base64) by Nikita Karetnikov <nikita@karetnikov.org> on
+;; February 12, 2014.  It was later renamed to (gcrypt base64) by
+;; Christopher Allan Webber <cwebber@dustycloud.org> on May 20, 2017.
+;;
+;; Some optimizations made by Ludovic Courtès <ludo@gnu.org>, 2015.
+;; Turned into a Guile module (instead of R6RS).
+;;
+;; 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/>.
+;;
+;; This file incorporates work covered by the following copyright and
+;; permission notice:
+;;
+;;   Copyright © 2009, 2010, 2012, 2013, 2018 Göran Weinholt <goran@weinholt.se>
+;;
+;;   Permission is hereby granted, free of charge, to any person obtaining a
+;;   copy of this software and associated documentation files (the "Software"),
+;;   to deal in the Software without restriction, including without limitation
+;;   the rights to use, copy, modify, merge, publish, distribute, sublicense,
+;;   and/or sell copies of the Software, and to permit persons to whom the
+;;   Software is furnished to do so, subject to the following conditions:
+;;
+;;   The above copyright notice and this permission notice shall be included in
+;;   all copies or substantial portions of the Software.
+;;
+;;   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;   IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+;;   FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL
+;;   THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+;;   LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+;;   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;   DEALINGS IN THE SOFTWARE.
+
+;; RFC 4648 Base-N Encodings
+
+(define-module (base64)
+  #:export (base64-encode
+            base64-decode
+            base64-alphabet
+            base64url-alphabet
+            get-delimited-base64
+            put-delimited-base64)
+  #:use-module (srfi srfi-11)
+  #:use-module (srfi srfi-60)
+  #:use-module (rnrs bytevectors)
+  #:use-module (rnrs io ports))
+
+
+(define-syntax define-alias
+  (syntax-rules ()
+    ((_ new old)
+     (define-syntax new (identifier-syntax old)))))
+
+;; Force the use of Guile's own primitives to avoid the overhead of its 'fx'
+;; procedures.
+
+(define-alias fxbit-field bit-field)
+(define-alias fxarithmetic-shift ash)
+(define-alias fxarithmetic-shift-left ash)
+(define-alias fxand logand)
+(define-alias fxior logior)
+(define-alias fxxor logxor)
+(define-alias fx=? =)
+(define-alias fx<=? <=)
+(define-alias fxzero? zero?)
+(define-alias fx+ +)
+(define-alias fx- -)
+(define-alias fxmod modulo)
+(define-alias mod modulo)
+
+(define-syntax-rule (assert exp)
+  (unless exp
+    (throw 'assertion-failure 'exp)))
+
+(define base64-alphabet
+  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/")
+
+(define base64url-alphabet
+  "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_")
+
+(define base64-encode
+  (case-lambda
+    ;; Simple interface. Returns a string containing the canonical
+    ;; base64 representation of the given bytevector.
+    ((bv)
+     (base64-encode bv 0 (bytevector-length bv) #f #f base64-alphabet #f))
+    ((bv start)
+     (base64-encode bv start (bytevector-length bv) #f #f base64-alphabet #f))
+    ((bv start end)
+     (base64-encode bv start end #f #f base64-alphabet #f))
+    ((bv start end line-length)
+     (base64-encode bv start end line-length #f base64-alphabet #f))
+    ((bv start end line-length no-padding)
+     (base64-encode bv start end line-length no-padding base64-alphabet #f))
+    ((bv start end line-length no-padding alphabet)
+     (base64-encode bv start end line-length no-padding alphabet #f))
+    ;; Base64 encodes the bytes [start,end[ in the given bytevector.
+    ;; Lines are limited to line-length characters (unless #f),
+    ;; which must be a multiple of four. To omit the padding
+    ;; characters (#\=) set no-padding to a true value. If port is
+    ;; #f, returns a string.
+    ((bv start end line-length no-padding alphabet port)
+     (assert (or (not line-length) (zero? (mod line-length 4))))
+     (let-values (((p extract) (if port
+                                   (values port (lambda () (values)))
+                                   (open-string-output-port))))
+       (letrec ((put (if line-length
+                         (let ((chars 0))
+                           (lambda (p c)
+                             (when (fx=? chars line-length)
+                               (set! chars 0)
+                               (put-char p #\linefeed))
+                             (set! chars (fx+ chars 1))
+                             (put-char p c)))
+                         put-char)))
+         (let lp ((i start))
+           (cond ((= i end))
+                 ((<= (+ i 3) end)
+                  (let ((x (bytevector-uint-ref bv i (endianness big) 3)))
+                    (put p (string-ref alphabet (fxbit-field x 18 24)))
+                    (put p (string-ref alphabet (fxbit-field x 12 18)))
+                    (put p (string-ref alphabet (fxbit-field x 6 12)))
+                    (put p (string-ref alphabet (fxbit-field x 0 6)))
+                    (lp (+ i 3))))
+                 ((<= (+ i 2) end)
+                  (let ((x (fxarithmetic-shift-left (bytevector-u16-ref bv i (endianness big)) 8)))
+                    (put p (string-ref alphabet (fxbit-field x 18 24)))
+                    (put p (string-ref alphabet (fxbit-field x 12 18)))
+                    (put p (string-ref alphabet (fxbit-field x 6 12)))
+                    (unless no-padding
+                      (put p #\=))))
+                 (else
+                  (let ((x (fxarithmetic-shift-left (bytevector-u8-ref bv i) 16)))
+                    (put p (string-ref alphabet (fxbit-field x 18 24)))
+                    (put p (string-ref alphabet (fxbit-field x 12 18)))
+                    (unless no-padding
+                      (put p #\=)
+                      (put p #\=)))))))
+       (extract)))))
+
+;; Create a lookup table for the alphabet and remember the latest table.
+(define get-decode-table
+  (let ((ascii-table #f)
+        (extra-table '())     ;in the unlikely case of unicode chars
+        (table-alphabet #f))
+    (lambda (alphabet)
+      (unless (eq? alphabet table-alphabet)
+        ;; Rebuild the table.
+        (do ((ascii (make-vector 128 #f))
+             (extra '())
+             (i 0 (+ i 1)))
+            ((= i (string-length alphabet))
+             (set! ascii-table ascii)
+             (set! extra-table extra))
+          (let ((c (char->integer (string-ref alphabet i))))
+            (if (fx<=? c 127)
+                (vector-set! ascii c i)
+                (set! extra (cons (cons c i) extra)))))
+        (set! table-alphabet alphabet))
+      (values ascii-table extra-table))))
+
+;; Decodes a base64 string, optionally ignoring non-alphabet
+;; characters and lack of padding.
+(define base64-decode
+  (case-lambda
+    ((str)
+     (base64-decode str base64-alphabet #f))
+    ((str alphabet)
+     (base64-decode str alphabet #f))
+    ((str alphabet port)
+     (base64-decode str alphabet port #t))
+    ((str alphabet port strict?)
+     (base64-decode str alphabet port strict? #t))
+    ((str alphabet port strict? strict-padding?)
+     (define (pad? c) (eqv? c (char->integer #\=)))
+     (let-values (((p extract) (if port
+                                   (values port (lambda () (values)))
+                                   (open-bytevector-output-port)))
+                  ((ascii extra) (get-decode-table alphabet)))
+       (define-syntax lookup
+         (syntax-rules ()
+           ((_ c) (or (and (fx<=? c 127) (vector-ref ascii c))
+                      (cond ((assv c extra) => cdr)
+                            (else #f))))))
+       (let lp-restart ((str str))
+         (let* ((len (if strict?
+                         (string-length str)
+                         (let lp ((i (fx- (string-length str) 1)))
+                           ;; Skip trailing invalid chars.
+                           (cond ((fxzero? i) 0)
+                                 ((let ((c (char->integer (string-ref str i))))
+                                    (or (lookup c) (pad? c)))
+                                  (fx+ i 1))
+                                 (else (lp (fx- i 1))))))))
+           (let lp ((i 0))
+             (cond
+              ((fx=? i len)
+               (extract))
+              ((fx<=? i (fx- len 4))
+               (let lp* ((c1 (char->integer (string-ref str i)))
+                         (c2 (char->integer (string-ref str (fx+ i 1))))
+                         (c3 (char->integer (string-ref str (fx+ i 2))))
+                         (c4 (char->integer (string-ref str (fx+ i 3))))
+                         (i i))
+                 (let ((i1 (lookup c1)) (i2 (lookup c2))
+                       (i3 (lookup c3)) (i4 (lookup c4)))
+                   (cond
+                    ((and i1 i2 i3 i4)
+                     ;; All characters present and accounted for.
+                     ;; The most common case.
+                     (let ((x (fxior (fxarithmetic-shift-left i1 18)
+                                     (fxarithmetic-shift-left i2 12)
+                                     (fxarithmetic-shift-left i3 6)
+                                     i4)))
+                       (put-u8 p (fxbit-field x 16 24))
+                       (put-u8 p (fxbit-field x 8 16))
+                       (put-u8 p (fxbit-field x 0 8))
+                       (lp (fx+ i 4))))
+                    ((and i1 i2 i3 (pad? c4) (= i (- len 4)))
+                     ;; One padding character at the end of the input.
+                     (let ((x (fxior (fxarithmetic-shift-left i1 18)
+                                     (fxarithmetic-shift-left i2 12)
+                                     (fxarithmetic-shift-left i3 6))))
+                       (put-u8 p (fxbit-field x 16 24))
+                       (put-u8 p (fxbit-field x 8 16))
+                       (lp (fx+ i 4))))
+                    ((and i1 i2 (pad? c3) (pad? c4) (= i (- len 4)))
+                     ;; Two padding characters.
+                     (let ((x (fxior (fxarithmetic-shift-left i1 18)
+                                     (fxarithmetic-shift-left i2 12))))
+                       (put-u8 p (fxbit-field x 16 24))
+                       (lp (fx+ i 4))))
+                    ((not strict?)
+                     ;; Non-alphabet characters.
+                     (let lp ((i i) (c* '()) (n 4))
+                       (cond ((fxzero? n)
+                              ;; Found four valid characters.
+                              (lp* (cadddr c*) (caddr c*) (cadr c*) (car c*)
+                                   (fx- i 4)))
+                             ((fx=? i len)
+                              (error 'base64-decode
+                                     "Invalid input in non-strict mode."
+                                     i c*))
+                             (else
+                              ;; Gather alphabetic (or valid
+                              ;; padding) characters.
+                              (let ((c (char->integer (string-ref str i))))
+                                (cond ((or (lookup c)
+                                           (and (pad? c)
+                                                (fx<=? n 2)
+                                                (fx=? i (fx- len n))))
+                                       (lp (fx+ i 1) (cons c c*) (fx- n 1)))
+                                      (else
+                                       (lp (fx+ i 1) c* n))))))))
+                    (else
+                     (error 'base64-decode
+                            "Invalid input in strict mode."
+                            c1 c2 c3 c4))))))
+              ((not strict-padding?)
+               ;; Append an appropriate amount of padding after the
+               ;; remaining characters.
+               (if (<= 2 (- len i) 3)
+                   (lp-restart (string-append (substring str i (string-length str))
+                                              (if (= (- len i) 2) "==" "=")))
+                   (error 'base64-decode "The input is too short." i)))
+              (else
+               (error 'base64-decode
+                      "The input is too short, it may be missing padding."
+                      i))))))))))
+
+(define (get-line-comp f port)
+  (if (port-eof? port)
+      (eof-object)
+      (f (get-line port))))
+
+;; Reads the common -----BEGIN/END type----- delimited format from
+;; the given port. Returns two values: a string with the type and a
+;; bytevector containing the base64 decoded data. The second value
+;; is the eof object if there is an eof before the BEGIN delimiter.
+(define get-delimited-base64
+  (case-lambda
+    ((port)
+     (get-delimited-base64 port #t))
+    ((port strict)
+     (define (get-first-data-line port)
+       ;; Some MIME data has header fields in the same format as mail
+       ;; or http. These are ignored.
+       (let ((line (get-line-comp string-trim-both port)))
+         (cond ((eof-object? line) line)
+               ((string-index line #\:)
+                (let lp ()               ;read until empty line
+                  (let ((line (get-line-comp string-trim-both port)))
+                    (if (string=? line "")
+                        (get-line-comp string-trim-both port)
+                        (lp)))))
+               (else line))))
+     (let ((line (get-line-comp string-trim-both port)))
+       (cond ((eof-object? line)
+              (values "" (eof-object)))
+             ((string=? line "")
+              (get-delimited-base64 port))
+             ((and (string-prefix? "-----BEGIN " line)
+                   (string-suffix? "-----" line))
+              (let* ((type (substring line 11 (- (string-length line) 5)))
+                     (endline (string-append "-----END " type "-----")))
+                (let-values ([(outp extract) (open-bytevector-output-port)])
+                  (let lp ((previous "") (line (get-first-data-line port)))
+                    (cond ((eof-object? line)
+                           (error 'get-delimited-base64
+                                  "unexpected end of file"))
+                          ((string-prefix? "-" line)
+                           (unless (string=? line endline)
+                             (error 'get-delimited-base64
+                                    "bad end delimiter" type line))
+                           (values type (extract)))
+                          ((and (= (string-length line) 5)
+                                (string-prefix? "=" line))
+                           ;; Skip Radix-64 checksum
+                           (lp previous (get-line-comp string-trim-both port)))
+                          ((not (fxzero? (fxmod (fx+ (string-length previous)
+                                                     (string-length line))
+                                                4)))
+                           ;; OpenSSH outputs lines with a bad length
+                           (lp (string-append previous line)
+                               (get-line-comp string-trim-both port)))
+                          (else
+                           (base64-decode (string-append previous line) base64-alphabet outp)
+                           (lp "" (get-line-comp string-trim-both port))))))))
+             (else ;skip garbage (like in openssl x509 -in foo -text output).
+              (get-delimited-base64 port)))))))
+
+(define put-delimited-base64
+  (case-lambda
+    ((port type bv line-length)
+     (display (string-append "-----BEGIN " type "-----\n") port)
+     (base64-encode bv 0 (bytevector-length bv)
+                    line-length #f base64-alphabet port)
+     (display (string-append "\n-----END " type "-----\n") port))
+    ((port type bv)
+     (put-delimited-base64 port type bv 76))))
diff --git a/haunt/jakob/dynamic/capabilities/comment-form.scm b/haunt/jakob/dynamic/capabilities/comment-form.scm
new file mode 100644
index 0000000..b435089
--- /dev/null
+++ b/haunt/jakob/dynamic/capabilities/comment-form.scm
@@ -0,0 +1,33 @@
+;;; 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 (jakob dynamic capabilities comment-form)
+  #:use-module (haunt html)
+  #:use-module (ice-9 match)
+  #:use-module (jakob dynamic util)
+  #:use-module (jakob theme)
+  #:use-module (json)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (get-comment-form))
+
+(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'."
+  (values '((content-type . (text/html)))
+          (sxml->html-string (theme #:content '(p "Hello, world!")))))
diff --git a/haunt/jakob/dynamic/capabilities/comments.scm b/haunt/jakob/dynamic/capabilities/comments.scm
new file mode 100644
index 0000000..d4159fa
--- /dev/null
+++ b/haunt/jakob/dynamic/capabilities/comments.scm
@@ -0,0 +1,153 @@
+;;; 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 (jakob dynamic capabilities comments)
+  #:use-module (ice-9 match)
+  #:use-module (jakob dynamic util)
+  #:use-module (json)
+  #:use-module (squee)
+  #: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 "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 (format-comment comment)
+    (match comment
+      ((id name subject email comment url approved reactions)
+       `((id . ,id)
+         (name . ,name)
+         (subject . ,subject)
+         (email . ,email)
+         (comment . ,comment)
+         (url . ,url)
+         (publish-time . ,approved)
+         (reactions . ,(if reactions
+                           (with-input-from-string reactions read)
+                           '()))))))
+  (let* ((query "SELECT id, name, subject, email, comment, url, approved, reactions
+                 FROM comments WHERE slug = $1 and approved IS NOT NULL")
+         (result (exec-query conn query (list slug))))
+    (map format-comment 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'."
+  (let* ((query-string (uri-query (request-uri request)))
+         (params (if query-string
+                     (decode-form query-string)
+                     '()))
+         (slug (assoc-ref params "p")))
+    (if slug
+        (values '((content-type . (application/json)))
+                (scm->json-string
+                 (list->vector
+                  (get-comments-by-slug (car slug)))))
+        (values (build-response #:code 400)
+                (scm->json-string
+                 `((success . #f)
+                   (error . "missing `slug' query parameter")))))))
+
+
+
+(define (put-comment request body)
+  "API endpoint handler for submitting a comment"
+  (define (valid-comment? form-data)
+    (and (assoc "slug" form-data)
+         (assoc "name" form-data)
+         (assoc "comment" form-data)))
+  (define (insert-comment form-data)
+    (exec-query conn
+                "INSERT INTO comments (submitted, slug, name, subject,
+                                       email, url, comment)
+                 VALUES (now(), $1, $2, $3, $4, $5, $6);"
+                (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")))
+    (values '((content-type . (application/json)))
+            (scm->json-string `((success . #t)))))
+  (let ((form-data (decode-form body)))
+    (if (valid-comment? form-data)
+        (insert-comment form-data)
+        (values (build-response #:code 400)
+                (scm->json-string
+                 `((success . #f)
+                   (error . "missing `slug', `name', or `comment'")))))))
+
+
+
+(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* ((query-string (uri-query (request-uri request)))
+         (form-data (if query-string
+                        (decode-form query-string)
+                        '())))
+    (if (valid-reaction? form-data) 
+        (let ((id (assoc-value form-data "id"))
+              (reaction (assoc-value form-data "reaction"))
+              (reactions (comment-reactions id)))
+          (if reactions
+              (begin
+                (set-reactions id (add-reaction reactions reaction))
+                (values '((content-type . (application/json)))
+                        (scm->json-string `((success . #t)))))
+              (values (build-response #:code 400)
+                      (scm->json-string
+                       `((success . #f)
+                         (error . "no such comment"))))))
+        (values (build-response #:code 400)
+                (scm->json-string
+                 `((success . #f)
+                   (error . "missing `id', or `reaction'")))))))
+
+;; (define (make-challenge request body)
+;;   (let-values (((uuid value image) (new-captcha)))
+;;     (hash-set! challenges uuid value)
+;;     (hash-for-each (lambda (x y) (display x) (newline)) challenges)
+;;     (values `((content-type . (application/base64))
+;;               (access-control-allow-origin . "*")
+;;               (x-captcha-id . ,uuid))
+;;             (base64-encode image))))
diff --git a/haunt/jakob/dynamic/capabilities/gallery.scm b/haunt/jakob/dynamic/capabilities/gallery.scm
new file mode 100644
index 0000000..b8b46c9
--- /dev/null
+++ b/haunt/jakob/dynamic/capabilities/gallery.scm
@@ -0,0 +1,111 @@
+;;; 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 (jakob dynamic capabilities gallery)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 ftw)
+  #:use-module (ice-9 match)
+  #:use-module (jakob dynamic util)
+  #:use-module (json)
+  #:use-module (squee)
+  #:use-module (srfi srfi-1)
+  #:use-module (web request)
+  #:use-module (web response)
+  #:use-module (web uri)
+  #:export (get-gallery get-image))
+
+(define conn (connect-to-postgres-paramstring "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 (get-gallery-images code)
+  "Handler for enumerating the image in a gallery."
+  (define (format-image image)
+    (match image
+      ((title filename thumbnail datetime)
+       `((title . ,title)
+         (filename . ,filename)
+         (thumbnail . ,thumbnail)
+         (datetime . ,datetime)))))
+  (let* ((images (exec-query conn "SELECT title, filename, thumb_filename, datetime FROM images WHERE vanity = $1" (list code))))
+    (list->vector (map format-image images))))
+
+(define (get-gallery-info code)
+  "Handler for enumerating the image in a gallery."
+  (define (format-gallery info)
+    (match info
+      ((title description datetime)
+       `((title . ,title)
+         (description . ,description)
+         (datetime . ,datetime)))))
+  (let* ((info (exec-query conn "SELECT title, description, datetime FROM galleries WHERE vanity = $1" (list code))))
+    (format-gallery (car info))))
+
+(define (get-gallery request body)
+  (let* ((query-string (uri-query (request-uri request)))
+         (params (if query-string
+                     (decode-form query-string)
+                     '()))
+         (code (car (assoc-ref params "g"))))
+    (if (valid-gallery-code code)
+        (values '((content-type . (application/json)))
+                (scm->json-string `((info . ,(get-gallery-info code))
+                                    (images . ,(get-gallery-images code)))))
+        (values (build-response #:code 400)
+                (scm->json-string
+                 `((success . #f)
+                   (error . "Invalid gallery code")))))))
+
+(define (image-exists? file-name)
+  (define (string/= a b) (not (string= a b)))
+  (and (string/= file-name ".")
+       (string/= file-name "..")
+       (member file-name (scandir (%gallery-image-directory)))))
+
+(define (read-image file-name)
+  (let* ((ext (string-downcase (last (string-split file-name #\.))))
+         (mime (cond ((string= ext "jpg") 'image/jpeg)
+                     ((string= ext "png") 'image/png)
+                     (else (error "Unknown MIME type.")))))
+    (values `((content-type . (,mime)))
+            (call-with-input-file (format #f "~a/~a" (%gallery-image-directory) file-name)
+              (lambda (port)
+                (get-bytevector-all port))))))
+
+(define (get-image request body)
+  (let* ((query-string (uri-query (request-uri request)))
+         (params (if query-string
+                     (decode-form query-string)
+                     '()))
+         (file-name (car (assoc-ref params "name"))))
+    (if (image-exists? file-name)
+        (read-image file-name)
+        (values (build-response #:code 400)
+                (scm->json-string
+                 `((success . #f)
+                   (error . "Invalid filename")))))))
diff --git a/haunt/jakob/dynamic/capabilities/rsvp.scm b/haunt/jakob/dynamic/capabilities/rsvp.scm
new file mode 100644
index 0000000..c02b758
--- /dev/null
+++ b/haunt/jakob/dynamic/capabilities/rsvp.scm
@@ -0,0 +1,277 @@
+;;; 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 (jakob dynamic capabilities rsvp)
+  #:use-module (base64)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 match)
+  #:use-module (jakob dynamic util)
+  #: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"))))))))
diff --git a/haunt/jakob/dynamic/captcha.scm b/haunt/jakob/dynamic/captcha.scm
new file mode 100644
index 0000000..b095ebf
--- /dev/null
+++ b/haunt/jakob/dynamic/captcha.scm
@@ -0,0 +1,170 @@
+;;; 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 (captcha)
+  #:use-module (base64)
+  #:use-module (gcrypt hash)
+  #:use-module (gcrypt mac)
+  #:use-module (gcrypt random)
+  #:use-module (ice-9 binary-ports)
+  #:use-module (ice-9 iconv)
+  #:use-module (ice-9 local-eval)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
+  #:use-module (ice-9 threads)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-19)
+  #:export (new-captcha))
+
+(define proc-mutex (make-mutex))
+
+(define (random-term)
+  (match (random 5)
+    (0 `(* ,(+ 1 (random 10)) x))
+    (1 `(* ,(+ 1 (random 10)) (expt x ,(random 10))))
+    (2 `(* ,(+ 1 (random 10)) (exp x)))
+    (3 `(* ,(+ 1 (random 10)) (cos x)))
+    (4 `(* ,(+ 1 (random 10)) (sin x)))))
+
+(define (sexp->latex sexp)
+  (match sexp
+    (('+ rest ...) (string-join (map sexp->latex rest) " + "))
+    (('* rest ...) (string-join (map sexp->latex rest) " \\cdot "))
+    (('sin term) (format #f "\\sin(~a)" (sexp->latex term)))
+    (('cos term) (format #f "\\cos(~a)" (sexp->latex term)))
+    (('expt term n) (format #f "~a^{~a}" (sexp->latex term) (sexp->latex n)))
+    (('exp term) (format #f "e^{~a}" (sexp->latex term)))
+    ('x "x")
+    (n (cond ((and (number? n) (positive? n)) (format #f "~a" n))
+             ((and (number? n) (negative? n)) (format #f "(~a)" n))
+             ((number? n) "0")
+             (else (error "Do not know how to convert to latex." n))))))
+
+(define (differentiate-sexp sexp)
+  (match sexp
+    (('+ rest ...) `(+ ,@(map differentiate-sexp rest)))
+    (('* coeff term) (if (number? coeff)
+                         `(* ,coeff ,(differentiate-sexp term))
+                         (error "Do not know how to differentiate.")))
+    (('sin term) `(* ,(differentiate-sexp term) (cos ,term)))
+    (('cos term) `(* -1 ,(differentiate-sexp term) (sin ,term)))
+    (('exp term) `(* ,(differentiate-sexp term) (exp ,term)))
+    (('expt term n) `(* ,n (expt ,term ,(- n 1))))
+    ('x 1)
+    (n (if (number? n)
+           0
+           (error "Do not know how to differentiate.")))))
+
+(define (simplify-sexp sexp)
+  (match sexp
+    (('+ rest ...) `(+ ,@(map simplify-sexp rest)))
+    (('* 1 term) (simplify-sexp term))
+    (('* 1 rest ...) (simplify-sexp `(* ,@rest)))
+    (('sin term) `(sin ,(simplify-sexp term)))
+    (('sin term) `(cos ,(simplify-sexp term)))
+    (('exp term) `(exp ,(simplify-sexp term)))
+    (('expt term 1) (simplify-sexp term))
+    (('expt term n) `(expt ,(simplify-sexp term) ,(simplify-sexp n)))
+    (term term)))
+
+(define (random-expression)
+  (let ((n-terms (+ 2 (random 3))))
+    `(+ ,@(map (lambda (x) (random-term)) (iota n-terms)))))
+
+(define (latex->image src)
+  (chdir "/tmp")
+  (with-mutex proc-mutex
+    (call-with-output-file "formula.tex"
+      (lambda (port)
+        (format port "\\def\\formula{~a}
+\\documentclass[border=2pt]{standalone}
+\\usepackage{amsmath}
+\\usepackage{varwidth}
+\\begin{document}
+\\begin{varwidth}{\\linewidth}
+\\[ \\formula \\]
+\\end{varwidth}
+\\end{document}
+" src)))
+    (unless (eqv? 0 (status:exit-val (system "pdflatex formula.tex")))
+      (error "Cannot generate PDF"))
+    (let* ((port (open-input-pipe "convert -density 300 formula.pdf -quality 90 png:-"))
+           (data (get-bytevector-all port)))
+      (unless (eqv? 0 (status:exit-val (close-pipe port)))
+          (error "Cannot generate PNG"))
+      data)))
+
+(define (new-uuid)
+  (with-mutex proc-mutex
+    (let* ((port (open-input-pipe "uuidgen"))
+           (str  (read-line port)))
+      (close-pipe port)
+      str)))
+
+(define (new-captcha)
+  (let* ((lower-bound (random 10))
+         (upper-bound (+ lower-bound 1 (random 9)))
+         (expression (random-expression))
+         (latex-src (sexp->latex (simplify-sexp (differentiate-sexp expression)))))
+    (values (new-uuid)
+            (- (local-eval expression (let ((x upper-bound)) (the-environment)))
+               (local-eval expression (let ((x lower-bound)) (the-environment))))
+            (latex->image (format #f "\\int_{~a}^{~a} ~a \\, dx"
+                                  lower-bound
+                                  upper-bound
+                                  latex-src)))))
+
+
+
+;; How many zeroes the SHA-256 hash has to be prefixed by to be a valid proof of work.
+(define %hardness 4)
+
+;; This is an ephemeral key. At this point, it doesn't make sense to store keys
+;; locally, since the server process is singular and long-running.
+(define %pow-mac-key (gen-random-bv 64))
+
+(define (proof-of-work)
+  (define challenge
+    (call-with-input-file "/dev/urandom"
+      (lambda (port) (base64-encode (get-bytevector-n port 32)))))
+  (define expiry-timestamp
+    (date->string
+     (time-utc->date (make-time 'time-utc 0 (+ 512 (time-second (current-time)))))
+     "~Y-~m-~d ~H:~M:~S"))
+  (define challenge-signature
+    (sign-data-base64 %pow-mac-key challenge))
+  (define timestamp-signature
+    (sign-data-base64 %pow-mac-key expiry-timestamp))
+  (values challenge challenge-signature expiry-timestamp timestamp-signature))
+
+(define (check-proof-of-work prefix
+                             challenge challenge-signature
+                             expiry-timestamp timestamp-signature)
+  (define hash-value
+    (chain (list prefix challenge)
+           (string-concatenate _)
+           (string->bytevector _ "utf8")
+           (bytevector-hash _ (lookup-hash-algorithm 'sha256))
+           (bytevector->base16-string _)))
+  (define zero-prefix (string-join (map (lambda (_) "0") (iota %hardness)) ""))
+  (and (= 32 (string-length prefix))
+       (string-prefix? zero-prefix hash-value)
+       (valid-base64-signature? %pow-mac-key challenge challenge-signature)
+       (valid-base64-signature? %pow-mac-key expiry-timestamp timestamp-signature)
+       (time<=? (current-time)
+                (date->time-utc (string->date expiry-timestamp "~Y-~m-~d ~H:~M:~S")))))
diff --git a/haunt/jakob/dynamic/import-images.sh b/haunt/jakob/dynamic/import-images.sh
new file mode 100644
index 0000000..23f6130
--- /dev/null
+++ b/haunt/jakob/dynamic/import-images.sh
@@ -0,0 +1,16 @@
+#!/usr/bin/env bash
+
+set -euo pipefail
+
+VANITY="$1"
+shift
+
+for item in "$@"; do
+    filename=$(basename -- "$item")
+    extension="${filename##*.}"
+    filename="${filename%.*}"
+    uuid="$(uuidgen)"
+    cp "$item" "/home/jakob/gallery-images/$uuid.$extension"
+    convert "/home/jakob/gallery-images/$uuid.$extension" -thumbnail '100x100>' "/home/jakob/gallery-images/${uuid}_thumb.png"
+    psql jakob_gallery -c "INSERT INTO images (vanity, title, filename, thumb_filename, datetime) VALUES ('$VANITY', '$filename', '$uuid.$extension', '${uuid}_thumb.png', now());"
+done
diff --git a/haunt/jakob/dynamic/logging.scm b/haunt/jakob/dynamic/logging.scm
new file mode 100644
index 0000000..42b367d
--- /dev/null
+++ b/haunt/jakob/dynamic/logging.scm
@@ -0,0 +1,37 @@
+;;; 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 (jakob dynamic logging)
+  #:use-module (ice-9 format)
+  #:use-module (srfi srfi-19)
+  #:export (log-append!))
+
+(define %log-file-name (make-parameter "/var/log/jakob-dynamic.log"))
+(define %log-level (make-parameter 'info))
+
+(define (dominates message-level baseline-level)
+  "Determine if `a' should be shown for baseline log level `b'."
+  (define log-level-hierarchy '(debug info warn error))
+  (>= (list-index log-level-hierarchy message-level)
+      (list-index log-level-hierarchy baseline-level)))
+
+(define (log-append! level message)
+  "Append `message', at `level', to the log buffer."
+  (when (dominates level (%log-level))
+    (call-with-output-file (%log-file-name)
+      (lambda (port)
+        (let ((now (date->string (current-date) "~4")))
+          (format port "[~a] ~a: ~a~%" now level message))))))
diff --git a/haunt/jakob/dynamic/schema-comments.sql b/haunt/jakob/dynamic/schema-comments.sql
new file mode 100644
index 0000000..b2cb652
--- /dev/null
+++ b/haunt/jakob/dynamic/schema-comments.sql
@@ -0,0 +1,16 @@
+CREATE TABLE comments(
+    id SERIAL PRIMARY KEY,
+    approved TIMESTAMP,
+    submitted TIMESTAMP NOT NULL,
+    slug VARCHAR(100) NOT NULL,
+    name VARCHAR(50) NOT NULL,
+    subject VARCHAR(100),
+    email VARCHAR(100),
+    url VARCHAR(100),
+    comment VARCHAR(1024) NOT NULL,
+    reactions VARCHAR(1024)
+);
+
+-- Use `now' for `submitted'.
+
+-- INSERT INTO comments (submitted, slug, name, comment) VALUES (now(), 'test', 'Jakob', 'Hello, world!');
diff --git a/haunt/jakob/dynamic/schema-gallery.sql b/haunt/jakob/dynamic/schema-gallery.sql
new file mode 100644
index 0000000..bad4100
--- /dev/null
+++ b/haunt/jakob/dynamic/schema-gallery.sql
@@ -0,0 +1,18 @@
+CREATE TABLE IF NOT EXISTS galleries (
+  id SERIAL,
+  vanity char(12) NOT NULL,
+  title varchar(128),
+  description varchar(4096) NOT NULL,
+  datetime timestamp with time zone NOT NULL,
+  PRIMARY KEY (id)
+);
+
+CREATE TABLE IF NOT EXISTS images (
+  id SERIAL,
+  vanity char(12) NOT NULL,
+  title varchar(128),
+  filename varchar(64) NOT NULL,
+  thumb_filename varchar(64) NOT NULL,
+  datetime timestamp with time zone NOT NULL,
+  PRIMARY KEY (id)
+);
diff --git a/haunt/jakob/dynamic/schema-rsvp.sql b/haunt/jakob/dynamic/schema-rsvp.sql
new file mode 100644
index 0000000..3e6a21f
--- /dev/null
+++ b/haunt/jakob/dynamic/schema-rsvp.sql
@@ -0,0 +1,34 @@
+CREATE TABLE IF NOT EXISTS events (
+  id SERIAL,
+  title varchar(128) NOT NULL,
+  description varchar(16384) NOT NULL,
+  datetime timestamp with time zone NOT NULL,
+  location varchar(128) NOT NULL,
+  PRIMARY KEY (id)
+);
+
+CREATE TABLE IF NOT EXISTS invitations (
+  id SERIAL,
+  vanity char(12) NOT NULL,
+  comments varchar(1024) NOT NULL,
+  created_on timestamp with time zone default current_timestamp,
+  capabilities bigint NOT NULL,
+  event_id integer NOT NULL,
+  PRIMARY KEY (id)
+);
+
+CREATE TABLE IF NOT EXISTS rsvps (
+  id SERIAL,
+  vanity char(12) NOT NULL,
+  invitation_id char(12) NOT NULL,
+  event_id bigint NOT NULL,
+  fullname varchar(128) NOT NULL,
+  email varchar(256) NOT NULL,
+  guests varchar(1024) NOT NULL,
+  attending varchar(32) NOT NULL,
+  PRIMARY KEY (id)
+);
+
+-- `rsvps` contains the bare minimum. If we later decide we need additional
+-- fields, we'll have an additional table mapping events.id to attribute names
+-- and rsvps.id to attribute values.
diff --git a/haunt/jakob/dynamic/util.scm b/haunt/jakob/dynamic/util.scm
new file mode 100644
index 0000000..6cdb4e5
--- /dev/null
+++ b/haunt/jakob/dynamic/util.scm
@@ -0,0 +1,69 @@
+;;; 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 (jakob dynamic util)
+  #:use-module (ice-9 match)
+  #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (web uri)
+  #:export (assoc-value
+            acons-normalize
+            base64-length
+            decode-form))
+
+(define (assoc-value alist key)
+  "Return the `car' of `(assoc alist key)' if truthy"
+  (let ((result (assoc-ref alist key)))
+    (if result (car result) result)))
+
+(define (acons-list k v alist)
+  "Add V to K to alist as list"
+  (let ((value (assoc-ref alist k)))
+    (if value
+        (let ((alist (alist-delete k alist)))
+          (acons k (cons v value) alist))
+        (acons k (list v) alist))))
+
+(define (acons-normalize key value alist)
+  "Add KEY -> VALUE to ALIST such that no entries for KEY are duplicates"
+  (cons (cons key value)
+        (filter (lambda (pair) (not (equal? (car pair) key))) alist)))
+
+(define (list->alist lst)
+  "Build a alist of list based on a list of key and values.
+
+   Multiple values can be associated with the same key"
+  (let next ((lst lst)
+             (out '()))
+    (if (null? lst)
+        out
+        (next (cdr lst) (acons-list (caar lst) (cdar lst) out)))))
+
+(define (decode-form bv)
+  "Convert BV querystring or form data to an alist"
+  (define string (if (string? bv) bv (utf8->string bv)))
+  (define pairs (map (cut string-split <> #\=)
+                     ;; semi-colon and amp can be used as pair separator
+                     (append-map (cut string-split <> #\;)
+                                 (string-split string #\&))))
+  (list->alist (map (match-lambda
+                      ((key value)
+                       (cons (uri-decode key) (uri-decode value)))) pairs)))
+
+(define (base64-length n)
+  "The length of the base64 string encoding `n' bytes."
+  (inexact->exact (* 4 (ceiling (/ n 3.0)))))
diff --git a/haunt/jakob/utils/comments.scm b/haunt/jakob/utils/comments.scm
index 3f55345..45c97c5 100644
--- a/haunt/jakob/utils/comments.scm
+++ b/haunt/jakob/utils/comments.scm
@@ -16,8 +16,6 @@
 
 (define-module (jakob utils comments)
   #:use-module (commonmark)
-  ;; #:use-module (dynamic capabilities comments)
-  #:use-module (dynamic util)
   #:use-module (gcrypt base16)
   #:use-module (gcrypt hash)
   #:use-module (ice-9 receive)
@@ -26,6 +24,8 @@
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-43)
   #:use-module (srfi-197)
+  #:use-module (jakob dynamic capabilities comments)
+  #:use-module (jakob dynamic util)
   #:use-module (json)
   #:use-module (web client)
   #:use-module (web response)
@@ -64,7 +64,7 @@
   (let* ((author-name (assoc-ref comment 'name))
          (author-url (assoc-ref comment 'url))
          (author-photo (gravatar-url (assoc-ref comment 'email)))
-         (publish-datetime (assoc-ref comment 'published))
+         (publish-datetime (assoc-ref comment 'publish-time))
          (content-text (assoc-ref comment 'comment))
          (content-reactions (assoc-ref comment 'reactions)))
     `(li (@ (class "p-comment h-cite comment comment-source-internal"))
@@ -83,13 +83,11 @@
               ,@(chain content-text
                        (safe-markdown->sxml _)))
          (div (@ (class "metaline"))
-              (a (@ (class "u-url")
-                    (href ,author-url))
-                 (time (@ (class "dt-published")
-                          (datetime ,publish-datetime))
-                       ,(date->string
-                         (string->date publish-datetime "~Y~m~d~H~M~S")
-                         "~B ~e, ~Y at ~H:~M"))))
+              (time (@ (class "dt-published")
+                       (datetime ,publish-datetime))
+                    ,(date->string
+                      (string->date publish-datetime "~Y~m~d ~H~M~S.~N")
+                      "~B ~e, ~Y at ~H:~M")))
          (ul (@ (class "comment-reactions"))
              ,@(map (match-lambda
                       ((emote . count)
diff --git a/haunt/pages/about.sxml b/haunt/pages/about.sxml
index 56b6abf..d8b7f74 100644
--- a/haunt/pages/about.sxml
+++ b/haunt/pages/about.sxml
@@ -330,7 +330,7 @@ old."
 (theme
  #:title "About"
  #:content
-   (ul (@ (class "horizontal-list"))
+ `((ul (@ (class "horizontal-list"))
        (li "Email: " (strong "zerodaysfordays at ‌​‌‌‌​‌‌‍‌​‌‌​​​​‍‌​‌‌​​​‌‍‌‌​‌‌​​​‍‌​‌​‌​‌‌‍‌‌​‌‌‌‌‌‍‌​‌‌‌​​‌‍‌​‌​‌​‌​‍‌​‌‌‌‌​​‍‌​‌‌​‌​​‍‌​‌‌​‌‌​‍‌​‌‌​​​‌‍‌​‌‌‌​​​‍‌‌​‌‌‌‌‌‍‌​‌​‌‌​​‍‌​‌​‌‌‌‌‍‌​‌‌‌‌‌​‍‌​‌‌​​‌​‍‌‌​‌‌‌‌‌‍‌​‌‌​​‌​‍‌​‌‌‌​‌​sdf.org"))
        (li "XMPP: " (strong "jakob at ‌​‌‌‌​‌‌‍‌​‌‌​​​​‍‌​‌‌​​​‌‍‌‌​‌‌​​​‍‌​‌​‌​‌‌‍‌‌​‌‌‌‌‌‍‌​‌‌‌​​‌‍‌​‌​‌​‌​‍‌​‌‌‌‌​​‍‌​‌‌​‌​​‍‌​‌‌​‌‌​‍‌​‌‌​​​‌‍‌​‌‌‌​​​‍‌‌​‌‌‌‌‌‍‌​‌​‌‌​​‍‌​‌​‌‌‌‌‍‌​‌‌‌‌‌​‍‌​‌‌​​‌​‍‌‌​‌‌‌‌‌‍‌​‌‌​​‌​‍‌​‌‌‌​‌​xmpp.is"))
        (li "IRC: " (strong "tsarfox on irc.libera.chat.")))
diff --git a/haunt/squee.scm b/haunt/squee.scm
new file mode 100644
index 0000000..443fa09
--- /dev/null
+++ b/haunt/squee.scm
@@ -0,0 +1,372 @@
+;;; squee --- A guile interface to postgres via the ffi
+
+;; Copyright (C) 2015 Christopher Allan Webber <cwebber@dustycloud.org>
+
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library 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
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+(define-module (squee)
+  #:use-module (system foreign)
+  #:use-module (rnrs enums)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 format)
+  #:use-module (srfi srfi-26)
+  #:export (;; The important ones
+            connect-to-postgres-paramstring
+            exec-query
+            pg-conn-finish
+
+            ;; enums and indexes of enums
+            conn-status-enum conn-status-enum-index
+            polling-status-enum polling-status-index
+            exec-status-enum exec-status-enum-index
+            transaction-status-enum transaction-status-enum-index
+            verbosity-enum verbosity-enum-index
+            ping-enum ping-enum-index
+
+            ;; **repl and error messages only!**
+            enum-set-ref
+
+            ;; Connection stuff
+            <pg-conn> pg-conn? wrap-pg-conn unwrap-pg-conn
+
+            ;; @@: We don't export the result pointer though!
+            ;;   as this needs to be cleared to avoid memory
+            ;;   leaks...
+            ;;
+            ;;   We might provide a (exec-with-result-ptr)
+            ;;   that cleans up the result pointer after calling
+            ;;   some thunk though?
+            ;;
+            ;;   These are still useful for building your own
+            ;;   serializer though...
+            result-num-rows result-num-cols result-get-value
+            result-serializer-simple-list result-metadata))
+
+(define libpq (dynamic-link "libpq"))
+
+;; ---------------------
+;; Enums from libpq-fe.h
+;; ---------------------
+
+(define conn-status-enum
+  (make-enumeration
+   '(connection-ok
+     connection-bad
+     connection-started connection-made
+     connection-awaiting-response connection-auth-ok
+     connection-auth-ok connection-setenv
+     connection-ssl-startup
+     connection-needed)))
+
+(define conn-status-enum-index
+  (enum-set-indexer conn-status-enum))
+
+(define polling-status-enum
+  (make-enumeration
+   '(polling-failed
+     polling-reading
+     polling-writing
+     polling-ok
+     polling-active)))
+
+(define polling-status-enum-index
+  (enum-set-indexer polling-status-enum))
+
+(define exec-status-enum
+  (make-enumeration
+   '(empty-query
+     command-ok tuples-ok
+     copy-out copy-in
+     bad-response
+     nonfatal-error fatal-error
+     copy-both
+     single-tuple)))
+
+(define exec-status-enum-index
+  (enum-set-indexer exec-status-enum))
+
+(define transaction-status-enum
+  (make-enumeration
+   '(idle active intrans inerror unknown)))
+
+(define transaction-status-enum-index
+  (enum-set-indexer transaction-status-enum))
+
+(define verbosity-enum
+  (make-enumeration
+   '(terse default verbose)))
+
+(define verbosity-enum-index
+  (enum-set-indexer verbosity-enum))
+
+(define ping-enum
+  (make-enumeration
+   '(ok reject no-response no-attempt)))
+
+(define ping-enum-index
+  (enum-set-indexer ping-enum))
+
+(define-wrapped-pointer-type <pg-conn>
+  pg-conn?
+  wrap-pg-conn unwrap-pg-conn
+  (lambda (pg-conn port)
+    (format port "#<pg-conn ~x (~a)>"
+            (pointer-address (unwrap-pg-conn pg-conn))
+            (let ((status (pg-conn-status pg-conn)))
+              (cond ((eq? status (conn-status-enum-index 'connection-ok))
+                     "connected")
+                    ((eq? status (conn-status-enum-index 'connection-bad))
+                     (let ((conn-error (pg-conn-error-message pg-conn)))
+                       (if (equal? conn-error "")
+                           "disconnected"
+                           (format #f "disconnected, error: ~s" conn-error))))
+                    (#t
+                     (symbol->string
+                      (pg-conn-status-symbol pg-conn))))))))
+
+
+;; This one should NOT be exposed to the outside world!  We have our
+;; own result structure...
+
+(define-wrapped-pointer-type <result-ptr>
+  result-ptr?
+  wrap-result-ptr unwrap-result-ptr
+  (lambda (result-ptr port)
+    (format port "#<result-ptr ~x>"
+            (pointer-address (unwrap-result-ptr result-ptr)))))
+
+
+(define (enum-set-ref enum-set k)
+  "Take an ENUM-SET and get the item at position K
+
+This is O(n) but theoretically we don't use it much.
+Again, REPL only!"
+  (list-ref (enum-set->list enum-set) k))
+
+
+(define-syntax-rule (define-foreign-libpq name return_type func_name arg_types)
+  (define name
+    (pointer->procedure return_type
+                        (dynamic-func func_name libpq)
+                        arg_types)))
+
+
+(define-foreign-libpq %PQconnectdb '* "PQconnectdb" (list '*))
+(define-foreign-libpq %PQstatus int "PQstatus" (list '*))
+(define-foreign-libpq %PQerrorMessage '* "PQerrorMessage" (list '*))
+(define-foreign-libpq %PQfinish void "PQfinish" (list '*))
+(define-foreign-libpq %PQntuples int "PQntuples" (list '*))
+(define-foreign-libpq %PQnfields int "PQnfields" (list '*))
+
+
+(define-foreign-libpq %PQexec '* "PQexec" (list '* '*))
+(define-foreign-libpq %PQexecParams
+  '*  ;; Returns a PGresult
+  "PQexecParams"
+  (list '* ;; connection
+        '* ;; command, a string
+        int ;; number of parameters
+        '* ;; paramTypes, ok to leave NULL
+        '* ;; paramValues, here goes your actual parameters!
+        '* ;; paramLengths, ok to leave NULL
+        '* ;; paramFormats, ok to leave NULL
+        int)) ;; resultFormat... probably 0!
+
+(define-foreign-libpq %PQresultStatus int "PQresultStatus" (list '*))
+(define-foreign-libpq %PQresStatus '* "PQresStatus" (list int))
+(define-foreign-libpq %PQresultErrorMessage '* "PQresultErrorMessage" (list '*))
+(define-foreign-libpq %PQclear void "PQclear" (list '*))
+
+(define-foreign-libpq %PQcmdtuples '* "PQcmdTuples" (list '*))
+(define-foreign-libpq %PQntuples int "PQntuples" (list '*))
+(define-foreign-libpq %PQnfields int "PQnfields" (list '*))
+(define-foreign-libpq %PQgetisnull int "PQgetisnull" (list '* int int))
+(define-foreign-libpq %PQgetvalue '* "PQgetvalue" (list '* int int))
+
+
+;; Via mark_weaver.  Thanks Mark!
+;;
+;; So, apparently we can use a struct of strings just like an array
+;; of strings.  Because magic, and because Mark thinks the C standard
+;; allows it enough!
+
+(define (string-pointer-list->string-array ls)
+  "Take a list of strings, generate a C-compatible list of free strings"
+  (make-c-struct
+   (make-list (+ 1 (length ls)) '*)
+   (append ls (list %null-pointer))))
+
+(define (pg-conn-status pg-conn)
+  "Get the connection status from a postgres connection"
+  (%PQstatus (unwrap-pg-conn pg-conn)))
+
+(define (pg-conn-status-symbol pg-conn)
+  "Human readable version of the pg-conn status.
+
+Inefficient... don't use this in normal code... it's just for you and
+the REPL!  (Well, we do use it for errors, because those are
+comparatively \"rare\" so this is okay.)  Compare against the enum
+value of the symbol instead."
+  (let ((status (pg-conn-status pg-conn)))
+    (if (< status (length (enum-set->list conn-status-enum)))
+        (enum-set-ref conn-status-enum
+                (pg-conn-status pg-conn))
+        ;; Weird, this is bigger than our enum of statuses
+        (string->symbol
+         (format #f "unknown-status-~a" status)))))
+
+
+(define (pg-conn-error-message pg-conn)
+  "Get an error message for this connection"
+  (pointer->string (%PQerrorMessage (unwrap-pg-conn pg-conn))))
+
+
+(define (pg-conn-finish pg-conn)
+  "Close out a database connection.
+
+If the connection is already closed, this simply returns #f."
+  (if (eq? (pg-conn-status pg-conn)
+           (conn-status-enum-index 'connection-ok))
+      (begin
+        (%PQfinish (unwrap-pg-conn pg-conn))
+        #t)
+      #f))
+
+(define (connect-to-postgres-paramstring paramstring)
+  "Open a connection to the database via a parameter string"
+  (let* ((conn-pointer (%PQconnectdb (string->pointer paramstring)))
+         (pg-conn (wrap-pg-conn conn-pointer)))
+    (if (eq? conn-pointer %null-pointer)
+        (throw 'psql-connect-error
+               #f "Unable to establish connection"))
+    (let ((status (pg-conn-status pg-conn)))
+      (if (eq? status (conn-status-enum-index 'connection-ok))
+          pg-conn
+          (throw 'psql-connect-error
+                (enum-set-ref conn-status-enum status)
+                (pg-conn-error-message pg-conn))))))
+
+
+(define (result-num-rows result-ptr)
+  (%PQntuples (unwrap-result-ptr result-ptr)))
+
+(define (result-num-cols result-ptr)
+  (%PQnfields (unwrap-result-ptr result-ptr)))
+
+(define (result-get-value result-ptr row col)
+  (let ((res (unwrap-result-ptr result-ptr)))
+    (and (eqv? (%PQgetisnull res row col) 0)
+         (pointer->string
+          (%PQgetvalue res row col)))))
+
+
+;; @@: We ought to also have a vector version...
+;;     and other serializations...
+(define (result-serializer-simple-list result-ptr)
+  "Get a simple list of lists representing the result of the query"
+  (let ((rows-range (iota (result-num-rows result-ptr)))
+        (cols-range (iota (result-num-cols result-ptr))))
+    (map
+     (lambda (row-i)
+       (map
+        (lambda (col-i)
+          (result-get-value result-ptr row-i col-i))
+        cols-range))
+     rows-range)))
+
+;; TODO
+(define (result-metadata result-ptr)
+  #f)
+
+
+(define (result-ptr-clear result-ptr)
+  (%PQclear (unwrap-result-ptr result-ptr)))
+
+(define (result-error-message result-ptr)
+  (%PQresultErrorMessage (unwrap-result-ptr result-ptr)))
+
+
+(define* (exec-query pg-conn command #:optional (params '())
+                     #:key (serializer result-serializer-simple-list))
+  (let* ((param-pointers
+          (map (lambda (param)
+                 (if param
+                     (string->pointer param)
+                     %null-pointer))
+               params))
+         (command-pointer
+          (string->pointer command))
+         (param-array-pointer
+          (string-pointer-list->string-array param-pointers))
+         (result-ptr
+          (wrap-result-ptr
+           (if (null? params)
+               (%PQexec
+                (unwrap-pg-conn pg-conn)
+                command-pointer)
+               (%PQexecParams
+                (unwrap-pg-conn pg-conn)
+                command-pointer
+                (length params)
+                %null-pointer
+                param-array-pointer
+                %null-pointer %null-pointer 0)))))
+
+    ;; Protect the pointers, and thus the memory regions they point to
+    ;; from garbage collection, until %PQexecParams has returned
+    (identity param-pointers)
+    (identity command-pointer)
+    (identity param-array-pointer)
+
+    (if (eq? result-ptr %null-pointer)
+        ;; Presumably a database connection issue...
+        (throw 'psql-query-error
+               ;; See below for psql-query-error param definition
+               #f #f (pg-conn-error-message pg-conn)))
+
+    (let ((status (%PQresultStatus (unwrap-result-ptr result-ptr))))
+      (cond
+       ;; This is the kind of query that returns tuples
+       ((eq? status (exec-status-enum-index 'tuples-ok))
+        (let ((serialized-result (serializer result-ptr))
+              (metadata (result-metadata result-ptr)))
+          ;; Gotta clear the result to prevent memory leaks
+          (result-ptr-clear result-ptr)
+          (values serialized-result metadata)))
+
+       ;; This doesn't return tuples, eg it's a DELETE or something.
+       ((eq? status (exec-status-enum-index 'command-ok))
+        (let ((metadata (result-metadata result-ptr))
+              (rows (%PQcmdtuples (unwrap-result-ptr result-ptr))))
+          ;; Gotta clear the result to prevent memory leaks
+          (result-ptr-clear result-ptr)
+          ;; Return the number of affected rows.
+          (values (string->number
+                   (pointer->string rows)) metadata)))
+
+       ;; Uhoh, anything else is an error!
+       (#t
+        (let ((status-message (pointer->string (%PQresStatus status)))
+              (error-message (pointer->string
+                              (%PQresultErrorMessage (unwrap-result-ptr
+                                                      result-ptr)))))
+          (result-ptr-clear result-ptr)
+          (throw 'psql-query-error
+                 ;; @@: Do we need result-status?
+                 ;; (error-symbol result-status result-error-message)
+                 (enum-set-ref exec-status-enum status)
+                 status-message error-message)))))))
+
+;; (define conn (connect-to-postgres-paramstring "dbname=sandbox"))
diff --git a/haunt/srfi-197.scm b/haunt/srfi-197.scm
new file mode 100644
index 0000000..93fc0ab
--- /dev/null
+++ b/haunt/srfi-197.scm
@@ -0,0 +1,4 @@
+(define-module (srfi-197)
+  #:export (chain chain-and chain-when chain-lambda nest nest-reverse))
+
+(include "ext-srfi-197/srfi-197-syntax-case.scm")