[dynamic] Add endpoint for fetching all comments

3 files changed, 53 insertions, 26 deletions

diff --git a/jakob/dynamic/capabilities/comment-form.scm b/jakob/dynamic/capabilities/comment-form.scm
index 12a5f57..958e9dc 100644
--- a/jakob/dynamic/capabilities/comment-form.scm
+++ b/jakob/dynamic/capabilities/comment-form.scm
@@ -104,9 +104,6 @@
      ,(script "proof-of-work.js")))
 
 (define (get-comment-form request body)
-  "API endpoint handler for querying for the comments on a particular post
-
-This is a wrapper around `get-comments-by-slug'."
   (let-values (((captcha-id captcha-image) (new-captcha!)))
     (let* ((path-encoded (uri-path (request-uri request)))
            (path (split-and-decode-uri-path path-encoded))
diff --git a/jakob/dynamic/capabilities/comments.scm b/jakob/dynamic/capabilities/comments.scm
index fe355e2..7715174 100644
--- a/jakob/dynamic/capabilities/comments.scm
+++ b/jakob/dynamic/capabilities/comments.scm
@@ -34,34 +34,31 @@
   #:use-module (web response)
   #:use-module (web uri)
   #:export (get-comments
-            get-comments-by-slug
+            get-all-comments
 
             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
+(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))))
 
-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 (order-comments comments)
     (define seen (make-hash-table))
     (define (id comment) (first comment))
     (define (content comment) (drop-right comment 1))
@@ -86,13 +83,30 @@ This interface exists for dynamically generating the comment view from Haunt."
                    (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
+
+(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, originating_network, reply_to
+                 FROM comments WHERE approved IS NOT NULL
+                 ORDER BY approved DESC
+                 LIMIT $1")
+         (result (exec-query conn query (list limit)))
+         (result (map (lambda (comment)
+                        (append (drop-right comment 1) '(())))
+                      result)))
+    (map (cut apply make-internal-comment~ <>) result)))
+
 (define (get-comments request body)
   "API endpoint handler for querying for the comments on a particular post
 
@@ -108,7 +122,21 @@ This is a wrapper around `get-comments-by-slug'."
     (values '((content-type . (application/json)))
             (scm->json-string
              (list->vector
-              (map normalize-record (get-comments-by-slug (car slug))))))))
+              (map normalize-record (handle-get-comments-by-slug (car slug))))))))
+
+(define (get-all-comments request body)
+  (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)
+                     '()))
+         (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))))))
 
 
 
diff --git a/jakob/dynamic/capabilities/common.scm b/jakob/dynamic/capabilities/common.scm
index 2bca1a2..f76e6e9 100644
--- a/jakob/dynamic/capabilities/common.scm
+++ b/jakob/dynamic/capabilities/common.scm
@@ -23,6 +23,7 @@
             make-internal-comment
             internal-comment?
             internal-comment-id
+            internal-comment-slug
             internal-comment-name
             internal-comment-subject
             internal-comment-email
@@ -39,6 +40,7 @@
   internal-comment?
   json->internal-comment <=> internal-comment->json
   (id        internal-comment-id)
+  (slug      internal-comment-slug)
   (name      internal-comment-name)
   (subject   internal-comment-subject)
   (email     internal-comment-email)