diff options
Diffstat (limited to 'jakob')
34 files changed, 3890 insertions, 0 deletions
diff --git a/jakob/builder/atom.scm b/jakob/builder/atom.scm new file mode 100644 index 0000000..f145443 --- /dev/null +++ b/jakob/builder/atom.scm @@ -0,0 +1,109 @@ +;;; 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 builder atom) + #:use-module (haunt artifact) + #:use-module (haunt html) + #:use-module (haunt post) + #:use-module (haunt site) + #:use-module (haunt utils) + #:use-module (ice-9 match) + #:use-module (jakob builder blog) + #:use-module (jakob utils) + #:use-module (jakob utils sxml) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (web uri) + #:export (atom-feed)) + +;; Slight hack to use relative URLs in the Atom feed for Tor and i2p mirrors. +(define %disable-compliance (make-parameter (getenv "DISABLE_ATOM_COMPLIANCE"))) + +(define (format-date date) + "Format DATE into a date-time production as defined in RFC 3339" + (let* ((formatted (date->string date "~4")) + (up-to-tz-minute (string-drop-right formatted 2)) + (tz-minute (string-take-right formatted 2))) + (string-concatenate `(,up-to-tz-minute ":" ,tz-minute)))) + +(define (format-relative-path site path) + "Return an absolute URI for PATH" + (if (%disable-compliance) + path + (let ((path (if (not (string-prefix? "/" path)) + (format #f "/~a" path) + path))) + (uri->string + (build-uri 'https ;; (site-scheme site) + #:host (site-domain site) + #:path path))))) + +(define* (post->atom-entry site post #:key (blog-prefix "")) + "Convert POST into an Atom <entry> XML node." + (let ((uri (or (post-ref post 'crosspost) + (post-uri post)))) + `(entry + (title ,(post-ref post 'title)) + (id ,(format-relative-path site uri)) + (author + (name ,(post-ref post 'author)) + ,(let ((email (post-ref post 'email))) + (if email `(email ,email) '()))) + (updated ,(format-date (post-date post))) + (link (@ (href ,uri) (rel "alternate"))) + (summary (@ (type "html")) + ,(sxml->html-string + (append (first-paragraph post) + (if (post-ref post 'crosspost) + `((p "...") + (p "This is a crosspost. Click " + ,(hyperlink (post-ref post 'crosspost) "here") + " to read the rest of the article.")) + '())))) + ,@(map (lambda (enclosure) + `(link (@ (rel "enclosure") + (title ,(enclosure-title enclosure)) + (href ,(enclosure-url enclosure)) + (type ,(enclosure-mime-type enclosure)) + ,@(map (match-lambda + ((key . value) + (list key value))) + (enclosure-extra enclosure))))) + (post-ref-all post 'enclosure))))) + +(define* (atom-feed #:key + (file-name "feed.xml") + (subtitle "Recent Posts") + (filter posts/reverse-chronological) + (max-entries 20) + (blog-prefix "")) + "Minor modification to the 'atom-feed' builder in '(haunt builder atom)' to +add support for cross-posts. See the docstring in that manual for details on the +use of this function." + (lambda (site posts) + (serialized-artifact file-name + `(feed (@ (xmlns "http://www.w3.org/2005/Atom")) + (title ,(site-title site)) + (id ,(format-relative-path site file-name)) + (subtitle ,subtitle) + (updated ,(format-date (current-date))) + (link (@ (href ,(format-relative-path site file-name)) + (rel "self"))) + (link (@ (href ,(format-relative-path site "")))) + ,@(map (cut post->atom-entry site <> + #:blog-prefix blog-prefix) + (take-up-to max-entries (filter posts)))) + (@@ (haunt builder atom) sxml->xml*)))) diff --git a/jakob/builder/blog.scm b/jakob/builder/blog.scm new file mode 100644 index 0000000..e03c3e2 --- /dev/null +++ b/jakob/builder/blog.scm @@ -0,0 +1,201 @@ +;;; 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 builder blog) + #:use-module (haunt artifact) + #:use-module (haunt html) + #:use-module (haunt post) + #:use-module (haunt utils) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (jakob dynamic capabilities comment-form) + #:use-module (jakob theme) + #:use-module (jakob utils) + #:use-module (jakob utils pagination) + #:use-module (jakob utils sxml) + #:use-module (jakob utils tags) + #:use-module (jakob utils comments) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (web uri) + #:export (post-uri + blog)) + +;;; Commentary: +;;; +;;; In favor of greater flexibility, Haunt's default 'blog' builder was not used +;;; for this site. This modules implements a similar builder, 'blog', with +;;; pagination and support for tag navigation. +;;; +;;; Code: + + +;;; +;;; Rendering. +;;; + +(define (build-comment-url post) + (format #f "/api/comment-form/~a" (post-slug post))) + +(define (render-article post) + "Return the SHTML for POST's contents." + #<(main + (h1 ,(post-ref post 'title)) + (p ,(date->string (post-date post) "~B ~d, ~Y") + " ❖ " + "Tags: " + ,@(intersperse + (map (lambda (tag) + (hyperlink (tag-uri %tag-prefix tag) tag)) + (post-ref post 'tags)) + ", ")) + ,(when (post-ref post 'crosspost) + `(p (strong "This is a summary ") + "of a post that was published elsewhere. " + "To read the full post, visit " + ,(hyperlink (post-ref post 'crosspost) "this link") + ".")) + (div (@ (data-pagefind-body #t)) + (article ,(post-sxml post)) + (section + (@ (id "webmention")) + (h2 "Comments for this page") + (ul (@ (class "webmention-container")) + ,@(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")) + "Click " ,(hyperlink (build-comment-url post) "here") " to write a comment on this post.") + (form + (@ (id "webmention-form") + (action "https://webmention.io/jakob.space/webmention") + (method "post")) + (label "Or, if you've written about this " + ,(hyperlink "https://indieweb.org/responses" "elsewhere") + ", you can send me a Webmention:") + (div (@ (id "webmention-input-group")) + (input (@ (name "source") (type "url") (placeholder "https://..."))) + (input (@ (value "Send") (type "submit"))))) + ,(script "section-folds.js") + ,(script "comment-reaction.js"))))) + +(define (render-preview post) + "Return the SHTML for a preview of POST." + (let ((crosspost-uri (post-ref post 'crosspost)) + (local-uri (post-uri post))) + #<(section + (h2 ,(hyperlink (or crosspost-uri local-uri) (post-ref post 'title))) + (p ,(date->string (post-date post) "~B ~d, ~Y") + ,(when crosspost-uri + (list " ↻ " (hyperlink local-uri "Crosspost"))) + " ❖ Tags: " + ,@(intersperse + (map (lambda (tag) + (hyperlink (tag-uri %tag-prefix tag) tag)) + (post-ref post 'tags)) + ", ")) + ,(first-paragraph post) + (p ,(hyperlink (or crosspost-uri local-uri) "read more →"))))) + + +;;; +;;; Creation of permalink pages for individual lposts. +;;; + +;; Subdirectory for permalink pages. +(define %prefix "/blog") + +(define (post-identifier post) + "Return the 'slug' that identifies POST." + (let* ((file-name (post-file-name post)) + (splice-start (1+ (string-rindex file-name (cut char=? <> #\/)))) + (splice-end (string-rindex file-name (cut char=? <> #\.))) + (slug (substring file-name splice-start splice-end))) + slug)) + +(define (post-uri post) + "Return the path of POST relative to the site's root." + (string-append %prefix "/" (post-identifier post) ".html")) + +(define (post->page post) + "Return a Haunt page for POST." + (define meta-tags (call-with-input-string (post-ref post 'meta-tags) read)) + (define scripts (call-with-input-string (post-ref post 'scripts) read)) + (serialized-artifact (post-uri post) + (theme #:title (post-ref post 'title) + #:description (description-from-post post) + #:keywords (post-ref post 'tags) + #:meta (if (not (eof-object? meta-tags)) meta-tags '()) + #:scripts (if (not (eof-object? scripts)) scripts '()) + #:content (render-article post)) + sxml->html)) + + +;;; +;;; Navigation based on post tags. +;;; + +;; Subdirectory for post listings conditioned on post tags. +(define %tag-prefix "/blog/tag") + +(define (tags->pages posts) + "Return a list of pages for each tag used in POSTS, with said pages containing +only the posts tagged with that tag." + (flat-map (match-lambda + ((tag . posts) + (items->pages render-preview posts + (format #f "Posts tagged with \"~a\"" tag) + (tag-uri %tag-prefix tag "")))) + (group-by-tag (sort posts (lambda (a b) + (time<? (date->time-monotonic (post-date a)) (date->time-monotonic (post-date b))))) (cut post-ref <> 'tags)))) + +(define (all-tags posts) + "Return a page summarizing tag usage across POSTS." + (define content + `((h1 "All Tags") + (ul (@ (id "tag-cloud")) + ,@(map (match-lambda + ((tag count) + (hyperlink (tag-uri %tag-prefix tag) + `(li ,(format #f "~a (~a)" tag count))))) + (count-tags posts (cut post-ref <> 'tags)))))) + (serialized-artifact "tag.html" + (theme #:title "All Tags" + #:content content) + sxml->html)) + + +;;; +;;; Builder. +;;; + +(define (blog) + "Return a Haunt build procedure to create permalinks and post listings for all +of the 'post' objects associated with the site." + (lambda (site posts) + (append + ;; Permalinks. + (map post->page posts) + + ;; Main post navigation. + (items->pages render-preview (posts/reverse-chronological posts) + "Recent Posts" "index" + #:enable-search #t) + + ;; Tag-based navigation. + (list (all-tags posts)) + (tags->pages posts)))) diff --git a/jakob/builder/blogroll.scm b/jakob/builder/blogroll.scm new file mode 100644 index 0000000..59ce221 --- /dev/null +++ b/jakob/builder/blogroll.scm @@ -0,0 +1,136 @@ +;;; 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 builder blogroll) + #:use-module (haunt artifact) + #:use-module (haunt html) + #:use-module (haunt utils) + #:use-module (ice-9 match) + #:use-module (jakob theme) + #:use-module (jakob utils) + #:use-module (jakob utils sxml) + #:use-module (jakob utils tags) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:export (blogroll)) + +;;; Commentary: +;;; +;;; This module manages pages for listing the blogs that I personally follow and +;;; articles that I enjoyed reading. +;;; +;;; Code: + + +;;; +;;; Type for entries. +;;; + +(define-record-type <entry> + (make-entry name uri tags comments) + entry? + (name entry-name) + (uri entry-uri) + (tags entry-tags) + (comments entry-comments)) + +(define entry + (match-lambda + ((name uri tags) (make-entry name uri tags #f)) + ((name uri tags comments) (make-entry name uri tags comments)))) + + +;;; +;;; Rendering. +;;; + +(define* (render-preview name uri tags tag-prefix #:optional comments) + "Return an SHTML preview of an entry with the given parameters." + `(section + ,@(cons* + `(h2 ,(hyperlink uri name)) + `(p + ,(intersperse + (map (lambda (tag) + (hyperlink (tag-uri tag-prefix tag) tag)) + tags) + ", ")) + (or comments '())))) + +(define (render-tag-cloud prefix entries) + "Return SHTML listing the tags of ENTRIES in PREFIX with the number of times +each tag is used." + `(ul (@ (id "tag-cloud")) + ,@(map (match-lambda + ((tag count) + (hyperlink (tag-uri prefix tag) + `(li ,(format #f "~a (~a)" tag count))))) + (count-tags entries entry-tags)))) + +(define* (render-entries title prefix entries #:optional tag) + "Return an SHTML document listing ENTRIES in PREFIX, with a header of TITLE." + #<(main + (h1 ,(if tag + (format #f "~a - Tagged with \"~a\"" title tag) + title)) + ,(unless tag (render-tag-cloud prefix entries)) + ,(unless tag `(hr)) + ,@(map (lambda (entry) + (render-preview (entry-name entry) + (entry-uri entry) + (entry-tags entry) + prefix + (entry-comments entry))) + entries))) + +(define (entries->pages title prefix entries) + "Return a page listing ENTRIES in PREFIX with a header of TITLE, as well as +pages for each of the tags used in ENTRIES." + (cons + (serialized-artifact (string-append prefix "/index.html") + (theme #:title title + #:content (render-entries title prefix entries)) + sxml->html) + (map (match-lambda + ((tag . entries) + (serialized-artifact (tag-uri prefix tag) + (theme #:title title + #:content (render-entries title prefix entries tag)) + sxml->html))) + (group-by-tag entries entry-tags)))) + + + +;;; +;;; Builder. +;;; + +(define %blogroll + (list "Blogroll" + "/blogroll" + (map entry (primitive-load "data/blogroll.scm")))) + +(define %bookmarks + (list "Bookmarks" + "/bookmark" + (map entry (primitive-load "data/bookmarks.scm")))) + +(define (blogroll) + (lambda (site posts) + (flatten + (map (cut apply entries->pages <>) + (list %blogroll %bookmarks))))) diff --git a/jakob/builder/cookbook.scm b/jakob/builder/cookbook.scm new file mode 100644 index 0000000..7a916ca --- /dev/null +++ b/jakob/builder/cookbook.scm @@ -0,0 +1,67 @@ +;;; Copyright © 2019 - 2024 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: +;; +;; TODO +;; +;;; Code: + +(define-module (jakob builder cookbook) + #:use-module (haunt artifact) + #:use-module (haunt html) + #:use-module (haunt post) + #:use-module (haunt reader) + #:use-module (haunt site) + #:use-module (haunt utils) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (srfi srfi-11) + #:export (flat-pages)) + +(define* (cookbook directory #:key template prefix) + ;; TODO: Document me + (lambda (site posts) + ;; Recursively scan the directory and generate a page for each + ;; file found. + (define (enter? file-name stat memo) #t) + (define (noop file-name stat memo) memo) + (define keep? (site-file-filter site)) + (define (leaf file-name stat memo) + (if (keep? file-name) (cons file-name memo) memo)) + (define (err file-name stat errno memo) + (error "flat page directory scanning failed" file-name errno)) + (define src-files + (file-system-fold enter? leaf noop noop noop err '() directory)) + ;; (define (strip-extension file-name) + ;; (basename file-name + ;; (string-append "." (file-extension file-name)))) + ;; (map (lambda (file-name) + ;; (match (reader-find (site-readers site) file-name) + ;; (reader + ;; (let-values (((metadata body) (reader-read reader file-name))) + ;; (let* ((dir (substring (dirname file-name) + ;; (string-length directory))) + ;; (out (string-append (or prefix "/") dir + ;; (if (string-null? dir) "" "/") + ;; (strip-extension file-name) ".html")) + ;; (title (or (assq-ref metadata 'title) "Untitled"))) + ;; (serialized-artifact out (template site title body) + ;; sxml->html)))) + ;; (#f (error "no reader available for page" file-name)))) + ;; src-files) + )) diff --git a/jakob/builder/flat-pages.scm b/jakob/builder/flat-pages.scm new file mode 100644 index 0000000..e467219 --- /dev/null +++ b/jakob/builder/flat-pages.scm @@ -0,0 +1,86 @@ +;;; Haunt --- Static site generator for GNU Guile +;;; Copyright © 2015 David Thompson <davet@gnu.org> +;;; Copyright © 2016 Christopher Allan Webber <cwebber@dustycloud.org> +;;; Copyright © 2024 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This file is part of Haunt. +;;; +;;; Haunt 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. +;;; +;;; Haunt 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 Haunt. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Simple static web pages. +;; +;;; Code: + +(define-module (jakob builder flat-pages) + #:use-module (haunt artifact) + #:use-module (haunt html) + #:use-module (haunt post) + #:use-module (haunt reader) + #:use-module (haunt site) + #:use-module (haunt utils) + #:use-module (ice-9 ftw) + #:use-module (ice-9 match) + #:use-module (srfi srfi-11) + #:export (flat-pages)) + +(define* (flat-pages directory #:key + (strict #f) + template + prefix) + "Return a procedure that parses the files in DIRECTORY and returns a +list of HTML pages, one for each file. The files are parsed using the +readers configured for the current site. The structure of DIRECTORY +is preserved in the resulting pages and may be optionally nested +within the directory PREFIX. + +The content of each flat page is inserted into a complete HTML +document by the TEMPLATE procedure. This procedure takes three +arguments: the site object, the page title string, and an SXML tree of +the page body. It returns one value: a new SXML tree representing a +complete HTML page that presumably wraps the page body." + (lambda (site posts) + ;; Recursively scan the directory and generate a page for each + ;; file found. + (define (enter? file-name stat memo) #t) + (define (noop file-name stat memo) memo) + (define keep? (site-file-filter site)) + (define (leaf file-name stat memo) + (if (keep? file-name) (cons file-name memo) memo)) + (define (err file-name stat errno memo) + (error "flat page directory scanning failed" file-name errno)) + (define src-files + (file-system-fold enter? leaf noop noop noop err '() directory)) + (define (strip-extension file-name) + (basename file-name + (string-append "." (file-extension file-name)))) + (define results + (map (lambda (file-name) + (match (reader-find (site-readers site) file-name) + (#f (when strict + (error "no reader available for page" file-name)) + #f) + (reader + (let-values (((metadata body) (reader-read reader file-name))) + (let* ((dir (substring (dirname file-name) + (string-length directory))) + (out (string-append (or prefix "/") dir + (if (string-null? dir) "" "/") + (strip-extension file-name) ".html")) + (title (or (assq-ref metadata 'title) "Untitled"))) + (serialized-artifact out (template site title body) + sxml->html)))))) + src-files)) + (filter artifact? results))) diff --git a/jakob/builder/htaccess.scm b/jakob/builder/htaccess.scm new file mode 100644 index 0000000..77d50fe --- /dev/null +++ b/jakob/builder/htaccess.scm @@ -0,0 +1,50 @@ +;;; 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 builder htaccess) + #:use-module (haunt artifact) + #:use-module (ice-9 match) + #:export (htaccess)) + +;; Good resource: +;; <https://perishablepress.com/stupid-htaccess-tricks/#ess4> + +(define* (htaccess-writer contents #:optional (port (current-output-port))) + (display (string-join contents "\n") port) + (newline port)) + +(define* (htaccess #:key + (error-documents '()) + (redirects '())) + "Create an .htaccess file at the site's root. + +ERROR-DOCUMENTS specifies the file name of the page to display for a specific +HTTP error code: a list of (error-code . file-name) pairs. + +REDIRECTS specifies file names to show for certain requests: a list of (pattern +. file-name) pairs." + (define contents + `(,@(map (match-lambda + ((code . file-name) + (format #f "ErrorDocument ~a ~a" code file-name))) + error-documents) + ,@(map (match-lambda + ((pattern . file-name) + (format #f "RewriteRule ~a ~a" pattern file-name))) + redirects))) + + (lambda (site posts) + (serialized-artifact ".htaccess" contents htaccess-writer))) diff --git a/jakob/builder/outbox.scm b/jakob/builder/outbox.scm new file mode 100644 index 0000000..9bd5f75 --- /dev/null +++ b/jakob/builder/outbox.scm @@ -0,0 +1,155 @@ +;;; 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 builder outbox) + #:use-module (haunt artifact) + #:use-module (haunt html) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (jakob theme) + #:use-module (jakob utils pagination) + #:use-module (jakob utils sxml) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-19) + #:export (outbox)) + +;;; Commentary: +;;; +;;; My implementation of an "outbox" for sending comments via Webmention [1] to +;;; sites that support it. +;;; +;;; [1]: https://webmention.net/ +;;; +;;; Code: + +;; Prefix for all pages representing Webmention interactions. +(define %outbox-prefix "/outbox") + + +;;; +;;; Profile. +;;; + +(define %h-card + `(div (@ (class "u-author h-card")) + (img (@ (class "u-photo") + (src "/static/image/profile-picture.jpg") + (width "40"))) + (a (@ (class "u-url p-name") + (href "http://jakob.space")) + "Jakob L. Kreuze"))) + + +;;; +;;; Common rendering code. +;;; + +(define (datetime uri date) + `(p (a (@ (class "u-url") (href ,uri)) + (time (@ (class "dt-published") + (datetime ,(date->string date "~4"))) + ,(date->string date "~B ~e, ~Y"))))) + + +;;; +;;; Record type for replies -- by far, my most frequently-used type of +;;; Webmention response. +;;; + +(define-record-type <reply> + (make-reply content date target-uri target-handle) + reply? + (content reply-content) + (date reply-date) + (target-uri reply-target-uri) + (target-handle reply-target-handle)) + +(define (reply-uri reply) + (let* ((date (date->string (reply-date reply) "~Y-~m-~d-~H:~M:~S")) + (target (reply-target-handle reply)) + (slug (format #f "reply-~a-~a" target date))) + (string-append %outbox-prefix "/" slug ".html"))) + +(define reply + (match-lambda + ((target-uri target-handle date-string content) + (let ((date (string->date date-string "~Y-~m-~dT~H:~M:~S~z"))) + (make-reply content date target-uri target-handle))))) + + +;;; +;;; Reply rendering. +;;; + +(define (render-reply reply) + (let ((content (cons* (car (reply-content reply)) + `(@ (class "e-content")) + (cdr (reply-content reply))))) + `(div (@ (class "h-entry")) + ,%h-card + (p "In reply to: " + (a (@ (class "u-in-reply-to") + (href ,(reply-target-uri reply))) + ,(reply-target-handle reply))) + ,content + ,(datetime (reply-uri reply) (reply-date reply))))) + +(define (render-preview reply) + (let* ((simple-text? (eqv? 'p (car (reply-content reply)))) + (truncated? (and simple-text? + (> (length (cdr (reply-content reply))) 80))) + (preview (if simple-text? + (if truncated? + (format #f "~a..." + (substring (cdr (reply-content reply)) + 0 80)) + (cdr (reply-content reply))) + "[No preview available...]"))) + `(section + (h2 ,(hyperlink + (reply-uri reply) + (format #f "Reply directed towards ~a on ~a" + (reply-target-handle reply) + (date->string (reply-date reply) "~B ~e, ~Y")))) + (p ,preview)))) + +(define (reply->page reply) + (let ((title (format #f "Reply to ~a" (reply-target-handle reply)))) + (serialized-artifact (reply-uri reply) + (theme #:title title + ;; #:description (first-paragraph post) + ;; #:keywords (post-ref post 'tags) + #:content (render-reply reply)) + sxml->html))) + + +;;; +;;; Builder. +;;; + +(define (outbox) + (let ((replies (map reply (primitive-load "data/replies.scm")))) + (lambda (site posts) + (append + ;; Permalinks. + (map reply->page replies) + + ;; Outbox listing. + (items->pages render-preview + (reverse replies) + "Webmentions" + (string-append %outbox-prefix "/" "index") + #:items-per-page 50))))) diff --git a/jakob/dynamic/blacklist.scm b/jakob/dynamic/blacklist.scm new file mode 100644 index 0000000..4796cab --- /dev/null +++ b/jakob/dynamic/blacklist.scm @@ -0,0 +1,151 @@ +;;; 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 dynamic blacklist) + #:use-module (jakob dynamic errors) + #:use-module (jakob dynamic logging) + #:export (fail-when-ip-blacklisted)) + +(define %blacklisted-ip-list + '("113.221.133.247" ; identified as spammer - [2022-12-23T20:50:04-0500] info: POST (comment) (113.221.133.247) + "113.4.118.66" ; identified as spammer - [2022-12-31T16:29:29-0500] info: POST (comment) (113.4.118.66) + "113.4.158.97" ; identified as spammer - [2023-01-04T09:10:08-0500] info: POST (comment) (113.4.158.97) + "114.119.145.88" ; identified as web crawler - [2022-12-16T00:39:39-0500] info: GET (comment-form backdoorctf-2017-funsignals) (114.119.145.88) + "114.119.154.200" ; identified as web crawler - [2023-01-04T00:28:39-0500] info: GET (comment-form rust-on-the-flipper-zero) (114.119.154.200) + "114.228.60.65" ; identified as spammer - [2022-12-17T01:01:09-0500] info: POST (comment) (114.228.60.65) + "114.25.102.177" ; identified as spammer - [2023-01-06T23:13:44-0500] info: POST (comment) (114.25.102.177) + "123.110.200.15" ; identified as spammer - [2023-01-06T07:42:35-0500] info: POST (comment) (123.110.200.15) + "125.228.230.78" ; identified as spammer - [2023-01-07T18:24:13-0500] info: POST (comment) (125.228.230.78) + "13.90.150.239" ; identified as web crawler - [2022-12-25T16:40:23-0500] info: GET (Probe) (13.90.150.239) + "135.181.137.110" ; identified as web crawler - [2022-12-26T21:43:57-0500] info: GET (comment-form sdl-tutorial-part-0x00---boilerplate-windowing-and-rendering) (135.181.137.110) + "135.181.180.59" ; identified as web crawler - [2022-12-13T03:51:15-0500] info: GET (comment-form rust-on-the-flipper-zero) (135.181.180.59) + "136.243.228.182" ; identified as web crawler - [2022-12-15T10:55:56-0500] info: GET (comment-form making-your-own-music-player-a-gentle-introduction-to-audio-programming) (136.243.228.182) + "138.199.19.247" ; identified as spammer - [2022-12-19T11:25:33-0500] info: POST (comment) (138.199.19.247) + "138.199.59.130" ; identified as spammer - [2022-12-23T21:52:36-0500] info: POST (comment) (138.199.59.130) + "138.199.59.172" ; identified as spammer - [2022-12-25T02:29:52-0500] info: POST (comment) (138.199.59.172) + "139.59.135.127" ; identified as script kiddie - [2022-12-10T16:36:27-0500] info: PUT (v2 cmdb system admin admin) (139.59.135.127) + "144.76.68.76" ; identified as web crawler - [2023-01-02T14:53:45-0500] info: GET (comment-form pushing-haunt-to-its-limits) (144.76.68.76) + "162.55.86.53" ; identified as web crawler - [2023-01-07T06:24:38-0500] info: GET (comment-form writeups-for-plaidctf-2019) (162.55.86.53) + "17.241.219.158" ; identified as web crawler - [2023-01-03T23:14:04-0500] info: GET (comment-form investigating-a-backdoorshshellbotaa-infection) (17.241.219.158) + "173.255.174.41" ; identified as spammer - [2022-12-24T05:23:08-0500] info: POST (comment) (173.255.174.41) + "181.214.173.130" ; identified as spammer - [2022-12-13T19:12:12-0500] info: POST (comment) (181.214.173.130) + "185.173.36.129" ; identified as spammer - [2022-12-30T14:12:23-0500] info: POST (comment) (185.173.36.129) + "185.191.171.1" ; identified as web crawler - [2022-12-24T21:59:38-0500] info: GET (comment-form writeups-for-plaidctf-2019) (185.191.171.1) + "185.191.171.10" ; identified as web crawler - [2023-01-06T16:34:54-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-36-74) (185.191.171.10) + "185.191.171.11" ; identified as web crawler - [2023-01-06T06:21:26-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-2-11) (185.191.171.11) + "185.191.171.12" ; identified as web crawler - [2022-12-24T14:52:20-0500] info: GET (comment-form analyzing-executable-size-part-0---a-small-proof-of-concept-loader) (185.191.171.12) + "185.191.171.13" ; identified as web crawler - [2022-12-30T08:47:19-0500] info: GET (comment-form dollar-bin-reverse-engineering) (185.191.171.13) + "185.191.171.14" ; identified as web crawler - [2023-01-02T01:35:22-0500] info: GET (comment-form first-impressions-of-the-rust-programming-language) (185.191.171.14) + "185.191.171.15" ; identified as web crawler - [2022-12-23T21:35:14-0500] info: GET (comment-form ret2emacs) (185.191.171.15) + "185.191.171.16" ; identified as web crawler - [2022-12-24T02:59:43-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-2-11) (185.191.171.16) + "185.191.171.17" ; identified as web crawler - [2022-12-18T07:03:35-0500] info: GET (comment-form pushing-haunt-to-its-limits) (185.191.171.17) + "185.191.171.19" ; identified as web crawler - [2022-12-24T05:15:58-0500] info: GET (comment-form sdl-tutorial-part-0x00---boilerplate-windowing-and-rendering) (185.191.171.19) + "185.191.171.2" ; identified as web crawler - [2023-01-05T11:08:56-0500] info: GET (comment-form writeups-for-plaidctf-2019) (185.191.171.2) + "185.191.171.23" ; identified as web crawler - [2022-12-24T22:37:16-0500] info: GET (comment-form a-good-bye-letter-to-my-life-long-companion) (185.191.171.23) + "185.191.171.24" ; identified as web crawler - [2022-12-24T03:34:17-0500] info: GET (comment-form reverse-engineering-babbys-first-archive-format) (185.191.171.24) + "185.191.171.25" ; identified as web crawler - [2022-12-24T16:02:33-0500] info: GET (comment-form first-impressions-of-the-kotlin-programming-language) (185.191.171.25) + "185.191.171.26" ; identified as web crawler - [2022-12-21T23:50:50-0500] info: GET (comment-form understand-game-hacking-in-one-post) (185.191.171.26) + "185.191.171.3" ; identified as web crawler - [2022-12-24T04:28:34-0500] info: GET (comment-form reverse-engineering-by-hand) (185.191.171.3) + "185.191.171.33" ; identified as web crawler - [2022-12-25T06:04:06-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-12-22) (185.191.171.33) + "185.191.171.35" ; identified as web crawler - [2022-12-21T19:05:05-0500] info: GET (comment-form rust-on-the-flipper-zero) (185.191.171.35) + "185.191.171.36" ; identified as web crawler - [2022-12-14T21:20:16-0500] info: GET (comment-form browser-games-arent-an-easy-target) (185.191.171.36) + "185.191.171.37" ; identified as web crawler - [2023-01-05T04:30:35-0500] info: GET (comment-form first-impressions-of-the-kotlin-programming-language) (185.191.171.37) + "185.191.171.38" ; identified as web crawler - [2023-01-02T03:08:49-0500] info: GET (comment-form rust-on-the-flipper-zero) (185.191.171.38) + "185.191.171.39" ; identified as web crawler - [2022-12-24T11:53:54-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-36-74) (185.191.171.39) + "185.191.171.4" ; identified as web crawler - [2022-12-20T13:40:53-0500] info: GET (comment-form umass-ctf-2021-postmortem) (185.191.171.4) + "185.191.171.40" ; identified as web crawler - [2022-12-25T00:32:43-0500] info: GET (comment-form first-impressions-of-the-myrddin-programming-language) (185.191.171.40) + "185.191.171.43" ; identified as web crawler - [2022-12-17T17:36:28-0500] info: GET (comment-form dollar-bin-reverse-engineering) (185.191.171.43) + "185.191.171.44" ; identified as web crawler - [2022-12-20T13:46:51-0500] info: GET (comment-form slime-the-world-a-postmortem) (185.191.171.44) + "185.191.171.5" ; identified as web crawler - [2023-01-05T16:16:16-0500] info: GET (comment-form first-impressions-of-the-myrddin-programming-language) (185.191.171.5) + "185.191.171.6" ; identified as web crawler - [2022-12-21T13:02:35-0500] info: GET (comment-form first-impressions-of-the-rust-programming-language) (185.191.171.6) + "185.191.171.7" ; identified as web crawler - [2022-12-15T18:56:17-0500] info: GET (comment) (185.191.171.7) + "185.191.171.8" ; identified as web crawler - [2022-12-24T12:19:23-0500] info: GET (comment-form the-many-faces-of-an-undying-programming-language) (185.191.171.8) + "185.191.171.9" ; identified as web crawler - [2022-12-22T00:33:36-0500] info: GET (comment-form investigating-a-backdoorshshellbotaa-infection) (185.191.171.9) + "185.51.134.245" ; identified as spammer - [2022-12-31T16:38:25-0500] info: POST (comment) (185.51.134.245) + "188.126.88.12" ; identified as spammer - [2023-01-04T23:15:14-0500] info: POST (comment) (188.126.88.12) + "188.126.94.243" ; identified as spammer - [2022-12-16T04:03:49-0500] info: POST (comment) (188.126.94.243) + "192.99.15.185" ; identified as web crawler - [2022-12-13T18:05:55-0500] info: GET (comment-form browser-games-arent-an-easy-target) (192.99.15.185) + "37.139.53.20" ; identified as spammer - [2022-12-28T20:18:09-0500] info: POST (comment) (37.139.53.20) + "37.139.53.30" ; identified as spammer - [2022-12-24T22:33:10-0500] info: POST (comment) (37.139.53.30) + "37.139.53.37" ; identified as spammer - [2022-12-12T23:31:09-0500] info: POST (comment) (37.139.53.37) + "37.139.53.40" ; identified as spammer - [2022-12-15T04:34:57-0500] info: POST (comment) (37.139.53.40) + "37.139.53.50" ; identified as spammer - [2022-12-15T23:35:29-0500] info: POST (comment) (37.139.53.50) + "37.139.53.82" ; identified as spammer - [2023-01-05T10:56:49-0500] info: POST (comment) (37.139.53.82) + "37.46.115.49" ; identified as spammer - [2023-01-02T04:12:27-0500] info: POST (comment) (37.46.115.49) + "51.222.253.1" ; identified as web crawler - [2022-12-19T03:06:58-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-2-11) (51.222.253.1) + "51.222.253.11" ; identified as web crawler - [2022-12-15T06:39:18-0500] info: GET (comment-form ret2emacs) (51.222.253.11) + "51.222.253.13" ; identified as web crawler - [2022-12-15T06:01:25-0500] info: GET (comment-form umass-ctf-2021-postmortem) (51.222.253.13) + "51.222.253.14" ; identified as web crawler - [2022-12-18T23:31:09-0500] info: GET (comment-form towards-guix-for-devops) (51.222.253.14) + "51.222.253.15" ; identified as web crawler - [2023-01-06T21:01:54-0500] info: GET (comment-form game-hacking-on-linux---scanmem-basics) (51.222.253.15) + "51.222.253.17" ; identified as web crawler - [2022-12-19T21:54:40-0500] info: GET (comment-form reverse-engineering-babbys-first-archive-format) (51.222.253.17) + "51.222.253.18" ; identified as web crawler - [2022-12-12T15:48:52-0500] info: GET (comment-form pushing-haunt-to-its-limits) (51.222.253.18) + "51.222.253.2" ; identified as web crawler - [2022-12-20T02:03:32-0500] info: GET (comment-form game-hacking-on-linux---scanmem-basics) (51.222.253.2) + "51.222.253.20" ; identified as web crawler - [2022-12-24T21:29:55-0500] info: GET (comment-form ret2emacs) (51.222.253.20) + "51.222.253.3" ; identified as web crawler - [2022-12-14T05:45:52-0500] info: GET (comment-form rust-on-the-flipper-zero) (51.222.253.3) + "51.222.253.4" ; identified as web crawler - [2022-12-20T17:16:43-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-23-35) (51.222.253.4) + "51.222.253.5" ; identified as web crawler - [2022-12-21T14:12:27-0500] info: GET (comment-form understand-game-hacking-in-one-post) (51.222.253.5) + "51.222.253.6" ; identified as web crawler - [2022-12-15T00:57:31-0500] info: GET (comment-form transitioning-to-haunt) (51.222.253.6) + "51.222.253.7" ; identified as web crawler - [2022-12-13T18:32:46-0500] info: GET (comment-form reverse-engineering-by-hand) (51.222.253.7) + "51.222.253.8" ; identified as web crawler - [2022-12-18T04:51:59-0500] info: GET (comment-form i-love-my-pinephone) (51.222.253.8) + "51.222.253.9" ; identified as web crawler - [2022-12-12T13:34:03-0500] info: GET (comment-form installing-gentoo-one-month-later) (51.222.253.9) + "59.33.205.196" ; identified as spammer - [2022-12-22T23:54:13-0500] info: POST (comment) (59.33.205.196) + "65.108.0.150" ; identified as web crawler - [2022-12-16T13:02:49-0500] info: GET (comment-form pushing-haunt-to-its-limits) (65.108.0.150) + "65.108.110.26" ; identified as web crawler - [2022-12-19T12:17:01-0500] info: GET (comment-form first-impressions-of-the-myrddin-programming-language) (65.108.110.26) + "65.108.125.120" ; identified as web crawler - [2023-01-02T03:19:03-0500] info: GET (comment-form first-impressions-of-the-kotlin-programming-language) (65.108.125.120) + "65.108.203.159" ; identified as web crawler - [2022-12-13T08:41:18-0500] info: GET (comment-form pushing-haunt-to-its-limits) (65.108.203.159) + "65.108.46.72" ; identified as web crawler - [2023-01-05T16:45:53-0500] info: GET (comment-form installing-gentoo-one-month-later) (65.108.46.72) + "65.109.26.102" ; identified as web crawler - [2022-12-22T06:41:24-0500] info: GET (comment-form umass-ctf-2021-postmortem) (65.109.26.102) + "65.21.237.125" ; identified as web crawler - [2023-01-03T21:53:45-0500] info: GET (comment-form pushing-haunt-to-its-limits) (65.21.237.125) + "66.249.66.130" ; identified as web crawler - [2023-01-02T10:47:58-0500] info: GET (comment-form first-impressions-of-the-myrddin-programming-language) (66.249.66.130) + "66.249.66.206" ; identified as web crawler - [2022-12-31T13:45:35-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-12-22) (66.249.66.206) + "66.249.66.28" ; identified as web crawler - [2022-12-18T03:48:57-0500] info: GET (comment-form a-good-bye-letter-to-my-life-long-companion) (66.249.66.28) + "66.249.66.3" ; identified as web crawler - [2022-12-18T03:48:07-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-12-22) (66.249.66.3) + "66.249.66.30" ; identified as web crawler - [2022-12-22T04:03:42-0500] info: GET (comment-form pushing-haunt-to-its-limits) (66.249.66.30) + "66.249.66.46" ; identified as web crawler - [2022-12-29T11:45:29-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-12-22) (66.249.66.46) + "66.249.70.124" ; identified as web crawler - [2022-12-30T08:03:43-0500] info: GET (comment-form pushing-haunt-to-its-limits) (66.249.70.124) + "66.249.70.96" ; identified as web crawler - [2022-12-30T08:48:44-0500] info: GET (comment-form pushing-haunt-to-its-limits) (66.249.70.96) + "77.240.183.231" ; identified as web crawler - [2022-12-17T08:20:56-0500] info: GET (comment-form sdl-tutorial-part-0x00---boilerplate-windowing-and-rendering) (77.240.183.231) + "81.170.128.52" ; identified as web crawler - [2022-12-22T09:13:14-0500] info: GET (comment-form first-impressions-of-the-rust-programming-language) (81.170.128.52) + "87.250.224.112" ; identified as web crawler - [2023-01-01T02:52:49-0500] info: GET (comment-form investigating-a-backdoorshshellbotaa-infection) (87.250.224.112) + "87.250.224.179" ; identified as web crawler - [2022-12-15T15:39:51-0500] info: GET (comment-form i-love-my-pinephone) (87.250.224.179) + "91.239.157.219" ; identified as spammer - [2022-12-19T05:04:59-0500] info: POST (comment) (91.239.157.219) + "91.240.118.252" ; identified as web crawler - [2022-12-24T15:38:52-0500] info: GET (comment-form a-good-bye-letter-to-my-life-long-companion) (91.240.118.252) + "95.181.233.157" ; identified as spammer - [2023-01-03T11:14:02-0500] info: POST (comment) (95.181.233.157) + "95.217.109.26" ; identified as web crawler - [2023-01-05T11:32:45-0500] info: GET (comment-form writeups-for-plaidctf-2019) (95.217.109.26) + "95.79.188.37" ; identified as spammer - [2022-12-15T19:28:36-0500] info: POST (comment) (95.79.188.37) + "95.91.111.111" ; identified as web crawler - [2023-01-04T06:33:30-0500] info: GET (comment-form towards-guix-for-devops) (95.91.111.111) + "99.105.215.234")) ; identified as web crawler - [2022-12-10T00:05:12-0500] info: GET (v1 timelines public) (limit=500) (99.105.215.234) +(define %blacklisted-ips + (let ((result (make-hash-table))) + (for-each (lambda (ip) + (hash-set! result ip #t)) + %blacklisted-ip-list) + result)) +(define %blacklisted-message + "If you are seeing this status code, it is because your IP address has +been associated with a pattern of misuse and was blacklisted. + +If you believe this is a mistake, please email the webmastere with a +detailed explanation of why you believe your prior use constituted a +legitimate purpose. Contact information is available ata +https:/jakob.space/about + +Otherwise: fuck off.") + +(define (fail-when-ip-blacklisted ip-address) + (when (hash-ref %blacklisted-ips ip-address) + (log-append! 'info (format #f "Blocked request from ~a" ip-address)) + (panic %blacklisted-message #:code 403))) diff --git a/jakob/dynamic/capabilities/comment-form.scm b/jakob/dynamic/capabilities/comment-form.scm new file mode 100644 index 0000000..f7d0491 --- /dev/null +++ b/jakob/dynamic/capabilities/comment-form.scm @@ -0,0 +1,119 @@ +;;; 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 dynamic capabilities comment-form) + #:use-module (gcrypt base64) + #:use-module (haunt html) + #:use-module (ice-9 match) + #:use-module (jakob builder blog) + #:use-module (jakob dynamic captcha) + #:use-module (jakob dynamic util) + #:use-module (jakob theme) + #:use-module (jakob utils sxml) + #:use-module (json) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:export (render-static-comment-form + render-dynamic-comment-form + get-comment-form)) + +(define (render-comment-field) + `(fieldset (@ (id "comment-content")) + (legend "Comment") + (label (@ (for "name") (class "required")) "Name:") + (input (@ (type "text") (id "name") (name "name") (required #t))) + (label (@ (for "email")) "Email:") + (input (@ (type "text") (id "email") (name "email"))) + (label (@ (for "url")) "Webpage URL:") + (input (@ (type "text") (id "url") (name "url"))) + (label (@ (for "subject")) "Subject:") + (input (@ (type "text") (id "subject") (name "subject"))) + (label (@ (for "comment") (class "required")) "Comment :") + (textarea (@ (id "coment") (name "comment"))) + (p "(*) Indicates a required field."))) + +(define* (render-comment-captcha-field #:optional (captcha-id "") captcha-image + #:key hidden) + `(fieldset ,(if hidden + '(@ (id "comment-captcha") (hidden "#t")) + '(@ (id "comment-captcha"))) + (legend "Captcha") + (div (@ (id "captcha-challenge-primary")) + (label (@ (for "captcha")) "Please evaluate the following definite integral:") + (img (@ (id "captcha-image") + (src ,(if captcha-image + (format #f "data:image/jpeg;charset=utf-8;base64,~a" + (base64-encode captcha-image)) + "")))) + (input (@ (type "text") (id "captcha") (name "captcha") (size 24)))) + (button (@ (id "pow-trigger") (hidden #t)) + "Too hard? (Or unable to see the challenge?)" + (br) + "Click here for an alternative captcha.") + (input (@ (autocomplete "off") (type "text") (id "captcha-id") (name "captcha-id") (hidden #t) (value ,captcha-id))) + (input (@ (autocomplete "off") (type "text") (id "captcha-alt") (name "captcha-alt") (hidden #t))) + (input (@ (autocomplete "off") (type "text") (id "captcha-alt-id") (name "captcha-alt-id") (hidden #t))) + (input (@ (type "submit") (id "submit-form") (value "Submit"))))) + +(define (render-static-comment-form slug captcha-id captcha-image) + `(div (@ (id "comment-form")) + (h1 "Comment form") + (form (@ (id "comment-input") (action "/api/comment") (method "post")) + (input (@ (type "text") (name "slug") (hidden #t) (value ,slug))) + ,(render-comment-field) + ,(render-comment-captcha-field captcha-id captcha-image)) + ,(script "proof-of-work.js"))) + +(define (render-dynamic-comment-form slug) + `(div (@ (id "comment-form")) + (h3 (@ (id "comment-form-header")) "Comment form") + (form (@ (id "comment-input") (action "/api/comment") (method "post")) + (input (@ (autocomplete "off") + (type "text") + (name "slug") + (hidden #t) + (value ,slug))) + (input (@ (autocomplete "off") + (type "text") + (name "reply-to") + (id "reply-to") + (hidden #t) + (value ""))) + ,(render-comment-field) + (fieldset (@ (id "captcha-trigger-block")) + (legend "Captcha") + (label "You need to complete a captcha to write a comment.") + (button (@ (id "captcha-challenge-trigger")) + "Click here to generate a captcha challenge")) + ,(render-comment-captcha-field #:hidden #t)) + ,(script "dynamic-comment-form.js") + ,(script "proof-of-work.js"))) + +(define (get-comment-form request body) + "API endpoint handler for querying for the comments on a particular post + +This is a wrapper around `get-comments-by-slug'." + (let-values (((captcha-id captcha-image) (new-captcha!))) + (let* ((path-encoded (uri-path (request-uri request))) + (path (split-and-decode-uri-path path-encoded)) + (slug (last path)) + (form (render-static-comment-form slug captcha-id captcha-image))) + (values '((content-type . (text/html))) + (sxml->html-string + (theme #:content form #:title "Comment prompt")))))) diff --git a/jakob/dynamic/capabilities/comments.scm b/jakob/dynamic/capabilities/comments.scm new file mode 100644 index 0000000..ee2a52d --- /dev/null +++ b/jakob/dynamic/capabilities/comments.scm @@ -0,0 +1,210 @@ +;;; 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 dynamic capabilities comments) + #:use-module (ice-9 match) + #:use-module (jakob dynamic capabilities common) + #:use-module (jakob dynamic captcha) + #:use-module (jakob dynamic config) + #:use-module (jakob dynamic errors) + #:use-module (jakob dynamic util) + #:use-module (json) + #:use-module (squee) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:export (get-comments + get-comments-by-slug + + put-comment + put-reaction)) + +(define conn (connect-to-postgres-paramstring (paramstring-for-dbname "jakob_comments"))) + +(define (get-comments-by-slug slug) + "Internal function for querying the approved comments on a post + +This interface exists for dynamically generating the comment view from Haunt." + (define (make-internal-comment~ . args) + (let* ((args-needing-processing (take-right args 4)) + (approved (list-ref args-needing-processing 0)) + (approved (string->date approved "~Y~m~d ~H~M~S.~N")) + (reactions (list-ref args-needing-processing 1)) + (reactions (if reactions + (with-input-from-string reactions read) + '())) + (originating-network (list-ref args-needing-processing 2)) + (replies (list-ref args-needing-processing 3))) + (apply make-internal-comment + `(,@(drop-right args 4) + ,approved + ,reactions + ,replies + ,originating-network)))) + (define (order-comments comments) + (define seen (make-hash-table)) + (define (id comment) (first comment)) + (define (content comment) (drop-right comment 1)) + (define (parent comment) (last comment)) + (define (has-children? id remaining) + (cond ((null? remaining) #f) + ((equal? id (parent (car remaining))) #t) + (else (has-children? id (cdr remaining))))) + (define (pass cur initial-comments remaining) + (cond ((null? initial-comments) (sort-comments (hash-ref seen 'terminal))) + ((null? cur) (pass (reverse remaining) (reverse remaining) (list))) + ((has-children? (id (car cur)) initial-comments) + (pass (cdr cur) initial-comments (cons (car cur) remaining))) + (else + (let* ((children (or (hash-ref seen (id (car cur))) '())) + (children (sort-comments children)) + (parsed (apply make-internal-comment~ (append (content (car cur)) (list children))))) + ;; Remove this comment from `seen'. + (hash-set! seen (id (car cur)) #f) + (if (parent (car cur)) + (hash-append! seen (parent (car cur)) parsed) + (hash-append! seen 'terminal parsed)) + (pass (cdr cur) initial-comments remaining))))) + (pass comments comments '())) + (let* ((query "SELECT id, name, subject, email, comment, url, approved, reactions, originating_network, reply_to + FROM comments WHERE slug = $1 and approved IS NOT NULL") + (result (exec-query conn query (list slug)))) + (if (positive? (length result)) + (order-comments result) + '()))) + +(define (get-comments request body) + "API endpoint handler for querying for the comments on a particular post + +This is a wrapper around `get-comments-by-slug'." + (define (normalize-record record) + (json-string->scm (internal-comment->json record))) + (let* ((query-string (uri-query (request-uri request))) + (params (if query-string + (decode-form query-string) + '())) + (slug (assoc-ref params "p"))) + (unless slug (panic "missing `slug' query parameter")) + (values '((content-type . (application/json))) + (scm->json-string + (list->vector + (map normalize-record (get-comments-by-slug (car slug)))))))) + + + +(define (put-comment request body) + "API endpoint handler for submitting a comment" + (define (request-originating-network request) + (cond ((from-tor? request) "tor") + ((from-i2p? request) "i2p") + (else "clearnet"))) + (define (valid-comment? form-data) + (and (assoc "slug" form-data) + (assoc "name" form-data) + (assoc "comment" form-data) + (or (assoc "captcha" form-data) + (and (assoc "captcha-alt" form-data) + (assoc "captcha-alt-id" form-data))) + (assoc "captcha-id" form-data) + (if (and (string? (assoc-value form-data "captcha-alt")) + (positive? (string-length (assoc-value form-data "captcha-alt")))) + (validate-proof-of-work! + (assoc-value form-data "captcha-alt") + (string->number (assoc-value form-data "captcha-alt-id"))) + (validate-captcha! + (assoc-value form-data "captcha") + (string->number (assoc-value form-data "captcha-id")))))) + (define (insert-comment form-data) + (exec-query conn + "INSERT INTO comments (submitted, slug, name, subject, email, + url, comment, reply_to, originating_network) + VALUES (now(), $1, $2, $3, $4, $5, $6, $7, $8);" + (list (assoc-value form-data "slug") + (assoc-value form-data "name") + (assoc-value form-data "subject") + (assoc-value form-data "email") + (assoc-value form-data "url") + (assoc-value form-data "comment") + (if (and (assoc-value form-data "reply-to") + (positive? (string-length (assoc-value form-data "reply-to")))) + (assoc-value form-data "reply-to") + #f) + (request-originating-network request))) + (values (build-response + #:code 307 + #:headers '((Location . "https://jakob.space"))) + (scm->json-string `((success . #t))))) + (let ((form-data (decode-form body))) + (unless (assoc "slug" form-data) (panic "missing param `slug'")) + (unless (assoc "name" form-data) (panic "missing param `name'")) + (unless (assoc "comment" form-data) (panic "missing param `comment'")) + (unless (assoc "captcha-id" form-data) (panic "missing param `captcha-id'")) + (unless (or (assoc "captcha" form-data) + (and (assoc "captcha-alt" form-data) + (assoc "captcha-alt-id" form-data))) + (panic "missing param `captcha' (or `captcha-alt' and `captcha-alt-id')")) + (if (and (string? (assoc-value form-data "captcha-alt")) + (positive? (string-length (assoc-value form-data "captcha-alt")))) + ;; Alternate captcha fields specified; take the code path that validates + ;; a proof-of-work. + (unless (validate-proof-of-work! + (assoc-value form-data "captcha-alt") + (string->number (assoc-value form-data "captcha-alt-id"))) + (panic "proof-of-work not acceptable")) + ;; Alternate captcha fields not specified, so take the normal code path + ;; where we validate a captcha response. + (unless (validate-captcha! + (assoc-value form-data "captcha") + (string->number (assoc-value form-data "captcha-id"))) + (panic "captcha incorrect"))) + (insert-comment form-data))) + + + +(define (add-reaction reactions reaction) + (with-output-to-string + (lambda () + (let ((parsed (call-with-input-string reactions read))) + (write (acons-normalize reaction + (if (assoc reaction parsed) (+ 1 (assoc-value parsed reaction)) 1) + parsed)))))) + +(define (put-reaction request body) + (define (set-reactions id reactions) + (exec-query conn "UPDATE comments SET reactions = $1 WHERE id = $2" + (list reactions id))) + (define (comment-reactions id) + (let* ((query "SELECT reactions FROM comments WHERE id = $1") + (result (exec-query conn query (list id)))) + ;; It could be NULL, in which case we want the empty list instead. + (if (positive? (length result)) (or (caar result) "()") #f))) + (define (valid-reaction? form-data) + (and (assoc "id" form-data) + (assoc "reaction" form-data))) + (let ((form-data (decode-form body))) + (unless (assoc "id" form-data) (panic "missing param `id'")) + (unless (assoc "reaction" form-data) (panic "missing param `reaction'")) + (let* ((id (assoc-value form-data "id")) + (reaction (assoc-value form-data "reaction")) + (reactions (comment-reactions id))) + (unless id (panic "no such comment")) + (unless (emoji? reaction) (panic "invalid reaction")) + (set-reactions id (add-reaction reactions reaction)) + (values '((content-type . (application/json))) + (scm->json-string `((success . #t))))))) diff --git a/jakob/dynamic/capabilities/common.scm b/jakob/dynamic/capabilities/common.scm new file mode 100644 index 0000000..2bca1a2 --- /dev/null +++ b/jakob/dynamic/capabilities/common.scm @@ -0,0 +1,68 @@ +;;; 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 dynamic capabilities common) + #:use-module (jakob dynamic util) + #:use-module (json) + #:use-module (srfi srfi-19) + #:export (json->internal-comment + internal-comment->json + make-internal-comment + internal-comment? + internal-comment-id + internal-comment-name + internal-comment-subject + internal-comment-email + internal-comment-comment + internal-comment-url + internal-comment-publish-time + internal-comment-reactions + internal-comment-replies + internal-comment-originating-network + sort-comments)) + +(define-json-mapping <internal-comment> + make-internal-comment + internal-comment? + json->internal-comment <=> internal-comment->json + (id internal-comment-id) + (name internal-comment-name) + (subject internal-comment-subject) + (email internal-comment-email) + (comment internal-comment-comment) + (url internal-comment-url) + (publish-time + internal-comment-publish-time + "publish-time" + (lambda (x) (string->date x "~Y~m~d ~H~M~S.~N")) + (lambda (x) (date->string x "~Y-~m-~d ~H:~M:~S.~N"))) + (reactions internal-comment-reactions) + (replies + internal-comment-replies + "replies" + (lambda (x) (map (lambda (comment) + (call-with-input-string (scm->json-string comment) json->internal-comment)) + (vector->list x))) + (lambda (x) (list->vector (map (lambda (y) + (json-string->scm (internal-comment->json y))) + x)))) + (originating-network internal-comment-originating-network)) + +(define (sort-comments comments) + "Sort COMMENTS, a list of `<internal-comment>' chronologically" + (sort comments (lambda (c1 c2) + (date<? (internal-comment-publish-time c1) + (internal-comment-publish-time c2))))) diff --git a/jakob/dynamic/capabilities/gallery.scm b/jakob/dynamic/capabilities/gallery.scm new file mode 100644 index 0000000..7087149 --- /dev/null +++ b/jakob/dynamic/capabilities/gallery.scm @@ -0,0 +1,79 @@ +;;; 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 dynamic capabilities gallery) + #:use-module (haunt html) + #:use-module (ice-9 match) + #:use-module (jakob dynamic config) + #:use-module (jakob dynamic errors) + #:use-module (jakob dynamic util) + #:use-module (jakob theme) + #:use-module (squee) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:export (get-gallery get-image)) + +(define conn (connect-to-postgres-paramstring (paramstring-for-dbname "jakob_gallery"))) + +;; How many bytes of entropy to use when generating vanity ID's. +(define %vanity-length (make-parameter 9)) + +;; Path where gallery images are stored. +(define %gallery-image-directory (make-parameter "/home/jakob/gallery-images/")) + +(define (valid-gallery-code code) + "Check database to see if `code' names a nonempty gallery." + (and (= (string-length code) (base64-length (%vanity-length))) + (positive? + (length + (exec-query conn "SELECT * FROM images WHERE vanity = $1" + (list code)))))) + +(define (render-gallery code) + (define info + (first + (exec-query conn "SELECT title, description, datetime FROM galleries WHERE vanity = $1" (list code)))) + (define images + (exec-query conn "SELECT title, filename, thumb_filename, datetime FROM images WHERE vanity = $1" (list code))) + (match info + ((title description datetime) + `(div (@ (id "gallery-container")) + (h1 ,title) + (h3 ,description) + ,(map (lambda (image) + (match image + ((title filename thumbnail datetime) + `(a (@ (href ,(format #f "/static-ext/~a" filename))) + (img (@ (src ,(format #f "/static-ext/~a" thumbnail)) + (alt ,title) + (title ,(format #f "~a - ~a" title datetime)))))))) + images))))) + +(define (get-gallery request body) + (let* ((query-string (uri-query (request-uri request))) + (params (if query-string + (decode-form query-string) + '())) + (code (if (assoc-ref params "g") + (car (assoc-ref params "g")) + (panic "no gallery code provided")))) + (unless (valid-gallery-code code) (panic "invalid gallery code")) + (values '((content-type . (text/html))) + (sxml->html-string + (theme #:title "Photo Gallery" #:content (render-gallery code)))))) diff --git a/jakob/dynamic/capabilities/poll.scm b/jakob/dynamic/capabilities/poll.scm new file mode 100644 index 0000000..560a8e3 --- /dev/null +++ b/jakob/dynamic/capabilities/poll.scm @@ -0,0 +1,329 @@ +;;; Copyright © 2019 - 2024 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 dynamic capabilities poll) + #:use-module (gcrypt base64) + #:use-module (haunt html) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #:use-module (jakob dynamic config) + #:use-module (jakob dynamic errors) + #:use-module (jakob dynamic util) + #:use-module (jakob theme) + #:use-module (json) + #:use-module (rnrs bytevectors) + #:use-module (squee) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (sxml simple) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri)) + +;; How many bytes of entropy to use when generating vanity ID's. +(define %vanity-length (make-parameter 12)) + +;; Global handle to the RSVP database. +(define conn (connect-to-postgres-paramstring (paramstring-for-dbname "jakob_poll"))) + + + +(define-record-type <poll> + (make-poll title description questions) + poll? + (title poll-title set-poll-title!) + (description poll-description set-poll-description!) + (questions poll-questions set-poll-questions!)) + +(define (valid-invite-code invitation) + "Check database to see if `invitation' exists." + (and (= (string-length invitation) (%vanity-length)) + (positive? + (length + (exec-query conn "SELECT * FROM invitations WHERE vanity = $1" + (list invitation)))))) + +(define (invite-code->poll-id invitation) + (caar + (exec-query conn "SELECT poll_id FROM invitations WHERE vanity = $1" + (list invitation)))) + +(define (get-poll id) + (define response + (car + (exec-query conn "SELECT title, description, questions FROM polls WHERE id = $1" + (list id)))) + (make-poll + (first response) + (second response) + (call-with-input-string (third response) read))) + +(define (valid-fields invitation) + (map car (poll-questions (get-poll (invite-code->poll-id invitation))))) + + + +(define-record-type <poll-response-create> + (make-poll-response-create-parameters) + poll-response-create-parameters? + (invitation-code poll-response-create-code set-poll-response-create-code!) + (response poll-response-create-response set-poll-response-create-response!)) + +(define (assoc-intersect keys alist) + "Filter `alist' down to just `keys'." + (filter (lambda (x) (member (car x) keys)) alist)) + +(define (params->poll-response-create params) + "Parse `params', an alist, into a `<poll-response-create>'." + (let* ((id (assoc-value params "id")) + (valid-fields (valid-fields id)) + (res (make-poll-response-create-parameters))) + (set-poll-response-create-code! res id) + (set-poll-response-create-response! res (assoc-intersect valid-fields params)) + (if (or + (any not + (list (poll-response-create-code res) + (poll-response-create-response res))) + (not (= (length valid-fields) + (length (poll-response-create-response res))))) + #f + res))) + +(params->poll-response-create '(("id" "ArVR1jTK2lbo") ("availability-1" "asdf") ("availability-2" "asdf"))) + +(define (invitation->poll-id vanity-code) + "For valid `vanity-code', find the corresponding poll ID." + (car + (exec-query conn "SELECT poll_id FROM invitations WHERE vanity = $1" + (list vanity-code)))) + + + +(define (create-new-event-rsvp params) + "Handler for responding to the poll." + (let ((params (params->rsvp-create params))) + (unless params + (panic "invalid form data")) + (unless (valid-invite-code (rsvp-create-code params)) + (panic "invalid invitation code")) + (let ((receipt-code (generate-vanity-code)) + (event-id (car (invitation->event-id (rsvp-create-code params))))) + (exec-query conn + "INSERT INTO rsvps (vanity, invitation_id, event_id, fullname, email, attending, guests) VALUES ($1, $2, $3, $4, $5, $6, $7)" + (list receipt-code + (rsvp-create-code params) + event-id + (rsvp-create-name params) + (rsvp-create-email params) + (rsvp-create-attending params) + (rsvp-create-guests params))) + (values '((content-type . (text/html))) + (sxml->html-string + (theme #:title "Thanks for RSVPing!" + #:content (render-event-rsvp-receipt receipt-code))))))) + + + +(define-record-type <rsvp-update> + (make-rsvp-update-parameters) + rsvp-update-parameters? + (invitation-code rsvp-update-code set-rsvp-update-code!) + (name rsvp-update-name set-rsvp-update-name!) + (email rsvp-update-email set-rsvp-update-email!) + (attending rsvp-update-attending set-rsvp-update-attending!) + (guests rsvp-update-guests set-rsvp-update-guests!)) + +(define (params->rsvp-update params) + "Parse `params', an alist, into a `<rsvp-update>'." + (let ((res (make-rsvp-update-parameters))) + (set-rsvp-update-code! res (assoc-value params "update")) + (set-rsvp-update-name! res (assoc-value params "name")) + (set-rsvp-update-email! res (assoc-value params "email")) + (set-rsvp-update-attending! res (assoc-value params "rsvp")) + (set-rsvp-update-guests! res (assoc-value params "guest-names")) + (if (any not + (list (rsvp-update-code res) + (rsvp-update-name res) + (rsvp-update-email res) + (rsvp-update-attending res) + (rsvp-update-guests res))) + #f + res))) + +(define (update-event-rsvp params) + "Handler for updating an RSVP to an event." + (let ((params (params->rsvp-update params))) + (unless params + (panic "invalid form data")) + (unless (valid-receipt-code (rsvp-update-code params)) + (panic "invalid recepit code")) + (exec-query conn + "UPDATE rsvps SET fullname = $2, email = $3, attending = $4, guests = $5 WHERE vanity = $1" + (list + (rsvp-update-code params) + (rsvp-update-name params) + (rsvp-update-email params) + (rsvp-update-attending params) + (rsvp-update-guests params))) + (values '((content-type . (text/html))) + (sxml->html-string + (theme #:title "Thanks for RSVPing!" + #:content (render-event-rsvp-receipt (rsvp-update-code params))))))) + + + +(define (post-event-rsvp request body) + "Entry point for RSVP create/update. We dispatch on the parameters." + (let ((form-data (decode-form body))) + (cond ((assoc-ref form-data "id") (create-new-event-rsvp form-data)) + ((assoc-ref form-data "update") (update-event-rsvp form-data)) + (else (panic "invalid invite/update code"))))) + + + +(define (get-event-image event-id) + "Return, as base64, the header image for `event-id'." + (call-with-input-file (format #f (%event-image-path-fmt) event-id) + (lambda (port) + (base64-encode (get-bytevector-all port))))) + +(define (render-event-invitation code) + (match-let* ((rsvp (exec-query conn "SELECT invitation_id, fullname, email, attending, guests FROM rsvps WHERE vanity = $1" (list code))) + (((invitation-code name email attending guests)) + (if (not (null? rsvp)) + rsvp + '((#f #f #f #f #f)))) + (invitation-code (or invitation-code code)) + (invitation (invitation->event-id invitation-code)) + (capabilities (cadr invitation)) + (((i_ title description date location)) + (exec-query conn "SELECT * FROM events WHERE id = $1" (list (car invitation)))) + (rsvps (exec-query conn "SELECT fullname, email, attending, guests FROM rsvps WHERE event_id = $1" (list (car invitation))))) + (values + "You've been invited to an event!" + `(div (@ (id "rsvp")) + (div (@ (id "event-info")) + (h1 ,title) + (img (@ (src ,(format #f "data:image/png;base64, ~a" (get-event-image (car invitation)))) + (style "float: right; margin: 16px;"))) + (p "Where: " ,location) + (p "When: " ,date) + (p ,@(cdr (xml->sxml (format #f "<div>~a</div>" description))))) + (form (@ (id "rsvp-input") + (action "/apps/rsvp") + (method "POST")) + (input (@ (type "text") + (hidden #t) + (name ,(if (not (null? rsvp)) "update" "id")) + (value ,code))) + (fieldset + (legend "Your Info") + + (label (@ (for "name")) "Name:") + (input (@ (type "text") + (id "name") + (name "name") + (required #t) + (size "24") + ,@(if name `((value ,name)) '()))) + + (label (@ (for "email")) "Email:") + (input (@ (type "text") + (id "email") + (name "email") + (required #t) + (size "24") + ,@(if email `((value ,email)) '())))) + + (fieldset + (legend "RSVP Status") + + (input (@ (type "radio") + (id "attending") + (value "attending") + (name "rsvp") + ,@(if (and attending (string= "attending" attending)) + '((checked ,#t)) + '()))) + (label (@ (for "attending")) "Attending") + + (input (@ (type "radio") + (value "tentative") + (id "tentative") + (name "rsvp") + ,@(if (and attending (string= "tentative" attending)) + '((checked ,#t)) + '()))) + (label (@ (for "tentative")) "Tentative") + + (input (@ (type "radio") + (value "not-attending") + (id "not-attending") + (name "rsvp") + ,@(if (and attending (string= "not-attending" attending)) + '((checked ,#t)) + '()))) + (label (@ (for "not-attending")) "Not Attending")) + + (fieldset + (legend "Guests") + + (label (@ (for "guest-names")) "Names:") + (input (@ (type "text") + (id "guest-names") + (name "guest-names") + (size "24") + ,@(if guests `((value ,guests)) '())))) + + (fieldset + (legend "All Set?") + (input (@ (type "submit") + (id "submit-form") + (value "Submit"))))) + + ,@(if (equal? capabilities "1") + `((h2 "Current RSVPs") + (table + ,@(map (match-lambda + ((name email attending guests) + `(tr (td ,name) (td ,email) (td ,guests) (td ,attending)))) + rsvps))) + `()))))) + +(define (get-event-invitation invitation-code) + "Handler for reading information about an event." + (let-values (((title content) (render-event-invitation invitation-code))) + (values '((content-type . (text/html))) + (sxml->html-string (theme #:title title #:content content))))) + +(define (get-event-info request body) + "Entry point to `get-event-receipt'/`get-event-invitation'." + (let* ((query-string (uri-query (request-uri request))) + (params (if query-string + (decode-form query-string) + '())) + (invitation-code (assoc-ref params "i")) + (receipt-code (assoc-ref params "r"))) + (unless (or receipt-code invitation-code) + (panic "missing invitation or receipt code")) + (unless (or (not receipt-code) (valid-receipt-code (car receipt-code))) + (panic "invalid receipt code")) + (unless (or (not invitation-code) (valid-invite-code (car invitation-code))) + (panic "invalid invitation code")) + + (cond (receipt-code (get-event-invitation (car receipt-code))) + (invitation-code (get-event-invitation (car invitation-code)))))) diff --git a/jakob/dynamic/capabilities/rsvp.scm b/jakob/dynamic/capabilities/rsvp.scm new file mode 100644 index 0000000..25f13b8 --- /dev/null +++ b/jakob/dynamic/capabilities/rsvp.scm @@ -0,0 +1,336 @@ +;;; 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 dynamic capabilities rsvp) + #:use-module (gcrypt base64) + #:use-module (haunt html) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #:use-module (jakob dynamic config) + #:use-module (jakob dynamic errors) + #:use-module (jakob dynamic util) + #:use-module (jakob theme) + #:use-module (json) + #:use-module (rnrs bytevectors) + #:use-module (squee) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (sxml simple) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:export (get-event-info post-event-rsvp)) + +;; How many bytes of entropy to use when generating vanity ID's. +(define %vanity-length (make-parameter 12)) + +;; Path where event header images are stored. +(define %event-image-path-fmt (make-parameter "/opt/jakob-dynamic/event-images/~a.png")) + +;; Global handle to the RSVP database. +(define conn (connect-to-postgres-paramstring (paramstring-for-dbname "jakob_rsvp"))) + + + +(define (generate-vanity-code) + "Generate a random vanity ID. + +A vanity ID is used in the RSVP system for creating unique URLs for invitations. +It is a base64 string, encoding `%vanity-length' bytes of randomness." + (define alphabet + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!@") + (call-with-input-file "/dev/urandom" + (lambda (port) + (let ((entropy (get-bytevector-n port (%vanity-length)))) + (list->string + (map (lambda (n) + (string-ref alphabet (remainder n (string-length alphabet)))) + (array->list entropy))))))) + +(define (valid-invite-code invitation) + "Check database to see if `invitation' exists." + (and (= (string-length invitation) (%vanity-length)) + (positive? + (length + (exec-query conn "SELECT * FROM invitations WHERE vanity = $1" + (list invitation)))))) + +(define (valid-receipt-code receipt) + "Check database to see if `receipt'." + (and (= (string-length receipt) (%vanity-length)) + (positive? + (length + (exec-query conn "SELECT * FROM rsvps WHERE vanity = $1" + (list receipt)))))) + + + +(define-record-type <rsvp-create> + (make-rsvp-create-parameters) + rsvp-create-parameters? + (invitation-code rsvp-create-code set-rsvp-create-code!) + (name rsvp-create-name set-rsvp-create-name!) + (email rsvp-create-email set-rsvp-create-email!) + (attending rsvp-create-attending set-rsvp-create-attending!) + (guests rsvp-create-guests set-rsvp-create-guests!)) + +(define (params->rsvp-create params) + "Parse `params', an alist, into a `<rsvp-create>'." + (let ((res (make-rsvp-create-parameters))) + (set-rsvp-create-code! res (assoc-value params "id")) + (set-rsvp-create-name! res (assoc-value params "name")) + (set-rsvp-create-email! res (assoc-value params "email")) + (set-rsvp-create-attending! res (assoc-value params "rsvp")) + (set-rsvp-create-guests! res (assoc-value params "guest-names")) + (if (any not + (list (rsvp-create-code res) + (rsvp-create-name res) + (rsvp-create-email res) + (rsvp-create-attending res) + (rsvp-create-guests res))) + #f + res))) + +(define (invitation->event-id vanity-code) + "For valid `vanity-code', find the corresponding event ID and capabilities." + (car + (exec-query conn "SELECT event_id, capabilities FROM invitations WHERE vanity = $1" + (list vanity-code)))) + + + +(define (render-event-rsvp-receipt receipt-code) + (let ((update-url (absolute-url (format #f "/apps/rsvp/event-info?r=~a" receipt-code)))) + `(div + (p "Thanks for registering! Please bookmark or save the following link:" + (a (@ (href ,update-url)) ,update-url)) + (p "This will enable you to update your RSVP later.")))) + +(define (create-new-event-rsvp params) + "Handler for RSVP'ing to an event." + (let ((params (params->rsvp-create params))) + (unless params + (panic "invalid form data")) + (unless (valid-invite-code (rsvp-create-code params)) + (panic "invalid invitation code")) + (let ((receipt-code (generate-vanity-code)) + (event-id (car (invitation->event-id (rsvp-create-code params))))) + (exec-query conn + "INSERT INTO rsvps (vanity, invitation_id, event_id, fullname, email, attending, guests) VALUES ($1, $2, $3, $4, $5, $6, $7)" + (list receipt-code + (rsvp-create-code params) + event-id + (rsvp-create-name params) + (rsvp-create-email params) + (rsvp-create-attending params) + (rsvp-create-guests params))) + (values '((content-type . (text/html))) + (sxml->html-string + (theme #:title "Thanks for RSVPing!" + #:content (render-event-rsvp-receipt receipt-code))))))) + + + +(define-record-type <rsvp-update> + (make-rsvp-update-parameters) + rsvp-update-parameters? + (invitation-code rsvp-update-code set-rsvp-update-code!) + (name rsvp-update-name set-rsvp-update-name!) + (email rsvp-update-email set-rsvp-update-email!) + (attending rsvp-update-attending set-rsvp-update-attending!) + (guests rsvp-update-guests set-rsvp-update-guests!)) + +(define (params->rsvp-update params) + "Parse `params', an alist, into a `<rsvp-update>'." + (let ((res (make-rsvp-update-parameters))) + (set-rsvp-update-code! res (assoc-value params "update")) + (set-rsvp-update-name! res (assoc-value params "name")) + (set-rsvp-update-email! res (assoc-value params "email")) + (set-rsvp-update-attending! res (assoc-value params "rsvp")) + (set-rsvp-update-guests! res (assoc-value params "guest-names")) + (if (any not + (list (rsvp-update-code res) + (rsvp-update-name res) + (rsvp-update-email res) + (rsvp-update-attending res) + (rsvp-update-guests res))) + #f + res))) + +(define (update-event-rsvp params) + "Handler for updating an RSVP to an event." + (let ((params (params->rsvp-update params))) + (unless params + (panic "invalid form data")) + (unless (valid-receipt-code (rsvp-update-code params)) + (panic "invalid recepit code")) + (exec-query conn + "UPDATE rsvps SET fullname = $2, email = $3, attending = $4, guests = $5 WHERE vanity = $1" + (list + (rsvp-update-code params) + (rsvp-update-name params) + (rsvp-update-email params) + (rsvp-update-attending params) + (rsvp-update-guests params))) + (values '((content-type . (text/html))) + (sxml->html-string + (theme #:title "Thanks for RSVPing!" + #:content (render-event-rsvp-receipt (rsvp-update-code params))))))) + + + +(define (post-event-rsvp request body) + "Entry point for RSVP create/update. We dispatch on the parameters." + (let ((form-data (decode-form body))) + (cond ((assoc-ref form-data "id") (create-new-event-rsvp form-data)) + ((assoc-ref form-data "update") (update-event-rsvp form-data)) + (else (panic "invalid invite/update code"))))) + + + +(define (get-event-image event-id) + "Return, as base64, the header image for `event-id'." + (call-with-input-file (format #f (%event-image-path-fmt) event-id) + (lambda (port) + (base64-encode (get-bytevector-all port))))) + +(define (render-event-invitation code) + (match-let* ((rsvp (exec-query conn "SELECT invitation_id, fullname, email, attending, guests FROM rsvps WHERE vanity = $1" (list code))) + (((invitation-code name email attending guests)) + (if (not (null? rsvp)) + rsvp + '((#f #f #f #f #f)))) + (invitation-code (or invitation-code code)) + (invitation (invitation->event-id invitation-code)) + (capabilities (cadr invitation)) + (((i_ title description date location)) + (exec-query conn "SELECT * FROM events WHERE id = $1" (list (car invitation)))) + (rsvps (exec-query conn "SELECT fullname, email, attending, guests FROM rsvps WHERE event_id = $1" (list (car invitation))))) + (values + "You've been invited to an event!" + `(div (@ (id "rsvp")) + (div (@ (id "event-info")) + (h1 ,title) + (img (@ (src ,(format #f "data:image/png;base64, ~a" (get-event-image (car invitation)))) + (style "float: right; margin: 16px;"))) + (p "Where: " ,location) + (p "When: " ,date) + (p ,@(cdr (xml->sxml (format #f "<div>~a</div>" description))))) + (form (@ (id "rsvp-input") + (action "/apps/rsvp") + (method "POST")) + (input (@ (type "text") + (hidden #t) + (name ,(if (not (null? rsvp)) "update" "id")) + (value ,code))) + (fieldset + (legend "Your Info") + + (label (@ (for "name")) "Name:") + (input (@ (type "text") + (id "name") + (name "name") + (required #t) + (size "24") + ,@(if name `((value ,name)) '()))) + + (label (@ (for "email")) "Email:") + (input (@ (type "text") + (id "email") + (name "email") + (required #t) + (size "24") + ,@(if email `((value ,email)) '())))) + + (fieldset + (legend "RSVP Status") + + (input (@ (type "radio") + (id "attending") + (value "attending") + (name "rsvp") + ,@(if (and attending (string= "attending" attending)) + '((checked ,#t)) + '()))) + (label (@ (for "attending")) "Attending") + + (input (@ (type "radio") + (value "tentative") + (id "tentative") + (name "rsvp") + ,@(if (and attending (string= "tentative" attending)) + '((checked ,#t)) + '()))) + (label (@ (for "tentative")) "Tentative") + + (input (@ (type "radio") + (value "not-attending") + (id "not-attending") + (name "rsvp") + ,@(if (and attending (string= "not-attending" attending)) + '((checked ,#t)) + '()))) + (label (@ (for "not-attending")) "Not Attending")) + + (fieldset + (legend "Guests") + + (label (@ (for "guest-names")) "Names:") + (input (@ (type "text") + (id "guest-names") + (name "guest-names") + (size "24") + ,@(if guests `((value ,guests)) '())))) + + (fieldset + (legend "All Set?") + (input (@ (type "submit") + (id "submit-form") + (value "Submit"))))) + + ,@(if (equal? capabilities "1") + `((h2 "Current RSVPs") + (table + ,@(map (match-lambda + ((name email attending guests) + `(tr (td ,name) (td ,email) (td ,guests) (td ,attending)))) + rsvps))) + `()))))) + +(define (get-event-invitation invitation-code) + "Handler for reading information about an event." + (let-values (((title content) (render-event-invitation invitation-code))) + (values '((content-type . (text/html))) + (sxml->html-string (theme #:title title #:content content))))) + +(define (get-event-info request body) + "Entry point to `get-event-receipt'/`get-event-invitation'." + (let* ((query-string (uri-query (request-uri request))) + (params (if query-string + (decode-form query-string) + '())) + (invitation-code (assoc-ref params "i")) + (receipt-code (assoc-ref params "r"))) + (unless (or receipt-code invitation-code) + (panic "missing invitation or receipt code")) + (unless (or (not receipt-code) (valid-receipt-code (car receipt-code))) + (panic "invalid receipt code")) + (unless (or (not invitation-code) (valid-invite-code (car invitation-code))) + (panic "invalid invitation code")) + + (cond (receipt-code (get-event-invitation (car receipt-code))) + (invitation-code (get-event-invitation (car invitation-code)))))) diff --git a/jakob/dynamic/captcha.scm b/jakob/dynamic/captcha.scm new file mode 100644 index 0000000..4407ae5 --- /dev/null +++ b/jakob/dynamic/captcha.scm @@ -0,0 +1,312 @@ +;;; 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 dynamic captcha) + #:use-module (gcrypt base16) + #:use-module (gcrypt base64) + #:use-module (gcrypt hash) + #:use-module (gcrypt random) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 iconv) + #:use-module (ice-9 iconv) + #:use-module (ice-9 local-eval) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module (ice-9 threads) + #:use-module (jakob dynamic errors) + #:use-module (json) + #:use-module (rnrs bytevectors) + #:use-module ((rnrs base) #:select (assert)) + #:use-module (rnrs conditions) + #:use-module (rnrs exceptions) + #:use-module (srfi-197) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-35) + #:export (make-queue + id-queue-free + id-queue-allocated + release-id! + dequeue-id! + + new-captcha! + validate-captcha! + make-captcha-challenge! + + validate-proof-of-work! + make-pow-challenge!)) + +(define-record-type <id-queue> + (make-id-queue mutex min-free-threshold free-ids allocated-ids) + id-queue? + (mutex id-queue-mutex) + (min-free-threshold id-queue-min-free-threshold) + (free-ids id-queue-free set-id-queue-free!) + (allocated-ids id-queue-allocated set-id-queue-allocated!)) + +(define* (make-queue n #:key (min-free-threshold 32)) + "Construct a stateful queue for tracking captcha IDs + +The parameter N specifies how many free IDs should initially be allocated. The +optional keyword argument MIN-FREE-THRESHOLD specifies when `dequeue-id!' should +iterate through the allocated list and free anything exceeding an +internally-defined `time-to-live-seconds'." + (make-id-queue (make-mutex) min-free-threshold (iota n) (list))) + +(define (append-to-free-queue! id queue) + "Add ID to the end of the free list of QUEUE" + (set-id-queue-free! + queue + (append! (id-queue-free queue) (list id)))) + +(define (remove-from-free-queue! id queue) + "Remove ID from the free list of QUEUE" + (set-id-queue-free! queue (delete! id (id-queue-free queue)))) + +(define (append-to-allocated-queue! id queue) + "Add ID to the end of the allocated list of QUEUE" + (set-id-queue-allocated! + queue + (append! (id-queue-allocated queue) (list (list id (current-time)))))) + +(define (remove-from-allocated-queue! id queue) + "Remove ID from the allocated list of QUEUE" + (set-id-queue-allocated! + queue + (filter! (lambda (x) (not (equal? id (car x)))) + (id-queue-allocated queue)))) + +(define (release-id! id queue) + "Release ID to the free list of QUEUE" + (with-mutex (id-queue-mutex queue) + (assert (find (lambda (x) (equal? id (car x))) (id-queue-allocated queue))) + (assert (not (member id (id-queue-free queue)))) + (append-to-free-queue! id queue) + (remove-from-allocated-queue! id queue))) + +(define (dequeue-id! queue) + "Draw a random ID from QUEUE and mark it as allocated" + (define time-to-live-seconds (* 20 60)) + (with-mutex (id-queue-mutex queue) + ;; Initial pass to "unintrusively" free any stale IDs. + (when (< (length (id-queue-free queue)) + (id-queue-min-free-threshold queue)) + (for-each + (match-lambda + ((id created-time) + (when (>= (- (time-second (current-time)) + (time-second created-time)) + time-to-live-seconds) + (remove-from-allocated-queue! id queue)))) + (list-copy (id-queue-allocated queue)))) + ;; If we're still over the threshold, we'll need to be more intrusive. + ;; Ideally, this is avoided by rate-limiting. + (when (< (length (id-queue-free queue)) + (id-queue-min-free-threshold queue)) + (let* ((to-take (- (id-queue-min-free-threshold queue) + (length (id-queue-free queue)))) + (to-free (map car (take (id-queue-allocated queue) to-take)))) + (set-id-queue-allocated! queue (drop (id-queue-allocated queue) to-take)) + (set-id-queue-free! queue (append! (id-queue-free queue) to-free)))) + (let* ((n (random (length (id-queue-free queue)))) + (id (list-ref (id-queue-free queue) n))) + (remove-from-free-queue! id queue) + (append-to-allocated-queue! id queue) + id))) + + + +(define proc-mutex (make-mutex)) +(define tex-challenge-id-queue (make-queue 1024)) +(define tex-challenges (make-hash-table 1024)) + +(define (random-term) + (match (random 5) + (0 `(* ,(+ 1 (random 10)) x)) + (1 `(* ,(+ 1 (random 10)) (expt x ,(random 10)))) + (2 `(* ,(+ 1 (random 10)) (exp x))) + (3 `(* ,(+ 1 (random 10)) (cos x))) + (4 `(* ,(+ 1 (random 10)) (sin x))))) + +(define (sexp->latex sexp) + (match sexp + (('+ rest ...) (string-join (map sexp->latex rest) " + ")) + (('* rest ...) (string-join (map sexp->latex rest) " \\cdot ")) + (('sin term) (format #f "\\sin(~a)" (sexp->latex term))) + (('cos term) (format #f "\\cos(~a)" (sexp->latex term))) + (('expt term n) (format #f "~a^{~a}" (sexp->latex term) (sexp->latex n))) + (('exp term) (format #f "e^{~a}" (sexp->latex term))) + ('x "x") + (n (cond ((and (number? n) (positive? n)) (format #f "~a" n)) + ((and (number? n) (negative? n)) (format #f "(~a)" n)) + ((number? n) "0") + (else (error "Do not know how to convert to latex." n)))))) + +(define (differentiate-sexp sexp) + (match sexp + (('+ rest ...) `(+ ,@(map differentiate-sexp rest))) + (('* coeff term) (if (number? coeff) + `(* ,coeff ,(differentiate-sexp term)) + (error "Do not know how to differentiate."))) + (('sin term) `(* ,(differentiate-sexp term) (cos ,term))) + (('cos term) `(* -1 ,(differentiate-sexp term) (sin ,term))) + (('exp term) `(* ,(differentiate-sexp term) (exp ,term))) + (('expt term n) `(* ,n (expt ,term ,(- n 1)))) + ('x 1) + (n (if (number? n) + 0 + (error "Do not know how to differentiate." n))))) + +(define (simplify-sexp sexp) + (match sexp + (('+ rest ...) `(+ ,@(map simplify-sexp rest))) + (('* 1 term) (simplify-sexp term)) + (('* 1 rest ...) (simplify-sexp `(* ,@rest))) + (('sin term) `(sin ,(simplify-sexp term))) + (('sin term) `(cos ,(simplify-sexp term))) + (('exp term) `(exp ,(simplify-sexp term))) + (('expt term 1) (simplify-sexp term)) + (('expt term n) `(expt ,(simplify-sexp term) ,(simplify-sexp n))) + (term term))) + +(define (random-expression) + (let ((n-terms (+ 2 (random 3)))) + `(+ ,@(map (lambda (x) (random-term)) (iota n-terms))))) + +(define (latex->image src) + (chdir "/tmp") + (with-mutex proc-mutex + (call-with-output-file "formula.tex" + (lambda (port) + (format port "\\def\\formula{~a} +\\documentclass[border=2pt]{standalone} +\\usepackage{amsmath} +\\usepackage{varwidth} +\\begin{document} +\\begin{varwidth}{\\linewidth} +\\[ \\formula \\] +\\end{varwidth} +\\end{document} +" src))) + (unless (eqv? 0 (status:exit-val (system "latex formula.tex"))) + (error "Cannot generate DVI" #f)) + (unless (eqv? 0 (status:exit-val (system "dvipng -D 300 formula.dvi"))) + (error "Cannot generate PNG" #f)) + (call-with-input-file "formula1.png" get-bytevector-all))) + +(define (new-captcha!) + (let* ((lower-bound (random 10)) + (upper-bound (+ lower-bound 1 (random 9))) + (expression (random-expression)) + (latex-src (sexp->latex (simplify-sexp (differentiate-sexp expression)))) + (solution (- (local-eval expression (let ((x upper-bound)) (the-environment))) + (local-eval expression (let ((x lower-bound)) (the-environment))))) + (id (dequeue-id! tex-challenge-id-queue))) + (hash-set! tex-challenges id solution) + (values id + (latex->image (format #f "\\int_{~a}^{~a} ~a \\, dx" + lower-bound + upper-bound + latex-src))))) + +(define deferred-queue-mutex (make-mutex)) +(define deferred-queue (list)) +(define maximum-free-captchas 16) + +(define (new-captcha-deferred!) + (define (repopulate-queue) + (let-values (((challenge-id image) (new-captcha!))) + (with-mutex deferred-queue-mutex + (set! deferred-queue (cons (list challenge-id image) deferred-queue))) + (unless (<= maximum-free-captchas (length deferred-queue)) + (repopulate-queue)))) + (call-with-new-thread repopulate-queue) + (with-mutex deferred-queue-mutex + (if (zero? (length deferred-queue)) + ;; High-pressure conditions; we're forced to generate one on the spot. + (new-captcha!) + ;; Otherwise, we can draw on work we did a while ago. + (let ((result (car deferred-queue))) + (set! deferred-queue (cdr deferred-queue)) + (apply values result))))) + +(define (validate-captcha! user-answer id) + (define epsilon 0.01) + (let ((solution (hash-ref tex-challenges id)) + (id-allocated (not (member id (id-queue-free tex-challenge-id-queue))))) + ;; FIXME: The predictable IDs means that its' easy for someone to screw with + ;; someone elses' captcha challenge (by invalidating it before they can + ;; submit it). Given the combination of our reaping algorithm and + ;; rate-limiting, does it make sense to only release the ID when the + ;; response is correct? + (when (and solution id-allocated) + (release-id! id tex-challenge-id-queue)) + (and solution + id-allocated + (<= (/ (abs (- solution (string->number user-answer))) + solution) + epsilon)))) + +(define (make-captcha-challenge! request body) + "API endpoint handler for requesting a captcha challenge" + (let-values (((challenge-id image) (new-captcha-deferred!))) + (values '((content-type . (application/json))) + (scm->json-string + `((challenge-id . ,challenge-id) + (image . ,(format #f "data:image/jpeg;charset=utf-8;base64,~a" + (base64-encode image)))))))) + + + +(define pow-challenge-id-queue (make-queue 1024)) +(define pow-challenges (make-hash-table 1024)) + +;; How many zeroes the SHA-256 hash has to be prefixed by to be a valid proof of work. +(define %hardness 4) + +(define (new-proof-of-work-challenge!) + (let ((id (dequeue-id! pow-challenge-id-queue)) + (challenge (base64-encode (gen-random-bv 32)))) + (hash-set! pow-challenges id challenge) + (values id challenge))) + +(define (validate-proof-of-work! prefix challenge-id) + (define zero-prefix (string-join (map (lambda (_) "0") (iota %hardness)) "")) + (when (member challenge-id (id-queue-free pow-challenge-id-queue)) + (panic "No such challenge ID")) + (let* ((challenge (hash-ref pow-challenges challenge-id)) + (hash-value (chain (list prefix challenge) + (string-concatenate _) + (string->bytevector _ "utf8") + (bytevector-hash _ (lookup-hash-algorithm 'sha256)) + (bytevector->base16-string _)))) + ;; Invariant from `unless' form: + ;; (not (member challenge-id (id-queue-free pow-challenge-id-queue))) + (when challenge + (release-id! challenge-id pow-challenge-id-queue)) + (and (= 32 (string-length prefix)) + (string-prefix? zero-prefix hash-value)))) + +(define (make-pow-challenge! request body) + "API endpoint handler for requesting a proof-of-work challenge" + (let-values (((challenge-id nonce) (new-proof-of-work-challenge!))) + (values '((content-type . (application/json))) + (scm->json-string + `((hardness . ,%hardness) + (challenge-id . ,challenge-id) + (nonce . ,nonce)))))) diff --git a/jakob/dynamic/config.scm b/jakob/dynamic/config.scm new file mode 100644 index 0000000..8fc9dea --- /dev/null +++ b/jakob/dynamic/config.scm @@ -0,0 +1,48 @@ +;;; 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 dynamic config) + #:export (%debug-enabled + %api-server-port + paramstring-for-dbname + absolute-url)) + +;; Whether or not to enable "debug mode", in which: +;; +;; - Log messages are written to stdout. +;; - Rate limiting is disabled. +(define %debug-enabled (make-parameter (or (getenv "API_SERVER_DEBUG") #f))) + +;; Port that the API server should listen on +(define %api-server-port (make-parameter (or (getenv "API_SERVER_PORT") 8080))) + +;; Should be fairly self-explanatory. +(define %postgresql-user (make-parameter (or (getenv "API_SERVER_DB_USER") "jakob_dynamic"))) +(define %postgresql-host (make-parameter (or (getenv "API_SERVER_DB_HOST") "localhost"))) +(define %postgresql-port (make-parameter (or (getenv "API_SERVER_DB_PORT") "5432"))) + +(define (paramstring-for-dbname dbname) + (format #f "host=~a port=~a user=~a dbname=~a" + (%postgresql-host) + (%postgresql-port) + (%postgresql-user) + dbname)) + +(define (absolute-url relative-path) + "Produce an absolute URL from the identifier RELATIVE-PATH" + (if (%debug-enabled) + (format #f "http://localhost:~a/~a" (%api-server-port) relative-path) + (string-append "https://jakob.space" relative-path))) diff --git a/jakob/dynamic/errors.scm b/jakob/dynamic/errors.scm new file mode 100644 index 0000000..05f9302 --- /dev/null +++ b/jakob/dynamic/errors.scm @@ -0,0 +1,39 @@ +;;; 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 dynamic errors) + #:use-module (rnrs conditions) + #:use-module (rnrs exceptions) + #:export (&reportable + + make-reportable-condition + reportable-condition? + + reportable-condition-code + reportable-condition-message + + panic)) + +;; Condition that can safely be presented to an API user +(define-condition-type &reportable &condition + make-reportable-condition + reportable-condition? + (code reportable-condition-code) + (message reportable-condition-message)) + +(define* (panic message #:key (code 400)) + "Raise MESSAGE as a &reportable condition" + (raise (condition (make-reportable-condition code message)))) diff --git a/jakob/dynamic/import-images.sh b/jakob/dynamic/import-images.sh new file mode 100644 index 0000000..23f6130 --- /dev/null +++ b/jakob/dynamic/import-images.sh @@ -0,0 +1,16 @@ +#!/usr/bin/env bash + +set -euo pipefail + +VANITY="$1" +shift + +for item in "$@"; do + filename=$(basename -- "$item") + extension="${filename##*.}" + filename="${filename%.*}" + uuid="$(uuidgen)" + cp "$item" "/home/jakob/gallery-images/$uuid.$extension" + convert "/home/jakob/gallery-images/$uuid.$extension" -thumbnail '100x100>' "/home/jakob/gallery-images/${uuid}_thumb.png" + psql jakob_gallery -c "INSERT INTO images (vanity, title, filename, thumb_filename, datetime) VALUES ('$VANITY', '$filename', '$uuid.$extension', '${uuid}_thumb.png', now());" +done diff --git a/jakob/dynamic/logging.scm b/jakob/dynamic/logging.scm new file mode 100644 index 0000000..c937c66 --- /dev/null +++ b/jakob/dynamic/logging.scm @@ -0,0 +1,39 @@ +;;; 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 dynamic logging) + #:use-module (ice-9 format) + #:use-module (jakob dynamic config) + #:use-module (srfi srfi-19) + #:export (log-append!)) + +(define %log-level (make-parameter 'info)) +(define %log-file-name + (make-parameter (if (%debug-enabled) "/dev/stdout" "/var/log/jakob-dynamic.log"))) + +(define (dominates message-level baseline-level) + "Determine if `a' should be shown for baseline log level `b'." + (define log-level-hierarchy '(debug info warn error)) + (>= (list-index log-level-hierarchy message-level) + (list-index log-level-hierarchy baseline-level))) + +(define (log-append! level message) + "Append `message', at `level', to the log buffer." + (when (dominates level (%log-level)) + (let ((output-port (open-file (%log-file-name) "a")) + (now (date->string (current-date) "~4"))) + (format output-port "[~a] ~a: ~a~%" now level message) + (close output-port)))) diff --git a/jakob/dynamic/rate-limiter.scm b/jakob/dynamic/rate-limiter.scm new file mode 100644 index 0000000..24239f6 --- /dev/null +++ b/jakob/dynamic/rate-limiter.scm @@ -0,0 +1,78 @@ +;;; 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 dynamic rate-limiter) + #:use-module (jakob dynamic errors) + #:use-module (jakob dynamic util) + #:use-module (json) + #:use-module (rnrs conditions) + #:use-module (rnrs exceptions) + #:use-module (srfi-197) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (web request) + #:use-module (web response) + #:export (rate-limit-wrap)) + +(define-record-type <requester-state> + (make-requester-state time request-bins) + requester-state? + (time requester-state-time) + (request-bins requester-state-bins)) + +(define active-rate-limits (make-hash-table)) + +(define (rate-limit-for-endpoint name) + (case name + ((put-reaction) 1) + ((get-event-rsvp) 1) + ((get-event-info) 8) + ((get-image) 8) + ((get-gallery) 8) + ((put-comment) 8) + ((get-comments) 1024) + (else 32))) + +(define (increment-key! hash-table key) + (let ((new-value (if (hash-ref hash-table key) + (+ 1 (hash-ref hash-table key)) + 1))) + (hash-set! hash-table key new-value))) + +(define (rate-limit-wrap proc) + (lambda (request body) + (unless (assoc-ref (request-headers request) 'x-forwarded-for) + (panic "X-Forwarded-For header not provided")) + (let ((endpoint-name (procedure-name proc)) + (requester (chain (assoc-ref (request-headers request) 'x-forwarded-for) + (string-split _ #\,) + (first _)))) + (unless (hash-ref active-rate-limits requester) + (hash-set! active-rate-limits + requester + (make-requester-state (current-time) (make-hash-table)))) + (increment-key! (requester-state-bins (hash-ref active-rate-limits requester)) endpoint-name) + ;; TODO: The `when' body is copy/pasted from above. I think this condition + ;; (time-based expiry) could be refactored. + (when (>= (current-time) + (+ (* 60 60) (requester-state-time (hash-ref active-rate-limits requester)))) + (hash-set! active-rate-limits + requester + (make-requester-state (current-time) (make-hash-table)))) + (when (and (> (hash-ref (requester-state-bins (hash-ref active-rate-limits requester)) endpoint-name) + (rate-limit-for-endpoint endpoint-name))) + (panic "Your IP address is currently being rate-limited." #:code 429)) + (proc request body)))) diff --git a/jakob/dynamic/schema-comments.sql b/jakob/dynamic/schema-comments.sql new file mode 100644 index 0000000..8519f4b --- /dev/null +++ b/jakob/dynamic/schema-comments.sql @@ -0,0 +1,18 @@ +CREATE TABLE comments( + id SERIAL PRIMARY KEY, + approved TIMESTAMP, + submitted TIMESTAMP NOT NULL, + slug VARCHAR(100) NOT NULL, + name VARCHAR(50) NOT NULL, + subject VARCHAR(100), + email VARCHAR(100), + url VARCHAR(100), + comment VARCHAR(1024) NOT NULL, + reactions VARCHAR(1024), + reply_to INT, + originating_network VARCHAR(100) +); + +-- Use `now' for `submitted'. + +-- INSERT INTO comments (submitted, slug, name, comment) VALUES (now(), 'test', 'Jakob', 'Hello, world!'); diff --git a/jakob/dynamic/schema-gallery.sql b/jakob/dynamic/schema-gallery.sql new file mode 100644 index 0000000..bad4100 --- /dev/null +++ b/jakob/dynamic/schema-gallery.sql @@ -0,0 +1,18 @@ +CREATE TABLE IF NOT EXISTS galleries ( + id SERIAL, + vanity char(12) NOT NULL, + title varchar(128), + description varchar(4096) NOT NULL, + datetime timestamp with time zone NOT NULL, + PRIMARY KEY (id) +); + +CREATE TABLE IF NOT EXISTS images ( + id SERIAL, + vanity char(12) NOT NULL, + title varchar(128), + filename varchar(64) NOT NULL, + thumb_filename varchar(64) NOT NULL, + datetime timestamp with time zone NOT NULL, + PRIMARY KEY (id) +); diff --git a/jakob/dynamic/schema-poll.sql b/jakob/dynamic/schema-poll.sql new file mode 100644 index 0000000..b15bdbd --- /dev/null +++ b/jakob/dynamic/schema-poll.sql @@ -0,0 +1,27 @@ +CREATE TABLE IF NOT EXISTS polls ( + id SERIAL, + title varchar(128) NOT NULL, + description varchar(16384) NOT NULL, + datetime timestamp with time zone NOT NULL, + questions varchar(16384) NOT NULL, + PRIMARY KEY (id) +); + +CREATE TABLE IF NOT EXISTS invitations ( + id SERIAL, + vanity char(12) NOT NULL, + comments varchar(1024) NOT NULL, + created_on timestamp with time zone default current_timestamp, + poll_id integer NOT NULL, + PRIMARY KEY (id) +); + +CREATE TABLE IF NOT EXISTS responses ( + id SERIAL, + invitation_code char(12) NOT NULL, + poll_id bigint NOT NULL, + response varchar(16384) NOT NULL, + PRIMARY KEY (id) +); + +-- `questions` and `response` are s-expressions. diff --git a/jakob/dynamic/schema-rsvp.sql b/jakob/dynamic/schema-rsvp.sql new file mode 100644 index 0000000..3e6a21f --- /dev/null +++ b/jakob/dynamic/schema-rsvp.sql @@ -0,0 +1,34 @@ +CREATE TABLE IF NOT EXISTS events ( + id SERIAL, + title varchar(128) NOT NULL, + description varchar(16384) NOT NULL, + datetime timestamp with time zone NOT NULL, + location varchar(128) NOT NULL, + PRIMARY KEY (id) +); + +CREATE TABLE IF NOT EXISTS invitations ( + id SERIAL, + vanity char(12) NOT NULL, + comments varchar(1024) NOT NULL, + created_on timestamp with time zone default current_timestamp, + capabilities bigint NOT NULL, + event_id integer NOT NULL, + PRIMARY KEY (id) +); + +CREATE TABLE IF NOT EXISTS rsvps ( + id SERIAL, + vanity char(12) NOT NULL, + invitation_id char(12) NOT NULL, + event_id bigint NOT NULL, + fullname varchar(128) NOT NULL, + email varchar(256) NOT NULL, + guests varchar(1024) NOT NULL, + attending varchar(32) NOT NULL, + PRIMARY KEY (id) +); + +-- `rsvps` contains the bare minimum. If we later decide we need additional +-- fields, we'll have an additional table mapping events.id to attribute names +-- and rsvps.id to attribute values. diff --git a/jakob/dynamic/util.scm b/jakob/dynamic/util.scm new file mode 100644 index 0000000..e34ae91 --- /dev/null +++ b/jakob/dynamic/util.scm @@ -0,0 +1,133 @@ +;;; 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 dynamic util) + #:use-module (ice-9 match) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (web request) + #:use-module (web uri) + #:export (assoc-value + acons-normalize + base64-length + decode-form + date<? + hash-append! + emoji? + from-tor? + from-i2p? + from-darknet?)) + +(define (assoc-value alist key) + "Return the `car' of `(assoc alist key)' if truthy" + (let ((result (assoc-ref alist key))) + (if result (car result) result))) + +(define (acons-list k v alist) + "Add V to K to alist as list" + (let ((value (assoc-ref alist k))) + (if value + (let ((alist (alist-delete k alist))) + (acons k (cons v value) alist)) + (acons k (list v) alist)))) + +(define (acons-normalize key value alist) + "Add KEY -> VALUE to ALIST such that no entries for KEY are duplicates" + (cons (cons key value) + (filter (lambda (pair) (not (equal? (car pair) key))) alist))) + +(define (list->alist lst) + "Build a alist of list based on a list of key and values. + + Multiple values can be associated with the same key" + (let next ((lst lst) + (out '())) + (if (null? lst) + out + (next (cdr lst) (acons-list (caar lst) (cdar lst) out))))) + +(define (decode-form bv) + "Convert BV querystring or form data to an alist" + (define string (if (string? bv) bv (utf8->string bv))) + (define pairs (map (cut string-split <> #\=) + ;; semi-colon and amp can be used as pair separator + (append-map (cut string-split <> #\;) + (string-split string #\&)))) + (list->alist (map (match-lambda + ((key value) + (cons (uri-decode key) (uri-decode value)))) pairs))) + +(define (base64-length n) + "The length of the base64 string encoding `n' bytes." + (inexact->exact (* 4 (ceiling (/ n 3.0))))) + +(define (date<? d1 d2) + "Return #t if D2 specifies a later date than D1" + (time<? (date->time-utc d1) (date->time-utc d2))) + +(define (hash-append! table key item) + "Append ITEM to the list specified by KEY in TABLE + +If KEY does not exist in TABLE, initialize kEY to (list ITEM)" + (if (hash-ref table key) + (hash-set! table key (cons item (hash-ref table key))) + (hash-set! table key (list item)))) + +(define (emoji? str) + "Determine if `str' is an 'acceptable' emoji character + +Acceptable is the following subset: + +- The 'Emoticons' block +- The 'Supplemental Symbols and Pictographs' block, excluding U+1F900 + through U+1F90B +- The hand symbols from the 'Miscellaneous Symbols and Pictographs' + block +- The hand symbols from the 'Dingbats' block +- U+1F37B and U+1F440 + +Notably, U+1F946 isn't normally treated an emoji, but it is here. I +think it should be! As an American, I should be able to use pictographs +to express my God-given constitutional rights!" + (and (string? str) + (= 1 (string-length str)) + (let ((codepoint (char->integer + (first (string->list str))))) + (or (<= #x1F600 codepoint #x1F64F) + (<= #x1F90C codepoint #x1F9FF) + (<= #x1F446 codepoint #x1F450) + (<= #x270A codepoint #x270D) + (= codepoint #x1F37B) + (= codepoint #x1F440))))) + +(define (from-tor? request) + "Return whether or not REQUEST was sent by the Tor daemon" + (let ((originating-ip (assoc-ref (request-headers request) 'x-forwarded-for))) + (or (string=? "127.0.0.1" originating-ip) + (string=? "::1" originating-ip)))) + +(define (from-i2p? request) + "Return whether or not REQUEST was sent by i2pd" + (let ((originating-ip (assoc-ref (request-headers request) 'x-forwarded-for))) + (and (or (string-prefix? "127." originating-ip) + (string-suffix? ":1" originating-ip)) + (not (from-tor? request))))) + +(define (from-darknet? request) + "Return whether or not REQUEST was sent by a darknet tunnel" + (or (from-tor? request) (from-i2p? request))) diff --git a/jakob/reader/html-prime.scm b/jakob/reader/html-prime.scm new file mode 100644 index 0000000..417249e --- /dev/null +++ b/jakob/reader/html-prime.scm @@ -0,0 +1,46 @@ +;;; 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: +;;; +;;; Temporary reader containing my changes to 'html-reader'. This module will +;;; remain until Haunt sees another release and, thus, the fixes are available. +;;; +;;; Code: + +(define-module (jakob reader html-prime) + #:use-module (haunt post) + #:use-module (haunt reader) + #:use-module (ice-9 match) + #:use-module (jakob utils sxml) + #:use-module (srfi srfi-26) + #:use-module (sxml simple) + #:export (html-reader-prime)) + +(define (read-html-post-prime port) + (values (read-metadata-headers port) + (let loop ((ret '())) + (catch 'parser-error + (lambda () + (match (xml->sxml port) + (('*TOP* sxml) (loop (cons sxml ret))))) + (lambda (key . parameters) + (rewrite-absolute-urls-as-relative + (reverse ret))))))) + +(define html-reader-prime + (make-reader (make-file-extension-matcher "html") + (cut call-with-input-file <> read-html-post-prime))) diff --git a/jakob/reader/org-mode-prime.scm b/jakob/reader/org-mode-prime.scm new file mode 100644 index 0000000..118f1a6 --- /dev/null +++ b/jakob/reader/org-mode-prime.scm @@ -0,0 +1,36 @@ +;;; Copyright © 2019 - 2024 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: +;;; +;;; Wrapper around the `org-mode-reader' to apply rewrite rules specific to my +;;; website. +;;; +;;; Code: + +(define-module (jakob reader org-mode-prime) + #:use-module (haunt reader) + #:use-module (jakob reader org-mode) + #:use-module (jakob utils sxml) + #:use-module (srfi srfi-11) + #:export (org-mode-reader-prime)) + +(define org-mode-reader-prime + (make-reader (reader-matcher org-mode-reader) + (lambda args + (let-values (((metadata sxml) (apply (reader-proc org-mode-reader) args))) + (values metadata + (rewrite-absolute-urls-as-relative sxml)))))) diff --git a/jakob/reader/org-mode.scm b/jakob/reader/org-mode.scm new file mode 100644 index 0000000..b55dbf3 --- /dev/null +++ b/jakob/reader/org-mode.scm @@ -0,0 +1,188 @@ +;;; Copyright © 2019 - 2024 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: +;;; +;;; Reader for Org syntax which invokes `org-export' via the Emacs daemon for +;;; rendering and metadata extraction. +;;; +;;; The choice to leverage Emacs, rather than writing a parser in Guile, was +;;; made because it enabled us to leverage other Emacs facilities such as +;;; `font-lock' and `htmlize' for syntax highlighting. +;;; +;;; Code: + +(define-module (jakob reader org-mode) + #:use-module (haunt reader) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module (ice-9 textual-ports) + #:use-module (jakob utils) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (srfi-197) + #:use-module (sxml simple) + #:export (render-org-mode-file + extract-org-mode-metadata + org-mode-reader)) + +;; Directory to store cached artifacts in. +;; +;; Caching is disabled if this is `#f'. +(define %cache-directory + (make-parameter (if (getenv "HAUNT_ORG_READER_DISABLE_CACHE") + #f + (or (getenv "HAUNT_ORG_READER_CACHE_DIR") + "./.org-mode-reader-cache/")))) + +;; File name of Elisp script to execute before anything else +(define %additional-emacs-preamble + (make-parameter (getenv "HAUNT_ORG_READER_EMACS_PREAMBLE"))) + +;; Additional Org-mode keywords to include in the extracted metadata. +(define %additional-keys + (make-parameter '("CROSSPOST" "SCRIPTS" "META-TAGS"))) + +;; Whether to use a running Emacs daemon to evaluate elisp forms. +(define %use-emacsclient + (make-parameter (getenv "HAUNT_ORG_READER_USE_EMACSCLIENT"))) + +(define (eval-in-emacs form) + "Evaluate s-exp FORM in Emacs and return the result + +If `%use-emacsclient' is truthy, evaluate FORM in the current running Emacs +daemon. Assumes that FORM does not write to `standard-output'." + (let* (;; If `HAUNT_ORG_READER_PREAMBLE' is specified, load that. + (form (if (%additional-emacs-preamble) + `(progn + (load-file ,(%additional-emacs-preamble)) + ,form) + form)) + ;; We need to explicitly request that Emacs write the result if using + ;; Emacs batch mode (which is how we evaluate forms without + ;; `emacsclient'.) + (form (if (not (%use-emacsclient)) + `(print ,form) + form)) + (stringified (call-with-output-string (cut write form <>))) + (port (if (%use-emacsclient) + (open-pipe* OPEN_READ "emacsclient" "-e" stringified) + (open-pipe* OPEN_READ "emacs" "--batch" "--eval" stringified))) + (result (read port)) + ;; The symbol `nil' doesn't have the same semantics in Scheme, so we'll + ;; convert it to the empty list. + (result (if (eqv? result 'nil) + '() + result))) + (if (eqv? 0 (status:exit-val (close-pipe port))) + result + (error "could not eval" form)))) + +(define (render-org-mode-file file-name) + "Export FILE-NAME as an HTML document string" + (define output-file-name (tmpnam)) + (define result + (eval-in-emacs + `(save-excursion + (load-file "./emacs-htmlize/htmlize.el") + (setq org-html-htmlize-output-type 'css) + (let ((enable-local-variables :all)) + (set-buffer (find-file-noselect ,file-name))) + (setq-local org-export-filter-latex-fragment-functions + (list (lambda (data backend channel) + (org-html-encode-plain-text data)))) + (let ((result (org-export-as 'html nil nil t))) + (with-temp-buffer + (insert result) + (write-region (point-min) (point-max) ,output-file-name)))))) + (define parsed (call-with-input-file output-file-name get-string-all)) + (delete-file output-file-name) + ;; We wrap in a `div' because when we call `xml->sxml' later on in + ;; `read-org-mode-post-fresh', it is expecting a single element. + (format #f "<div>~a</div>" parsed)) + +(define (extract-org-mode-metadata-raw file-name) + (map (match-lambda + ((key value) `(,(string->symbol (string-downcase key)) . ,value))) + (eval-in-emacs + `(save-excursion + (let ((enable-local-variables :all)) + (set-buffer (find-file-noselect ,file-name))) + (org-collect-keywords ',(append '("TITLE" "DATE" "TAGS") + (%additional-keys))))))) + +(define (parse-metadata metadata-alist) + (chain metadata-alist + (assq-map! _ 'date (cut string->date <> "<~Y-~m-~d ~a ~H:~M>")) + (assq-map! _ 'tags (cut string-split <> #\space)))) + +;; This is the public-facing interface. Because dates aren't serializable with +;; `write', the internal interface has extraction and parsing broken out into +;; separate procedures. +(define (extract-org-mode-metadata file-name) + "Parse the metadata out of FILE-NAME as an alist" + (chain file-name + (extract-org-mode-metadata-raw _) + (parse-metadata _))) + +(define (metadata-file-name hash) + (string-append (%cache-directory) + file-name-separator-string + hash + "-metadata")) +(define (sxml-file-name hash) + (string-append (%cache-directory) + file-name-separator-string + hash + "-sxml")) + +(define (read-org-mode-post-cached hash) + (values (parse-metadata (call-with-input-file (metadata-file-name hash) read)) + (call-with-input-file (sxml-file-name hash) read))) + +(define (read-org-mode-post-fresh hash file-name) + (let ((metadata (extract-org-mode-metadata-raw file-name)) + (sxml (match (call-with-input-string (render-org-mode-file file-name) xml->sxml) + (('*TOP* ('div sxml ...)) sxml)))) + (when (%cache-directory) + (call-with-output-file (metadata-file-name hash) (cut write metadata <>)) + (call-with-output-file (sxml-file-name hash) (cut write sxml <>))) + (values (parse-metadata metadata) sxml))) + +(define (read-org-mode-post file-name) + (define hash + (let* ((port (open-pipe* OPEN_READ "md5sum" file-name)) + (result (string-trim-both (get-string-all port)))) + (unless (eqv? 0 (status:exit-val (close-pipe port))) + (error "cannot hash file")) + (first (string-split result #\ )))) + (when (%cache-directory) + (cond ((and (file-exists? (%cache-directory)) + (not (eqv? 'directory (stat:type (stat (%cache-directory)))))) + (error "cache directory exists but is not a directory" + (%cache-directory))) + ((not (file-exists? (%cache-directory))) + (mkdir (%cache-directory))))) + (if (and (%cache-directory) + (file-exists? (metadata-file-name hash)) + (file-exists? (sxml-file-name hash))) + (read-org-mode-post-cached hash) + (read-org-mode-post-fresh hash file-name))) + +(define org-mode-reader + (make-reader (make-file-extension-matcher "org") + read-org-mode-post)) diff --git a/jakob/theme.scm b/jakob/theme.scm new file mode 100644 index 0000000..b5b817d --- /dev/null +++ b/jakob/theme.scm @@ -0,0 +1,129 @@ +;;; 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 theme) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:use-module (jakob utils sxml) + #:export (theme)) + + +;;; +;;; SHTML generation in the site's theme. +;;; + +(define %stylesheets '("normalize.css" "fonts.css" "highlight.css" "style.css")) +(define %link-rel '(("alternate" "/feed.xml" "application/atom+xml") + ("icon" "/static/image/favicon.ico" "image/vnd.microsoft.icon") + ("me" "https://social.jakob.space/jakob") + ("webmention" "https://webmention.io/jakob.space/webmention") + ("pingback" "https://webmention.io/jakob.space/xmlrpc") + ("pgpkey authn" "/static/gpg.txt"))) +(define %nav-bar-tabs '(("About" "/pages/about.html") + ("Tags" "/tag.html") + ("More ▼" "#" + ("Blogroll" "/blogroll/") + ("Bookmarks" "/bookmark/") + ("Changelog" "/pages/changelog.html")))) + +(define %title "Jakob's Personal Webpage") + +(define (format-nav-item item-content) + (let* ((anchor-element (apply hyperlink (reverse (take item-content 2)))) + (children (drop item-content 2))) + (if (null? children) + `(li ,anchor-element) + `(li (@ (class "drop-parent")) + ,anchor-element + (ul (@ (class "drop-menu")) + ,@(map format-nav-item children)))))) + +(define %header + `(header + ,(hyperlink "/" (image "lambda.svg" "home")) + (nav (ul + ,@(map format-nav-item %nav-bar-tabs))))) + +(define %footer + `(footer + (div + (p "© 2015 - 2024 Jakob L. Kreuze") + ,(image "cc-by-sa-4.0.png" + "Creative Commons Attribution-ShareAlike 4.0 International (CC +BY-SA 4.0) Logo")) + (p "Unless otherwise specified, the text and images on this site are free +culture works available under the " + ,(hyperlink "https://creativecommons.org/licenses/by-sa/4.0/" + "Creative Commons Attribution Share-Alike 4.0 +International") + " license.") + (p "This website is built with " + ,(hyperlink "http://haunt.dthompson.us/" "Haunt") + ", a static site generator written in " + ,(hyperlink "https://gnu.org/software/guile" "Guile Scheme") + ". The source code is available " + ,(hyperlink "https://git.sr.ht/~jakob/blog" "here") + ".") + (p (a (@ (href "/pages/weblabels.html") (rel "jslicense")) + "JavaScript license information")))) + +(define* (theme #:key + (title '()) + (description "") + (keywords '()) + (meta '()) + (scripts '()) + (content '(div ""))) + "Return an SHTML document using the website's theme." + `((doctype "html") + (html + (@ (lang "en")) + + (head + ,(if (null? title) + `(title %title) + `(title ,(string-join (list title %title) " — "))) + + (meta (@ (charset "utf-8"))) + (meta (@ (name "keywords") (content ,(string-join keywords ", ")))) + (meta (@ (name "description") (content ,description))) + (meta (@ (name "language") (content "EN"))) + (meta (@ (name "viewport") (content "width=device-width, initial-scale=1.0"))) + (meta (@ (name "HandheldFriendly") (content "True"))) + + (meta (@ (name "author") (content "Jakob L. Kreuze"))) + (meta (@ (name "subject") (content "Personal website of Jakob L. Kreuze"))) + (meta (@ (name "medium") (content "blog"))) + + (meta (@ (name "og:title") (content ,title))) + + ,@(map (match-lambda + ((name . content) + `(meta (@ (name ,name) (content ,content))))) + meta) + + ,@(map (lambda (file-name) (stylesheet file-name)) %stylesheets) + + ,@(map (match-lambda + ((rel href) `(link (@ (rel ,rel) (href ,href)))) + ((rel href type) `(link (@ (rel ,rel) (href ,href) (type ,type))))) + %link-rel)) + + (body + ,%header + ,content + ,@scripts + ,%footer)))) diff --git a/jakob/utils.scm b/jakob/utils.scm new file mode 100644 index 0000000..ad35f4c --- /dev/null +++ b/jakob/utils.scm @@ -0,0 +1,108 @@ +;;; 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) + #:use-module (haunt post) + #:use-module (ice-9 match) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:export (assq-map! + maybe-cons* + maybe-list + date->string* + intersperse + first-paragraph + description-from-post + + elide-string)) + +(define (assq-map! alist key fn) + "Destructively apply FN to KEY in ALIST, if it exists" + (match (assq-ref alist key) + (#f alist) + (val (assq-set! alist key (fn val))))) + +(define (maybe-list . args) + "Create a list of all ARGS that are neither #f nor unspecified." + (remove (lambda (element) + (or (not element) (unspecified? element))) + args)) + +(define (maybe-cons* . args) + "Cons all ARGS that are neither #f nor unspecified." + (apply cons* (apply maybe-list args))) + +(define (date->string* date) + "Convert DATE to human readable string." + (date->string date "~a ~d ~B ~Y")) + +(define (intersperse lst delim) + "Return the elements of LST delimited by DELIM, such that the resultant list +is of an odd length and every second element is DELIM." + (if (<= (length lst) 1) + lst + (cons* (car lst) + delim + (intersperse (cdr lst) delim)))) + +(define (remove-footnote-references content) + "Remove any <sup> elements from CONTENT." + (map (lambda (elt) + (if (list? elt) + (remove-footnote-references elt) + elt)) + (remove (lambda (elt) + (and (list? elt) (eq? 'sup (car elt)))) + content))) + +(define (first-paragraph post) + (let loop ((sxml (post-sxml post))) + (match sxml + (((and ('p content ...) paragraph) . tail) + (remove-footnote-references paragraph)) + ((head . tail) (loop tail))))) + +(define (description-from-post post) + (define (first-elem sxml) + (if (and (list? sxml) (positive? (length sxml))) + (if (symbol? (first sxml)) + sxml + (let ((reduced (remove null? (map first-elem sxml)))) + (if (positive? (length reduced)) + (first reduced) + '()))) + '())) + (define (collect-strings elt res) + (cond ((null? elt) res) + ((string? (car elt)) (collect-strings (cdr elt) (cons (car elt) res))) + ((list? (car elt)) (if (and (positive? (length (car elt))) + (not (eq? '@ (caar elt)))) + (let ((nested (collect-strings (car elt) (list)))) + (collect-strings (cdr elt) (append nested res))) + (collect-strings (cdr elt) res))) + (else (collect-strings (cdr elt) res)))) + (let* ((sxml (first-paragraph post)) + (extracted (collect-strings (first-elem sxml) (list)))) + (string-join (map string-trim-both (reverse extracted)) " "))) + +(define (elide-string s len) + "Return S elided to be at most LEN characters" + (when (< len 3) (error "LEN cannot be smaller than 3")) + (if (<= (string-length s) len) + s + (string-append (string-take s (floor/ (- len 3) 2)) + "..." + (string-take-right s (ceiling/ (- len 3) 2))))) 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)) |