Initial commit

2 files changed, 125 insertions, 2 deletions

diff --git a/haunt/jakob/builder/blog.scm b/haunt/jakob/builder/blog.scm
index bea9ed5..6cabd16 100644
--- a/haunt/jakob/builder/blog.scm
+++ b/haunt/jakob/builder/blog.scm
@@ -26,6 +26,7 @@
   #:use-module (jakob utils pagination)
   #:use-module (jakob utils sxml)
   #:use-module (jakob utils tags)
+  #:use-module (jakob utils webmention)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-19)
   #:use-module (srfi srfi-26)
@@ -83,7 +84,8 @@
       (@ (id "webmention"))
       (h2 ,(hyperlink "https://indieweb.org/Webmention" "Webmentions")
           " for this Page")
-      (ul (@ (id "webmention-container")))
+      (ul (@ (id "webmention-container"))
+          ,@(render-comment-view (fetch-webmentions (post-slug post))))
       (form
        (@ (action "https://webmention.io/jakob.space/webmention")
           (method "post"))
@@ -96,7 +98,8 @@
          ,(hyperlink (build-anonymous-comment-url post) "anonymous comment")
          ".")
       ,(script "section-folds.js")
-      ,(script "webmention.js"))))
+      ;; ,(script "webmention.js")
+      )))
 
 (define (render-preview post)
   "Return the SHTML for a preview of POST."
diff --git a/haunt/jakob/utils/webmention.scm b/haunt/jakob/utils/webmention.scm
new file mode 100644
index 0000000..9f1d289
--- /dev/null
+++ b/haunt/jakob/utils/webmention.scm
@@ -0,0 +1,120 @@
+;;; Copyright © 2019 - 2022 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 utils webmention)
+  #:use-module (ice-9 receive)
+  #:use-module (ice-9 iconv)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-43)
+  #:use-module (json)
+  #:use-module (web client)
+  #:use-module (web response)
+  #:use-module (oop goops)
+  #:export (render-comment-view
+            fetch-webmentions))
+
+(define (strip uri)
+  (let* ((needle "://")
+         (index (string-contains uri needle)))
+    (if index
+        (strip (substring uri (+ index (string-length needle))))
+        uri)))
+
+(define (format-comment object)
+  (let* ((author (assoc-ref object "author"))
+         (author-name (assoc-ref author "name"))
+         (author-photo (assoc-ref author "photo"))
+         (author-url (assoc-ref author "url"))
+         (content (assoc-ref object "content"))
+         (content-text (assoc-ref content "text"))
+         (published-time (assoc-ref object "published"))
+         (received-time (assoc-ref object "wm-received"))
+         (url (assoc-ref object "url")))
+    `(li (@ (class "p-comment h-cite comment comment-source-webmention"))
+         (img (@ (class "comment-source-identifier")
+                 (alt "Webmention logo")
+                 (src "/static/image/webmention-logo.png")))
+         (div (@ (class "p-author h-card author"))
+              (img (@ (class "u-photo")
+                      (src ,(if (string-prefix? author-url "https://lobste.rs/")
+                                "/static/image/lobsters.png"
+                                (or author-photo "/static/image/default-icon.png")))))
+              (a (@ (class "p-name u-url")
+                    (href ,author-url))
+                 ,author-name)
+              (a (@ (class "author-url")
+                    (href ,author-url))
+                 ,(strip author-url)))
+         (div (@ (class "e-content p-name comment-content"))
+              ,content-text)
+         (div (@ (class "metaline"))
+              (a (@ (class "u-url")
+                    (href ,url))
+                 (time (@ (class "dt-published")
+                          (datetime ,(or published-time received-time)))
+                       ,(date->string
+                         (string->date (if (eqv? 'null published-time)
+                                           (if (eqv? 'null received-time)
+                                               (current-time)
+                                               received-time)
+                                           published-time)
+                                       "~Y~m~d~H~M~S")
+                         "~B ~e, ~Y at ~H:~M")))))))
+
+(define (format-interaction object)
+  (let* ((author (assoc-ref object "author"))
+         (author-name (assoc-ref author "name"))
+         (author-photo (assoc-ref author "photo"))
+         (author-url (assoc-ref author "url")))
+    `(li (@ (class "p-comment h-cite interaction comment-source-webmention"))
+         (a (@ (href ,author-url))
+            (img (@ (class "u-photo")
+                    (src ,(if (string-prefix? author-url "https://lobste.rs/")
+                              "/static/image/lobsters.png"
+                              (or author-photo "/static/image/default-icon.png"))))))
+         (div (@ (class "e-content p-name comment-content"))
+              (em
+               ,(match (assoc-ref object "wm-property")
+                  ("repost-of" "Reposted this!")
+                  ("like-of" "Favorited this!")
+                  (_ "[No Text Provided!]"))))
+         (img (@ (class "comment-source-identifier")
+                 (alt "Webmention logo")
+                 (src "/static/image/webmention-logo.png"))))))
+
+(define (render-comment-view response)
+  (vector->list
+   (vector-map (lambda (_ x)
+                 (if (and (assoc-ref x "wm-property")
+                          (or (string= (assoc-ref x "wm-property") "in-reply-to")
+                              (string= (assoc-ref x "wm-property") "mention-of")))
+                     (format-comment x)
+                     (format-interaction x)))
+               (assoc-ref response "children"))))
+
+(define (fetch-webmentions slug)
+  (define prefixes '("http://jakob.space/" "https://jakob.space/"
+                     "http://jakob.space/blog/" "https://jakob.space/blog/"))
+  (let ((url (format #f "https://webmention.io/api/mentions.jf2?per-page=200&page=0&~a"
+                     (string-join
+                      (map (lambda (pre)
+                             (format #f "target[]=~a~a.html" pre slug))
+                           prefixes)
+                      "&"))))
+    (receive (response-status response-body)
+        (http-request url)
+      (call-with-input-string (bytevector->string response-body "UTF-8") json->scm))))