;;; Copyright © 2019 - 2022 Jakob L. Kreuze ;;; ;;; 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 ;;; . (define-module (jakob dynamic capabilities comments) #:use-module (ice-9 match) #:use-module (jakob dynamic capabilities common) #:use-module (jakob dynamic captcha) #:use-module (jakob dynamic errors) #:use-module (jakob dynamic util) #:use-module (json) #:use-module (squee) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #: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 "user=jakob_dynamic 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 (make-internal-comment~ . args) (let* ((approved (first (take-right args 2))) (approved (string->date approved "~Y~m~d ~H~M~S.~N")) (reactions (last args)) (reactions (if reactions (with-input-from-string reactions read) '()))) (apply make-internal-comment (append (drop-right args 2) (list approved reactions))))) (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 (cut apply make-internal-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'." (define (normalize-record record) (json-string->scm (internal-comment->json record))) (let* ((query-string (uri-query (request-uri request))) (params (if query-string (decode-form query-string) '())) (slug (assoc-ref params "p"))) (unless slug (panic "missing `slug' query parameter")) (values '((content-type . (application/json))) (scm->json-string (list->vector (map normalize-record (get-comments-by-slug (car slug)))))))) (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) (or (assoc "captcha" form-data) (and (assoc "captcha-alt" form-data) (assoc "captcha-alt-id" form-data))) (assoc "captcha-id" form-data) (if (and (string? (assoc-value form-data "captcha-alt")) (positive? (string-length (assoc-value form-data "captcha-alt")))) (validate-proof-of-work! (assoc-value form-data "captcha-alt") (string->number (assoc-value form-data "captcha-alt-id"))) (validate-captcha! (assoc-value form-data "captcha") (string->number (assoc-value form-data "captcha-id")))))) (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 (build-response #:code 307 #:headers '((location . "https://jakob.space"))) (scm->json-string `((success . #t))))) (let ((form-data (decode-form body))) (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))) (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) '()))) (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)))))))