path: root/jakob/dynamic/capabilities/comments.scm

;;; Copyright © 2019 - 2023 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 (haunt html)
  #:use-module (ice-9 match)
  #:use-module (jakob dynamic capabilities common)
  #:use-module (jakob dynamic captcha)
  #:use-module (jakob dynamic config)
  #:use-module (jakob dynamic errors)
  #:use-module (jakob dynamic logging)
  #:use-module (jakob dynamic notify)
  #:use-module (jakob dynamic util)
  #:use-module (jakob theme)
  #: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-all-comments

            put-comment
            put-reaction))

(define conn (connect-to-postgres-paramstring (paramstring-for-dbname "jakob_comments")))

(define (make-internal-comment~ . args)
  (let* ((args-needing-processing (take-right args 4))
         (approved (list-ref args-needing-processing 0))
         (approved (string->date approved "~Y~m~d ~H~M~S.~N"))
         (reactions (list-ref args-needing-processing 1))
         (reactions (if reactions
                        (with-input-from-string reactions read)
                        '()))
         (originating-network (list-ref args-needing-processing 2))
         (replies (list-ref args-needing-processing 3)))
    (apply make-internal-comment
           `(,@(drop-right args 4)
             ,approved
             ,reactions
             ,replies
             ,originating-network))))

(define (order-comments comments)
    (define seen (make-hash-table))
    (define (id comment) (first comment))
    (define (content comment) (drop-right comment 1))
    (define (parent comment) (last comment))
    (define (has-children? id remaining)
      (cond ((null? remaining) #f)
            ((equal? id (parent (car remaining))) #t)
            (else (has-children? id (cdr remaining)))))
    (define (pass cur initial-comments remaining)
      (cond ((null? initial-comments) (sort-comments (hash-ref seen 'terminal)))
            ((null? cur) (pass (reverse remaining) (reverse remaining) (list)))
            ((has-children? (id (car cur)) initial-comments)
             (pass (cdr cur) initial-comments (cons (car cur) remaining)))
            (else
             (let* ((children (or (hash-ref seen (id (car cur))) '()))
                    (children (sort-comments children))
                    (parsed (apply make-internal-comment~ (append (content (car cur)) (list children)))))
               ;; Remove this comment from `seen'.
               (hash-set! seen (id (car cur)) #f)
               (if (parent (car cur))
                   (hash-append! seen (parent (car cur)) parsed)
                   (hash-append! seen 'terminal parsed))
               (pass (cdr cur) initial-comments remaining)))))
    (pass comments comments '()))

(define (handle-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."

  (let* ((query "SELECT id, slug, name, subject, email, comment, url, approved, reactions, originating_network, reply_to
                 FROM comments WHERE slug = $1 and approved IS NOT NULL")
         (result (exec-query conn query (list slug))))
    (if (positive? (length result))
        (order-comments result)
        '())))

(define (handle-get-all-comments limit)
  (let* ((query "SELECT id, slug, name, subject, email, comment, url, approved, reactions
                 FROM comments WHERE approved IS NOT NULL
                 ORDER BY approved DESC
                 LIMIT $1")
         (result (exec-query conn query (list limit))))
    (map (lambda (comment) (apply make-internal-comment~ `(,@comment "clearnet" ()))) 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 (handle-get-comments-by-slug (car slug))))))))

(define (get-all-comments request body)
  (define (normalize-record record)
    (write record)
    (json-string->scm (internal-comment->json record)))
  (let* ((query-string (uri-query (request-uri request)))
         (params (if query-string
                     (decode-form query-string)
                     '()))
         (limit (or (assoc-value params "limit") "10"))
         (result (handle-get-all-comments limit)))
    (values '((content-type . (application/json)))
            (scm->json-string
             (list->vector
              (map normalize-record result))))))



(define (put-comment request body)
  "API endpoint handler for submitting a comment"
  (define (request-originating-network request)
    (cond ((from-tor? request) "tor")
          ((from-i2p? request) "i2p")
          (else                "clearnet")))
  (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, reply_to, originating_network)
                 VALUES (now(), $1, $2, $3, $4, $5, $6, $7, $8);"
                (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")
                      (if (and (assoc-value form-data "reply-to")
                               (positive? (string-length (assoc-value form-data "reply-to"))))
                          (assoc-value form-data "reply-to")
                          #f)
                      (request-originating-network request)))
    (if (equal? "application/json" (assoc-ref (request-headers request) 'accept))
        (values (build-response #:code 202
                                #:headers '((content-type . (application/json))))
                (scm->json-string `((success . #t))))
        (values (build-response #:code 202
                                #:headers '((content-type . (text/html))))
                (sxml->html-string
                 (theme #:title "Comment Posted!"
                        #:content
                        `(div (h2 "Comment successfully posted!")
                              (p "Thanks! Comments on this site are subject to "
                                 (em "manual approval")
                                 ", so it may be some time before you see your comment. "
                                 "But if you're seeing this, we did receive it!")
                              (p (a (@ (href "/")) "Click here to return to the homepage."))))))))
  (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")))
    (log-append! 'debug (format #f "Form data: ~a" form-data))
    (notify 5
            (if (assoc "subject" form-data)
                (format #f "New Comment: ~a" (assoc-value form-data "subject"))
                "New Comment")
            (format #f "~a: ~a"
                    (assoc-value form-data "name")
                    (assoc-value form-data "comment")))
    (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 ((form-data (decode-form body)))
    (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 id (panic "no such comment"))
      (unless (emoji? reaction) (panic "invalid reaction"))
      (set-reactions id (add-reaction reactions reaction))
      (values '((content-type . (application/json)))
              (scm->json-string `((success . #t)))))))