diff options
Diffstat (limited to 'haunt/jakob/utils/comments.scm')
| -rw-r--r-- | haunt/jakob/utils/comments.scm | 196 |
1 files changed, 117 insertions, 79 deletions
diff --git a/haunt/jakob/utils/comments.scm b/haunt/jakob/utils/comments.scm index 2375531..8645fb7 100644 --- a/haunt/jakob/utils/comments.scm +++ b/haunt/jakob/utils/comments.scm @@ -25,6 +25,7 @@ #:use-module (jakob dynamic util) #: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) @@ -33,6 +34,7 @@ #: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 _) @@ -53,39 +55,14 @@ (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-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" @@ -96,46 +73,74 @@ (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 (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")) - ,(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")))) - (div (@ (class "p-author h-card author")) - (img (@ (class "u-photo") (src ,author-photo)))) - (div (@ (class "metaline")) - (span (@ (class author-name)) ,author-name) - ,@(if author-url - `(" • " - (a (@ (class "author-url") - (href ,author-url)) - "(" ,(strip author-url) ")")) - `()) - " • " - (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 (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) + webmention-comment + internal-comment-comment) + comment)) + (define (comment-url comment) + ((if (webmention? comment) + webmention-url + internal-comment-url) + comment)) + (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"))) + `(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 (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")) + ,@(chain comment + (comment-content _) + (safe-markdown->sxml _))) + (ul (@ (class "comment-reactions")) + ,@(map (match-lambda + ((emote . count) + `(li ,(format #f "~a (~a)" emote count)))) + (comment-reactions 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" @@ -166,14 +171,47 @@ (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" - (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 (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'" |