diff options
Diffstat (limited to 'haunt/jakob/utils/comments.scm')
| -rw-r--r-- | haunt/jakob/utils/comments.scm | 124 |
1 files changed, 107 insertions, 17 deletions
diff --git a/haunt/jakob/utils/comments.scm b/haunt/jakob/utils/comments.scm index 45c97c5..2375531 100644 --- a/haunt/jakob/utils/comments.scm +++ b/haunt/jakob/utils/comments.scm @@ -18,18 +18,19 @@ #:use-module (commonmark) #:use-module (gcrypt base16) #:use-module (gcrypt hash) - #: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 (srfi-197) + #:use-module (ice-9 receive) #:use-module (jakob dynamic capabilities comments) #:use-module (jakob dynamic util) #:use-module (json) + #:use-module (oop goops) + #: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)) + #:export (render-comment-view fetch-comments fetch-webmentions)) (define (gravatar-url email) (chain email @@ -52,6 +53,40 @@ (else sexp))) (sanitize (commonmark->sxml text))) +(define (webmention->comment webmention) + (define (wm-not-null? value) + (and value + (not (eqv? 'null value)) + (not (string= "" value)))) + (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"))) + (content (assoc-ref webmention "content")) + (published-time (assoc-ref webmention "published")) + (received-time (assoc-ref webmention "wm-received")) + (url (assoc-ref webmention "url")) + (time (if (eqv? 'null published-time) received-time published-time)) + ;; TODO: We shouldn't have to normalize; we should just parse this into + ;; a SRFI-19 date when we're creating the alist. (Or, even better, use + ;; records instead of alists so we can avoid the `webmention' tag.) + (time (date->string (string->date time "~Y~m~dT~H~M~S") "~Y-~m-~d ~H:~M:~S.~N"))) + `((webmention . #t) + (name . ,author-name) + (photo . ,author-photo) + (comment . ,(if content (assoc-ref content "text") #f)) + (url . ,author-url) + (publish-time . ,time) + (reactions . ())))) + (define (format-comment comment) "Format `comment', an alist, as SXML for a comment-type interaction" (define (strip uri) @@ -63,41 +98,96 @@ uri))) (let* ((author-name (assoc-ref comment 'name)) (author-url (assoc-ref comment 'url)) - (author-photo (gravatar-url (assoc-ref comment 'email))) + (author-photo (cond ((assoc 'email comment) (gravatar-url (assoc-ref comment 'email))) + ((assoc 'photo comment) (assoc-ref comment 'photo)) + (else "/static/image/default-icon.png"))) (publish-datetime (assoc-ref comment 'publish-time)) (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") + ,(if (assoc 'webmention comment) + `(img (@ (class "comment-source-identifier") + (alt "Icon for comments posted externally and syndicated by Webmention") + (src "/static/image/webmention-logo.png"))) + `(img (@ (class "comment-source-identifier") (alt "Icon for comments posted on jakob.space") - (src "/static/image/lambda.svg"))) + (src "/static/image/lambda.svg")))) (div (@ (class "p-author h-card author")) - (img (@ (class "u-photo") (src ,author-photo))) + (img (@ (class "u-photo") (src ,author-photo)))) + (div (@ (class "metaline")) (span (@ (class author-name)) ,author-name) ,@(if author-url - `((a (@ (class "author-url") + `(" • " + (a (@ (class "author-url") (href ,author-url)) "(" ,(strip author-url) ")")) - `())) - (div (@ (class "e-content p-name comment-content")) - ,@(chain content-text - (safe-markdown->sxml _))) - (div (@ (class "metaline")) + `()) + " • " (time (@ (class "dt-published") (datetime ,publish-datetime)) ,(date->string (string->date publish-datetime "~Y~m~d ~H~M~S.~N") "~B ~e, ~Y at ~H:~M"))) + (div (@ (class "e-content p-name comment-content")) + ,@(chain content-text + (safe-markdown->sxml _))) (ul (@ (class "comment-reactions")) ,@(map (match-lambda ((emote . count) `(li ,(format #f "~a (~a)" emote count)))) content-reactions))))) -(define (render-comment-view response) +(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 (render-comment-view comments-response webmentions-response) "Render `response', the output of `fetch-webmentions', as SXML" - (map format-comment response)) + (let ((webmention-comments (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 (map webmention->comment webmention-comments)) + (lambda (a b) (time>? (date->time-utc (string->date (assoc-ref a 'publish-time) "~Y~m~d ~H~M~S.~N")) + (date->time-utc (string->date (assoc-ref b 'publish-time) "~Y~m~d ~H~M~S.~N")))))))) (define (fetch-comments slug) "Blocking call to webmention.io to retrieve a vector of all Webmentions for `slug'" (get-comments-by-slug slug)) + +(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/")) + (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)))) |