diff options
| -rw-r--r-- | dynamic/capabilities/comments.scm | 119 | ||||
| -rw-r--r-- | dynamic/util.scm | 14 |
2 files changed, 78 insertions, 55 deletions
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))) diff --git a/dynamic/util.scm b/dynamic/util.scm index 29a40db..b2e7221 100644 --- a/dynamic/util.scm +++ b/dynamic/util.scm @@ -20,9 +20,16 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) #:use-module (web uri) - #:export (base64-length + #:export (assoc-value + acons-normalize + base64-length decode-form)) +(define (assoc-value alist key) + "Return the `car' of `(assoc alist key)' if truthy" + (let ((result (assoc-ref alist key))) + (if result (car result) result))) + (define (acons-list k v alist) "Add V to K to alist as list" (let ((value (assoc-ref alist k))) @@ -31,6 +38,11 @@ (acons k (cons v value) alist)) (acons k (list v) alist)))) +(define (acons-normalize key value alist) + "Add KEY -> VALUE to ALIST such that no entries for KEY are duplicates" + (cons (cons key value) + (filter (lambda (pair) (not (equal? (car pair) key))) alist))) + (define (list->alist lst) "Build a alist of list based on a list of key and values. |