diff options
| -rw-r--r-- | haunt/jakob/utils/webmention.scm | 60 |
1 files changed, 29 insertions, 31 deletions
diff --git a/haunt/jakob/utils/webmention.scm b/haunt/jakob/utils/webmention.scm index 9f1d289..f30bb12 100644 --- a/haunt/jakob/utils/webmention.scm +++ b/haunt/jakob/utils/webmention.scm @@ -27,23 +27,25 @@ #:export (render-comment-view fetch-webmentions)) -(define (strip uri) - (let* ((needle "://") - (index (string-contains uri needle))) - (if index - (strip (substring uri (+ index (string-length needle)))) - uri))) - -(define (format-comment object) - (let* ((author (assoc-ref object "author")) +(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-photo (assoc-ref author "photo")) (author-url (assoc-ref author "url")) - (content (assoc-ref object "content")) + (content (assoc-ref webmention "content")) (content-text (assoc-ref content "text")) - (published-time (assoc-ref object "published")) - (received-time (assoc-ref object "wm-received")) - (url (assoc-ref object "url"))) + (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") @@ -65,18 +67,14 @@ (a (@ (class "u-url") (href ,url)) (time (@ (class "dt-published") - (datetime ,(or published-time received-time))) + (datetime ,time)) ,(date->string - (string->date (if (eqv? 'null published-time) - (if (eqv? 'null received-time) - (current-time) - received-time) - published-time) - "~Y~m~d~H~M~S") + (string->date time "~Y~m~d~H~M~S") "~B ~e, ~Y at ~H:~M"))))))) -(define (format-interaction object) - (let* ((author (assoc-ref object "author")) +(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-photo (assoc-ref author "photo")) (author-url (assoc-ref author "url"))) @@ -88,33 +86,33 @@ (or author-photo "/static/image/default-icon.png")))))) (div (@ (class "e-content p-name comment-content")) (em - ,(match (assoc-ref object "wm-property") + ,(match (assoc-ref webmention "wm-property") ("repost-of" "Reposted this!") ("like-of" "Favorited this!") - (_ "[No Text Provided!]")))) + (_ "[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 "wm-property") - (or (string= (assoc-ref x "wm-property") "in-reply-to") - (string= (assoc-ref x "wm-property") "mention-of"))) + (member (assoc-ref x "wm-property") '("in-reply-to" "mention-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 ((url (format #f "https://webmention.io/api/mentions.jf2?per-page=200&page=0&~a" - (string-join - (map (lambda (pre) + (let* ((target-queries (map (lambda (pre) (format #f "target[]=~a~a.html" pre slug)) - prefixes) - "&")))) + prefixes)) + (url (format #f "https://webmention.io/api/mentions.jf2?per-page=200&page=0&~a" + (string-join targets-queries "&")))) (receive (response-status response-body) (http-request url) (call-with-input-string (bytevector->string response-body "UTF-8") json->scm)))) |