1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
|
;;; 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 comments)
;; #:use-module (dynamic capabilities comments)
#:use-module (dynamic util)
#: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 (json)
#:use-module (web client)
#:use-module (web response)
#:export (render-comment-view fetch-comments))
(define (gravatar-url 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 (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)))
(let* ((author-name (assoc-ref comment 'name))
(author-url (assoc-ref comment 'url))
(author-photo (gravatar-url (assoc-ref comment 'email)))
(publish-datetime (assoc-ref comment 'published))
(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")
(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)))
(span (@ (class author-name)) ,author-name)
,@(if author-url
`((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 ,author-url))
(time (@ (class "dt-published")
(datetime ,publish-datetime))
,(date->string
(string->date publish-datetime "~Y~m~d~H~M~S")
"~B ~e, ~Y at ~H:~M"))))
(ul (@ (class "comment-reactions"))
,@(map (match-lambda
((emote . count)
`(li ,(format "~a (~a)" emote count))))
content-reactions)))))
(define (render-comment-view response)
"Render `response', the output of `fetch-webmentions', as SXML"
(map format-comment response))
(define (fetch-comments slug)
"Blocking call to webmention.io to retrieve a vector of all Webmentions for `slug'"
(get-comments-by-slug slug)
;; (list '((id . 1)
;; (published . "20220514122120")
;; (name . "Jakob")
;; (subject . "Test")
;; (email . "jakob@memeware.net")
;; (comment . "Test")
;; (url . "jakob.space")
;; (reactions . (("🎖️" . 2)))))
)
;; dynamic
|
