[dynamic] Refactor and improve error reporting with R6RS exceptions

8 files changed, 177 insertions, 156 deletions

diff --git a/haunt/api.scm b/haunt/api.scm
index b1db096..1b24bc0 100644
--- a/haunt/api.scm
+++ b/haunt/api.scm
@@ -20,8 +20,12 @@
              (jakob dynamic capabilities comments)
              (jakob dynamic capabilities gallery)
              (jakob dynamic capabilities rsvp)
+             (jakob dynamic errors)
              (jakob dynamic logging)
              (jakob dynamic rate-limiter)
+             (json)
+             (rnrs conditions)
+             (rnrs exceptions)
              (srfi srfi-1)
              (web request)
              (web response)
@@ -34,25 +38,45 @@
           (string-append "Resource not found: "
                          (uri->string (request-uri request)))))
 
+(define (format-error-response condition)
+  "Format CONDITION, a &reportable-condition, as an HTTP response"
+  (values (build-response #:code (reportable-condition-code condition))
+          (scm->json-string
+           `((success . #f)
+             (error . ,(reportable-condition-message condition))))))
+
+(define-syntax values->list
+  (syntax-rules ()
+    ((values-list exp)
+     (call-with-values (lambda () exp) list))))
+
 (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))
+        (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)))
-  ((rate-limit-wrap
-    (match (cons (request-method request) endpoint)
-      (('GET "comment-form" _) get-comment-form)
-      ('(GET "challenge" "proof-of-work") make-pow-challenge!)
-      ('(GET "challenge" "captcha") make-captcha-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))
+    (log-append! 'info (if args
+                           (format #f "~a ~a (~a) (~a)" method endpoint args originating-ip)
+                           (format #f "~a ~a (~a)" method endpoint originating-ip))))
+  ;; Somewhat painful wrap/unwrap of values because there isn't support for
+  ;; returning multiple values from a `guard' clause.
+  (apply values
+    (guard (ex ((reportable-condition? ex)
+                (values->list (format-error-response ex))))
+      (values->list
+       ((rate-limit-wrap
+         (match (cons (request-method request) endpoint)
+           (('GET "comment-form" _) get-comment-form)
+           ('(GET "challenge" "proof-of-work") make-pow-challenge!)
+           ('(GET "challenge" "captcha") make-captcha-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."
diff --git a/haunt/jakob/dynamic/capabilities/comment-form.scm b/haunt/jakob/dynamic/capabilities/comment-form.scm
index 23d669d..83c9e1a 100644
--- a/haunt/jakob/dynamic/capabilities/comment-form.scm
+++ b/haunt/jakob/dynamic/capabilities/comment-form.scm
@@ -31,10 +31,6 @@
   #:use-module (web uri)
   #:export (render-static-comment-form
             render-dynamic-comment-form
-
-            render-comment-form-success
-            render-comment-form-failure
-
             get-comment-form))
 
 (define (render-commenter-info-field)
@@ -102,11 +98,6 @@
      ,(script "dynamic-comment-form.js")
      ,(script "proof-of-work.js")))
 
-(define (render-comment-form-success slug)
-  `((div (h1 "Success!")
-         (meta (@ (http-equiv "refresh")
-                  (content "1; url=https://jakob.space"))))))
-
 (define (get-comment-form request body)
   "API endpoint handler for querying for the comments on a particular post
 
@@ -115,7 +106,7 @@ This is a wrapper around `get-comments-by-slug'."
     (let* ((path-encoded (uri-path (request-uri request)))
            (path (split-and-decode-uri-path path-encoded))
            (slug (last path))
-           (form (render-staticcomment-form slug #f captcha-id captcha-image)))
+           (form (render-static-comment-form slug #f captcha-id captcha-image)))
       (values '((content-type . (text/html)))
               (sxml->html-string
                (theme #:content form #:title "Comment prompt"))))))
diff --git a/haunt/jakob/dynamic/capabilities/comments.scm b/haunt/jakob/dynamic/capabilities/comments.scm
index d3cb812..314ae75 100644
--- a/haunt/jakob/dynamic/capabilities/comments.scm
+++ b/haunt/jakob/dynamic/capabilities/comments.scm
@@ -15,12 +15,10 @@
 ;;; <http://www.gnu.org/licenses/>.
 
 (define-module (jakob dynamic capabilities comments)
-  #:use-module (haunt html)
   #:use-module (ice-9 match)
   #:use-module (jakob dynamic captcha)
-  #:use-module (jakob dynamic capabilities comment-form)
+  #:use-module (jakob dynamic errors)
   #:use-module (jakob dynamic util)
-  #:use-module (jakob theme)
   #:use-module (json)
   #:use-module (squee)
   #:use-module (web request)
@@ -64,22 +62,17 @@ This is a wrapper around `get-comments-by-slug'."
                      (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")))))))
+    (unless slug (panic "missing `slug' query parameter"))
+    (values '((content-type . (application/json)))
+            (scm->json-string
+             (list->vector
+              (get-comments-by-slug (car slug)))))))
 
 
 
 (define (put-comment request body)
   "API endpoint handler for submitting a comment"
   (define (valid-comment? form-data)
-    (display form-data)
     (and (assoc "slug" form-data)
          (assoc "name" form-data)
          (assoc "comment" form-data)
@@ -106,18 +99,34 @@ This is a wrapper around `get-comments-by-slug'."
                       (assoc-value form-data "email")
                       (assoc-value form-data "url")
                       (assoc-value form-data "comment")))
-    (values '((content-type . (text/html)))
-            (sxml->html-string
-             (theme
-              #:content (render-comment-form-success (assoc-value form-data "slug"))
-              #:title "Success!"))))
+    (values (build-response
+             #:code 307
+             #:headers '((location . "https://jakob.space")))
+            (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'")))))))
+    (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)))
 
 
 
@@ -145,20 +154,12 @@ This is a wrapper around `get-comments-by-slug'."
          (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'")))))))
+    (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 reactions (panic "no such comment"))
+      (set-reactions id (add-reaction reactions reaction))
+      (values '((content-type . (application/json)))
+              (scm->json-string `((success . #t)))))))
diff --git a/haunt/jakob/dynamic/capabilities/gallery.scm b/haunt/jakob/dynamic/capabilities/gallery.scm
index b8b46c9..ce154b9 100644
--- a/haunt/jakob/dynamic/capabilities/gallery.scm
+++ b/haunt/jakob/dynamic/capabilities/gallery.scm
@@ -18,6 +18,7 @@
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 ftw)
   #:use-module (ice-9 match)
+  #:use-module (jakob dynamic errors)
   #:use-module (jakob dynamic util)
   #:use-module (json)
   #:use-module (squee)
@@ -72,14 +73,10 @@
                      (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")))))))
+    (unless (valid-gallery-code code) (panic "invalid gallery code"))
+    (values '((content-type . (application/json)))
+            (scm->json-string `((info . ,(get-gallery-info code))
+                                (images . ,(get-gallery-images code)))))))
 
 (define (image-exists? file-name)
   (define (string/= a b) (not (string= a b)))
@@ -103,9 +100,5 @@
                      (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")))))))
+    (unless (image-exists? file-name) (panic "invalid filename"))
+    (read-image file-name)))
diff --git a/haunt/jakob/dynamic/capabilities/rsvp.scm b/haunt/jakob/dynamic/capabilities/rsvp.scm
index d7d6fb9..e29d5fb 100644
--- a/haunt/jakob/dynamic/capabilities/rsvp.scm
+++ b/haunt/jakob/dynamic/capabilities/rsvp.scm
@@ -18,6 +18,7 @@
   #:use-module (gcrypt base64)
   #:use-module (ice-9 binary-ports)
   #:use-module (ice-9 match)
+  #:use-module (jakob dynamic errors)
   #:use-module (jakob dynamic util)
   #:use-module (json)
   #:use-module (rnrs bytevectors)
@@ -101,31 +102,24 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness."
 (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)))))))))
+    (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 . (application/json)))
+              (scm->json-string
+               `((receipt . ,receipt-code)))))))
 
 
 
@@ -158,28 +152,22 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness."
 (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)))))))))
+    (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 . (application/json)))
+            (scm->json-string
+             `((receipt . ,(rsvp-update-code params)))))))
 
 
 
@@ -188,10 +176,7 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness."
   (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"))))))))
+          (else (panic "invalid invite/update code")))))
 
 
 
@@ -270,8 +255,4 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness."
            (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"))))))))
+          (else (panic "invalid invitation or receipt code")))))
diff --git a/haunt/jakob/dynamic/captcha.scm b/haunt/jakob/dynamic/captcha.scm
index 05426d1..b71bb23 100644
--- a/haunt/jakob/dynamic/captcha.scm
+++ b/haunt/jakob/dynamic/captcha.scm
@@ -26,9 +26,11 @@
   #:use-module (ice-9 match)
   #:use-module (ice-9 popen)
   #:use-module (ice-9 threads)
+  #:use-module (jakob dynamic errors)
   #:use-module (json)
   #:use-module (rnrs bytevectors)
   #:use-module ((rnrs base) #:select (assert))
+  #:use-module (rnrs conditions)
   #:use-module (rnrs exceptions)
   #:use-module (srfi-197)
   #:use-module (srfi srfi-1)
@@ -168,7 +170,7 @@ internally-defined `time-to-live-seconds'."
     ('x 1)
     (n (if (number? n)
            0
-           (error "Do not know how to differentiate.")))))
+           (error "Do not know how to differentiate." n)))))
 
 (define (simplify-sexp sexp)
   (match sexp
@@ -202,11 +204,11 @@ internally-defined `time-to-live-seconds'."
 \\end{document}
 " src)))
     (unless (eqv? 0 (status:exit-val (system "pdflatex formula.tex")))
-      (error "Cannot generate PDF"))
+      (error "Cannot generate PDF" #f))
     (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"))
+          (error "Cannot generate PNG" #f))
       data)))
 
 (define (new-captcha!)
@@ -266,8 +268,7 @@ internally-defined `time-to-live-seconds'."
 (define (validate-proof-of-work! prefix challenge-id)
   (define zero-prefix (string-join (map (lambda (_) "0") (iota %hardness)) ""))
   (when (member challenge-id (id-queue-free pow-challenge-id-queue))
-    (raise (condition (&message
-                       (message "No such challenge ID")))))
+    (panic "No such challenge ID"))
   (let* ((challenge (hash-ref pow-challenges challenge-id))
          (hash-value (chain (list prefix challenge)
                             (string-concatenate _)
diff --git a/haunt/jakob/dynamic/errors.scm b/haunt/jakob/dynamic/errors.scm
new file mode 100644
index 0000000..2394cb7
--- /dev/null
+++ b/haunt/jakob/dynamic/errors.scm
@@ -0,0 +1,38 @@
+;;; 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 errors)
+  #:use-module (rnrs conditions)
+  #:export (&reportable
+
+            make-reportable-condition
+            reportable-condition?
+
+            reportable-condition-code
+            reportable-condition-message
+
+            panic))
+
+;; Condition that can safely be presented to an API user
+(define-condition-type &reportable &condition
+  make-reportable-condition
+  reportable-condition?
+  (code reportable-condition-code)
+  (message reportable-condition-message))
+
+(define* (panic message #:key (code 400))
+  "Raise MESSAGE as a &reportable condition"
+  (raise (condition (make-reportable-condition code message))))
diff --git a/haunt/jakob/dynamic/rate-limiter.scm b/haunt/jakob/dynamic/rate-limiter.scm
index bd39d07..d6ef28c 100644
--- a/haunt/jakob/dynamic/rate-limiter.scm
+++ b/haunt/jakob/dynamic/rate-limiter.scm
@@ -15,6 +15,7 @@
 ;;; <http://www.gnu.org/licenses/>.
 
 (define-module (jakob dynamic rate-limiter)
+  #:use-module (jakob dynamic errors)
   #:use-module (jakob dynamic util)
   #:use-module (json)
   #:use-module (rnrs conditions)
@@ -34,11 +35,7 @@
 
 (define active-rate-limits (make-hash-table))
 
-(define (rate-limit-handler-stub request body)
-  (values (build-response #:code 429)
-          (scm->json-string
-           `((success . #f)
-             (error . "Your IP address is currently being rate-limited.")))))
+(define (rate-limit-for-endpoint name) 32)
 
 (define (increment-key! hash-table key)
   (let ((new-value (if (hash-ref hash-table key)
@@ -46,12 +43,10 @@
                        1)))
     (hash-set! hash-table key new-value)))
 
-(define (rate-limit-for-endpoint name) 32)
-
 (define (rate-limit-wrap proc)
   (lambda (request body)
     (unless (assoc-ref (request-headers request) 'x-forwarded-for)
-      (raise (condition (make-message-condition "X-Forwarded-For header not provided"))))
+      (panic "X-Forwarded-For header not provided"))
     (let ((endpoint-name (procedure-name proc))
           (requester (chain (assoc-ref (request-headers request) 'x-forwarded-for)
                             (string-split _ #\,)
@@ -68,10 +63,7 @@
         (hash-set! active-rate-limits
                    requester
                    (make-requester-state (current-time) (make-hash-table))))
-      (if (and (> (hash-ref (requester-state-bins (hash-ref active-rate-limits requester)) endpoint-name)
-                  (rate-limit-for-endpoint endpoint-name)))
-          (values (build-response #:code 429)
-                  (scm->json-string
-                   `((success . #f)
-                     (error . "Your IP address is currently being rate-limited."))))
-          (proc request body)))))
+      (when (and (> (hash-ref (requester-state-bins (hash-ref active-rate-limits requester)) endpoint-name)
+                    (rate-limit-for-endpoint endpoint-name)))
+        (panic "Your IP address is currently being rate-limited." #:code 429))
+      (proc request body))))