diff options
Diffstat (limited to 'haunt/jakob')
| -rw-r--r-- | haunt/jakob/builder/blog.scm | 4 | ||||
| -rw-r--r-- | haunt/jakob/utils/comments.scm | 124 | ||||
| -rw-r--r-- | haunt/jakob/utils/webmention.scm | 135 |
3 files changed, 108 insertions, 155 deletions
diff --git a/haunt/jakob/builder/blog.scm b/haunt/jakob/builder/blog.scm index cef3b69..f0f5561 100644 --- a/haunt/jakob/builder/blog.scm +++ b/haunt/jakob/builder/blog.scm @@ -75,9 +75,7 @@ (@ (id "webmention")) (h2 "Comments for this page") (ul (@ (id "webmention-container")) - ;; ,@(render-comment-view (fetch-webmentions (post-identifier post)))) - ,@(render-comment-view (fetch-comments (post-identifier post)))) - + ,@(render-comment-view (fetch-comments (post-identifier post)) (fetch-webmentions (post-identifier post)))) (div (@ (id "comment-form-primary") (hidden #t)) ,(render-dynamic-comment-form (post-identifier post))) (p (@ (id "comment-form-alt")) 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)))) diff --git a/haunt/jakob/utils/webmention.scm b/haunt/jakob/utils/webmention.scm deleted file mode 100644 index 713ce39..0000000 --- a/haunt/jakob/utils/webmention.scm +++ /dev/null @@ -1,135 +0,0 @@ -;;; 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 webmention) - #: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) - #:use-module (oop goops) - #:export (render-comment-view - fetch-webmentions)) - -(define (wm-not-null? value) - (and value - (not (eqv? 'null value)) - (not (string= "" value)))) - -(define (format-comment webmention) - "Format `webmention', 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 (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")) - (content-text (assoc-ref content "text")) - (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))) - `(li (@ (class "p-comment h-cite comment comment-source-webmention")) - (img (@ (class "comment-source-identifier") - (alt "Webmention logo") - (src "/static/image/webmention-logo.png"))) - (div (@ (class "p-author h-card author")) - (img (@ (class "u-photo") (src ,author-photo))) - (a (@ (class "p-name u-url") - (href ,author-url)) - ,author-name) - (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 ,url)) - (time (@ (class "dt-published") - (datetime ,time)) - ,(date->string - (string->date time "~Y~m~d~H~M~S") - "~B ~e, ~Y at ~H:~M"))))))) - -(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 response) - "Render `response', the output of `fetch-webmentions', as SXML" - (vector->list - (vector-map (lambda (_ x) - (if (and (assoc-ref x "content") - (not (string= (assoc-ref x "wm-property") "repost-of"))) - (format-comment x) - (format-interaction x))) - (assoc-ref response "children")))) - -(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)))) |