Show recent comments in sidebar

3 files changed, 46 insertions, 22 deletions

diff --git a/jakob/dynamic/capabilities/comments.scm b/jakob/dynamic/capabilities/comments.scm
index 7715174..eca05c8 100644
--- a/jakob/dynamic/capabilities/comments.scm
+++ b/jakob/dynamic/capabilities/comments.scm
@@ -97,15 +97,12 @@ This interface exists for dynamically generating the comment view from Haunt."
         '())))
 
 (define (handle-get-all-comments limit)
-  (let* ((query "SELECT id, slug, name, subject, email, comment, url, approved, reactions, originating_network, reply_to
+  (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)))
-         (result (map (lambda (comment)
-                        (append (drop-right comment 1) '(())))
-                      result)))
-    (map (cut apply make-internal-comment~ <>) result)))
+         (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
@@ -126,6 +123,7 @@ This is a wrapper around `get-comments-by-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
diff --git a/jakob/theme.scm b/jakob/theme.scm
index 7e29aa2..0cfebd6 100644
--- a/jakob/theme.scm
+++ b/jakob/theme.scm
@@ -18,6 +18,9 @@
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (ice-9 match)
+  #:use-module (jakob dynamic capabilities common)
+  #:use-module (jakob utils)
+  #:use-module (jakob utils comments)
   #:use-module (jakob utils sxml)
   #:export (theme))
 
@@ -60,6 +63,8 @@
     (time (@ (datetime ,(date->string (current-date) "~Y-~m-~d")))
           (string-upcase ,(date->string (current-date) "~d~b~Y")))))
 
+;; Evaluate ONCE for each invocation of haunt.
+(define %recent-comments (fetch-recent-comments))
 (define %default-sidebar-modules
   `((section
      (@ (class "module search-module")
@@ -120,20 +125,21 @@
             (style ,(fugue-icon-path "megaphone")))
          "Recent Comments")
      (div (@ (class "sidebar-comment-list"))
-          (article (@ (class "sidebar-comment-box"))
-             (span (@ (class "comment-context"))
-                   "on: "
-                   (a (@ (href "/blog/usb-pd-is-pretty-cool.html")) "USB-PD Is Pretty Cool"))
-                (strong "Bob")
-                (a (@ (href "/blog/usb-pd-is-pretty-cool.html#comment-reply"))
-                   "I used PETG to make sure it didn't warp..."))
-          (article (@ (class "sidebar-comment-box"))
-             (span (@ (class "comment-context"))
-                   "on: "
-                   (a (@ (href "/blog/usb-pd-is-pretty-cool.html")) "USB-PD Is Pretty Cool"))
-             (strong "Alice")
-             (a (@ (href "/blog/usb-pd-is-pretty-cool.html#comment-reply"))
-                "This is a lifesaver for field work. Have you..."))))))
+          ,@(map (lambda (comment)
+                   `(article (@ (class "sidebar-comment-box"))
+                       (span (@ (class "comment-context"))
+                          "on: "
+                          (a (@ (href ,(format #f "/blog/~a.html" (internal-comment-slug comment))))
+                             ,(internal-comment-slug comment)))
+                       (strong ,(internal-comment-name comment))
+                       (a (@ (href ,(format #f "/blog/~a.html#comment-~a"
+                                            (internal-comment-slug comment)
+                                            (internal-comment-id comment))))
+                          ,(let ((text (internal-comment-comment comment)))
+                             (if (> (string-length text) 25)
+                                 (format #f "~a..." (string-take text 25))
+                                 text)))))
+                 %recent-comments)))))
 
 (define %footer
   (let ((year (date-year (current-date))))
diff --git a/jakob/utils/comments.scm b/jakob/utils/comments.scm
index 2779e67..f9228bd 100644
--- a/jakob/utils/comments.scm
+++ b/jakob/utils/comments.scm
@@ -32,7 +32,10 @@
   #:use-module (srfi-197)
   #:use-module (web client)
   #:use-module (web response)
-  #:export (render-comment-view fetch-comments fetch-webmentions))
+  #:export (render-comment-view
+            fetch-comments
+            fetch-recent-comments
+            fetch-webmentions))
 
 (define (gravatar-url email)
   "Return the gravatar.com URL for user identified by EMAIL"
@@ -111,7 +114,10 @@
     (if (webmention? comment)
          '()
          (internal-comment-reactions comment)))
-  `(article (@ (class "comment-block"))
+  `(article (@ ,@(if (not (webmention? comment))
+                     `((id ,(format #f "comment-~a" (internal-comment-id comment))))
+                     '())
+               (class "comment-block"))
       (header (@ (class "comment-meta"))
          (img (@ (class "comment-avatar")
                  (src ,(comment-photo comment))
@@ -239,6 +245,20 @@
                  (map scm->json-string _)
                  (map (lambda (x) (call-with-input-string x json->internal-comment)) _))))))
 
+(define (fetch-recent-comments)
+  "Blocking call to retrieve a vector of the three most recent comments"
+  (if (getenv "HAUNT_SKIP_COMMENTS")
+      '()
+      (let ((url "https://jakob.space/api/all-comments?limit=3"))
+        (receive (response-status response-body)
+            (http-request url)
+          (chain response-body
+                 (bytevector->string _ "UTF-8")
+                 (json-string->scm _)
+                 (vector->list _)
+                 (map scm->json-string _)
+                 (map (lambda (x) (call-with-input-string x json->internal-comment)) _))))))
+
 (define (fetch-webmentions slug)
   "Blocking call to webmention.io to retrieve a vector of all Webmentions for `slug'"
   (define prefixes '("http://jakob.space/" "https://jakob.space/"