diff options
Diffstat (limited to 'jakob/utils/comments.scm')
| -rw-r--r-- | jakob/utils/comments.scm | 263 |
1 files changed, 263 insertions, 0 deletions
diff --git a/jakob/utils/comments.scm b/jakob/utils/comments.scm new file mode 100644 index 0000000..4ec3718 --- /dev/null +++ b/jakob/utils/comments.scm @@ -0,0 +1,263 @@ +;;; Copyright © 2019 - 2023 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 (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 <webmention> + (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))))) |