[dynamic] Initital static builder for comments

1 files changed, 98 insertions, 0 deletions

diff --git a/haunt/jakob/utils/comments.scm b/haunt/jakob/utils/comments.scm
new file mode 100644
index 0000000..a1deea7
--- /dev/null
+++ b/haunt/jakob/utils/comments.scm
@@ -0,0 +1,98 @@
+;;; 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 comments)
+  ;; #:use-module (dynamic capabilities comments)
+  #:use-module (dynamic util)
+  #:use-module (hashing md5)
+  #: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)
+  #:export (render-comment-view fetch-comments))
+
+(define (gravatar-url email)
+  (format #f "https://www.gravatar.com/avatar/~a" (md5->string (md5 (string->bytevector (string-trim-both (string-downcase email)) "utf8")))))
+;; (chain email
+;;        (string-downcase _)
+;;        (string-trim-both _)
+;;        (string->bytevector _ "utf8")
+;;        (md5 _))
+
+(define (format-comment comment)
+  "Format `comment', an alist, as SXML for a comment-type interaction"
+  (define (strip uri)
+    "Attempt to remove any sort of protocol specification from `uri'"
+    (let* ((needle "://")
+           (index (string-contains uri needle)))
+      (if index
+          (strip (substring uri (+ index (string-length needle))))
+          uri)))
+  (let* ((author-name (assoc-ref comment 'name))
+         (author-url (assoc-ref comment 'url))
+         (author-photo (gravatar-url (assoc-ref comment 'email)))
+         (publish-datetime (assoc-ref comment 'published))
+         (content-text (assoc-ref comment 'comment))
+         (content-reactions (assoc-ref comment 'reactions)))
+    `(li (@ (class "p-comment h-cite comment comment-source-internal"))
+         (img (@ (class "comment-source-identifier")
+                 (alt "Icon for comments posted on jakob.space")
+                 (src "/static/image/lambda.svg")))
+         (div (@ (class "p-author h-card author"))
+              (img (@ (class "u-photo") (src ,author-photo)))
+              (span (@ (class author-name)) ,author-name)
+              ,@(if author-url
+                    `((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 ,author-url))
+                 (time (@ (class "dt-published")
+                          (datetime ,publish-datetime))
+                       ,(date->string
+                         (string->date publish-datetime "~Y~m~d~H~M~S")
+                         "~B ~e, ~Y at ~H:~M"))))
+         (ul (@ (class "comment-reactions"))
+             ,@(map (match-lambda
+                      ((emote . count)
+                       `(li ,(format "~a (~a)" emote count))))
+                    content-reactions)))))
+
+(define (render-comment-view response)
+  "Render `response', the output of `fetch-webmentions', as SXML"
+  (map format-comment response))
+
+(define (fetch-comments slug)
+  "Blocking call to webmention.io to retrieve a vector of all Webmentions for `slug'"
+  (get-comments-by-slug slug)
+  ;; (list '((id . 1)
+  ;;         (published . "20220514122120")
+  ;;         (name . "Jakob")
+  ;;         (subject . "Test")
+  ;;         (email . "jakob@memeware.net")
+  ;;         (comment . "Test")
+  ;;         (url . "jakob.space")
+  ;;         (reactions . (("🎖️" . 2)))))
+  )
+;; dynamic