diff options
Diffstat (limited to 'haunt')
| -rw-r--r-- | haunt/api.scm | 54 | ||||
| -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 | ||||
| -rw-r--r-- | haunt/jakob/dynamic/captcha.scm | 11 | ||||
| -rw-r--r-- | haunt/jakob/dynamic/errors.scm | 38 | ||||
| -rw-r--r-- | haunt/jakob/dynamic/rate-limiter.scm | 22 |
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)))) |