diff options
Diffstat (limited to 'haunt/jakob/dynamic/capabilities/comments.scm')
| -rw-r--r-- | haunt/jakob/dynamic/capabilities/comments.scm | 153 |
1 files changed, 153 insertions, 0 deletions
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)))) |