diff options
43 files changed, 2399 insertions, 590 deletions
@@ -1,3 +1,4 @@ +.stfolder publish.sh /haunt/images/* diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 0000000..c94555d --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "ext-srfi-197"] + path = haunt/ext-srfi-197 + url = https://github.com/ar-nelson/srfi-197 diff --git a/dynamic/README.md b/dynamic/README.md deleted file mode 100644 index 0f64827..0000000 --- a/dynamic/README.md +++ /dev/null @@ -1,16 +0,0 @@ -# Dynamic API for jakob.space - -This is a Guile back-end for all dynamic capabilities on jakob.space. It is -assumed that the web server proxies all requests matching a `/api` prefix to -this server. - -## Dependencies - -Depending on who you ask, the package management situation for Guile is either -disappointing, or a pleasant reminder of simpler times. This module leverages -two Guile modules which, to my knowledge, are not packaged in the typical Guile -extension fashion. The respective `.scm` files will need to be downloaded and -added to Guile load path. - -- [base64 from guile-lib](https://github.com/jacobrec/guile-lib/blob/master/base64.scm) -- [squee](https://notabug.org/cwebber/guile-squee/) diff --git a/dynamic/capabilities/comments.scm b/dynamic/capabilities/comments.scm deleted file mode 100644 index d7dc1fa..0000000 --- a/dynamic/capabilities/comments.scm +++ /dev/null @@ -1,40 +0,0 @@ -;;; Copyright © 2019 - 2022 Jakob L. Kreuze <zerodaysfordays@sdf.org> -;;; -;;; This program is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; <http://www.gnu.org/licenses/>. - -(define challenges (make-hash-table)) -(define conn (connect-to-postgres-paramstring "dbname=jakob_comments")) - -(define (get-comments request body) - (values '((content-type . (application/json))) - (scm->json-string - '((title . "whoa buddy") - (author . "Jakob Kreuze") - (date . "2022-03-27") - (text . "bad take, bad take!"))))) - -(define (put-comment request body) - (display (decode-form body)) - (newline) - (values '((content-type . (text/plain))) "Hello hacker!")) - -(define (make-challenge request body) - (let-values (((uuid value image) (new-captcha))) - (hash-set! challenges uuid value) - (hash-for-each (lambda (x y) (display x) (newline)) challenges) - (values `((content-type . (application/base64)) - (access-control-allow-origin . "*") - (x-captcha-id . ,uuid)) - (base64-encode image)))) diff --git a/dynamic/captcha.scm b/dynamic/captcha.scm deleted file mode 100644 index f3564a5..0000000 --- a/dynamic/captcha.scm +++ /dev/null @@ -1,123 +0,0 @@ -;;; Copyright © 2019 - 2022 Jakob L. Kreuze <zerodaysfordays@sdf.org> -;;; -;;; This program is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; <http://www.gnu.org/licenses/>. - -(define-module (captcha) - #:use-module (ice-9 binary-ports) - #:use-module (ice-9 local-eval) - #:use-module (ice-9 match) - #:use-module (ice-9 popen) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 threads) - #:use-module (srfi srfi-1) - #:export (new-captcha)) - -(define proc-mutex (make-mutex)) - -(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."))))) - -(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 "pdflatex formula.tex"))) - (error "Cannot generate PDF")) - (let* ((port (open-input-pipe "convert -density 300 formula.pdf -quality 90 png:-")) - (data (get-bytevector-all port))) - (unless (eqv? 0 (status:exit-val (close-pipe port))) - (error "Cannot generate PNG")) - data))) - -(define (new-uuid) - (with-mutex proc-mutex - (let* ((port (open-input-pipe "uuidgen")) - (str (read-line port))) - (close-pipe port) - str))) - -(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))))) - (values (new-uuid) - (- (local-eval expression (let ((x upper-bound)) (the-environment))) - (local-eval expression (let ((x lower-bound)) (the-environment)))) - (latex->image (format #f "\\int_{~a}^{~a} ~a \\, dx" - lower-bound - upper-bound - latex-src))))) diff --git a/haunt/README.md b/haunt/README.md new file mode 100644 index 0000000..d655bb5 --- /dev/null +++ b/haunt/README.md @@ -0,0 +1,217 @@ +# The Personal Website of Jakob L. Kreuze + +This repository contains the source code for my personal website. In particular: + +- The Haunt configuration +- The Guile API server implementing all of the website's dynamic functionality +- Org source files for all of the articles published on the website + +The first two are under `haunt/`, and the last is under `org/`. + +## Building + +My website is, in theory, reproducible. +If you find that to not be the case, please let me know. + +### Dependencies + +- GNU Guile `>= 2.2.7` +- `haunt == 0.2.4` +- `guile-commonmark >= 0.1.2` +- `guile-gcrypt >= 0.3.0` +- `guile-json >= 4.7.2` +- `git` + +### Articles + +Posts must be compiled before the website can be built (otherwise `haunt/posts` is unpopulated). + +1. Install [ox-haunt](https://git.sr.ht/~jakob/ox-haunt). +2. `(setq ox-haunt-images-dir "./haunt/static/image/")` +2. For every `$article` in `ls org/*/*.org`, + 1. `M-x find-file RET $article` + 2. `M-x org-export-dispatch RET s h` + +### Website + +When all of the articles have been compiled, the website can be built by running `haunt build` in the `haunt/` directory. +When `haunt build` completes, the output will be at `haunt/site/`. + +## Deploying + +Recommend using `rsync -azv --delete --progress haunt/site/ [DESTINATION]` to update the static components on a remote. + +The following OpenRC service will manage the API server: + +```sh +#!/sbin/openrc-run + +command="/usr/bin/guile" +command_args="-L ${JAKOB_API_DIR} ${JAKOB_API_DIR}/api.scm" +command_background=true +command_user="${JAKOB_API_USER}:${JAKOB_API_GROUP}" + +pidfile="/run/${RC_SVCNAME}.pid" + +depend() { + need net +} +``` + +A sample `/etc/conf.d/jakob-api`: + +```sh +JAKOB_API_DIR=/opt/jakob-api/ +JAKOB_API_USER=jakob-api +JAKOB_API_GROUP=jakob-api +``` + +Ideas for a better name are appreciated 🙂 + +Before running the API server, the following databases will need to be created: + +- `jakob_rsvp` + - Initialized with `haunt/jakob/dynamic/schema-rsvp.sql` +- `jakob_gallery` + - Initialized with `haunt/jakob/dynamic/schema-gallery.sql` +- `jakob_comments` + - Initialized with `haunt/jakob/dynamic/schema-comments.sql` + +### Dependencies + +- GNU Guile `>= 2.2.7` +- `guile-gcrypt >= 0.3.0` +- `guile-json >= 4.7.2` +- `latex` and `dvipng` +- PostgreSQL `>= 14.0` + +[squee](https://notabug.org/cwebber/guile-squee/) is currently vendored at `haunt/squee.scm`. + +**TODO**: Should we package `squee` for Gentoo? Or use something more standard? I don't like vendoring code. + +## API + +Dynamic capabilities such as comments are implemented by the Guile API server (`haunt/api.scm`). +It is assumed that the web server proxies all requests matching a `/api` prefix to this server. +By default, the API server runs on port `8081`. + +**TODO**: "By default" implies that it's configurable without modifying the source code. It should be configurable. That shouldn't be a hard lift. + +### Comments + +#### Proof of Work + +Used to generate a transient proof-of-work challenge. + +**URL** : `/api/challenge/proof-of-work` + +**Method** : `GET` + +**Auth required** : NO + +**Data constraints** : NONE + +##### Success Response + +**Code** : `200 OK` + +**Content example** + +```json +{ + "hardness": 4, + "challenge-id": 621, + "nonce": "pXdoMbxdsmz7zK86MbyLF3qnDVBiPgIy9TY7Optnnow=" +} +``` + +#### Normal Captcha + +Used to generate a visual (math problem) captcha challenge. + +**URL** : `/api/challenge/captcha` + +**Method** : `GET` + +**Auth required** : NO + +**Data constraints** : NONE + +##### Success Response + +**Code** : `200 OK` + +**Content example** + +```json +{ + "challenge-id": 263, + "image": "data:image/jpeg;charset=utf-8;base64,[...]" +} +``` + +#### Post Comment + +Used to generate a visual (math problem) captcha challenge. + +**URL** : `/api/comment` + +**Method** : `POST` + +**Auth required** : NO + +**Data constraints** + +Data should be `application/x-www-form-urlencoded`. + +- `slug`: identifier for the post being commented on. +- `name`: author name for comment. +- `comment`: markdown string containing comment content. +- `captcha-id`: `challenge-id` for captcha challenge. +- `captcha`: solution for captcha with identifier `challenge-id`. +- `subject` (optional): subject string of comment. +- `email` (optional): email address of author. +- `url` (optional): homepage of author. + +`captcha-id` and the captcha challenge can be generated with the "Proof of Work" or "Normal Captcha" endpoints. +If the captcha was created by the former endpoint, then the field names are `captcha-alt` and `captcha-alt-id`. + +##### Success Response + +**Code** : `307 Temporary Redirect` + +**Content example** + +```json +{ + "success": true, +} +``` + +### Other Endpoints + +# License Information + +## Haunt Sources and Guile API Server + +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/>. + +## squee + +This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. + +This library 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 Lesser General Public License for more details. + +You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +## oneko.js + +Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the “Software”), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED “AS IS”, WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/dynamic/api.scm b/haunt/api.scm index 6cda81a..810b905 100644 --- a/dynamic/api.scm +++ b/haunt/api.scm @@ -1,4 +1,4 @@ -;;; Copyright © 2019 - 2022 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; 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 @@ -14,14 +14,23 @@ ;;; along with this program. If not, see ;;; <http://www.gnu.org/licenses/>. -(use-modules (dynamic capabilities gallery) - (dynamic capabilities rsvp) - (dynamic logging) +(use-modules (ice-9 match) + (jakob dynamic blacklist) + (jakob dynamic captcha) + (jakob dynamic capabilities comment-form) + (jakob dynamic capabilities comments) + (jakob dynamic capabilities gallery) + (jakob dynamic capabilities rsvp) + (jakob dynamic errors) + (jakob dynamic logging) + (jakob dynamic rate-limiter) + (json) + (rnrs conditions) + (rnrs exceptions) (srfi srfi-1) - (ice-9 match) - (web server) (web request) (web response) + (web server) (web uri)) (define (not-found request) @@ -30,22 +39,46 @@ (string-append "Resource not found: " (uri->string (request-uri request))))) +(define (format-error-response condition) + "Format CONDITION, a &reportable-condition, as an HTTP response" + (values (build-response #:code (reportable-condition-code condition)) + (scm->json-string + `((success . #f) + (error . ,(reportable-condition-message condition)))))) + +(define-syntax values->list + (syntax-rules () + ((values-list exp) + (call-with-values (lambda () exp) list)))) + (define (handle-api-request request body endpoint) "Route handler for the API server." (let ((method (request-method request)) - (originating-ip (assoc-ref (request-headers request) 'X-Forwarded-For)) + (originating-ip (assoc-ref (request-headers request) 'x-forwarded-for)) (args (uri-query (request-uri request)))) - (log-append! 'info (format #f "~a ~a (~a) (~a)" method endpoint args originating-ip))) - ((match (cons (request-method request) endpoint) - ;; ('(GET "challenge") make-challenge) - ;; ('(GET "comments") get-comments) - ;; ('(POST "comment") put-comment) - ('(GET "gallery") get-gallery) - ('(GET "gallery" "image") get-image) - ('(GET "rsvp" "event-info") get-event-info) - ('(POST "rsvp") post-event-rsvp) - (_ (lambda (. args) (not-found request)))) - request body)) + (log-append! 'info (if args + (format #f "~a ~a (~a) (~a)" method endpoint args originating-ip) + (format #f "~a ~a (~a)" method endpoint originating-ip))) + ;; Somewhat painful wrap/unwrap of values because there isn't support for + ;; returning multiple values from a `guard' clause. + (apply values + (guard (ex ((reportable-condition? ex) + (values->list (format-error-response ex)))) + (fail-when-ip-blacklisted originating-ip) + (values->list + ((rate-limit-wrap + (match (cons (request-method request) endpoint) + (('GET "comment-form" _) get-comment-form) + ('(GET "challenge" "proof-of-work") make-pow-challenge!) + ('(GET "challenge" "captcha") make-captcha-challenge!) + ('(GET "comments") get-comments) + (('POST "comment") put-comment) + (('GET "gallery") get-gallery) + (('GET "gallery" "image") get-image) + (('GET "rsvp" "event-info") get-event-info) + (('POST "rsvp") post-event-rsvp) + (_ (lambda (. args) (not-found request))))) + request body)))))) (define (main-request-handler request body) "Server entry-point; parse `request' and defer to routing system." @@ -71,4 +104,5 @@ (not-found request))) (values (wrap-response response) resp-body))) +(format #t "Server started.~%") (run-server main-request-handler 'http `(#:addr ,INADDR_ANY #:port 8080)) diff --git a/haunt/demux.scm b/haunt/demux.scm new file mode 100644 index 0000000..2de029d --- /dev/null +++ b/haunt/demux.scm @@ -0,0 +1,54 @@ +;;; 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/>. + +(use-modules (srfi srfi-1) + (web request) + (web response) + (web server) + (web uri) + (web client)) + +(define static-url "http://localhost:8080") +(define dynamic-url "http://localhost:8081") + +(define (main-request-handler request body) + "Demuxer entry-point; parse `request' and forward to the correct local service" + (define (wrap-response response) + (if (response? response) + (build-response + #:version (response-version response) + #:code (response-code response) + #:reason-phrase (response-reason-phrase response) + #:headers (remove (lambda (hdr) (eqv? 'content-length (car hdr))) + (response-headers response)) + #:port (response-port response) + #:validate-headers? #f) + (cons '(Access-Control-Allow-Origin . "*") response))) + (let* ((path-encoded (uri-path (request-uri request))) + (path (split-and-decode-uri-path path-encoded))) + (define-values (response resp-body) + (let ((url (if (and (positive? (length path)) (string= "api" (first path))) + (string-concatenate (list dynamic-url path-encoded)) + (string-concatenate (list static-url path-encoded))))) + (http-request url + #:method (request-method request) + #:body body + #:version '(1 . 1) + #:keep-alive? #f + #:headers (request-headers request)))) + (values (wrap-response response) resp-body))) + +(run-server main-request-handler 'http '(#:port 8082)) diff --git a/haunt/jakob/builder/blog.scm b/haunt/jakob/builder/blog.scm index c9b01c8..de1c788 100644 --- a/haunt/jakob/builder/blog.scm +++ b/haunt/jakob/builder/blog.scm @@ -21,12 +21,13 @@ #: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 webmention) + #:use-module (jakob utils comments) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) @@ -47,19 +48,8 @@ ;;; Rendering. ;;; -(define (build-anonymous-comment-url post) - (let* ((target (format #f "http://jakob.space~a" (post-uri post))) - (params `(("dontask" . "1") - ("me" . "https://commentpara.de") - ("reply" . ,target))) - (query (string-join (map (lambda (pair) - (string-concatenate - (list (uri-encode (car pair)) - "=" - (uri-encode (cdr pair))))) - params) - "&"))) - (format #f "https://quill.p3k.io/?~a" query))) +(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." @@ -82,21 +72,22 @@ (article ,(post-sxml post)) (section (@ (id "webmention")) - (h2 ,(hyperlink "https://indieweb.org/Webmention" "Webmentions") - " for this Page") - (ul (@ (id "webmention-container")) - ,@(render-comment-view (fetch-webmentions (post-identifier post)))) + (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 - (@ (action "https://webmention.io/jakob.space/webmention") + (@ (id "webmention-form") + (action "https://webmention.io/jakob.space/webmention") (method "post")) - (label "Have you written a " - ,(hyperlink "https://indieweb.org/responses" "response") - " to this? Let me know the URL:") + (label "Alternatively, if you've written about this " + ,(hyperlink "https://indieweb.org/responses" "elsewhere") + ", you can let me know the URL:") (input (@ (name "source") (type "url"))) (input (@ (value "Send Webmention") (type "submit")))) - (p "Alternatively, you can send an " - ,(hyperlink (build-anonymous-comment-url post) "anonymous comment") - ".") ,(script "section-folds.js") ;; ,(script "webmention.js") ))) diff --git a/haunt/jakob/dynamic/blacklist.scm b/haunt/jakob/dynamic/blacklist.scm new file mode 100644 index 0000000..4796cab --- /dev/null +++ b/haunt/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/haunt/jakob/dynamic/capabilities/comment-form.scm b/haunt/jakob/dynamic/capabilities/comment-form.scm new file mode 100644 index 0000000..ddb02f4 --- /dev/null +++ b/haunt/jakob/dynamic/capabilities/comment-form.scm @@ -0,0 +1,122 @@ +;;; 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-commenter-info-field) + `(fieldset (@ (id "commenter-info")) + (legend "Commenter Info") + (label (@ (for "name")) "Name:") + (input (@ (type "text") (id "name") (name "name") (required #t) (size 24))) + (label (@ (for "email")) "Email (optional, used for Gravatar):") + (input (@ (type "text") (id "email") (name "email") (size 24))) + (label (@ (for "url")) "Webpage URL (optional):") + (input (@ (type "text") (id "url") (name "url") (size 24))))) + +(define (render-comment-content-field) + `(fieldset (@ (id "comment-content")) + (legend "Comment") + (label (@ (for "subject")) "Subject (optional):") + (input (@ (type "text") (id "subject") (name "subject") (size 24))) + (label (@ (for "comment")) "Comment :") + (textarea (@ (id "coment") (name "comment") (rows 4) (cols 50))))) + +(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?) Click here.") + (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-commenter-info-field) + ,(render-comment-content-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-commenter-info-field) + ,(render-comment-content-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/haunt/jakob/dynamic/capabilities/comments.scm b/haunt/jakob/dynamic/capabilities/comments.scm new file mode 100644 index 0000000..98560b0 --- /dev/null +++ b/haunt/jakob/dynamic/capabilities/comments.scm @@ -0,0 +1,203 @@ +;;; 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 database) + #: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 3)) + (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) + '())) + (replies (list-ref args-needing-processing 2))) + + (apply make-internal-comment + (append (drop-right args 3) (list approved reactions replies))))) + (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, 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 (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) + VALUES (now(), $1, $2, $3, $4, $5, $6, $7);" + (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))) + (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* ((query-string (uri-query (request-uri request))) + (form-data (if query-string + (decode-form query-string) + '()))) + (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 reactions (panic "no such comment")) + (set-reactions id (add-reaction reactions reaction)) + (values '((content-type . (application/json))) + (scm->json-string `((success . #t))))))) diff --git a/haunt/jakob/dynamic/capabilities/common.scm b/haunt/jakob/dynamic/capabilities/common.scm new file mode 100644 index 0000000..4f6d3d9 --- /dev/null +++ b/haunt/jakob/dynamic/capabilities/common.scm @@ -0,0 +1,50 @@ +(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 + 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))))) + +(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/dynamic/capabilities/gallery.scm b/haunt/jakob/dynamic/capabilities/gallery.scm index 1d63061..f0c5b66 100644 --- a/dynamic/capabilities/gallery.scm +++ b/haunt/jakob/dynamic/capabilities/gallery.scm @@ -1,4 +1,4 @@ -;;; Copyright © 2019 - 2022 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; 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 @@ -14,11 +14,13 @@ ;;; along with this program. If not, see ;;; <http://www.gnu.org/licenses/>. -(define-module (dynamic capabilities gallery) - #:use-module (dynamic util) +(define-module (jakob dynamic capabilities gallery) #:use-module (ice-9 binary-ports) #:use-module (ice-9 ftw) #:use-module (ice-9 match) + #:use-module (jakob dynamic database) + #:use-module (jakob dynamic errors) + #:use-module (jakob dynamic util) #:use-module (json) #:use-module (squee) #:use-module (srfi srfi-1) @@ -27,7 +29,7 @@ #:use-module (web uri) #:export (get-gallery get-image)) -(define conn (connect-to-postgres-paramstring "dbname=jakob_gallery")) +(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)) @@ -72,14 +74,10 @@ (decode-form query-string) '())) (code (car (assoc-ref params "g")))) - (if (valid-gallery-code code) - (values '((content-type . (application/json))) - (scm->json-string `((info . ,(get-gallery-info code)) - (images . ,(get-gallery-images code))))) - (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "Invalid gallery code"))))))) + (unless (valid-gallery-code code) (panic "invalid gallery code")) + (values '((content-type . (application/json))) + (scm->json-string `((info . ,(get-gallery-info code)) + (images . ,(get-gallery-images code))))))) (define (image-exists? file-name) (define (string/= a b) (not (string= a b))) @@ -103,9 +101,5 @@ (decode-form query-string) '())) (file-name (car (assoc-ref params "name")))) - (if (image-exists? file-name) - (read-image file-name) - (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "Invalid filename"))))))) + (unless (image-exists? file-name) (panic "invalid filename")) + (read-image file-name))) diff --git a/dynamic/capabilities/rsvp.scm b/haunt/jakob/dynamic/capabilities/rsvp.scm index 4ac2eff..2975e4d 100644 --- a/dynamic/capabilities/rsvp.scm +++ b/haunt/jakob/dynamic/capabilities/rsvp.scm @@ -1,4 +1,4 @@ -;;; Copyright © 2019 - 2022 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; 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 @@ -14,11 +14,13 @@ ;;; along with this program. If not, see ;;; <http://www.gnu.org/licenses/>. -(define-module (dynamic capabilities rsvp) - #:use-module (base64) - #:use-module (dynamic util) +(define-module (jakob dynamic capabilities rsvp) + #:use-module (gcrypt base64) #:use-module (ice-9 binary-ports) #:use-module (ice-9 match) + #:use-module (jakob dynamic database) + #:use-module (jakob dynamic errors) + #:use-module (jakob dynamic util) #:use-module (json) #:use-module (rnrs bytevectors) #:use-module (squee) @@ -36,7 +38,7 @@ (define %event-image-path-fmt (make-parameter "/home/jakob/event-images/~a.png")) ;; Global handle to the RSVP database. -(define conn (connect-to-postgres-paramstring "dbname=jakob_rsvp")) +(define conn (connect-to-postgres-paramstring (paramstring-for-dbname "jakob_rsvp"))) @@ -101,31 +103,24 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." (define (create-new-event-rsvp params) "Handler for RSVP'ing to an event." (let ((params (params->rsvp-create params))) - (cond ((not params) - (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "Invalid form data"))))) - ((not (valid-invite-code (rsvp-create-code params))) - (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "Invalid invitation code"))))) - (else - (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 . (application/json))) - (scm->json-string - `((receipt . ,receipt-code))))))))) + (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 . (application/json))) + (scm->json-string + `((receipt . ,receipt-code))))))) @@ -158,28 +153,21 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." (define (update-event-rsvp params) "Handler for updating an RSVP to an event." (let ((params (params->rsvp-update params))) - (cond ((not params) - (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "Invalid form data"))))) - ((not (valid-receipt-code (rsvp-update-code params))) - (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "Invalid receipt code"))))) - (else - (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 . (application/json))) - (scm->json-string - `((receipt . ,(rsvp-update-code 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 . (application/json))) + (scm->json-string + `((receipt . ,(rsvp-update-code params))))))) @@ -188,10 +176,7 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." (let* ((params (json-string->scm (utf8->string body)))) (cond ((assoc-ref params "id") (create-new-event-rsvp params)) ((assoc-ref params "update") (update-event-rsvp params)) - (else (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "Invalid invite/update code")))))))) + (else (panic "invalid invite/update code"))))) @@ -270,8 +255,4 @@ It is a base64 string, encoding `%vanity-length' bytes of randomness." (get-event-receipt (car receipt-code))) ((and invitation-code (valid-invite-code (car invitation-code))) (get-event-invitation (car invitation-code))) - (else - (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "Invalid invitation or receipt code")))))))) + (else (panic "invalid invitation or receipt code"))))) diff --git a/haunt/jakob/dynamic/captcha.scm b/haunt/jakob/dynamic/captcha.scm new file mode 100644 index 0000000..4407ae5 --- /dev/null +++ b/haunt/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/haunt/jakob/dynamic/database.scm b/haunt/jakob/dynamic/database.scm new file mode 100644 index 0000000..f5b1353 --- /dev/null +++ b/haunt/jakob/dynamic/database.scm @@ -0,0 +1,29 @@ +;;; 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 database) + #:export (paramstring-for-dbname)) + +(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)) diff --git a/haunt/jakob/dynamic/errors.scm b/haunt/jakob/dynamic/errors.scm new file mode 100644 index 0000000..05f9302 --- /dev/null +++ b/haunt/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/dynamic/import-images.sh b/haunt/jakob/dynamic/import-images.sh index 23f6130..23f6130 100644 --- a/dynamic/import-images.sh +++ b/haunt/jakob/dynamic/import-images.sh diff --git a/dynamic/logging.scm b/haunt/jakob/dynamic/logging.scm index dab2464..7b1bd0a 100644 --- a/dynamic/logging.scm +++ b/haunt/jakob/dynamic/logging.scm @@ -1,4 +1,4 @@ -;;; Copyright © 2019 - 2022 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; 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 @@ -14,7 +14,7 @@ ;;; along with this program. If not, see ;;; <http://www.gnu.org/licenses/>. -(define-module (dynamic logging) +(define-module (jakob dynamic logging) #:use-module (ice-9 format) #:use-module (srfi srfi-19) #:export (log-append!)) @@ -31,7 +31,7 @@ (define (log-append! level message) "Append `message', at `level', to the log buffer." (when (dominates level (%log-level)) - (call-with-output-file (%log-file-name) - (lambda (port) - (let ((now (date->string (current-date) "~4"))) - (format port "[~a] ~a: ~a~%" now level message)))))) + (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/haunt/jakob/dynamic/rate-limiter.scm b/haunt/jakob/dynamic/rate-limiter.scm new file mode 100644 index 0000000..36450f9 --- /dev/null +++ b/haunt/jakob/dynamic/rate-limiter.scm @@ -0,0 +1,77 @@ +;;; 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 + ((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/dynamic/schema-comments.sql b/haunt/jakob/dynamic/schema-comments.sql index 1c690f3..1f2edc7 100644 --- a/dynamic/schema-comments.sql +++ b/haunt/jakob/dynamic/schema-comments.sql @@ -4,9 +4,14 @@ CREATE TABLE comments( 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 + comment VARCHAR(1024) NOT NULL, + reactions VARCHAR(1024), + reply_to INT ); -- Use `now' for `submitted'. + +-- INSERT INTO comments (submitted, slug, name, comment) VALUES (now(), 'test', 'Jakob', 'Hello, world!'); diff --git a/dynamic/schema-gallery.sql b/haunt/jakob/dynamic/schema-gallery.sql index bad4100..bad4100 100644 --- a/dynamic/schema-gallery.sql +++ b/haunt/jakob/dynamic/schema-gallery.sql diff --git a/dynamic/schema-rsvp.sql b/haunt/jakob/dynamic/schema-rsvp.sql index 3e6a21f..3e6a21f 100644 --- a/dynamic/schema-rsvp.sql +++ b/haunt/jakob/dynamic/schema-rsvp.sql diff --git a/dynamic/util.scm b/haunt/jakob/dynamic/util.scm index 29a40db..a7fd38d 100644 --- a/dynamic/util.scm +++ b/haunt/jakob/dynamic/util.scm @@ -1,4 +1,4 @@ -;;; Copyright © 2019 - 2022 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; 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 @@ -14,14 +14,24 @@ ;;; along with this program. If not, see ;;; <http://www.gnu.org/licenses/>. -(define-module (dynamic util) +(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 uri) - #:export (base64-length - decode-form)) + #:export (assoc-value + acons-normalize + base64-length + decode-form + date<? + hash-append!)) + +(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" @@ -31,6 +41,11 @@ (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. @@ -55,3 +70,15 @@ (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)))) diff --git a/haunt/jakob/theme.scm b/haunt/jakob/theme.scm index 2d999f1..7b46b2a 100644 --- a/haunt/jakob/theme.scm +++ b/haunt/jakob/theme.scm @@ -49,7 +49,7 @@ (define %footer `(footer (div - (p "© 2015 - 2022 Jakob L. Kreuze") + (p "© 2015 - 2023 Jakob L. Kreuze") ,(image "cc-by-sa-4.0.png" "Creative Commons Attribution-ShareAlike 4.0 International (CC BY-SA 4.0) Logo")) diff --git a/haunt/jakob/utils.scm b/haunt/jakob/utils.scm index a3ad1b7..a41d21a 100644 --- a/haunt/jakob/utils.scm +++ b/haunt/jakob/utils.scm @@ -18,6 +18,7 @@ #:use-module (haunt post) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) #:export (maybe-cons* maybe-list date->string* diff --git a/haunt/jakob/utils/comments.scm b/haunt/jakob/utils/comments.scm new file mode 100644 index 0000000..e41fe2c --- /dev/null +++ b/haunt/jakob/utils/comments.scm @@ -0,0 +1,247 @@ +;;; 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 (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) + ((if (webmention? comment) + webmention-url + internal-comment-url) + comment)) + (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"))) + `(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'" + (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/")) + (let* ((target-queries (map (lambda (pre) + (format #f "target[]=~a~a.html" pre slug)) + prefixes)) + (url (format #f "https://webmention.io/api/mentions.jf2?per-page=200&page=0&~a" + (string-join target-queries "&")))) + (receive (response-status response-body) + (http-request url) + (call-with-input-string (bytevector->string response-body "UTF-8") json->scm)))) diff --git a/haunt/jakob/utils/webmention.scm b/haunt/jakob/utils/webmention.scm deleted file mode 100644 index 713ce39..0000000 --- a/haunt/jakob/utils/webmention.scm +++ /dev/null @@ -1,135 +0,0 @@ -;;; Copyright © 2019 - 2022 Jakob L. Kreuze <zerodaysfordays@sdf.org> -;;; -;;; This program is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; <http://www.gnu.org/licenses/>. - -(define-module (jakob utils webmention) - #:use-module (ice-9 receive) - #:use-module (ice-9 iconv) - #:use-module (ice-9 match) - #:use-module (srfi srfi-19) - #:use-module (srfi srfi-43) - #:use-module (json) - #:use-module (web client) - #:use-module (web response) - #:use-module (oop goops) - #:export (render-comment-view - fetch-webmentions)) - -(define (wm-not-null? value) - (and value - (not (eqv? 'null value)) - (not (string= "" value)))) - -(define (format-comment webmention) - "Format `webmention', an alist, as SXML for a comment-type interaction" - (define (strip uri) - "Attempt to remove any sort of protocol specification from `uri'" - (let* ((needle "://") - (index (string-contains uri needle))) - (if index - (strip (substring uri (+ index (string-length needle)))) - uri))) - (let* ((author (assoc-ref webmention "author")) - (author-name (assoc-ref author "name")) - (author-url (assoc-ref author "url")) - (author-url - (if (wm-not-null? author-url) - author-url - (assoc-ref webmention "wm-source"))) - (author-photo (assoc-ref author "photo")) - (author-photo - (cond ((string-prefix? "https://lobste.rs/" author-url) "/static/image/lobsters.png") - ((wm-not-null? author-photo) author-photo) - (else "/static/image/default-icon.png"))) - (content (assoc-ref webmention "content")) - (content-text (assoc-ref content "text")) - (published-time (assoc-ref webmention "published")) - (received-time (assoc-ref webmention "wm-received")) - (url (assoc-ref webmention "url")) - (time (if (eqv? 'null published-time) received-time published-time))) - `(li (@ (class "p-comment h-cite comment comment-source-webmention")) - (img (@ (class "comment-source-identifier") - (alt "Webmention logo") - (src "/static/image/webmention-logo.png"))) - (div (@ (class "p-author h-card author")) - (img (@ (class "u-photo") (src ,author-photo))) - (a (@ (class "p-name u-url") - (href ,author-url)) - ,author-name) - (a (@ (class "author-url") - (href ,author-url)) - ,(strip author-url))) - (div (@ (class "e-content p-name comment-content")) - ,content-text) - (div (@ (class "metaline")) - (a (@ (class "u-url") - (href ,url)) - (time (@ (class "dt-published") - (datetime ,time)) - ,(date->string - (string->date time "~Y~m~d~H~M~S") - "~B ~e, ~Y at ~H:~M"))))))) - -(define (format-interaction webmention) - "Format `webmention', an alist, as SXML for a rich interaction without content" - (let* ((author (assoc-ref webmention "author")) - (author-name (assoc-ref author "name")) - (author-url (assoc-ref author "url")) - (author-url - (if (wm-not-null? author-url) - author-url - (assoc-ref webmention "wm-source"))) - (author-photo (assoc-ref author "photo")) - (author-photo - (cond ((string-prefix? "https://lobste.rs/" author-url) "/static/image/lobsters.png") - ((wm-not-null? author-photo) author-photo) - (else "/static/image/default-icon.png")))) - `(li (@ (class "p-comment h-cite interaction comment-source-webmention")) - (a (@ (href ,author-url)) - (img (@ (class "u-photo") (src ,author-photo)))) - (div (@ (class "e-content p-name comment-content")) - (em - ,(match (assoc-ref webmention "wm-property") - ("repost-of" "Reposted this!") - ("like-of" "Favorited this!") - ("bookmark-of" "Bookmarked this!") - ("mention-of" "Mentioned this!") - (_ "[No Text Provided]")))) - (img (@ (class "comment-source-identifier") - (alt "Webmention logo") - (src "/static/image/webmention-logo.png")))))) - -(define (render-comment-view response) - "Render `response', the output of `fetch-webmentions', as SXML" - (vector->list - (vector-map (lambda (_ x) - (if (and (assoc-ref x "content") - (not (string= (assoc-ref x "wm-property") "repost-of"))) - (format-comment x) - (format-interaction x))) - (assoc-ref response "children")))) - -(define (fetch-webmentions slug) - "Blocking call to webmention.io to retrieve a vector of all Webmentions for `slug'" - (define prefixes '("http://jakob.space/" "https://jakob.space/" - "http://jakob.space/blog/" "https://jakob.space/blog/")) - (let* ((target-queries (map (lambda (pre) - (format #f "target[]=~a~a.html" pre slug)) - prefixes)) - (url (format #f "https://webmention.io/api/mentions.jf2?per-page=200&page=0&~a" - (string-join target-queries "&")))) - (receive (response-status response-body) - (http-request url) - (call-with-input-string (bytevector->string response-body "UTF-8") json->scm)))) diff --git a/haunt/pages/about.sxml b/haunt/pages/about.sxml index 4b82736..19aa8f1 100644 --- a/haunt/pages/about.sxml +++ b/haunt/pages/about.sxml @@ -159,15 +159,15 @@ Linux.") (define (lang-to-button lang) (case lang - ((c) '(button (@ (class "lang-c")) "C")) - ((c++) '(button (@ (class "lang-cpp")) "C++")) - ((python) '(button (@ (class "lang-python")) "Python")) - ((rust) '(button (@ (class "lang-rust")) "Rust")) - ((kotlin) '(button (@ (class "lang-kotlin")) "Kotlin")) - ((fennel) '(button (@ (class "lang-fennel")) "Fennel")) - ((elisp) '(button (@ (class "lang-elisp")) "Elisp")) - ((scheme) '(button (@ (class "lang-scheme")) "Scheme")) - ((ebuild) '(button (@ (class "lang-ebuild")) "Ebuild")))) + ((c) '(button (@ (class "lang lang-c")) "C")) + ((c++) '(button (@ (class "lang lang-cpp")) "C++")) + ((python) '(button (@ (class "lang lang-python")) "Python")) + ((rust) '(button (@ (class "lang lang-rust")) "Rust")) + ((kotlin) '(button (@ (class "lang lang-kotlin")) "Kotlin")) + ((fennel) '(button (@ (class "lang lang-fennel")) "Fennel")) + ((elisp) '(button (@ (class "lang lang-elisp")) "Elisp")) + ((scheme) '(button (@ (class "lang lang-scheme")) "Scheme")) + ((ebuild) '(button (@ (class "lang lang-ebuild")) "Ebuild")))) (define (date-of-first-commit repository-path) "Return the date of the first commit in `repository-path'." diff --git a/haunt/pages/weblabels.sxml b/haunt/pages/weblabels.sxml index 0c53551..c90b620 100644 --- a/haunt/pages/weblabels.sxml +++ b/haunt/pages/weblabels.sxml @@ -24,6 +24,18 @@ #:content `((h2 "JavaScript Web Labels") (table (@ (id "jslicense-labels1")) + (tr (td ,(hyperlink "/static/js/dynamic-comment-form.js" + `(p "/static/js/dynamic-comment-form.js"))) + (td ,(hyperlink "http://www.gnu.org/licenses/gpl-3.0.html" + `(p "GNU General Public License 3.0 or later"))) + (td ,(hyperlink "/static/js/dynamic-comment-form.js" + `(p "/static/js/dynamic-comment-form.js")))) + (tr (td ,(hyperlink "/static/js/proof-of-work.js" + `(p "/static/js/proof-of-work.js"))) + (td ,(hyperlink "http://www.gnu.org/licenses/gpl-3.0.html" + `(p "GNU General Public License 3.0 or later"))) + (td ,(hyperlink "/static/js/proof-of-work.js" + `(p "/static/js/proof-of-work.js")))) (tr (td ,(hyperlink "/static/js/webmention.js" `(p "/static/js/webmention.js"))) (td ,(hyperlink "http://www.gnu.org/licenses/gpl-3.0.html" @@ -42,6 +54,12 @@ `(p "GNU General Public License 3.0 or later"))) (td ,(hyperlink "/static/js/rsvp.js" `(p "/static/js/rsvp.js")))) + (tr (td ,(hyperlink "/static/js/gallery.js" + `(p "/static/js/gallery.js"))) + (td ,(hyperlink "http://www.gnu.org/licenses/gpl-3.0.html" + `(p "GNU General Public License 3.0 or later"))) + (td ,(hyperlink "/static/js/gallery.js" + `(p "/static/js/gallery.js")))) (tr (td ,(hyperlink "/static/js/oneko.js" `(p "/static/js/oneko.js"))) (td ,(hyperlink "http://www.jclark.com/xml/copying.txt" diff --git a/haunt/squee.scm b/haunt/squee.scm new file mode 100644 index 0000000..443fa09 --- /dev/null +++ b/haunt/squee.scm @@ -0,0 +1,372 @@ +;;; squee --- A guile interface to postgres via the ffi + +;; Copyright (C) 2015 Christopher Allan Webber <cwebber@dustycloud.org> + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library 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 +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (squee) + #:use-module (system foreign) + #:use-module (rnrs enums) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (srfi srfi-26) + #:export (;; The important ones + connect-to-postgres-paramstring + exec-query + pg-conn-finish + + ;; enums and indexes of enums + conn-status-enum conn-status-enum-index + polling-status-enum polling-status-index + exec-status-enum exec-status-enum-index + transaction-status-enum transaction-status-enum-index + verbosity-enum verbosity-enum-index + ping-enum ping-enum-index + + ;; **repl and error messages only!** + enum-set-ref + + ;; Connection stuff + <pg-conn> pg-conn? wrap-pg-conn unwrap-pg-conn + + ;; @@: We don't export the result pointer though! + ;; as this needs to be cleared to avoid memory + ;; leaks... + ;; + ;; We might provide a (exec-with-result-ptr) + ;; that cleans up the result pointer after calling + ;; some thunk though? + ;; + ;; These are still useful for building your own + ;; serializer though... + result-num-rows result-num-cols result-get-value + result-serializer-simple-list result-metadata)) + +(define libpq (dynamic-link "libpq")) + +;; --------------------- +;; Enums from libpq-fe.h +;; --------------------- + +(define conn-status-enum + (make-enumeration + '(connection-ok + connection-bad + connection-started connection-made + connection-awaiting-response connection-auth-ok + connection-auth-ok connection-setenv + connection-ssl-startup + connection-needed))) + +(define conn-status-enum-index + (enum-set-indexer conn-status-enum)) + +(define polling-status-enum + (make-enumeration + '(polling-failed + polling-reading + polling-writing + polling-ok + polling-active))) + +(define polling-status-enum-index + (enum-set-indexer polling-status-enum)) + +(define exec-status-enum + (make-enumeration + '(empty-query + command-ok tuples-ok + copy-out copy-in + bad-response + nonfatal-error fatal-error + copy-both + single-tuple))) + +(define exec-status-enum-index + (enum-set-indexer exec-status-enum)) + +(define transaction-status-enum + (make-enumeration + '(idle active intrans inerror unknown))) + +(define transaction-status-enum-index + (enum-set-indexer transaction-status-enum)) + +(define verbosity-enum + (make-enumeration + '(terse default verbose))) + +(define verbosity-enum-index + (enum-set-indexer verbosity-enum)) + +(define ping-enum + (make-enumeration + '(ok reject no-response no-attempt))) + +(define ping-enum-index + (enum-set-indexer ping-enum)) + +(define-wrapped-pointer-type <pg-conn> + pg-conn? + wrap-pg-conn unwrap-pg-conn + (lambda (pg-conn port) + (format port "#<pg-conn ~x (~a)>" + (pointer-address (unwrap-pg-conn pg-conn)) + (let ((status (pg-conn-status pg-conn))) + (cond ((eq? status (conn-status-enum-index 'connection-ok)) + "connected") + ((eq? status (conn-status-enum-index 'connection-bad)) + (let ((conn-error (pg-conn-error-message pg-conn))) + (if (equal? conn-error "") + "disconnected" + (format #f "disconnected, error: ~s" conn-error)))) + (#t + (symbol->string + (pg-conn-status-symbol pg-conn)))))))) + + +;; This one should NOT be exposed to the outside world! We have our +;; own result structure... + +(define-wrapped-pointer-type <result-ptr> + result-ptr? + wrap-result-ptr unwrap-result-ptr + (lambda (result-ptr port) + (format port "#<result-ptr ~x>" + (pointer-address (unwrap-result-ptr result-ptr))))) + + +(define (enum-set-ref enum-set k) + "Take an ENUM-SET and get the item at position K + +This is O(n) but theoretically we don't use it much. +Again, REPL only!" + (list-ref (enum-set->list enum-set) k)) + + +(define-syntax-rule (define-foreign-libpq name return_type func_name arg_types) + (define name + (pointer->procedure return_type + (dynamic-func func_name libpq) + arg_types))) + + +(define-foreign-libpq %PQconnectdb '* "PQconnectdb" (list '*)) +(define-foreign-libpq %PQstatus int "PQstatus" (list '*)) +(define-foreign-libpq %PQerrorMessage '* "PQerrorMessage" (list '*)) +(define-foreign-libpq %PQfinish void "PQfinish" (list '*)) +(define-foreign-libpq %PQntuples int "PQntuples" (list '*)) +(define-foreign-libpq %PQnfields int "PQnfields" (list '*)) + + +(define-foreign-libpq %PQexec '* "PQexec" (list '* '*)) +(define-foreign-libpq %PQexecParams + '* ;; Returns a PGresult + "PQexecParams" + (list '* ;; connection + '* ;; command, a string + int ;; number of parameters + '* ;; paramTypes, ok to leave NULL + '* ;; paramValues, here goes your actual parameters! + '* ;; paramLengths, ok to leave NULL + '* ;; paramFormats, ok to leave NULL + int)) ;; resultFormat... probably 0! + +(define-foreign-libpq %PQresultStatus int "PQresultStatus" (list '*)) +(define-foreign-libpq %PQresStatus '* "PQresStatus" (list int)) +(define-foreign-libpq %PQresultErrorMessage '* "PQresultErrorMessage" (list '*)) +(define-foreign-libpq %PQclear void "PQclear" (list '*)) + +(define-foreign-libpq %PQcmdtuples '* "PQcmdTuples" (list '*)) +(define-foreign-libpq %PQntuples int "PQntuples" (list '*)) +(define-foreign-libpq %PQnfields int "PQnfields" (list '*)) +(define-foreign-libpq %PQgetisnull int "PQgetisnull" (list '* int int)) +(define-foreign-libpq %PQgetvalue '* "PQgetvalue" (list '* int int)) + + +;; Via mark_weaver. Thanks Mark! +;; +;; So, apparently we can use a struct of strings just like an array +;; of strings. Because magic, and because Mark thinks the C standard +;; allows it enough! + +(define (string-pointer-list->string-array ls) + "Take a list of strings, generate a C-compatible list of free strings" + (make-c-struct + (make-list (+ 1 (length ls)) '*) + (append ls (list %null-pointer)))) + +(define (pg-conn-status pg-conn) + "Get the connection status from a postgres connection" + (%PQstatus (unwrap-pg-conn pg-conn))) + +(define (pg-conn-status-symbol pg-conn) + "Human readable version of the pg-conn status. + +Inefficient... don't use this in normal code... it's just for you and +the REPL! (Well, we do use it for errors, because those are +comparatively \"rare\" so this is okay.) Compare against the enum +value of the symbol instead." + (let ((status (pg-conn-status pg-conn))) + (if (< status (length (enum-set->list conn-status-enum))) + (enum-set-ref conn-status-enum + (pg-conn-status pg-conn)) + ;; Weird, this is bigger than our enum of statuses + (string->symbol + (format #f "unknown-status-~a" status))))) + + +(define (pg-conn-error-message pg-conn) + "Get an error message for this connection" + (pointer->string (%PQerrorMessage (unwrap-pg-conn pg-conn)))) + + +(define (pg-conn-finish pg-conn) + "Close out a database connection. + +If the connection is already closed, this simply returns #f." + (if (eq? (pg-conn-status pg-conn) + (conn-status-enum-index 'connection-ok)) + (begin + (%PQfinish (unwrap-pg-conn pg-conn)) + #t) + #f)) + +(define (connect-to-postgres-paramstring paramstring) + "Open a connection to the database via a parameter string" + (let* ((conn-pointer (%PQconnectdb (string->pointer paramstring))) + (pg-conn (wrap-pg-conn conn-pointer))) + (if (eq? conn-pointer %null-pointer) + (throw 'psql-connect-error + #f "Unable to establish connection")) + (let ((status (pg-conn-status pg-conn))) + (if (eq? status (conn-status-enum-index 'connection-ok)) + pg-conn + (throw 'psql-connect-error + (enum-set-ref conn-status-enum status) + (pg-conn-error-message pg-conn)))))) + + +(define (result-num-rows result-ptr) + (%PQntuples (unwrap-result-ptr result-ptr))) + +(define (result-num-cols result-ptr) + (%PQnfields (unwrap-result-ptr result-ptr))) + +(define (result-get-value result-ptr row col) + (let ((res (unwrap-result-ptr result-ptr))) + (and (eqv? (%PQgetisnull res row col) 0) + (pointer->string + (%PQgetvalue res row col))))) + + +;; @@: We ought to also have a vector version... +;; and other serializations... +(define (result-serializer-simple-list result-ptr) + "Get a simple list of lists representing the result of the query" + (let ((rows-range (iota (result-num-rows result-ptr))) + (cols-range (iota (result-num-cols result-ptr)))) + (map + (lambda (row-i) + (map + (lambda (col-i) + (result-get-value result-ptr row-i col-i)) + cols-range)) + rows-range))) + +;; TODO +(define (result-metadata result-ptr) + #f) + + +(define (result-ptr-clear result-ptr) + (%PQclear (unwrap-result-ptr result-ptr))) + +(define (result-error-message result-ptr) + (%PQresultErrorMessage (unwrap-result-ptr result-ptr))) + + +(define* (exec-query pg-conn command #:optional (params '()) + #:key (serializer result-serializer-simple-list)) + (let* ((param-pointers + (map (lambda (param) + (if param + (string->pointer param) + %null-pointer)) + params)) + (command-pointer + (string->pointer command)) + (param-array-pointer + (string-pointer-list->string-array param-pointers)) + (result-ptr + (wrap-result-ptr + (if (null? params) + (%PQexec + (unwrap-pg-conn pg-conn) + command-pointer) + (%PQexecParams + (unwrap-pg-conn pg-conn) + command-pointer + (length params) + %null-pointer + param-array-pointer + %null-pointer %null-pointer 0))))) + + ;; Protect the pointers, and thus the memory regions they point to + ;; from garbage collection, until %PQexecParams has returned + (identity param-pointers) + (identity command-pointer) + (identity param-array-pointer) + + (if (eq? result-ptr %null-pointer) + ;; Presumably a database connection issue... + (throw 'psql-query-error + ;; See below for psql-query-error param definition + #f #f (pg-conn-error-message pg-conn))) + + (let ((status (%PQresultStatus (unwrap-result-ptr result-ptr)))) + (cond + ;; This is the kind of query that returns tuples + ((eq? status (exec-status-enum-index 'tuples-ok)) + (let ((serialized-result (serializer result-ptr)) + (metadata (result-metadata result-ptr))) + ;; Gotta clear the result to prevent memory leaks + (result-ptr-clear result-ptr) + (values serialized-result metadata))) + + ;; This doesn't return tuples, eg it's a DELETE or something. + ((eq? status (exec-status-enum-index 'command-ok)) + (let ((metadata (result-metadata result-ptr)) + (rows (%PQcmdtuples (unwrap-result-ptr result-ptr)))) + ;; Gotta clear the result to prevent memory leaks + (result-ptr-clear result-ptr) + ;; Return the number of affected rows. + (values (string->number + (pointer->string rows)) metadata))) + + ;; Uhoh, anything else is an error! + (#t + (let ((status-message (pointer->string (%PQresStatus status))) + (error-message (pointer->string + (%PQresultErrorMessage (unwrap-result-ptr + result-ptr))))) + (result-ptr-clear result-ptr) + (throw 'psql-query-error + ;; @@: Do we need result-status? + ;; (error-symbol result-status result-error-message) + (enum-set-ref exec-status-enum status) + status-message error-message))))))) + +;; (define conn (connect-to-postgres-paramstring "dbname=sandbox")) diff --git a/haunt/srfi-197.scm b/haunt/srfi-197.scm new file mode 100644 index 0000000..93fc0ab --- /dev/null +++ b/haunt/srfi-197.scm @@ -0,0 +1,4 @@ +(define-module (srfi-197) + #:export (chain chain-and chain-when chain-lambda nest nest-reverse)) + +(include "ext-srfi-197/srfi-197-syntax-case.scm") diff --git a/haunt/static/css/style.css b/haunt/static/css/style.css index 4b682d2..b48108b 100644 --- a/haunt/static/css/style.css +++ b/haunt/static/css/style.css @@ -1,3 +1,5 @@ +[hidden] { display: none !important; } + html { font-family: "Cantarell", sans-serif; } @@ -159,78 +161,128 @@ figure > figcaption { display: inline; } -/* Webmention. */ +/* Comments & Webmention. */ + +#webmention p .author-name { + margin: 4px; +} + #webmention { border-top: 2px solid #d2d6dd; } -ul#webmention-container { +ul.webmention-container { list-style-type: none; } -ul#webmention-container li { +ul.webmention-container > li { border: 2px solid #d2d6dd; border-bottom: none; } -ul#webmention-container li:last-child { +ul.webmention-container > li:last-child { border-bottom: 2px solid #d2d6dd; } -ul#webmention-container li.comment { - padding: 1.5rem; +ul.webmention-container > li.comment { + padding: 0.5rem; } -ul#webmention-container li.comment img.u-photo { +ul.webmention-container > li.comment img.u-photo { width: 4rem; padding: 0 1rem 1rem 0; float: left; + clear: both; + height: 100%; } -ul#webmention-container li.interaction { +ul.webmention-container > li.interaction { padding: 4px; } -ul#webmention-container li.interaction img.u-photo { +ul.webmention-container > li.interaction img.u-photo { max-width: 16px; margin-right: 8px; float: left; + clear: both; } -ul#webmention-container div.p-author * { - padding-right: 1rem; +ul.webmention-container ul.comment-reactions { + margin-top: 8px; +} + +ul.webmention-container ul.comment-reactions li { + border-radius: 4px; + border: 1px solid #d2d6dd; + display: inline; + list-style-type: none; + padding: 4px; } /* Webmention (or comment) source indicator. */ -ul#webmention-container .comment-source-webmention { +ul.webmention-container .comment { position: relative; } -ul#webmention-container .comment-source-webmention .comment-source-identifier { +ul.webmention-container .comment .comment-source-identifier { position: absolute; - top: 0; - right: 0; + top: 4px; + right: 4px; max-width: 16px; } /* Webmention form. */ -form { +#webmention-form form { border-top: 2px solid #d2d6dd; padding-top: 1rem; } -form input { +#webmention-form form input { margin-top: 1rem; } -form input[type=url] { +#webmention-form form input[type=url] { display: block; width: 100%; } +/* Comment form. */ + +#comment-form #commenter-info label, +#comment-form #comment-content label { + display: block; + width: 20em; + float: left; + clear: left; +} + +#comment-form #captcha-trigger-block label { + display: block; +} + +#comment-form label, +#comment-form input, +#comment-form button { + margin-top: 1em; +} + +#comment-form #commenter-info input, +#comment-form #comment-content input { + width: 20em; + float: left; +} + +#comment-form #comment-captcha input { + display: block; +} + +#comment-form img { + max-width: 100%; +} + /* Source code. */ pre { @@ -298,7 +350,7 @@ tr:nth-child(even) { /* Buttons. */ -button { +.lang button { display: inline; padding: .3em .6em .3em; font-size: 75%; diff --git a/haunt/static/image/default-icon.png b/haunt/static/image/default-icon.png Binary files differindex ffd12bf..832f3ef 100644 --- a/haunt/static/image/default-icon.png +++ b/haunt/static/image/default-icon.png diff --git a/haunt/static/js/dynamic-comment-form.js b/haunt/static/js/dynamic-comment-form.js new file mode 100644 index 0000000..4be2d52 --- /dev/null +++ b/haunt/static/js/dynamic-comment-form.js @@ -0,0 +1,94 @@ +/* + * dynamic-comment-form.js -- Captcha challenge loader + * Copyright © 2022 - 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/>. + */ + +function makeRequest (method, url) { + return new Promise(function (resolve, reject) { + var xhr = new XMLHttpRequest(); + xhr.open(method, url); + xhr.onload = function () { + if (xhr.status >= 200 && xhr.status < 300) { + resolve(xhr.response); + } else { + reject({ + status: xhr.status, + statusText: xhr.statusText + }); + } + }; + xhr.onerror = function () { + reject({ + status: xhr.status, + statusText: xhr.statusText + }); + }; + xhr.send(); + }); +} + +window.addEventListener("load", () => { + let primaryDisplay = document.getElementById("comment-form-primary"); + primaryDisplay.removeAttribute("hidden"); + + let altDisplay = document.getElementById("comment-form-alt"); + altDisplay.remove(); + + let trigger = document.getElementById("captcha-challenge-trigger"); + let triggerBlock = document.getElementById("captcha-trigger-block"); + trigger.addEventListener("click", (event) => { + let captchaField = document.getElementById("comment-captcha"); + + let captchaId = document.getElementById("captcha-id"); + let captchaImage = document.getElementById("captcha-image"); + + trigger.innerHTML = "Please wait..."; + trigger.disabled = true; + + if (captchaId.value === "") { + makeRequest("GET", "/api/challenge/captcha") + .then(function (data) { + // Update form with parsed values. + let challengeData = JSON.parse(data); + captchaId.value = challengeData["challenge-id"]; + captchaImage.src = challengeData["image"]; + + // Unhide fieldset. + captchaField.removeAttribute("hidden"); + + // Hide initial trigger. + triggerBlock.remove(); + }) + .catch(console.err); + } + + event.preventDefault(); + }); +}); + + +window.addEventListener("load", () => { + let header = document.getElementById("comment-form-header"); + let replyTo = document.getElementById("reply-to"); + let buttons = document.querySelectorAll(".comment-reply-button"); + buttons.forEach((button) => { + button.addEventListener("click", (event) => { + header.innerHTML = "Comment form (reply mode)"; + replyTo.value = button.getAttribute("data-reply-to-id"); + }); + }); +}); diff --git a/haunt/static/js/gallery.js b/haunt/static/js/gallery.js index d7ed13b..038340c 100644 --- a/haunt/static/js/gallery.js +++ b/haunt/static/js/gallery.js @@ -1,6 +1,6 @@ /* * gallery.js -- Simple web-based gallery viewer. - * Copyright © 2022 Jakob L. Kreuze <zerodaysfordays@sdf.org> + * Copyright © 2022 - 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 diff --git a/haunt/static/js/local.js b/haunt/static/js/local.js deleted file mode 100644 index 51e0ea1..0000000 --- a/haunt/static/js/local.js +++ /dev/null @@ -1,110 +0,0 @@ -/* - * local.js -- Fetch and display local comments. - * Copyright © 2022 Jakob L. Kreuze <zerodaysfordays@sdf.org> - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License as - * published by the Free Software Foundation; either version 3 of the - * License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program. If not, see - * <http://www.gnu.org/licenses/>. - */ - -function getData(url, callback) { - let xhr = new XMLHttpRequest(); - xhr.onload = function(data) { - callback(data); - } - xhr.onerror = function(error) { - throw new Error(`Request failed: ${error}`); - } -} - -function makeComment(comment) { - const strip = (uri) => { - const sep = "://"; - return uri.substring(uri.indexOf(sep) + sep.length); - }; - - const element = (type, attributes) => { - let res = document.createElement(type); - for (const attribute in attributes) { - res.setAttribute(attribute, attributes[attribute]); - } - return res; - }; - - // Create the h-card section. - let avatar = element("img", { - "class": "u-photo", - "src": `https://www.gravatar.com/avatar/${comment.iconHash}?s=200` - }); - - let authorName = element("a", { - "class": "p-name u-url", - "href": comment.authorUrl - }); - authorName.textContent = comment.authorName; - - let authorURI = element("a", { - "class": "author_url", - "href": comment.author.url - }); - authorURI.textContent = strip(comment.author.url); - - let hCardContainer = element("div", { - "class": "p-author h-card author" - }); - hCardContainer.appendChild(avatar); - hCardContainer.appendChild(authorName); - hCardContainer.appendChild(authorURI); - - // Create the content section. - let contentContainer = element("div", { - "class": "e-content p-name comment-content", - }); - - contentContainer.textContent = comment.content; - - // Create the metaline section. - let pubTime = comment.published; - let time = element("time", { - "class": "dt-published", - "datetime": pubTime, - }); - time.textContent = (new Date(pubTime)).toString(); - - let linkBack = element("a", { - "class": "u-url", - "href": comment.url - }); - linkBack.appendChild(time); - - let metalineContainer = element("div", { - "class": "metaline" - }); - metalineContainer.appendChild(linkBack); - - // Put it all together. - let wrapper = element("li", { - "class": "p-comment h-cite comment", - }); - wrapper.appendChild(hCardContainer); - wrapper.appendChild(contentContainer); - wrapper.appendChild(metalineContainer); - - return wrapper; -} - -getData("http://localhost:8081/api/challenge", (b64data) => { - console.log("Here2"); - document.getElementById("captcha").src = 'data:image/png;base64,' + b64data; -}); -console.log("Here1"); diff --git a/haunt/static/js/proof-of-work.js b/haunt/static/js/proof-of-work.js new file mode 100644 index 0000000..b4b5c57 --- /dev/null +++ b/haunt/static/js/proof-of-work.js @@ -0,0 +1,109 @@ +/* + * proof-of-work.js -- Alternative captcha based on SHA-256 proof-of-work. + * Copyright © 2022 - 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/>. + */ + +function makeid(length) { + let result = ''; + let alphabet = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; + for (let i = 0; i < length; i++) { + result += alphabet.charAt(Math.floor(Math.random() * alphabet.length)); + } + return result; +} + +async function digestMessage(message) { + const msgUtf8 = new TextEncoder().encode(message); + const hashBuffer = await crypto.subtle.digest('SHA-256', msgUtf8); + const hashArray = Array.from(new Uint8Array(hashBuffer)); + const hashHex = hashArray.map((b) => b.toString(16).padStart(2, '0')).join(''); + return hashHex; +} + +async function findPrefix(hardness, nonce) { + while (true) { + let prefix = makeid(32); + let digestHex = await digestMessage(prefix + nonce); + if (digestHex.startsWith("0".repeat(hardness))) { + return prefix; + } + } +} + +function makeRequest (method, url) { + return new Promise(function (resolve, reject) { + var xhr = new XMLHttpRequest(); + xhr.open(method, url); + xhr.onload = function () { + if (xhr.status >= 200 && xhr.status < 300) { + resolve(xhr.response); + } else { + reject({ + status: xhr.status, + statusText: xhr.statusText + }); + } + }; + xhr.onerror = function () { + reject({ + status: xhr.status, + statusText: xhr.statusText + }); + }; + xhr.send(); + }); +} + +function raceEndpoint() { + return new Promise(function (resolve, reject) { + makeRequest("GET", "/api/challenge/proof-of-work") + .then(function (data) { + let challengeData = JSON.parse(data); + findPrefix(challengeData.hardness, challengeData.nonce) + .then((prefix) => { resolve([prefix, challengeData["challenge-id"]]) } ); + }) + .catch(reject); + }); +} + +window.addEventListener("load", () => { + let trigger = document.getElementById("pow-trigger"); + trigger.removeAttribute("hidden"); + trigger.addEventListener("click", (e) => { + trigger.innerHTML = "Please wait..."; + trigger.disabled = true; + raceEndpoint() + .then((result) => { + let resultField = document.getElementById("captcha-alt"); + let challengeIdField = document.getElementById("captcha-alt-id"); + resultField.value = result[0]; + challengeIdField.value = result[1]; + trigger.innerHTML = "Proof-of-Work completed successfully!"; + trigger.disabled = true; + + // Hide the primary captcha, too, to make it clear that it isn't necessary to complete. + let primaryChallenge = document.getElementById("captcha-challenge-primary"); + primaryChallenge.hidden = true; + }) + .catch((err) => { + console.log(err); + trigger.innerHTML = "Proof-of-Work failed!"; + trigger.disabled = true; + }); + e.preventDefault(); + }) +}); diff --git a/haunt/static/js/rsvp.js b/haunt/static/js/rsvp.js index f0a4353..06cdb66 100644 --- a/haunt/static/js/rsvp.js +++ b/haunt/static/js/rsvp.js @@ -1,6 +1,6 @@ /* * rsvp.js -- Simple web-based RSVP tool. - * Copyright © 2022 Jakob L. Kreuze <zerodaysfordays@sdf.org> + * Copyright © 2022 - 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 diff --git a/haunt/static/js/section-folds.js b/haunt/static/js/section-folds.js index 559dd9a..9440264 100644 --- a/haunt/static/js/section-folds.js +++ b/haunt/static/js/section-folds.js @@ -1,6 +1,6 @@ /* * section-folds.js -- Parse out sections to hide behind an "unfold" dialog - * Copyright © 2022 Jakob L. Kreuze <zerodaysfordays@sdf.org> + * Copyright © 2022 - 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 diff --git a/haunt/static/js/webmention.js b/haunt/static/js/webmention.js index c451031..d280d4d 100644 --- a/haunt/static/js/webmention.js +++ b/haunt/static/js/webmention.js @@ -1,6 +1,6 @@ /* * webmention.js -- Fetch and display mentions from webmention.io. - * Copyright © 2019 - 2020 Jakob L. Kreuze <zerodaysfordays@sdf.org> + * 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 diff --git a/haunt/tests/captcha.scm b/haunt/tests/captcha.scm new file mode 100644 index 0000000..aeea265 --- /dev/null +++ b/haunt/tests/captcha.scm @@ -0,0 +1,46 @@ +;;; 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/>. + +(use-modules (jakob dynamic captcha) + (srfi srfi-64)) + +(test-begin "id-queue-test") + +(define queue (make-queue 4 #:min-free-threshold 2)) + +(define id1 (dequeue-id! queue)) +(define id2 (dequeue-id! queue)) + +;; Two IDs are unique, if drawn in such a way that one is not invalidated by the +;; time the other is drawn. +(test-assert (number? id1)) +(test-assert (number? id2)) +(test-assert (not (= id1 id2))) + +;; IDs can be released and are appropriately removed from the allocated list. +(test-assert (positive? (length (id-queue-allocated queue)))) +(release-id! id1 queue) +(release-id! id2 queue) +(test-assert (zero? (length (id-queue-allocated queue)))) + +;; IDs are unconditionally freed under pressure. +(define id11 (dequeue-id! queue)) +(define id12 (dequeue-id! queue)) +(define id13 (dequeue-id! queue)) +(define id14 (dequeue-id! queue)) +(test-assert (member id11 (id-queue-free queue))) + +(test-end "id-queue-test") |
