From d84e451c8cf3aa181867736acfa3d533302d0288 Mon Sep 17 00:00:00 2001 From: "Jakob L. Kreuze" Date: Sat, 5 Nov 2022 11:05:44 -0400 Subject: [dynamic] Refine query API --- dynamic/capabilities/comments.scm | 119 +++++++++++++++++++++----------------- 1 file changed, 65 insertions(+), 54 deletions(-) (limited to 'dynamic/capabilities/comments.scm') diff --git a/dynamic/capabilities/comments.scm b/dynamic/capabilities/comments.scm index 6786474..fb965c9 100644 --- a/dynamic/capabilities/comments.scm +++ b/dynamic/capabilities/comments.scm @@ -22,11 +22,17 @@ #:use-module (web request) #:use-module (web response) #:use-module (web uri) - #:export (get-comments put-comment put-reaction)) + #:export (get-comments + get-comments-by-slug + put-comment + put-reaction)) (define conn (connect-to-postgres-paramstring "dbname=jakob_comments")) -(define (get-comments-slug slug) +(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 reactions) @@ -35,23 +41,26 @@ (subject . ,subject) (email . ,email) (comment . ,comment) - (reactions . ,reactions))))) + (reactions . ,(with-input-from-string reactions read)))))) (let* ((query "SELECT id, name, subject, email, comment, reactions - FROM comments WHERE slug = $1") + FROM comments WHERE slug = $1 and approved IS NOT NULL") (result (exec-query conn query (list (car slug))))) - (values '((content-type . (application/json))) - (scm->json-string - (list->vector - (map format-comment result)))))) + (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 - (get-comments-slug slug) + (values '((content-type . (application/json))) + (scm->json-string + (list->vector + (get-comments-by-slug slug)))) (values (build-response #:code 400) (scm->json-string `((success . #f) @@ -59,28 +68,25 @@ -(define (assoc-value alist key) - (let ((result (assoc-ref alist key))) - (if result (car result) result))) - -(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 . (text/plain))) "Hello hacker!")) - -(define (valid-comment? form-data) - (and (assoc "slug" form-data) - (assoc "name" form-data) - (assoc "comment" form-data))) - (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) @@ -91,16 +97,6 @@ -(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 (acons-normalize key value alist) - (cons (cons key value) - (filter (lambda (pair) (not (equal? (car pair) key))) alist))) - (define (add-reaction reactions reaction) (with-output-to-string (lambda () @@ -109,24 +105,39 @@ (if (assoc reaction parsed) (+ 1 (assoc-value parsed reaction)) 1) parsed)))))) -(define (set-reactions id reactions) - (exec-query conn - "UPDATE comments SET reactions = $1 WHERE id = $2" - (list reactions id)) - (values '((content-type . (text/plain))) "Reacted hacker!")) - -;; TODO: Need to validate `form-data' first. (define (put-reaction request body) - (let* ((form-data (decode-form body)) - (id (assoc-value form-data "id")) - (reaction (assoc-value form-data "reaction")) - (reactions (comment-reactions id))) - (if reactions - (set-reactions id (add-reaction reactions reaction)) + (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 . "no such comment"))))))) + (error . "missing `id', or `reaction'"))))))) ;; (define (make-challenge request body) ;; (let-values (((uuid value image) (new-captcha))) -- cgit v1.3