The `org' directory is no longer necessary

4 files changed, 525 insertions, 0 deletions

diff --git a/jakob/utils/comments.scm b/jakob/utils/comments.scm
new file mode 100644
index 0000000..4ec3718
--- /dev/null
+++ b/jakob/utils/comments.scm
@@ -0,0 +1,263 @@
+;;; Copyright © 2019 - 2023 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 (commonmark)
+  #:use-module (gcrypt base16)
+  #:use-module (gcrypt hash)
+  #:use-module (ice-9 iconv)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 receive)
+  #:use-module (jakob dynamic capabilities common)
+  #:use-module (jakob dynamic util)
+  #:use-module (jakob utils)
+  #: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)
+  #:use-module (web client)
+  #:use-module (web response)
+  #: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 _)
+         (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-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"
+  (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)))
+  (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)
+        `((p ,(webmention-comment comment)))
+        (safe-markdown->sxml
+         (internal-comment-comment comment))))
+  (define (comment-url comment)
+    (define text
+      ((if (webmention? comment)
+           webmention-url
+           internal-comment-url)
+       comment))
+    (elide-string text 32))
+  (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")))
+            (match (internal-comment-originating-network comment)
+              ("tor" `(img (@ (class "comment-source-identifier")
+                              (alt "Icon for comments posted on jakob.space via Tor;
+The Tor logo belongs to The Tor Project, Inc. and is licensed under the CC BY 3.0 US")
+                              (src "/static/image/tor.svg"))))
+              ("i2p" `(img (@ (class "comment-source-identifier")
+                              (alt "Icon for comments posted on jakob.space via I2P;
+The I2P logo belongs to The I2P Project, and is licensed under the CC BY 4.0")
+                              (src "/static/image/i2p.svg"))))
+              (_     `(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 (and (comment-url comment)
+                       (not (string= "" (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"))
+            ,@(comment-content comment))
+       (ul (@ (class "comment-reactions"))
+           ,@(map (match-lambda
+                    ((emote . count)
+                     `(li ,(format #f "~a (~a)" emote count))))
+                  (comment-reactions comment)))
+       ,(when (internal-comment? comment)
+          `(p (a (@ (class "comment-reply-button")
+                    (href "#webmention-form")
+                    (data-reply-to-id ,(internal-comment-id comment)))
+                 "reply")))
+       ,(when (and (internal-comment? comment)
+                   (positive? (length (internal-comment-replies comment))))
+          `(ul (@ (class "webmention-container"))
+               ,@(map format-comment (internal-comment-replies 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"
+  (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 (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"
+  (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'"
+  (if (getenv "HAUNT_SKIP_COMMENTS")
+      '()
+      (let ((url (format #f "https://jakob.space/api/comments?p=~a" slug)))
+        (receive (response-status response-body)
+            (http-request url)
+          (chain response-body
+                 (bytevector->string _ "UTF-8")
+                 (json-string->scm _)
+                 (vector->list _)
+                 (map scm->json-string _)
+                 (map (lambda (x) (call-with-input-string x json->internal-comment)) _))))))
+
+(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/"))
+  (if (getenv "HAUNT_SKIP_COMMENTS")
+      `(("children" . #()))
+      (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/jakob/utils/pagination.scm b/jakob/utils/pagination.scm
new file mode 100644
index 0000000..f75f02f
--- /dev/null
+++ b/jakob/utils/pagination.scm
@@ -0,0 +1,114 @@
+;;; Copyright © 2019 - 2020 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/>.
+
+;;; Commentary:
+;;;
+;;; Common procedures for splitting up large numbers of items across pages.
+;;;
+;;; Code:
+
+(define-module (jakob utils pagination)
+  #:use-module (haunt artifact)
+  #:use-module (haunt html)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (jakob theme)
+  #:use-module (jakob utils)
+  #:use-module (jakob utils sxml)
+  #:export (paginate
+            
+            render-listing
+            items->pages))
+
+(define %items-per-page 10)
+
+
+;;;
+;;; Partitioning.
+;;;
+
+(define* (paginate items #:key (items-per-page %items-per-page))
+  "Partition ITEMS into list of no more than ITEMS-PER-PAGE items, returning
+lists of the form (index, items)."
+  (let loop ((index 1)
+             (lst items)
+             (result '()))
+    (if (null? lst)
+        result
+        (let ((how-many (min %items-per-page (length lst))))
+          (loop (1+ index)
+                (drop lst how-many)
+                (cons (list index (take lst how-many))
+                      result))))))
+
+
+;;;
+;;; Rendering.
+;;;
+
+(define* (render-listing content title previous-page next-page
+                         #:key enable-search)
+  "Return an SHTML document showing CONTENT, with the header TITLE and links to
+PREVIOUS-PAGE and NEXT-PAGE."
+  #<((h1 ,title)
+     ,@(if enable-search
+           '((div (@ (id "search"))))
+           '())
+     ,@content
+     (nav
+      (@ (id "pagination"))
+      ,(when previous-page
+         (hyperlink previous-page "← Previous Page"))
+      ,(when next-page
+         (hyperlink next-page "Next Page →")))
+     ,@(if enable-search
+           `((link (@ (rel "stylesheet")
+                      (href "/_pagefind/pagefind-ui.css")))
+             (script (@ (src "/_pagefind/pagefind-ui.js")))
+             (script "window.addEventListener('DOMContentLoaded', function (event) { return new PagefindUI({ element: '#search' }); })"))
+           '())))
+
+(define* (items->pages render-item items base-title base-file-name
+                       #:key enable-search (items-per-page %items-per-page))
+  "Return a list of Haunt pages for ITEMS with no more than ITEMS-PER-PAGE items
+to a page, with headers containing BASE-TITLE and output file names beginning
+with BASE-FILE-NAME. RENDER-ITEM is a procedure returning a SXML rendering of
+the item from ITEMS passed as a parameter."
+  (define (index->file-name index)
+    (if (= index 1)
+        (format #f "~a.html" base-file-name)
+        (format #f "~a-~a.html" base-file-name index)))
+  (map (match-lambda
+         ((index subset)
+          (let ((title (if (= index 1)
+                           base-title
+                           (format #f "~a — Page ~a" base-title index)))
+                (previous-page (if (>= (1- index) 1)
+                                   (index->file-name (1- index))
+                                   #f))
+                (next-page (if (<= (1+ index) (ceiling/ (length items)
+                                                        %items-per-page))
+                               (index->file-name (1+ index))
+                               #f))
+                (enable-search (and enable-search (= index 1))))
+            (serialized-artifact (index->file-name index)
+                                 (theme #:title title
+                                        #:content
+                                        (render-listing (map render-item subset) title
+                                                        previous-page next-page
+                                                        #:enable-search enable-search))
+                                 sxml->html))))
+       (paginate items)))
diff --git a/jakob/utils/sxml.scm b/jakob/utils/sxml.scm
new file mode 100644
index 0000000..0fc34d2
--- /dev/null
+++ b/jakob/utils/sxml.scm
@@ -0,0 +1,91 @@
+;;; Copyright © 2019 - 2020 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 sxml)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:export (hyperlink
+            image
+            stylesheet
+            script
+
+            sanitize-subtree
+            rewrite-absolute-urls-as-relative))
+
+
+;;;
+;;; Utility procedures to aid in writing SXML by hand.
+;;;
+
+(define (hyperlink target text)
+  `(a (@ (href ,target)) ,text))
+
+(define* (image file-name #:optional description)
+  (let ((src (string-append "/static/image/" file-name)))
+    (if description
+        `(img (@ (src ,src) (alt ,description) (title ,description)))
+        `(img (@ (src ,src))))))
+
+(define (stylesheet file-name)
+  `(link (@ (rel "stylesheet") (href ,(format #f "/static/css/~a" file-name)))))
+
+(define (script file-name)
+  (let ((src (string-append "/static/js/" file-name)))
+    `(script (@ (src ,src)))))
+
+
+;;;
+;;; A reader extension for implicitly-sanitized SXML trees.
+;;;
+
+(define (sanitize-subtree subtree)
+  "Remove `nil', `#f', and any unspecified elements from `sbtree'"
+  (if (list? subtree)
+      (map sanitize-subtree (remove (lambda (elt)
+                                      (or (unspecified? elt)
+                                          (eq? 'nil elt)
+                                          (eq? #f elt)))
+                                    subtree))
+      subtree))
+
+(define (sxml-reader chr port)
+  "Read an SXML literal expression possibly containing unquote forms and
+sanitize the resultant subtree."
+  `(sanitize-subtree ,(cons 'quasiquote (list (read port)))))
+
+;; Install the reader extension when imported.
+(read-hash-extend #\< sxml-reader)
+
+(define (rewrite-absolute-urls-as-relative tree)
+  (match tree
+    (('a attrs body ...)
+     (if (assoc 'href (cdr attrs))
+         (let* ((url (car (assoc-ref (cdr attrs) 'href)))
+                (url (if (string-prefix? "https://jakob.space" url)
+                         (string-drop url (string-length "https://jakob.space"))
+                         url))
+                (url (if (string-prefix? "http://jakob.space" url)
+                         (string-drop url (string-length "http://jakob.space"))
+                         url))
+                (attrs `(@ (href ,url) ,@(filter (match-lambda
+                                                   (('href _) #f)
+                                                   (_         #t))
+                                                 (cdr attrs)))))
+           `(a ,attrs ,@body))
+         tree))
+    ((xs ...)
+     (map rewrite-absolute-urls-as-relative xs))
+    (elem elem)))
diff --git a/jakob/utils/tags.scm b/jakob/utils/tags.scm
new file mode 100644
index 0000000..656f712
--- /dev/null
+++ b/jakob/utils/tags.scm
@@ -0,0 +1,57 @@
+;;; Copyright © 2019 - 2020 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/>.
+
+;;; Commentary:
+;;;
+;;; Common procedures for tag-based navigation.
+;;;
+;;; Code:
+
+(define-module (jakob utils tags)
+  #:use-module (srfi srfi-1)
+  #:export (group-by-tag
+            count-tags
+            tag-uri))
+
+(define (group-by-tag items accessor)
+  "Return lists of the form (tag items) for each tag used in ITEMS. ACCESSOR is
+a procedure that takes a single item as an argument and returns its tags."
+  (let ((table (make-hash-table)))
+    (for-each (lambda (item)
+                (let ((tags (accessor item)))
+                  (for-each (lambda (tag)
+                              (let ((current (hash-ref table tag)))
+                                (if current
+                                    (hash-set! table tag (cons item current))
+                                    (hash-set! table tag (list item)))))
+                            tags)))
+              items)
+    (hash-fold alist-cons '() table)))
+
+(define (count-tags items accessor)
+  "Return lists of the form (tag-name count) summarizing tag usage across ENTRIES,
+ordered such that tags with greater usage are at the beginning of the list, and
+tags with less usage are at the end of the list. ACCESSOR is a procedure that
+takes a single item as an argument and returns its tags."
+  (sort (map (lambda (tag)
+               (list (car tag) (length (cdr tag))))
+             (group-by-tag items accessor))
+        (lambda (a b) (> (cadr a) (cadr b)))))
+
+(define* (tag-uri prefix tag #:optional (extension ".html"))
+  "Return a URI relative to the site's root for a page listing entries in PREFIX
+that are tagged with TAG."
+  (string-append prefix "/" tag extension))