;;; Copyright © 2019 - 2023 Jakob L. Kreuze ;;; ;;; 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 ;;; . (define-module (jakob utils comments) #:use-module (commonmark) #:use-module (gcrypt base16) #:use-module (gcrypt hash) #:use-module (ice-9 iconv) #:use-module (ice-9 match) #:use-module (ice-9 receive) #:use-module (jakob dynamic capabilities common) #:use-module (jakob dynamic util) #:use-module (jakob utils) #:use-module (json) #:use-module (oop goops) #:use-module (srfi srfi-9) #:use-module (srfi srfi-19) #:use-module (srfi srfi-43) #:use-module (srfi-197) #:use-module (web client) #:use-module (web response) #:export (render-comment-view fetch-comments fetch-webmentions)) (define (gravatar-url email) "Return the gravatar.com URL for user identified by EMAIL" (chain email (string-downcase _) (string-trim-both _) (string->bytevector _ "utf8") (bytevector-hash _ (lookup-hash-algorithm 'md5)) (bytevector->base16-string _) (format #f "https://www.gravatar.com/avatar/~a" _))) (define (safe-markdown->sxml text) "Convert TEXT to an sxml form filtering out any unsafe entities" (define (sanitize sexp) (cond ((and (list? sexp) (positive? (length sexp)) (eqv? 'img (car sexp))) #f) ((list? sexp) (filter identity (map sanitize sexp))) (else sexp))) (sanitize (commonmark->sxml text))) (define-record-type (make-webmention name photo comment url publish-time) webmention? (name webmention-name) (photo webmention-photo) (comment webmention-comment) (url webmention-url) (publish-time webmention-publish-time)) (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))) (define (comment-photo comment) (cond ((and (webmention? comment) (webmention-photo comment)) (webmention-photo comment)) ((and (internal-comment? comment) (internal-comment-email comment)) (gravatar-url (internal-comment-email comment))) (else "/static/image/default-icon.png"))) (define (comment-name comment) ((if (webmention? comment) webmention-name internal-comment-name) comment)) (define (comment-content comment) (if (webmention? comment) `((p ,(webmention-comment comment))) (safe-markdown->sxml (internal-comment-comment comment)))) (define (comment-url comment) (define text ((if (webmention? comment) webmention-url internal-comment-url) comment)) (elide-string text 32)) (define (comment-publish-time comment) ((if (webmention? comment) webmention-publish-time internal-comment-publish-time) comment)) (define (comment-reactions comment) (if (webmention? comment) '() (internal-comment-reactions comment))) `(li (@ (class "p-comment h-cite comment comment-source-internal")) ,(if (webmention? comment) `(img (@ (class "comment-source-identifier") (alt "Icon for comments posted externally and syndicated by Webmention") (src "/static/image/webmention-logo.png"))) (match (internal-comment-originating-network comment) ("tor" `(img (@ (class "comment-source-identifier") (alt "Icon for comments posted on jakob.space via Tor; The Tor logo belongs to The Tor Project, Inc. and is licensed under the CC BY 3.0 US") (src "/static/image/tor.svg")))) ("i2p" `(img (@ (class "comment-source-identifier") (alt "Icon for comments posted on jakob.space via I2P; The I2P logo belongs to The I2P Project, and is licensed under the CC BY 4.0") (src "/static/image/i2p.svg")))) (_ `(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 ,(comment-photo comment))))) (div (@ (class "metaline")) (span (@ (class author-name)) ,(comment-name comment)) ,@(if (and (comment-url comment) (not (string= "" (comment-url comment)))) `(" • " (a (@ (class "author-url") (href ,(comment-url comment))) "(" ,(strip (comment-url comment)) ")")) `()) " • " (time (@ (class "dt-published") (datetime ,(comment-publish-time comment))) ,(date->string (comment-publish-time comment) "~B ~e, ~Y at ~H:~M"))) (div (@ (class "e-content p-name comment-content")) ,@(comment-content comment)) (ul (@ (class "comment-reactions")) ,@(map (match-lambda ((emote . count) `(li ,(format #f "~a (~a)" emote count)))) (comment-reactions comment))) ,(when (internal-comment? comment) `(p (a (@ (class "comment-reply-button") (href "#webmention-form") (data-reply-to-id ,(internal-comment-id comment))) "reply"))) ,(when (and (internal-comment? comment) (positive? (length (internal-comment-replies comment)))) `(ul (@ (class "webmention-container")) ,@(map format-comment (internal-comment-replies comment)))))) (define (wm-not-null? value) (and value (not (eqv? 'null value)) (not (string= "" value)))) (define (format-interaction webmention) "Format `webmention', an alist, as SXML for a rich interaction without content" (let* ((author (assoc-ref webmention "author")) (author-name (assoc-ref author "name")) (author-url (assoc-ref author "url")) (author-url (if (wm-not-null? author-url) author-url (assoc-ref webmention "wm-source"))) (author-photo (assoc-ref author "photo")) (author-photo (cond ((string-prefix? "https://lobste.rs/" author-url) "/static/image/lobsters.png") ((wm-not-null? author-photo) author-photo) (else "/static/image/default-icon.png")))) `(li (@ (class "p-comment h-cite interaction comment-source-webmention")) (a (@ (href ,author-url)) (img (@ (class "u-photo") (src ,author-photo)))) (div (@ (class "e-content p-name comment-content")) (em ,(match (assoc-ref webmention "wm-property") ("repost-of" "Reposted this!") ("like-of" "Favorited this!") ("bookmark-of" "Bookmarked this!") ("mention-of" "Mentioned this!") (_ "[No Text Provided]")))) (img (@ (class "comment-source-identifier") (alt "Webmention logo") (src "/static/image/webmention-logo.png")))))) (define (alist->webmention alist) (let* ((author (assoc-ref alist "author")) (author-name (assoc-ref author "name")) (author-url (assoc-ref author "url")) (author-url (if (wm-not-null? author-url) author-url (assoc-ref alist "wm-source"))) (author-photo (assoc-ref author "photo")) (author-photo (cond ((string-prefix? "https://lobste.rs/" author-url) "/static/image/lobsters.png") ((wm-not-null? author-photo) author-photo) (else "/static/image/default-icon.png"))) (content (assoc-ref alist "content")) (content (if content (assoc-ref content "text") #f)) (published-time (assoc-ref alist "published")) (received-time (assoc-ref alist "wm-received")) (url (assoc-ref alist "url")) (time (if (eqv? 'null published-time) received-time published-time)) (time (string->date time "~Y~m~dT~H~M~S"))) (make-webmention author-name author-photo content author-url time))) (define (render-comment-view comments-response webmentions-response) "Render `response', the output of `fetch-webmentions', as SXML" (define (publish-time x) ((if (webmention? x) webmention-publish-time internal-comment-publish-time) x)) (define (date>? a b) (time>? (date->time-utc a) (date->time-utc b))) (let ((webmentions (map alist->webmention (filter (lambda (x) (string= (assoc-ref x "wm-property") "in-reply-to")) (vector->list (assoc-ref webmentions-response "children")))))) (map format-comment (sort (append comments-response webmentions) (lambda (a b) (date>? (publish-time a) (publish-time b))))))) (define (fetch-comments slug) "Blocking call to webmention.io to retrieve a vector of all Webmentions for `slug'" (if (getenv "HAUNT_SKIP_COMMENTS") '() (let ((url (format #f "https://jakob.space/api/comments?p=~a" slug))) (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/" "http://jakob.space/blog/" "https://jakob.space/blog/")) (if (getenv "HAUNT_SKIP_COMMENTS") `(("children" . #())) (let* ((target-queries (map (lambda (pre) (format #f "target[]=~a~a.html" pre slug)) prefixes)) (url (format #f "https://webmention.io/api/mentions.jf2?per-page=200&page=0&~a" (string-join target-queries "&")))) (receive (response-status response-body) (http-request url) (call-with-input-string (bytevector->string response-body "UTF-8") json->scm)))))