diff options
| author | Jakob L. Kreuze | 2023-02-12 14:50:42 -0500 |
|---|---|---|
| committer | Jakob L. Kreuze | 2023-02-12 14:50:42 -0500 |
| commit | 4b8de0bcf0ca598804a9d462933d492232b4b314 (patch) | |
| tree | c0dc84333273faa56915f90b27865b2374679de4 /haunt/jakob | |
| parent | 8e2abe9549360f37f6703bd995b8278e4fb6b291 (diff) | |
Merge branch 'self-hosted-comments'
It's been working well enough. I think it's time to get the initial version of
this on `master'.
Diffstat (limited to 'haunt/jakob')
21 files changed, 1817 insertions, 161 deletions
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/haunt/jakob/dynamic/capabilities/gallery.scm b/haunt/jakob/dynamic/capabilities/gallery.scm new file mode 100644 index 0000000..f0c5b66 --- /dev/null +++ b/haunt/jakob/dynamic/capabilities/gallery.scm @@ -0,0 +1,105 @@ +;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (jakob dynamic capabilities gallery) + #:use-module (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) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:export (get-gallery get-image)) + +(define conn (connect-to-postgres-paramstring (paramstring-for-dbname "jakob_gallery"))) + +;; How many bytes of entropy to use when generating vanity ID's. +(define %vanity-length (make-parameter 9)) + +;; Path where gallery images are stored. +(define %gallery-image-directory (make-parameter "/home/jakob/gallery-images/")) + +(define (valid-gallery-code code) + "Check database to see if `code' names a nonempty gallery." + (and (= (string-length code) (base64-length (%vanity-length))) + (positive? + (length + (exec-query conn "SELECT * FROM images WHERE vanity = $1" + (list code)))))) + +(define (get-gallery-images code) + "Handler for enumerating the image in a gallery." + (define (format-image image) + (match image + ((title filename thumbnail datetime) + `((title . ,title) + (filename . ,filename) + (thumbnail . ,thumbnail) + (datetime . ,datetime))))) + (let* ((images (exec-query conn "SELECT title, filename, thumb_filename, datetime FROM images WHERE vanity = $1" (list code)))) + (list->vector (map format-image images)))) + +(define (get-gallery-info code) + "Handler for enumerating the image in a gallery." + (define (format-gallery info) + (match info + ((title description datetime) + `((title . ,title) + (description . ,description) + (datetime . ,datetime))))) + (let* ((info (exec-query conn "SELECT title, description, datetime FROM galleries WHERE vanity = $1" (list code)))) + (format-gallery (car info)))) + +(define (get-gallery request body) + (let* ((query-string (uri-query (request-uri request))) + (params (if query-string + (decode-form query-string) + '())) + (code (car (assoc-ref params "g")))) + (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))) + (and (string/= file-name ".") + (string/= file-name "..") + (member file-name (scandir (%gallery-image-directory))))) + +(define (read-image file-name) + (let* ((ext (string-downcase (last (string-split file-name #\.)))) + (mime (cond ((string= ext "jpg") 'image/jpeg) + ((string= ext "png") 'image/png) + (else (error "Unknown MIME type."))))) + (values `((content-type . (,mime))) + (call-with-input-file (format #f "~a/~a" (%gallery-image-directory) file-name) + (lambda (port) + (get-bytevector-all port)))))) + +(define (get-image request body) + (let* ((query-string (uri-query (request-uri request))) + (params (if query-string + (decode-form query-string) + '())) + (file-name (car (assoc-ref params "name")))) + (unless (image-exists? file-name) (panic "invalid filename")) + (read-image file-name))) diff --git a/haunt/jakob/dynamic/capabilities/rsvp.scm b/haunt/jakob/dynamic/capabilities/rsvp.scm new file mode 100644 index 0000000..2975e4d --- /dev/null +++ b/haunt/jakob/dynamic/capabilities/rsvp.scm @@ -0,0 +1,258 @@ +;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (jakob dynamic capabilities rsvp) + #:use-module (gcrypt base64) + #:use-module (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) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:export (get-event-info post-event-rsvp)) + +;; How many bytes of entropy to use when generating vanity ID's. +(define %vanity-length (make-parameter 9)) + +;; Path where event header images are stored. +(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 (paramstring-for-dbname "jakob_rsvp"))) + + + +(define (generate-vanity-code) + "Generate a random vanity ID. + +A vanity ID is used in the RSVP system for creating unique URLs for invitations. +It is a base64 string, encoding `%vanity-length' bytes of randomness." + (call-with-input-file "/dev/urandom" + (lambda (port) (base64-encode (get-bytevector-n port 9))))) + +(define (valid-invite-code invitation) + "Check database to see if `invitation' exists." + (and (= (string-length invitation) (base64-length (%vanity-length))) + (positive? + (length + (exec-query conn "SELECT * FROM invitations WHERE vanity = $1" + (list invitation)))))) + +(define (valid-receipt-code receipt) + "Check database to see if `receipt'." + (and (= (string-length receipt) (base64-length (%vanity-length))) + (positive? + (length + (exec-query conn "SELECT * FROM rsvps WHERE vanity = $1" + (list receipt)))))) + + + +(define-record-type <rsvp-create> + (make-rsvp-create-parameters) + rsvp-create-parameters? + (invitation-code rsvp-create-code set-rsvp-create-code!) + (name rsvp-create-name set-rsvp-create-name!) + (email rsvp-create-email set-rsvp-create-email!) + (attending rsvp-create-attending set-rsvp-create-attending!) + (guests rsvp-create-guests set-rsvp-create-guests!)) + +(define (params->rsvp-create params) + "Parse `params', an alist, into a `<rsvp-create>'." + (let ((res (make-rsvp-create-parameters))) + (set-rsvp-create-code! res (assoc-ref params "id")) + (set-rsvp-create-name! res (assoc-ref params "name")) + (set-rsvp-create-email! res (assoc-ref params "email")) + (set-rsvp-create-attending! res (assoc-ref params "rsvp")) + (set-rsvp-create-guests! res (assoc-ref params "guests")) + (if (any not + (list (rsvp-create-code res) + (rsvp-create-name res) + (rsvp-create-email res) + (rsvp-create-attending res) + (rsvp-create-guests res))) + #f + res))) + +(define (invitation->event-id vanity-code) + "For valid `vanity-code', find the corresponding event ID and capabilities." + (car + (exec-query conn "SELECT event_id, capabilities FROM invitations WHERE vanity = $1" + (list vanity-code)))) + +(define (create-new-event-rsvp params) + "Handler for RSVP'ing to an event." + (let ((params (params->rsvp-create params))) + (unless params + (panic "invalid form data")) + (unless (valid-invite-code (rsvp-create-code params)) + (panic "invalid invitation code")) + (let ((receipt-code (generate-vanity-code)) + (event-id (car (invitation->event-id (rsvp-create-code params))))) + (exec-query conn + "INSERT INTO rsvps (vanity, invitation_id, event_id, fullname, email, attending, guests) VALUES ($1, $2, $3, $4, $5, $6, $7)" + (list receipt-code + (rsvp-create-code params) + event-id + (rsvp-create-name params) + (rsvp-create-email params) + (rsvp-create-attending params) + (rsvp-create-guests params))) + (values '((content-type . (application/json))) + (scm->json-string + `((receipt . ,receipt-code))))))) + + + +(define-record-type <rsvp-update> + (make-rsvp-update-parameters) + rsvp-update-parameters? + (invitation-code rsvp-update-code set-rsvp-update-code!) + (name rsvp-update-name set-rsvp-update-name!) + (email rsvp-update-email set-rsvp-update-email!) + (attending rsvp-update-attending set-rsvp-update-attending!) + (guests rsvp-update-guests set-rsvp-update-guests!)) + +(define (params->rsvp-update params) + "Parse `params', an alist, into a `<rsvp-update>'." + (let ((res (make-rsvp-update-parameters))) + (set-rsvp-update-code! res (assoc-ref params "update")) + (set-rsvp-update-name! res (assoc-ref params "name")) + (set-rsvp-update-email! res (assoc-ref params "email")) + (set-rsvp-update-attending! res (assoc-ref params "rsvp")) + (set-rsvp-update-guests! res (assoc-ref params "guests")) + (if (any not + (list (rsvp-update-code res) + (rsvp-update-name res) + (rsvp-update-email res) + (rsvp-update-attending res) + (rsvp-update-guests res))) + #f + res))) + +(define (update-event-rsvp params) + "Handler for updating an RSVP to an event." + (let ((params (params->rsvp-update params))) + (unless params + (panic "invalid form data")) + (unless (valid-receipt-code (rsvp-update-code params)) + (panic "invalid recepit code")) + (exec-query conn + "UPDATE rsvps SET fullname = $2, email = $3, attending = $4, guests = $5 WHERE vanity = $1" + (list + (rsvp-update-code params) + (rsvp-update-name params) + (rsvp-update-email params) + (rsvp-update-attending params) + (rsvp-update-guests params))) + (values '((content-type . (application/json))) + (scm->json-string + `((receipt . ,(rsvp-update-code params))))))) + + + +(define (post-event-rsvp request body) + "Entry point for RSVP create/update. We dispatch on the parameters." + (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 (panic "invalid invite/update code"))))) + + + +(define (get-event-image event-id) + "Return, as base64, the header image for `event-id'." + (call-with-input-file (format #f (%event-image-path-fmt) event-id) + (lambda (port) + (base64-encode (get-bytevector-all port))))) + +(define (get-event-invitation invitation-code) + "Handler for reading information about an event." + (define (format-rsvp rsvp) + (match rsvp + ((name email attending guests) + `((name . ,name) + (email . ,email) + (attending . ,attending) + (guests . ,guests))))) + (let* ((invitation (invitation->event-id invitation-code)) + (capabilities (cadr invitation)) + (event (exec-query conn "SELECT * FROM events WHERE id = $1" (list (car invitation)))) + (rsvps (exec-query conn "SELECT fullname, email, attending, guests FROM rsvps WHERE event_id = $1" (list (car invitation))))) + (match (car event) + ((i_ title description date location) + (values '((content-type . (application/json))) + (scm->json-string + `((title . ,title) + (description . ,description) + (image . ,(get-event-image (car invitation))) + (date . ,date) + (location . ,location) + ,@(if (= 1 (logand (string->number capabilities) 1)) + `((rsvps . ,(list->vector (map format-rsvp rsvps)))) + '())))))))) + +(define (get-event-receipt receipt-code) + "Handler for reading information about an event, with receipt info." + (define (format-rsvp rsvp) + (match rsvp + ((name email attending guests) + `((name . ,name) + (email . ,email) + (attending . ,attending) + (guests . ,guests))))) + (let* ((rsvp (exec-query conn "SELECT invitation_id, fullname, email, attending, guests FROM rsvps WHERE vanity = $1" (list receipt-code))) + (invitation (invitation->event-id (caar rsvp))) + (capabilities (cadr invitation)) + (event (exec-query conn "SELECT * FROM events WHERE id = $1" (list (car invitation)))) + (rsvps (exec-query conn "SELECT fullname, email, attending, guests FROM rsvps WHERE event_id = $1" (list (car invitation))))) + (match (car event) + ((i_ title description date location) + (values '((content-type . (application/json))) + (scm->json-string + `((title . ,title) + (description . ,description) + (image . ,(get-event-image (car invitation))) + (date . ,date) + (location . ,location) + (name . ,(list-ref (car rsvp) 1)) + (email . ,(list-ref (car rsvp) 2)) + (attending . ,(list-ref (car rsvp) 3)) + (guests . ,(list-ref (car rsvp) 4)) + ,@(if (= 1 (logand (string->number capabilities) 1)) + `((rsvps . ,(list->vector (map format-rsvp rsvps)))) + '())))))))) + +(define (get-event-info request body) + "Entry point to `get-event-receipt'/`get-event-invitation'." + (let* ((query-string (uri-query (request-uri request))) + (params (if query-string + (decode-form query-string) + '())) + (invitation-code (assoc-ref params "i")) + (receipt-code (assoc-ref params "r"))) + (cond ((and receipt-code (valid-receipt-code (car receipt-code))) + (get-event-receipt (car receipt-code))) + ((and invitation-code (valid-invite-code (car invitation-code))) + (get-event-invitation (car invitation-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/haunt/jakob/dynamic/import-images.sh b/haunt/jakob/dynamic/import-images.sh new file mode 100644 index 0000000..23f6130 --- /dev/null +++ b/haunt/jakob/dynamic/import-images.sh @@ -0,0 +1,16 @@ +#!/usr/bin/env bash + +set -euo pipefail + +VANITY="$1" +shift + +for item in "$@"; do + filename=$(basename -- "$item") + extension="${filename##*.}" + filename="${filename%.*}" + uuid="$(uuidgen)" + cp "$item" "/home/jakob/gallery-images/$uuid.$extension" + convert "/home/jakob/gallery-images/$uuid.$extension" -thumbnail '100x100>' "/home/jakob/gallery-images/${uuid}_thumb.png" + psql jakob_gallery -c "INSERT INTO images (vanity, title, filename, thumb_filename, datetime) VALUES ('$VANITY', '$filename', '$uuid.$extension', '${uuid}_thumb.png', now());" +done diff --git a/haunt/jakob/dynamic/logging.scm b/haunt/jakob/dynamic/logging.scm new file mode 100644 index 0000000..7b1bd0a --- /dev/null +++ b/haunt/jakob/dynamic/logging.scm @@ -0,0 +1,37 @@ +;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (jakob dynamic logging) + #:use-module (ice-9 format) + #:use-module (srfi srfi-19) + #:export (log-append!)) + +(define %log-file-name (make-parameter "/var/log/jakob-dynamic.log")) +(define %log-level (make-parameter 'info)) + +(define (dominates message-level baseline-level) + "Determine if `a' should be shown for baseline log level `b'." + (define log-level-hierarchy '(debug info warn error)) + (>= (list-index log-level-hierarchy message-level) + (list-index log-level-hierarchy baseline-level))) + +(define (log-append! level message) + "Append `message', at `level', to the log buffer." + (when (dominates level (%log-level)) + (let ((output-port (open-file (%log-file-name) "a")) + (now (date->string (current-date) "~4"))) + (format output-port "[~a] ~a: ~a~%" now level message) + (close output-port)))) diff --git a/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/haunt/jakob/dynamic/schema-comments.sql b/haunt/jakob/dynamic/schema-comments.sql new file mode 100644 index 0000000..1f2edc7 --- /dev/null +++ b/haunt/jakob/dynamic/schema-comments.sql @@ -0,0 +1,17 @@ +CREATE TABLE comments( + id SERIAL PRIMARY KEY, + approved TIMESTAMP, + submitted TIMESTAMP NOT NULL, + slug VARCHAR(100) NOT NULL, + name VARCHAR(50) NOT NULL, + subject VARCHAR(100), + email VARCHAR(100), + url VARCHAR(100), + comment VARCHAR(1024) NOT NULL, + reactions VARCHAR(1024), + reply_to INT +); + +-- Use `now' for `submitted'. + +-- INSERT INTO comments (submitted, slug, name, comment) VALUES (now(), 'test', 'Jakob', 'Hello, world!'); diff --git a/haunt/jakob/dynamic/schema-gallery.sql b/haunt/jakob/dynamic/schema-gallery.sql new file mode 100644 index 0000000..bad4100 --- /dev/null +++ b/haunt/jakob/dynamic/schema-gallery.sql @@ -0,0 +1,18 @@ +CREATE TABLE IF NOT EXISTS galleries ( + id SERIAL, + vanity char(12) NOT NULL, + title varchar(128), + description varchar(4096) NOT NULL, + datetime timestamp with time zone NOT NULL, + PRIMARY KEY (id) +); + +CREATE TABLE IF NOT EXISTS images ( + id SERIAL, + vanity char(12) NOT NULL, + title varchar(128), + filename varchar(64) NOT NULL, + thumb_filename varchar(64) NOT NULL, + datetime timestamp with time zone NOT NULL, + PRIMARY KEY (id) +); diff --git a/haunt/jakob/dynamic/schema-rsvp.sql b/haunt/jakob/dynamic/schema-rsvp.sql new file mode 100644 index 0000000..3e6a21f --- /dev/null +++ b/haunt/jakob/dynamic/schema-rsvp.sql @@ -0,0 +1,34 @@ +CREATE TABLE IF NOT EXISTS events ( + id SERIAL, + title varchar(128) NOT NULL, + description varchar(16384) NOT NULL, + datetime timestamp with time zone NOT NULL, + location varchar(128) NOT NULL, + PRIMARY KEY (id) +); + +CREATE TABLE IF NOT EXISTS invitations ( + id SERIAL, + vanity char(12) NOT NULL, + comments varchar(1024) NOT NULL, + created_on timestamp with time zone default current_timestamp, + capabilities bigint NOT NULL, + event_id integer NOT NULL, + PRIMARY KEY (id) +); + +CREATE TABLE IF NOT EXISTS rsvps ( + id SERIAL, + vanity char(12) NOT NULL, + invitation_id char(12) NOT NULL, + event_id bigint NOT NULL, + fullname varchar(128) NOT NULL, + email varchar(256) NOT NULL, + guests varchar(1024) NOT NULL, + attending varchar(32) NOT NULL, + PRIMARY KEY (id) +); + +-- `rsvps` contains the bare minimum. If we later decide we need additional +-- fields, we'll have an additional table mapping events.id to attribute names +-- and rsvps.id to attribute values. diff --git a/haunt/jakob/dynamic/util.scm b/haunt/jakob/dynamic/util.scm new file mode 100644 index 0000000..a7fd38d --- /dev/null +++ b/haunt/jakob/dynamic/util.scm @@ -0,0 +1,84 @@ +;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (jakob dynamic util) + #:use-module (ice-9 match) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (web uri) + #: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" + (let ((value (assoc-ref alist k))) + (if value + (let ((alist (alist-delete k alist))) + (acons k (cons v value) alist)) + (acons k (list v) alist)))) + +(define (acons-normalize key value alist) + "Add KEY -> VALUE to ALIST such that no entries for KEY are duplicates" + (cons (cons key value) + (filter (lambda (pair) (not (equal? (car pair) key))) alist))) + +(define (list->alist lst) + "Build a alist of list based on a list of key and values. + + Multiple values can be associated with the same key" + (let next ((lst lst) + (out '())) + (if (null? lst) + out + (next (cdr lst) (acons-list (caar lst) (cdar lst) out))))) + +(define (decode-form bv) + "Convert BV querystring or form data to an alist" + (define string (if (string? bv) bv (utf8->string bv))) + (define pairs (map (cut string-split <> #\=) + ;; semi-colon and amp can be used as pair separator + (append-map (cut string-split <> #\;) + (string-split string #\&)))) + (list->alist (map (match-lambda + ((key value) + (cons (uri-decode key) (uri-decode value)))) pairs))) + +(define (base64-length n) + "The length of the base64 string encoding `n' bytes." + (inexact->exact (* 4 (ceiling (/ n 3.0))))) + +(define (date<? d1 d2) + "Return #t if D2 specifies a later date than D1" + (time<? (date->time-utc d1) (date->time-utc d2))) + +(define (hash-append! table key item) + "Append ITEM to the list specified by KEY in TABLE + +If KEY does not exist in TABLE, initialize kEY to (list ITEM)" + (if (hash-ref table key) + (hash-set! table key (cons item (hash-ref table key))) + (hash-set! table key (list item)))) 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)))) |