1 files changed, 210 insertions, 0 deletions
diff --git a/jakob/dynamic/capabilities/comments.scm b/jakob/dynamic/capabilities/comments.scm
new file mode 100644
index 0000000..ee2a52d
--- /dev/null
+++ b/jakob/dynamic/capabilities/comments.scm
@@ -0,0 +1,210 @@
+;;; 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 (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 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 (paramstring-for-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* ((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 '()))
+  (let* ((query "SELECT id, 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 (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 (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)))
+    (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 ((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)))))))