diff options
Diffstat (limited to 'haunt/jakob/dynamic/capabilities')
| -rw-r--r-- | haunt/jakob/dynamic/capabilities/comment-form.scm | 11 | ||||
| -rw-r--r-- | haunt/jakob/dynamic/capabilities/comments.scm | 83 | ||||
| -rw-r--r-- | haunt/jakob/dynamic/capabilities/gallery.scm | 21 | ||||
| -rw-r--r-- | haunt/jakob/dynamic/capabilities/rsvp.scm | 93 |
4 files changed, 87 insertions, 121 deletions
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"))))) |