[dynamic] Refactor and improve error reporting with R6RS exceptions

1 files changed, 42 insertions, 41 deletions

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)))))))