diff options
| author | Jakob L. Kreuze <zerodaysfordays@sdf.org> | 2024-07-13 18:04:05 -0400 |
|---|---|---|
| committer | Jakob L. Kreuze <zerodaysfordays@sdf.org> | 2024-07-13 18:11:42 -0400 |
| commit | 81c4d517735983a5afd6e9dc800257c761598527 (patch) | |
| tree | 6b924707914d385126e6d330d2c628fd26f23a27 /jakob/dynamic | |
| parent | 7f37518e4792f040a753a5d8d68d51e76cc0b2be (diff) | |
The `org' directory is no longer necessary
Diffstat (limited to 'jakob/dynamic')
| -rw-r--r-- | jakob/dynamic/blacklist.scm | 151 | ||||
| -rw-r--r-- | jakob/dynamic/capabilities/comment-form.scm | 119 | ||||
| -rw-r--r-- | jakob/dynamic/capabilities/comments.scm | 210 | ||||
| -rw-r--r-- | jakob/dynamic/capabilities/common.scm | 68 | ||||
| -rw-r--r-- | jakob/dynamic/capabilities/gallery.scm | 79 | ||||
| -rw-r--r-- | jakob/dynamic/capabilities/poll.scm | 329 | ||||
| -rw-r--r-- | jakob/dynamic/capabilities/rsvp.scm | 336 | ||||
| -rw-r--r-- | jakob/dynamic/captcha.scm | 312 | ||||
| -rw-r--r-- | jakob/dynamic/config.scm | 48 | ||||
| -rw-r--r-- | jakob/dynamic/errors.scm | 39 | ||||
| -rw-r--r-- | jakob/dynamic/import-images.sh | 16 | ||||
| -rw-r--r-- | jakob/dynamic/logging.scm | 39 | ||||
| -rw-r--r-- | jakob/dynamic/rate-limiter.scm | 78 | ||||
| -rw-r--r-- | jakob/dynamic/schema-comments.sql | 18 | ||||
| -rw-r--r-- | jakob/dynamic/schema-gallery.sql | 18 | ||||
| -rw-r--r-- | jakob/dynamic/schema-poll.sql | 27 | ||||
| -rw-r--r-- | jakob/dynamic/schema-rsvp.sql | 34 | ||||
| -rw-r--r-- | jakob/dynamic/util.scm | 133 |
18 files changed, 2054 insertions, 0 deletions
diff --git a/jakob/dynamic/blacklist.scm b/jakob/dynamic/blacklist.scm new file mode 100644 index 0000000..4796cab --- /dev/null +++ b/jakob/dynamic/blacklist.scm @@ -0,0 +1,151 @@ +;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (jakob dynamic blacklist) + #:use-module (jakob dynamic errors) + #:use-module (jakob dynamic logging) + #:export (fail-when-ip-blacklisted)) + +(define %blacklisted-ip-list + '("113.221.133.247" ; identified as spammer - [2022-12-23T20:50:04-0500] info: POST (comment) (113.221.133.247) + "113.4.118.66" ; identified as spammer - [2022-12-31T16:29:29-0500] info: POST (comment) (113.4.118.66) + "113.4.158.97" ; identified as spammer - [2023-01-04T09:10:08-0500] info: POST (comment) (113.4.158.97) + "114.119.145.88" ; identified as web crawler - [2022-12-16T00:39:39-0500] info: GET (comment-form backdoorctf-2017-funsignals) (114.119.145.88) + "114.119.154.200" ; identified as web crawler - [2023-01-04T00:28:39-0500] info: GET (comment-form rust-on-the-flipper-zero) (114.119.154.200) + "114.228.60.65" ; identified as spammer - [2022-12-17T01:01:09-0500] info: POST (comment) (114.228.60.65) + "114.25.102.177" ; identified as spammer - [2023-01-06T23:13:44-0500] info: POST (comment) (114.25.102.177) + "123.110.200.15" ; identified as spammer - [2023-01-06T07:42:35-0500] info: POST (comment) (123.110.200.15) + "125.228.230.78" ; identified as spammer - [2023-01-07T18:24:13-0500] info: POST (comment) (125.228.230.78) + "13.90.150.239" ; identified as web crawler - [2022-12-25T16:40:23-0500] info: GET (Probe) (13.90.150.239) + "135.181.137.110" ; identified as web crawler - [2022-12-26T21:43:57-0500] info: GET (comment-form sdl-tutorial-part-0x00---boilerplate-windowing-and-rendering) (135.181.137.110) + "135.181.180.59" ; identified as web crawler - [2022-12-13T03:51:15-0500] info: GET (comment-form rust-on-the-flipper-zero) (135.181.180.59) + "136.243.228.182" ; identified as web crawler - [2022-12-15T10:55:56-0500] info: GET (comment-form making-your-own-music-player-a-gentle-introduction-to-audio-programming) (136.243.228.182) + "138.199.19.247" ; identified as spammer - [2022-12-19T11:25:33-0500] info: POST (comment) (138.199.19.247) + "138.199.59.130" ; identified as spammer - [2022-12-23T21:52:36-0500] info: POST (comment) (138.199.59.130) + "138.199.59.172" ; identified as spammer - [2022-12-25T02:29:52-0500] info: POST (comment) (138.199.59.172) + "139.59.135.127" ; identified as script kiddie - [2022-12-10T16:36:27-0500] info: PUT (v2 cmdb system admin admin) (139.59.135.127) + "144.76.68.76" ; identified as web crawler - [2023-01-02T14:53:45-0500] info: GET (comment-form pushing-haunt-to-its-limits) (144.76.68.76) + "162.55.86.53" ; identified as web crawler - [2023-01-07T06:24:38-0500] info: GET (comment-form writeups-for-plaidctf-2019) (162.55.86.53) + "17.241.219.158" ; identified as web crawler - [2023-01-03T23:14:04-0500] info: GET (comment-form investigating-a-backdoorshshellbotaa-infection) (17.241.219.158) + "173.255.174.41" ; identified as spammer - [2022-12-24T05:23:08-0500] info: POST (comment) (173.255.174.41) + "181.214.173.130" ; identified as spammer - [2022-12-13T19:12:12-0500] info: POST (comment) (181.214.173.130) + "185.173.36.129" ; identified as spammer - [2022-12-30T14:12:23-0500] info: POST (comment) (185.173.36.129) + "185.191.171.1" ; identified as web crawler - [2022-12-24T21:59:38-0500] info: GET (comment-form writeups-for-plaidctf-2019) (185.191.171.1) + "185.191.171.10" ; identified as web crawler - [2023-01-06T16:34:54-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-36-74) (185.191.171.10) + "185.191.171.11" ; identified as web crawler - [2023-01-06T06:21:26-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-2-11) (185.191.171.11) + "185.191.171.12" ; identified as web crawler - [2022-12-24T14:52:20-0500] info: GET (comment-form analyzing-executable-size-part-0---a-small-proof-of-concept-loader) (185.191.171.12) + "185.191.171.13" ; identified as web crawler - [2022-12-30T08:47:19-0500] info: GET (comment-form dollar-bin-reverse-engineering) (185.191.171.13) + "185.191.171.14" ; identified as web crawler - [2023-01-02T01:35:22-0500] info: GET (comment-form first-impressions-of-the-rust-programming-language) (185.191.171.14) + "185.191.171.15" ; identified as web crawler - [2022-12-23T21:35:14-0500] info: GET (comment-form ret2emacs) (185.191.171.15) + "185.191.171.16" ; identified as web crawler - [2022-12-24T02:59:43-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-2-11) (185.191.171.16) + "185.191.171.17" ; identified as web crawler - [2022-12-18T07:03:35-0500] info: GET (comment-form pushing-haunt-to-its-limits) (185.191.171.17) + "185.191.171.19" ; identified as web crawler - [2022-12-24T05:15:58-0500] info: GET (comment-form sdl-tutorial-part-0x00---boilerplate-windowing-and-rendering) (185.191.171.19) + "185.191.171.2" ; identified as web crawler - [2023-01-05T11:08:56-0500] info: GET (comment-form writeups-for-plaidctf-2019) (185.191.171.2) + "185.191.171.23" ; identified as web crawler - [2022-12-24T22:37:16-0500] info: GET (comment-form a-good-bye-letter-to-my-life-long-companion) (185.191.171.23) + "185.191.171.24" ; identified as web crawler - [2022-12-24T03:34:17-0500] info: GET (comment-form reverse-engineering-babbys-first-archive-format) (185.191.171.24) + "185.191.171.25" ; identified as web crawler - [2022-12-24T16:02:33-0500] info: GET (comment-form first-impressions-of-the-kotlin-programming-language) (185.191.171.25) + "185.191.171.26" ; identified as web crawler - [2022-12-21T23:50:50-0500] info: GET (comment-form understand-game-hacking-in-one-post) (185.191.171.26) + "185.191.171.3" ; identified as web crawler - [2022-12-24T04:28:34-0500] info: GET (comment-form reverse-engineering-by-hand) (185.191.171.3) + "185.191.171.33" ; identified as web crawler - [2022-12-25T06:04:06-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-12-22) (185.191.171.33) + "185.191.171.35" ; identified as web crawler - [2022-12-21T19:05:05-0500] info: GET (comment-form rust-on-the-flipper-zero) (185.191.171.35) + "185.191.171.36" ; identified as web crawler - [2022-12-14T21:20:16-0500] info: GET (comment-form browser-games-arent-an-easy-target) (185.191.171.36) + "185.191.171.37" ; identified as web crawler - [2023-01-05T04:30:35-0500] info: GET (comment-form first-impressions-of-the-kotlin-programming-language) (185.191.171.37) + "185.191.171.38" ; identified as web crawler - [2023-01-02T03:08:49-0500] info: GET (comment-form rust-on-the-flipper-zero) (185.191.171.38) + "185.191.171.39" ; identified as web crawler - [2022-12-24T11:53:54-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-36-74) (185.191.171.39) + "185.191.171.4" ; identified as web crawler - [2022-12-20T13:40:53-0500] info: GET (comment-form umass-ctf-2021-postmortem) (185.191.171.4) + "185.191.171.40" ; identified as web crawler - [2022-12-25T00:32:43-0500] info: GET (comment-form first-impressions-of-the-myrddin-programming-language) (185.191.171.40) + "185.191.171.43" ; identified as web crawler - [2022-12-17T17:36:28-0500] info: GET (comment-form dollar-bin-reverse-engineering) (185.191.171.43) + "185.191.171.44" ; identified as web crawler - [2022-12-20T13:46:51-0500] info: GET (comment-form slime-the-world-a-postmortem) (185.191.171.44) + "185.191.171.5" ; identified as web crawler - [2023-01-05T16:16:16-0500] info: GET (comment-form first-impressions-of-the-myrddin-programming-language) (185.191.171.5) + "185.191.171.6" ; identified as web crawler - [2022-12-21T13:02:35-0500] info: GET (comment-form first-impressions-of-the-rust-programming-language) (185.191.171.6) + "185.191.171.7" ; identified as web crawler - [2022-12-15T18:56:17-0500] info: GET (comment) (185.191.171.7) + "185.191.171.8" ; identified as web crawler - [2022-12-24T12:19:23-0500] info: GET (comment-form the-many-faces-of-an-undying-programming-language) (185.191.171.8) + "185.191.171.9" ; identified as web crawler - [2022-12-22T00:33:36-0500] info: GET (comment-form investigating-a-backdoorshshellbotaa-infection) (185.191.171.9) + "185.51.134.245" ; identified as spammer - [2022-12-31T16:38:25-0500] info: POST (comment) (185.51.134.245) + "188.126.88.12" ; identified as spammer - [2023-01-04T23:15:14-0500] info: POST (comment) (188.126.88.12) + "188.126.94.243" ; identified as spammer - [2022-12-16T04:03:49-0500] info: POST (comment) (188.126.94.243) + "192.99.15.185" ; identified as web crawler - [2022-12-13T18:05:55-0500] info: GET (comment-form browser-games-arent-an-easy-target) (192.99.15.185) + "37.139.53.20" ; identified as spammer - [2022-12-28T20:18:09-0500] info: POST (comment) (37.139.53.20) + "37.139.53.30" ; identified as spammer - [2022-12-24T22:33:10-0500] info: POST (comment) (37.139.53.30) + "37.139.53.37" ; identified as spammer - [2022-12-12T23:31:09-0500] info: POST (comment) (37.139.53.37) + "37.139.53.40" ; identified as spammer - [2022-12-15T04:34:57-0500] info: POST (comment) (37.139.53.40) + "37.139.53.50" ; identified as spammer - [2022-12-15T23:35:29-0500] info: POST (comment) (37.139.53.50) + "37.139.53.82" ; identified as spammer - [2023-01-05T10:56:49-0500] info: POST (comment) (37.139.53.82) + "37.46.115.49" ; identified as spammer - [2023-01-02T04:12:27-0500] info: POST (comment) (37.46.115.49) + "51.222.253.1" ; identified as web crawler - [2022-12-19T03:06:58-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-2-11) (51.222.253.1) + "51.222.253.11" ; identified as web crawler - [2022-12-15T06:39:18-0500] info: GET (comment-form ret2emacs) (51.222.253.11) + "51.222.253.13" ; identified as web crawler - [2022-12-15T06:01:25-0500] info: GET (comment-form umass-ctf-2021-postmortem) (51.222.253.13) + "51.222.253.14" ; identified as web crawler - [2022-12-18T23:31:09-0500] info: GET (comment-form towards-guix-for-devops) (51.222.253.14) + "51.222.253.15" ; identified as web crawler - [2023-01-06T21:01:54-0500] info: GET (comment-form game-hacking-on-linux---scanmem-basics) (51.222.253.15) + "51.222.253.17" ; identified as web crawler - [2022-12-19T21:54:40-0500] info: GET (comment-form reverse-engineering-babbys-first-archive-format) (51.222.253.17) + "51.222.253.18" ; identified as web crawler - [2022-12-12T15:48:52-0500] info: GET (comment-form pushing-haunt-to-its-limits) (51.222.253.18) + "51.222.253.2" ; identified as web crawler - [2022-12-20T02:03:32-0500] info: GET (comment-form game-hacking-on-linux---scanmem-basics) (51.222.253.2) + "51.222.253.20" ; identified as web crawler - [2022-12-24T21:29:55-0500] info: GET (comment-form ret2emacs) (51.222.253.20) + "51.222.253.3" ; identified as web crawler - [2022-12-14T05:45:52-0500] info: GET (comment-form rust-on-the-flipper-zero) (51.222.253.3) + "51.222.253.4" ; identified as web crawler - [2022-12-20T17:16:43-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-23-35) (51.222.253.4) + "51.222.253.5" ; identified as web crawler - [2022-12-21T14:12:27-0500] info: GET (comment-form understand-game-hacking-in-one-post) (51.222.253.5) + "51.222.253.6" ; identified as web crawler - [2022-12-15T00:57:31-0500] info: GET (comment-form transitioning-to-haunt) (51.222.253.6) + "51.222.253.7" ; identified as web crawler - [2022-12-13T18:32:46-0500] info: GET (comment-form reverse-engineering-by-hand) (51.222.253.7) + "51.222.253.8" ; identified as web crawler - [2022-12-18T04:51:59-0500] info: GET (comment-form i-love-my-pinephone) (51.222.253.8) + "51.222.253.9" ; identified as web crawler - [2022-12-12T13:34:03-0500] info: GET (comment-form installing-gentoo-one-month-later) (51.222.253.9) + "59.33.205.196" ; identified as spammer - [2022-12-22T23:54:13-0500] info: POST (comment) (59.33.205.196) + "65.108.0.150" ; identified as web crawler - [2022-12-16T13:02:49-0500] info: GET (comment-form pushing-haunt-to-its-limits) (65.108.0.150) + "65.108.110.26" ; identified as web crawler - [2022-12-19T12:17:01-0500] info: GET (comment-form first-impressions-of-the-myrddin-programming-language) (65.108.110.26) + "65.108.125.120" ; identified as web crawler - [2023-01-02T03:19:03-0500] info: GET (comment-form first-impressions-of-the-kotlin-programming-language) (65.108.125.120) + "65.108.203.159" ; identified as web crawler - [2022-12-13T08:41:18-0500] info: GET (comment-form pushing-haunt-to-its-limits) (65.108.203.159) + "65.108.46.72" ; identified as web crawler - [2023-01-05T16:45:53-0500] info: GET (comment-form installing-gentoo-one-month-later) (65.108.46.72) + "65.109.26.102" ; identified as web crawler - [2022-12-22T06:41:24-0500] info: GET (comment-form umass-ctf-2021-postmortem) (65.109.26.102) + "65.21.237.125" ; identified as web crawler - [2023-01-03T21:53:45-0500] info: GET (comment-form pushing-haunt-to-its-limits) (65.21.237.125) + "66.249.66.130" ; identified as web crawler - [2023-01-02T10:47:58-0500] info: GET (comment-form first-impressions-of-the-myrddin-programming-language) (66.249.66.130) + "66.249.66.206" ; identified as web crawler - [2022-12-31T13:45:35-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-12-22) (66.249.66.206) + "66.249.66.28" ; identified as web crawler - [2022-12-18T03:48:57-0500] info: GET (comment-form a-good-bye-letter-to-my-life-long-companion) (66.249.66.28) + "66.249.66.3" ; identified as web crawler - [2022-12-18T03:48:07-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-12-22) (66.249.66.3) + "66.249.66.30" ; identified as web crawler - [2022-12-22T04:03:42-0500] info: GET (comment-form pushing-haunt-to-its-limits) (66.249.66.30) + "66.249.66.46" ; identified as web crawler - [2022-12-29T11:45:29-0500] info: GET (comment-form writeups-for-dennis-yurichevs-reverse-engineering-challenges-12-22) (66.249.66.46) + "66.249.70.124" ; identified as web crawler - [2022-12-30T08:03:43-0500] info: GET (comment-form pushing-haunt-to-its-limits) (66.249.70.124) + "66.249.70.96" ; identified as web crawler - [2022-12-30T08:48:44-0500] info: GET (comment-form pushing-haunt-to-its-limits) (66.249.70.96) + "77.240.183.231" ; identified as web crawler - [2022-12-17T08:20:56-0500] info: GET (comment-form sdl-tutorial-part-0x00---boilerplate-windowing-and-rendering) (77.240.183.231) + "81.170.128.52" ; identified as web crawler - [2022-12-22T09:13:14-0500] info: GET (comment-form first-impressions-of-the-rust-programming-language) (81.170.128.52) + "87.250.224.112" ; identified as web crawler - [2023-01-01T02:52:49-0500] info: GET (comment-form investigating-a-backdoorshshellbotaa-infection) (87.250.224.112) + "87.250.224.179" ; identified as web crawler - [2022-12-15T15:39:51-0500] info: GET (comment-form i-love-my-pinephone) (87.250.224.179) + "91.239.157.219" ; identified as spammer - [2022-12-19T05:04:59-0500] info: POST (comment) (91.239.157.219) + "91.240.118.252" ; identified as web crawler - [2022-12-24T15:38:52-0500] info: GET (comment-form a-good-bye-letter-to-my-life-long-companion) (91.240.118.252) + "95.181.233.157" ; identified as spammer - [2023-01-03T11:14:02-0500] info: POST (comment) (95.181.233.157) + "95.217.109.26" ; identified as web crawler - [2023-01-05T11:32:45-0500] info: GET (comment-form writeups-for-plaidctf-2019) (95.217.109.26) + "95.79.188.37" ; identified as spammer - [2022-12-15T19:28:36-0500] info: POST (comment) (95.79.188.37) + "95.91.111.111" ; identified as web crawler - [2023-01-04T06:33:30-0500] info: GET (comment-form towards-guix-for-devops) (95.91.111.111) + "99.105.215.234")) ; identified as web crawler - [2022-12-10T00:05:12-0500] info: GET (v1 timelines public) (limit=500) (99.105.215.234) +(define %blacklisted-ips + (let ((result (make-hash-table))) + (for-each (lambda (ip) + (hash-set! result ip #t)) + %blacklisted-ip-list) + result)) +(define %blacklisted-message + "If you are seeing this status code, it is because your IP address has +been associated with a pattern of misuse and was blacklisted. + +If you believe this is a mistake, please email the webmastere with a +detailed explanation of why you believe your prior use constituted a +legitimate purpose. Contact information is available ata +https:/jakob.space/about + +Otherwise: fuck off.") + +(define (fail-when-ip-blacklisted ip-address) + (when (hash-ref %blacklisted-ips ip-address) + (log-append! 'info (format #f "Blocked request from ~a" ip-address)) + (panic %blacklisted-message #:code 403))) diff --git a/jakob/dynamic/capabilities/comment-form.scm b/jakob/dynamic/capabilities/comment-form.scm new file mode 100644 index 0000000..f7d0491 --- /dev/null +++ b/jakob/dynamic/capabilities/comment-form.scm @@ -0,0 +1,119 @@ +;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (jakob dynamic capabilities comment-form) + #:use-module (gcrypt base64) + #:use-module (haunt html) + #:use-module (ice-9 match) + #:use-module (jakob builder blog) + #:use-module (jakob dynamic captcha) + #:use-module (jakob dynamic util) + #:use-module (jakob theme) + #:use-module (jakob utils sxml) + #:use-module (json) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:export (render-static-comment-form + render-dynamic-comment-form + get-comment-form)) + +(define (render-comment-field) + `(fieldset (@ (id "comment-content")) + (legend "Comment") + (label (@ (for "name") (class "required")) "Name:") + (input (@ (type "text") (id "name") (name "name") (required #t))) + (label (@ (for "email")) "Email:") + (input (@ (type "text") (id "email") (name "email"))) + (label (@ (for "url")) "Webpage URL:") + (input (@ (type "text") (id "url") (name "url"))) + (label (@ (for "subject")) "Subject:") + (input (@ (type "text") (id "subject") (name "subject"))) + (label (@ (for "comment") (class "required")) "Comment :") + (textarea (@ (id "coment") (name "comment"))) + (p "(*) Indicates a required field."))) + +(define* (render-comment-captcha-field #:optional (captcha-id "") captcha-image + #:key hidden) + `(fieldset ,(if hidden + '(@ (id "comment-captcha") (hidden "#t")) + '(@ (id "comment-captcha"))) + (legend "Captcha") + (div (@ (id "captcha-challenge-primary")) + (label (@ (for "captcha")) "Please evaluate the following definite integral:") + (img (@ (id "captcha-image") + (src ,(if captcha-image + (format #f "data:image/jpeg;charset=utf-8;base64,~a" + (base64-encode captcha-image)) + "")))) + (input (@ (type "text") (id "captcha") (name "captcha") (size 24)))) + (button (@ (id "pow-trigger") (hidden #t)) + "Too hard? (Or unable to see the challenge?)" + (br) + "Click here for an alternative captcha.") + (input (@ (autocomplete "off") (type "text") (id "captcha-id") (name "captcha-id") (hidden #t) (value ,captcha-id))) + (input (@ (autocomplete "off") (type "text") (id "captcha-alt") (name "captcha-alt") (hidden #t))) + (input (@ (autocomplete "off") (type "text") (id "captcha-alt-id") (name "captcha-alt-id") (hidden #t))) + (input (@ (type "submit") (id "submit-form") (value "Submit"))))) + +(define (render-static-comment-form slug captcha-id captcha-image) + `(div (@ (id "comment-form")) + (h1 "Comment form") + (form (@ (id "comment-input") (action "/api/comment") (method "post")) + (input (@ (type "text") (name "slug") (hidden #t) (value ,slug))) + ,(render-comment-field) + ,(render-comment-captcha-field captcha-id captcha-image)) + ,(script "proof-of-work.js"))) + +(define (render-dynamic-comment-form slug) + `(div (@ (id "comment-form")) + (h3 (@ (id "comment-form-header")) "Comment form") + (form (@ (id "comment-input") (action "/api/comment") (method "post")) + (input (@ (autocomplete "off") + (type "text") + (name "slug") + (hidden #t) + (value ,slug))) + (input (@ (autocomplete "off") + (type "text") + (name "reply-to") + (id "reply-to") + (hidden #t) + (value ""))) + ,(render-comment-field) + (fieldset (@ (id "captcha-trigger-block")) + (legend "Captcha") + (label "You need to complete a captcha to write a comment.") + (button (@ (id "captcha-challenge-trigger")) + "Click here to generate a captcha challenge")) + ,(render-comment-captcha-field #:hidden #t)) + ,(script "dynamic-comment-form.js") + ,(script "proof-of-work.js"))) + +(define (get-comment-form request body) + "API endpoint handler for querying for the comments on a particular post + +This is a wrapper around `get-comments-by-slug'." + (let-values (((captcha-id captcha-image) (new-captcha!))) + (let* ((path-encoded (uri-path (request-uri request))) + (path (split-and-decode-uri-path path-encoded)) + (slug (last path)) + (form (render-static-comment-form slug captcha-id captcha-image))) + (values '((content-type . (text/html))) + (sxml->html-string + (theme #:content form #:title "Comment prompt")))))) diff --git a/jakob/dynamic/capabilities/comments.scm b/jakob/dynamic/capabilities/comments.scm new file mode 100644 index 0000000..ee2a52d --- /dev/null +++ b/jakob/dynamic/capabilities/comments.scm @@ -0,0 +1,210 @@ +;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (jakob dynamic capabilities comments) + #:use-module (ice-9 match) + #:use-module (jakob dynamic capabilities common) + #:use-module (jakob dynamic captcha) + #:use-module (jakob dynamic config) + #:use-module (jakob dynamic errors) + #:use-module (jakob dynamic util) + #:use-module (json) + #:use-module (squee) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:export (get-comments + get-comments-by-slug + + put-comment + put-reaction)) + +(define conn (connect-to-postgres-paramstring (paramstring-for-dbname "jakob_comments"))) + +(define (get-comments-by-slug slug) + "Internal function for querying the approved comments on a post + +This interface exists for dynamically generating the comment view from Haunt." + (define (make-internal-comment~ . args) + (let* ((args-needing-processing (take-right args 4)) + (approved (list-ref args-needing-processing 0)) + (approved (string->date approved "~Y~m~d ~H~M~S.~N")) + (reactions (list-ref args-needing-processing 1)) + (reactions (if reactions + (with-input-from-string reactions read) + '())) + (originating-network (list-ref args-needing-processing 2)) + (replies (list-ref args-needing-processing 3))) + (apply make-internal-comment + `(,@(drop-right args 4) + ,approved + ,reactions + ,replies + ,originating-network)))) + (define (order-comments comments) + (define seen (make-hash-table)) + (define (id comment) (first comment)) + (define (content comment) (drop-right comment 1)) + (define (parent comment) (last comment)) + (define (has-children? id remaining) + (cond ((null? remaining) #f) + ((equal? id (parent (car remaining))) #t) + (else (has-children? id (cdr remaining))))) + (define (pass cur initial-comments remaining) + (cond ((null? initial-comments) (sort-comments (hash-ref seen 'terminal))) + ((null? cur) (pass (reverse remaining) (reverse remaining) (list))) + ((has-children? (id (car cur)) initial-comments) + (pass (cdr cur) initial-comments (cons (car cur) remaining))) + (else + (let* ((children (or (hash-ref seen (id (car cur))) '())) + (children (sort-comments children)) + (parsed (apply make-internal-comment~ (append (content (car cur)) (list children))))) + ;; Remove this comment from `seen'. + (hash-set! seen (id (car cur)) #f) + (if (parent (car cur)) + (hash-append! seen (parent (car cur)) parsed) + (hash-append! seen 'terminal parsed)) + (pass (cdr cur) initial-comments remaining))))) + (pass comments comments '())) + (let* ((query "SELECT id, name, subject, email, comment, url, approved, reactions, originating_network, reply_to + FROM comments WHERE slug = $1 and approved IS NOT NULL") + (result (exec-query conn query (list slug)))) + (if (positive? (length result)) + (order-comments result) + '()))) + +(define (get-comments request body) + "API endpoint handler for querying for the comments on a particular post + +This is a wrapper around `get-comments-by-slug'." + (define (normalize-record record) + (json-string->scm (internal-comment->json record))) + (let* ((query-string (uri-query (request-uri request))) + (params (if query-string + (decode-form query-string) + '())) + (slug (assoc-ref params "p"))) + (unless slug (panic "missing `slug' query parameter")) + (values '((content-type . (application/json))) + (scm->json-string + (list->vector + (map normalize-record (get-comments-by-slug (car slug)))))))) + + + +(define (put-comment request body) + "API endpoint handler for submitting a comment" + (define (request-originating-network request) + (cond ((from-tor? request) "tor") + ((from-i2p? request) "i2p") + (else "clearnet"))) + (define (valid-comment? form-data) + (and (assoc "slug" form-data) + (assoc "name" form-data) + (assoc "comment" form-data) + (or (assoc "captcha" form-data) + (and (assoc "captcha-alt" form-data) + (assoc "captcha-alt-id" form-data))) + (assoc "captcha-id" form-data) + (if (and (string? (assoc-value form-data "captcha-alt")) + (positive? (string-length (assoc-value form-data "captcha-alt")))) + (validate-proof-of-work! + (assoc-value form-data "captcha-alt") + (string->number (assoc-value form-data "captcha-alt-id"))) + (validate-captcha! + (assoc-value form-data "captcha") + (string->number (assoc-value form-data "captcha-id")))))) + (define (insert-comment form-data) + (exec-query conn + "INSERT INTO comments (submitted, slug, name, subject, email, + url, comment, reply_to, originating_network) + VALUES (now(), $1, $2, $3, $4, $5, $6, $7, $8);" + (list (assoc-value form-data "slug") + (assoc-value form-data "name") + (assoc-value form-data "subject") + (assoc-value form-data "email") + (assoc-value form-data "url") + (assoc-value form-data "comment") + (if (and (assoc-value form-data "reply-to") + (positive? (string-length (assoc-value form-data "reply-to")))) + (assoc-value form-data "reply-to") + #f) + (request-originating-network request))) + (values (build-response + #:code 307 + #:headers '((Location . "https://jakob.space"))) + (scm->json-string `((success . #t))))) + (let ((form-data (decode-form body))) + (unless (assoc "slug" form-data) (panic "missing param `slug'")) + (unless (assoc "name" form-data) (panic "missing param `name'")) + (unless (assoc "comment" form-data) (panic "missing param `comment'")) + (unless (assoc "captcha-id" form-data) (panic "missing param `captcha-id'")) + (unless (or (assoc "captcha" form-data) + (and (assoc "captcha-alt" form-data) + (assoc "captcha-alt-id" form-data))) + (panic "missing param `captcha' (or `captcha-alt' and `captcha-alt-id')")) + (if (and (string? (assoc-value form-data "captcha-alt")) + (positive? (string-length (assoc-value form-data "captcha-alt")))) + ;; Alternate captcha fields specified; take the code path that validates + ;; a proof-of-work. + (unless (validate-proof-of-work! + (assoc-value form-data "captcha-alt") + (string->number (assoc-value form-data "captcha-alt-id"))) + (panic "proof-of-work not acceptable")) + ;; Alternate captcha fields not specified, so take the normal code path + ;; where we validate a captcha response. + (unless (validate-captcha! + (assoc-value form-data "captcha") + (string->number (assoc-value form-data "captcha-id"))) + (panic "captcha incorrect"))) + (insert-comment form-data))) + + + +(define (add-reaction reactions reaction) + (with-output-to-string + (lambda () + (let ((parsed (call-with-input-string reactions read))) + (write (acons-normalize reaction + (if (assoc reaction parsed) (+ 1 (assoc-value parsed reaction)) 1) + parsed)))))) + +(define (put-reaction request body) + (define (set-reactions id reactions) + (exec-query conn "UPDATE comments SET reactions = $1 WHERE id = $2" + (list reactions id))) + (define (comment-reactions id) + (let* ((query "SELECT reactions FROM comments WHERE id = $1") + (result (exec-query conn query (list id)))) + ;; It could be NULL, in which case we want the empty list instead. + (if (positive? (length result)) (or (caar result) "()") #f))) + (define (valid-reaction? form-data) + (and (assoc "id" form-data) + (assoc "reaction" form-data))) + (let ((form-data (decode-form body))) + (unless (assoc "id" form-data) (panic "missing param `id'")) + (unless (assoc "reaction" form-data) (panic "missing param `reaction'")) + (let* ((id (assoc-value form-data "id")) + (reaction (assoc-value form-data "reaction")) + (reactions (comment-reactions id))) + (unless id (panic "no such comment")) + (unless (emoji? reaction) (panic "invalid reaction")) + (set-reactions id (add-reaction reactions reaction)) + (values '((content-type . (application/json))) + (scm->json-string `((success . #t))))))) diff --git a/jakob/dynamic/capabilities/common.scm b/jakob/dynamic/capabilities/common.scm new file mode 100644 index 0000000..2bca1a2 --- /dev/null +++ b/jakob/dynamic/capabilities/common.scm @@ -0,0 +1,68 @@ +;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (jakob dynamic capabilities common) + #:use-module (jakob dynamic util) + #:use-module (json) + #:use-module (srfi srfi-19) + #:export (json->internal-comment + internal-comment->json + make-internal-comment + internal-comment? + internal-comment-id + internal-comment-name + internal-comment-subject + internal-comment-email + internal-comment-comment + internal-comment-url + internal-comment-publish-time + internal-comment-reactions + internal-comment-replies + internal-comment-originating-network + sort-comments)) + +(define-json-mapping <internal-comment> + make-internal-comment + internal-comment? + json->internal-comment <=> internal-comment->json + (id internal-comment-id) + (name internal-comment-name) + (subject internal-comment-subject) + (email internal-comment-email) + (comment internal-comment-comment) + (url internal-comment-url) + (publish-time + internal-comment-publish-time + "publish-time" + (lambda (x) (string->date x "~Y~m~d ~H~M~S.~N")) + (lambda (x) (date->string x "~Y-~m-~d ~H:~M:~S.~N"))) + (reactions internal-comment-reactions) + (replies + internal-comment-replies + "replies" + (lambda (x) (map (lambda (comment) + (call-with-input-string (scm->json-string comment) json->internal-comment)) + (vector->list x))) + (lambda (x) (list->vector (map (lambda (y) + (json-string->scm (internal-comment->json y))) + x)))) + (originating-network internal-comment-originating-network)) + +(define (sort-comments comments) + "Sort COMMENTS, a list of `<internal-comment>' chronologically" + (sort comments (lambda (c1 c2) + (date<? (internal-comment-publish-time c1) + (internal-comment-publish-time c2))))) diff --git a/jakob/dynamic/capabilities/gallery.scm b/jakob/dynamic/capabilities/gallery.scm new file mode 100644 index 0000000..7087149 --- /dev/null +++ b/jakob/dynamic/capabilities/gallery.scm @@ -0,0 +1,79 @@ +;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (jakob dynamic capabilities gallery) + #:use-module (haunt html) + #:use-module (ice-9 match) + #:use-module (jakob dynamic config) + #:use-module (jakob dynamic errors) + #:use-module (jakob dynamic util) + #:use-module (jakob theme) + #:use-module (squee) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:export (get-gallery get-image)) + +(define conn (connect-to-postgres-paramstring (paramstring-for-dbname "jakob_gallery"))) + +;; How many bytes of entropy to use when generating vanity ID's. +(define %vanity-length (make-parameter 9)) + +;; Path where gallery images are stored. +(define %gallery-image-directory (make-parameter "/home/jakob/gallery-images/")) + +(define (valid-gallery-code code) + "Check database to see if `code' names a nonempty gallery." + (and (= (string-length code) (base64-length (%vanity-length))) + (positive? + (length + (exec-query conn "SELECT * FROM images WHERE vanity = $1" + (list code)))))) + +(define (render-gallery code) + (define info + (first + (exec-query conn "SELECT title, description, datetime FROM galleries WHERE vanity = $1" (list code)))) + (define images + (exec-query conn "SELECT title, filename, thumb_filename, datetime FROM images WHERE vanity = $1" (list code))) + (match info + ((title description datetime) + `(div (@ (id "gallery-container")) + (h1 ,title) + (h3 ,description) + ,(map (lambda (image) + (match image + ((title filename thumbnail datetime) + `(a (@ (href ,(format #f "/static-ext/~a" filename))) + (img (@ (src ,(format #f "/static-ext/~a" thumbnail)) + (alt ,title) + (title ,(format #f "~a - ~a" title datetime)))))))) + images))))) + +(define (get-gallery request body) + (let* ((query-string (uri-query (request-uri request))) + (params (if query-string + (decode-form query-string) + '())) + (code (if (assoc-ref params "g") + (car (assoc-ref params "g")) + (panic "no gallery code provided")))) + (unless (valid-gallery-code code) (panic "invalid gallery code")) + (values '((content-type . (text/html))) + (sxml->html-string + (theme #:title "Photo Gallery" #:content (render-gallery code)))))) diff --git a/jakob/dynamic/capabilities/poll.scm b/jakob/dynamic/capabilities/poll.scm new file mode 100644 index 0000000..560a8e3 --- /dev/null +++ b/jakob/dynamic/capabilities/poll.scm @@ -0,0 +1,329 @@ +;;; Copyright © 2019 - 2024 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (jakob dynamic capabilities poll) + #:use-module (gcrypt base64) + #:use-module (haunt html) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #:use-module (jakob dynamic config) + #:use-module (jakob dynamic errors) + #:use-module (jakob dynamic util) + #:use-module (jakob theme) + #:use-module (json) + #:use-module (rnrs bytevectors) + #:use-module (squee) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (sxml simple) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri)) + +;; How many bytes of entropy to use when generating vanity ID's. +(define %vanity-length (make-parameter 12)) + +;; Global handle to the RSVP database. +(define conn (connect-to-postgres-paramstring (paramstring-for-dbname "jakob_poll"))) + + + +(define-record-type <poll> + (make-poll title description questions) + poll? + (title poll-title set-poll-title!) + (description poll-description set-poll-description!) + (questions poll-questions set-poll-questions!)) + +(define (valid-invite-code invitation) + "Check database to see if `invitation' exists." + (and (= (string-length invitation) (%vanity-length)) + (positive? + (length + (exec-query conn "SELECT * FROM invitations WHERE vanity = $1" + (list invitation)))))) + +(define (invite-code->poll-id invitation) + (caar + (exec-query conn "SELECT poll_id FROM invitations WHERE vanity = $1" + (list invitation)))) + +(define (get-poll id) + (define response + (car + (exec-query conn "SELECT title, description, questions FROM polls WHERE id = $1" + (list id)))) + (make-poll + (first response) + (second response) + (call-with-input-string (third response) read))) + +(define (valid-fields invitation) + (map car (poll-questions (get-poll (invite-code->poll-id invitation))))) + + + +(define-record-type <poll-response-create> + (make-poll-response-create-parameters) + poll-response-create-parameters? + (invitation-code poll-response-create-code set-poll-response-create-code!) + (response poll-response-create-response set-poll-response-create-response!)) + +(define (assoc-intersect keys alist) + "Filter `alist' down to just `keys'." + (filter (lambda (x) (member (car x) keys)) alist)) + +(define (params->poll-response-create params) + "Parse `params', an alist, into a `<poll-response-create>'." + (let* ((id (assoc-value params "id")) + (valid-fields (valid-fields id)) + (res (make-poll-response-create-parameters))) + (set-poll-response-create-code! res id) + (set-poll-response-create-response! res (assoc-intersect valid-fields params)) + (if (or + (any not + (list (poll-response-create-code res) + (poll-response-create-response res))) + (not (= (length valid-fields) + (length (poll-response-create-response res))))) + #f + res))) + +(params->poll-response-create '(("id" "ArVR1jTK2lbo") ("availability-1" "asdf") ("availability-2" "asdf"))) + +(define (invitation->poll-id vanity-code) + "For valid `vanity-code', find the corresponding poll ID." + (car + (exec-query conn "SELECT poll_id FROM invitations WHERE vanity = $1" + (list vanity-code)))) + + + +(define (create-new-event-rsvp params) + "Handler for responding to the poll." + (let ((params (params->rsvp-create params))) + (unless params + (panic "invalid form data")) + (unless (valid-invite-code (rsvp-create-code params)) + (panic "invalid invitation code")) + (let ((receipt-code (generate-vanity-code)) + (event-id (car (invitation->event-id (rsvp-create-code params))))) + (exec-query conn + "INSERT INTO rsvps (vanity, invitation_id, event_id, fullname, email, attending, guests) VALUES ($1, $2, $3, $4, $5, $6, $7)" + (list receipt-code + (rsvp-create-code params) + event-id + (rsvp-create-name params) + (rsvp-create-email params) + (rsvp-create-attending params) + (rsvp-create-guests params))) + (values '((content-type . (text/html))) + (sxml->html-string + (theme #:title "Thanks for RSVPing!" + #:content (render-event-rsvp-receipt receipt-code))))))) + + + +(define-record-type <rsvp-update> + (make-rsvp-update-parameters) + rsvp-update-parameters? + (invitation-code rsvp-update-code set-rsvp-update-code!) + (name rsvp-update-name set-rsvp-update-name!) + (email rsvp-update-email set-rsvp-update-email!) + (attending rsvp-update-attending set-rsvp-update-attending!) + (guests rsvp-update-guests set-rsvp-update-guests!)) + +(define (params->rsvp-update params) + "Parse `params', an alist, into a `<rsvp-update>'." + (let ((res (make-rsvp-update-parameters))) + (set-rsvp-update-code! res (assoc-value params "update")) + (set-rsvp-update-name! res (assoc-value params "name")) + (set-rsvp-update-email! res (assoc-value params "email")) + (set-rsvp-update-attending! res (assoc-value params "rsvp")) + (set-rsvp-update-guests! res (assoc-value params "guest-names")) + (if (any not + (list (rsvp-update-code res) + (rsvp-update-name res) + (rsvp-update-email res) + (rsvp-update-attending res) + (rsvp-update-guests res))) + #f + res))) + +(define (update-event-rsvp params) + "Handler for updating an RSVP to an event." + (let ((params (params->rsvp-update params))) + (unless params + (panic "invalid form data")) + (unless (valid-receipt-code (rsvp-update-code params)) + (panic "invalid recepit code")) + (exec-query conn + "UPDATE rsvps SET fullname = $2, email = $3, attending = $4, guests = $5 WHERE vanity = $1" + (list + (rsvp-update-code params) + (rsvp-update-name params) + (rsvp-update-email params) + (rsvp-update-attending params) + (rsvp-update-guests params))) + (values '((content-type . (text/html))) + (sxml->html-string + (theme #:title "Thanks for RSVPing!" + #:content (render-event-rsvp-receipt (rsvp-update-code params))))))) + + + +(define (post-event-rsvp request body) + "Entry point for RSVP create/update. We dispatch on the parameters." + (let ((form-data (decode-form body))) + (cond ((assoc-ref form-data "id") (create-new-event-rsvp form-data)) + ((assoc-ref form-data "update") (update-event-rsvp form-data)) + (else (panic "invalid invite/update code"))))) + + + +(define (get-event-image event-id) + "Return, as base64, the header image for `event-id'." + (call-with-input-file (format #f (%event-image-path-fmt) event-id) + (lambda (port) + (base64-encode (get-bytevector-all port))))) + +(define (render-event-invitation code) + (match-let* ((rsvp (exec-query conn "SELECT invitation_id, fullname, email, attending, guests FROM rsvps WHERE vanity = $1" (list code))) + (((invitation-code name email attending guests)) + (if (not (null? rsvp)) + rsvp + '((#f #f #f #f #f)))) + (invitation-code (or invitation-code code)) + (invitation (invitation->event-id invitation-code)) + (capabilities (cadr invitation)) + (((i_ title description date location)) + (exec-query conn "SELECT * FROM events WHERE id = $1" (list (car invitation)))) + (rsvps (exec-query conn "SELECT fullname, email, attending, guests FROM rsvps WHERE event_id = $1" (list (car invitation))))) + (values + "You've been invited to an event!" + `(div (@ (id "rsvp")) + (div (@ (id "event-info")) + (h1 ,title) + (img (@ (src ,(format #f "data:image/png;base64, ~a" (get-event-image (car invitation)))) + (style "float: right; margin: 16px;"))) + (p "Where: " ,location) + (p "When: " ,date) + (p ,@(cdr (xml->sxml (format #f "<div>~a</div>" description))))) + (form (@ (id "rsvp-input") + (action "/apps/rsvp") + (method "POST")) + (input (@ (type "text") + (hidden #t) + (name ,(if (not (null? rsvp)) "update" "id")) + (value ,code))) + (fieldset + (legend "Your Info") + + (label (@ (for "name")) "Name:") + (input (@ (type "text") + (id "name") + (name "name") + (required #t) + (size "24") + ,@(if name `((value ,name)) '()))) + + (label (@ (for "email")) "Email:") + (input (@ (type "text") + (id "email") + (name "email") + (required #t) + (size "24") + ,@(if email `((value ,email)) '())))) + + (fieldset + (legend "RSVP Status") + + (input (@ (type "radio") + (id "attending") + (value "attending") + (name "rsvp") + ,@(if (and attending (string= "attending" attending)) + '((checked ,#t)) + '()))) + (label (@ (for "attending")) "Attending") + + (input (@ (type "radio") + (value "tentative") + (id "tentative") + (name "rsvp") + ,@(if (and attending (string= "tentative" attending)) + '((checked ,#t)) + '()))) + (label (@ (for "tentative")) "Tentative") + + (input (@ (type "radio") + (value "not-attending") + (id "not-attending") + (name "rsvp") + ,@(if (and attending (string= "not-attending" attending)) + '((checked ,#t)) + '()))) + (label (@ (for "not-attending")) "Not Attending")) + + (fieldset + (legend "Guests") + + (label (@ (for "guest-names")) "Names:") + (input (@ (type "text") + (id "guest-names") + (name "guest-names") + (size "24") + ,@(if guests `((value ,guests)) '())))) + + (fieldset + (legend "All Set?") + (input (@ (type "submit") + (id "submit-form") + (value "Submit"))))) + + ,@(if (equal? capabilities "1") + `((h2 "Current RSVPs") + (table + ,@(map (match-lambda + ((name email attending guests) + `(tr (td ,name) (td ,email) (td ,guests) (td ,attending)))) + rsvps))) + `()))))) + +(define (get-event-invitation invitation-code) + "Handler for reading information about an event." + (let-values (((title content) (render-event-invitation invitation-code))) + (values '((content-type . (text/html))) + (sxml->html-string (theme #:title title #:content content))))) + +(define (get-event-info request body) + "Entry point to `get-event-receipt'/`get-event-invitation'." + (let* ((query-string (uri-query (request-uri request))) + (params (if query-string + (decode-form query-string) + '())) + (invitation-code (assoc-ref params "i")) + (receipt-code (assoc-ref params "r"))) + (unless (or receipt-code invitation-code) + (panic "missing invitation or receipt code")) + (unless (or (not receipt-code) (valid-receipt-code (car receipt-code))) + (panic "invalid receipt code")) + (unless (or (not invitation-code) (valid-invite-code (car invitation-code))) + (panic "invalid invitation code")) + + (cond (receipt-code (get-event-invitation (car receipt-code))) + (invitation-code (get-event-invitation (car invitation-code)))))) diff --git a/jakob/dynamic/capabilities/rsvp.scm b/jakob/dynamic/capabilities/rsvp.scm new file mode 100644 index 0000000..25f13b8 --- /dev/null +++ b/jakob/dynamic/capabilities/rsvp.scm @@ -0,0 +1,336 @@ +;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (jakob dynamic capabilities rsvp) + #:use-module (gcrypt base64) + #:use-module (haunt html) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #:use-module (jakob dynamic config) + #:use-module (jakob dynamic errors) + #:use-module (jakob dynamic util) + #:use-module (jakob theme) + #:use-module (json) + #:use-module (rnrs bytevectors) + #:use-module (squee) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (sxml simple) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:export (get-event-info post-event-rsvp)) + +;; How many bytes of entropy to use when generating vanity ID's. +(define %vanity-length (make-parameter 12)) + +;; Path where event header images are stored. +(define %event-image-path-fmt (make-parameter "/opt/jakob-dynamic/event-images/~a.png")) + +;; Global handle to the RSVP database. +(define conn (connect-to-postgres-paramstring (paramstring-for-dbname "jakob_rsvp"))) + + + +(define (generate-vanity-code) + "Generate a random vanity ID. + +A vanity ID is used in the RSVP system for creating unique URLs for invitations. +It is a base64 string, encoding `%vanity-length' bytes of randomness." + (define alphabet + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789!@") + (call-with-input-file "/dev/urandom" + (lambda (port) + (let ((entropy (get-bytevector-n port (%vanity-length)))) + (list->string + (map (lambda (n) + (string-ref alphabet (remainder n (string-length alphabet)))) + (array->list entropy))))))) + +(define (valid-invite-code invitation) + "Check database to see if `invitation' exists." + (and (= (string-length invitation) (%vanity-length)) + (positive? + (length + (exec-query conn "SELECT * FROM invitations WHERE vanity = $1" + (list invitation)))))) + +(define (valid-receipt-code receipt) + "Check database to see if `receipt'." + (and (= (string-length receipt) (%vanity-length)) + (positive? + (length + (exec-query conn "SELECT * FROM rsvps WHERE vanity = $1" + (list receipt)))))) + + + +(define-record-type <rsvp-create> + (make-rsvp-create-parameters) + rsvp-create-parameters? + (invitation-code rsvp-create-code set-rsvp-create-code!) + (name rsvp-create-name set-rsvp-create-name!) + (email rsvp-create-email set-rsvp-create-email!) + (attending rsvp-create-attending set-rsvp-create-attending!) + (guests rsvp-create-guests set-rsvp-create-guests!)) + +(define (params->rsvp-create params) + "Parse `params', an alist, into a `<rsvp-create>'." + (let ((res (make-rsvp-create-parameters))) + (set-rsvp-create-code! res (assoc-value params "id")) + (set-rsvp-create-name! res (assoc-value params "name")) + (set-rsvp-create-email! res (assoc-value params "email")) + (set-rsvp-create-attending! res (assoc-value params "rsvp")) + (set-rsvp-create-guests! res (assoc-value params "guest-names")) + (if (any not + (list (rsvp-create-code res) + (rsvp-create-name res) + (rsvp-create-email res) + (rsvp-create-attending res) + (rsvp-create-guests res))) + #f + res))) + +(define (invitation->event-id vanity-code) + "For valid `vanity-code', find the corresponding event ID and capabilities." + (car + (exec-query conn "SELECT event_id, capabilities FROM invitations WHERE vanity = $1" + (list vanity-code)))) + + + +(define (render-event-rsvp-receipt receipt-code) + (let ((update-url (absolute-url (format #f "/apps/rsvp/event-info?r=~a" receipt-code)))) + `(div + (p "Thanks for registering! Please bookmark or save the following link:" + (a (@ (href ,update-url)) ,update-url)) + (p "This will enable you to update your RSVP later.")))) + +(define (create-new-event-rsvp params) + "Handler for RSVP'ing to an event." + (let ((params (params->rsvp-create params))) + (unless params + (panic "invalid form data")) + (unless (valid-invite-code (rsvp-create-code params)) + (panic "invalid invitation code")) + (let ((receipt-code (generate-vanity-code)) + (event-id (car (invitation->event-id (rsvp-create-code params))))) + (exec-query conn + "INSERT INTO rsvps (vanity, invitation_id, event_id, fullname, email, attending, guests) VALUES ($1, $2, $3, $4, $5, $6, $7)" + (list receipt-code + (rsvp-create-code params) + event-id + (rsvp-create-name params) + (rsvp-create-email params) + (rsvp-create-attending params) + (rsvp-create-guests params))) + (values '((content-type . (text/html))) + (sxml->html-string + (theme #:title "Thanks for RSVPing!" + #:content (render-event-rsvp-receipt receipt-code))))))) + + + +(define-record-type <rsvp-update> + (make-rsvp-update-parameters) + rsvp-update-parameters? + (invitation-code rsvp-update-code set-rsvp-update-code!) + (name rsvp-update-name set-rsvp-update-name!) + (email rsvp-update-email set-rsvp-update-email!) + (attending rsvp-update-attending set-rsvp-update-attending!) + (guests rsvp-update-guests set-rsvp-update-guests!)) + +(define (params->rsvp-update params) + "Parse `params', an alist, into a `<rsvp-update>'." + (let ((res (make-rsvp-update-parameters))) + (set-rsvp-update-code! res (assoc-value params "update")) + (set-rsvp-update-name! res (assoc-value params "name")) + (set-rsvp-update-email! res (assoc-value params "email")) + (set-rsvp-update-attending! res (assoc-value params "rsvp")) + (set-rsvp-update-guests! res (assoc-value params "guest-names")) + (if (any not + (list (rsvp-update-code res) + (rsvp-update-name res) + (rsvp-update-email res) + (rsvp-update-attending res) + (rsvp-update-guests res))) + #f + res))) + +(define (update-event-rsvp params) + "Handler for updating an RSVP to an event." + (let ((params (params->rsvp-update params))) + (unless params + (panic "invalid form data")) + (unless (valid-receipt-code (rsvp-update-code params)) + (panic "invalid recepit code")) + (exec-query conn + "UPDATE rsvps SET fullname = $2, email = $3, attending = $4, guests = $5 WHERE vanity = $1" + (list + (rsvp-update-code params) + (rsvp-update-name params) + (rsvp-update-email params) + (rsvp-update-attending params) + (rsvp-update-guests params))) + (values '((content-type . (text/html))) + (sxml->html-string + (theme #:title "Thanks for RSVPing!" + #:content (render-event-rsvp-receipt (rsvp-update-code params))))))) + + + +(define (post-event-rsvp request body) + "Entry point for RSVP create/update. We dispatch on the parameters." + (let ((form-data (decode-form body))) + (cond ((assoc-ref form-data "id") (create-new-event-rsvp form-data)) + ((assoc-ref form-data "update") (update-event-rsvp form-data)) + (else (panic "invalid invite/update code"))))) + + + +(define (get-event-image event-id) + "Return, as base64, the header image for `event-id'." + (call-with-input-file (format #f (%event-image-path-fmt) event-id) + (lambda (port) + (base64-encode (get-bytevector-all port))))) + +(define (render-event-invitation code) + (match-let* ((rsvp (exec-query conn "SELECT invitation_id, fullname, email, attending, guests FROM rsvps WHERE vanity = $1" (list code))) + (((invitation-code name email attending guests)) + (if (not (null? rsvp)) + rsvp + '((#f #f #f #f #f)))) + (invitation-code (or invitation-code code)) + (invitation (invitation->event-id invitation-code)) + (capabilities (cadr invitation)) + (((i_ title description date location)) + (exec-query conn "SELECT * FROM events WHERE id = $1" (list (car invitation)))) + (rsvps (exec-query conn "SELECT fullname, email, attending, guests FROM rsvps WHERE event_id = $1" (list (car invitation))))) + (values + "You've been invited to an event!" + `(div (@ (id "rsvp")) + (div (@ (id "event-info")) + (h1 ,title) + (img (@ (src ,(format #f "data:image/png;base64, ~a" (get-event-image (car invitation)))) + (style "float: right; margin: 16px;"))) + (p "Where: " ,location) + (p "When: " ,date) + (p ,@(cdr (xml->sxml (format #f "<div>~a</div>" description))))) + (form (@ (id "rsvp-input") + (action "/apps/rsvp") + (method "POST")) + (input (@ (type "text") + (hidden #t) + (name ,(if (not (null? rsvp)) "update" "id")) + (value ,code))) + (fieldset + (legend "Your Info") + + (label (@ (for "name")) "Name:") + (input (@ (type "text") + (id "name") + (name "name") + (required #t) + (size "24") + ,@(if name `((value ,name)) '()))) + + (label (@ (for "email")) "Email:") + (input (@ (type "text") + (id "email") + (name "email") + (required #t) + (size "24") + ,@(if email `((value ,email)) '())))) + + (fieldset + (legend "RSVP Status") + + (input (@ (type "radio") + (id "attending") + (value "attending") + (name "rsvp") + ,@(if (and attending (string= "attending" attending)) + '((checked ,#t)) + '()))) + (label (@ (for "attending")) "Attending") + + (input (@ (type "radio") + (value "tentative") + (id "tentative") + (name "rsvp") + ,@(if (and attending (string= "tentative" attending)) + '((checked ,#t)) + '()))) + (label (@ (for "tentative")) "Tentative") + + (input (@ (type "radio") + (value "not-attending") + (id "not-attending") + (name "rsvp") + ,@(if (and attending (string= "not-attending" attending)) + '((checked ,#t)) + '()))) + (label (@ (for "not-attending")) "Not Attending")) + + (fieldset + (legend "Guests") + + (label (@ (for "guest-names")) "Names:") + (input (@ (type "text") + (id "guest-names") + (name "guest-names") + (size "24") + ,@(if guests `((value ,guests)) '())))) + + (fieldset + (legend "All Set?") + (input (@ (type "submit") + (id "submit-form") + (value "Submit"))))) + + ,@(if (equal? capabilities "1") + `((h2 "Current RSVPs") + (table + ,@(map (match-lambda + ((name email attending guests) + `(tr (td ,name) (td ,email) (td ,guests) (td ,attending)))) + rsvps))) + `()))))) + +(define (get-event-invitation invitation-code) + "Handler for reading information about an event." + (let-values (((title content) (render-event-invitation invitation-code))) + (values '((content-type . (text/html))) + (sxml->html-string (theme #:title title #:content content))))) + +(define (get-event-info request body) + "Entry point to `get-event-receipt'/`get-event-invitation'." + (let* ((query-string (uri-query (request-uri request))) + (params (if query-string + (decode-form query-string) + '())) + (invitation-code (assoc-ref params "i")) + (receipt-code (assoc-ref params "r"))) + (unless (or receipt-code invitation-code) + (panic "missing invitation or receipt code")) + (unless (or (not receipt-code) (valid-receipt-code (car receipt-code))) + (panic "invalid receipt code")) + (unless (or (not invitation-code) (valid-invite-code (car invitation-code))) + (panic "invalid invitation code")) + + (cond (receipt-code (get-event-invitation (car receipt-code))) + (invitation-code (get-event-invitation (car invitation-code)))))) diff --git a/jakob/dynamic/captcha.scm b/jakob/dynamic/captcha.scm new file mode 100644 index 0000000..4407ae5 --- /dev/null +++ b/jakob/dynamic/captcha.scm @@ -0,0 +1,312 @@ +;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (jakob dynamic captcha) + #:use-module (gcrypt base16) + #:use-module (gcrypt base64) + #:use-module (gcrypt hash) + #:use-module (gcrypt random) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 iconv) + #:use-module (ice-9 iconv) + #:use-module (ice-9 local-eval) + #:use-module (ice-9 match) + #:use-module (ice-9 popen) + #:use-module (ice-9 threads) + #:use-module (jakob dynamic errors) + #:use-module (json) + #:use-module (rnrs bytevectors) + #:use-module ((rnrs base) #:select (assert)) + #:use-module (rnrs conditions) + #:use-module (rnrs exceptions) + #:use-module (srfi-197) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-35) + #:export (make-queue + id-queue-free + id-queue-allocated + release-id! + dequeue-id! + + new-captcha! + validate-captcha! + make-captcha-challenge! + + validate-proof-of-work! + make-pow-challenge!)) + +(define-record-type <id-queue> + (make-id-queue mutex min-free-threshold free-ids allocated-ids) + id-queue? + (mutex id-queue-mutex) + (min-free-threshold id-queue-min-free-threshold) + (free-ids id-queue-free set-id-queue-free!) + (allocated-ids id-queue-allocated set-id-queue-allocated!)) + +(define* (make-queue n #:key (min-free-threshold 32)) + "Construct a stateful queue for tracking captcha IDs + +The parameter N specifies how many free IDs should initially be allocated. The +optional keyword argument MIN-FREE-THRESHOLD specifies when `dequeue-id!' should +iterate through the allocated list and free anything exceeding an +internally-defined `time-to-live-seconds'." + (make-id-queue (make-mutex) min-free-threshold (iota n) (list))) + +(define (append-to-free-queue! id queue) + "Add ID to the end of the free list of QUEUE" + (set-id-queue-free! + queue + (append! (id-queue-free queue) (list id)))) + +(define (remove-from-free-queue! id queue) + "Remove ID from the free list of QUEUE" + (set-id-queue-free! queue (delete! id (id-queue-free queue)))) + +(define (append-to-allocated-queue! id queue) + "Add ID to the end of the allocated list of QUEUE" + (set-id-queue-allocated! + queue + (append! (id-queue-allocated queue) (list (list id (current-time)))))) + +(define (remove-from-allocated-queue! id queue) + "Remove ID from the allocated list of QUEUE" + (set-id-queue-allocated! + queue + (filter! (lambda (x) (not (equal? id (car x)))) + (id-queue-allocated queue)))) + +(define (release-id! id queue) + "Release ID to the free list of QUEUE" + (with-mutex (id-queue-mutex queue) + (assert (find (lambda (x) (equal? id (car x))) (id-queue-allocated queue))) + (assert (not (member id (id-queue-free queue)))) + (append-to-free-queue! id queue) + (remove-from-allocated-queue! id queue))) + +(define (dequeue-id! queue) + "Draw a random ID from QUEUE and mark it as allocated" + (define time-to-live-seconds (* 20 60)) + (with-mutex (id-queue-mutex queue) + ;; Initial pass to "unintrusively" free any stale IDs. + (when (< (length (id-queue-free queue)) + (id-queue-min-free-threshold queue)) + (for-each + (match-lambda + ((id created-time) + (when (>= (- (time-second (current-time)) + (time-second created-time)) + time-to-live-seconds) + (remove-from-allocated-queue! id queue)))) + (list-copy (id-queue-allocated queue)))) + ;; If we're still over the threshold, we'll need to be more intrusive. + ;; Ideally, this is avoided by rate-limiting. + (when (< (length (id-queue-free queue)) + (id-queue-min-free-threshold queue)) + (let* ((to-take (- (id-queue-min-free-threshold queue) + (length (id-queue-free queue)))) + (to-free (map car (take (id-queue-allocated queue) to-take)))) + (set-id-queue-allocated! queue (drop (id-queue-allocated queue) to-take)) + (set-id-queue-free! queue (append! (id-queue-free queue) to-free)))) + (let* ((n (random (length (id-queue-free queue)))) + (id (list-ref (id-queue-free queue) n))) + (remove-from-free-queue! id queue) + (append-to-allocated-queue! id queue) + id))) + + + +(define proc-mutex (make-mutex)) +(define tex-challenge-id-queue (make-queue 1024)) +(define tex-challenges (make-hash-table 1024)) + +(define (random-term) + (match (random 5) + (0 `(* ,(+ 1 (random 10)) x)) + (1 `(* ,(+ 1 (random 10)) (expt x ,(random 10)))) + (2 `(* ,(+ 1 (random 10)) (exp x))) + (3 `(* ,(+ 1 (random 10)) (cos x))) + (4 `(* ,(+ 1 (random 10)) (sin x))))) + +(define (sexp->latex sexp) + (match sexp + (('+ rest ...) (string-join (map sexp->latex rest) " + ")) + (('* rest ...) (string-join (map sexp->latex rest) " \\cdot ")) + (('sin term) (format #f "\\sin(~a)" (sexp->latex term))) + (('cos term) (format #f "\\cos(~a)" (sexp->latex term))) + (('expt term n) (format #f "~a^{~a}" (sexp->latex term) (sexp->latex n))) + (('exp term) (format #f "e^{~a}" (sexp->latex term))) + ('x "x") + (n (cond ((and (number? n) (positive? n)) (format #f "~a" n)) + ((and (number? n) (negative? n)) (format #f "(~a)" n)) + ((number? n) "0") + (else (error "Do not know how to convert to latex." n)))))) + +(define (differentiate-sexp sexp) + (match sexp + (('+ rest ...) `(+ ,@(map differentiate-sexp rest))) + (('* coeff term) (if (number? coeff) + `(* ,coeff ,(differentiate-sexp term)) + (error "Do not know how to differentiate."))) + (('sin term) `(* ,(differentiate-sexp term) (cos ,term))) + (('cos term) `(* -1 ,(differentiate-sexp term) (sin ,term))) + (('exp term) `(* ,(differentiate-sexp term) (exp ,term))) + (('expt term n) `(* ,n (expt ,term ,(- n 1)))) + ('x 1) + (n (if (number? n) + 0 + (error "Do not know how to differentiate." n))))) + +(define (simplify-sexp sexp) + (match sexp + (('+ rest ...) `(+ ,@(map simplify-sexp rest))) + (('* 1 term) (simplify-sexp term)) + (('* 1 rest ...) (simplify-sexp `(* ,@rest))) + (('sin term) `(sin ,(simplify-sexp term))) + (('sin term) `(cos ,(simplify-sexp term))) + (('exp term) `(exp ,(simplify-sexp term))) + (('expt term 1) (simplify-sexp term)) + (('expt term n) `(expt ,(simplify-sexp term) ,(simplify-sexp n))) + (term term))) + +(define (random-expression) + (let ((n-terms (+ 2 (random 3)))) + `(+ ,@(map (lambda (x) (random-term)) (iota n-terms))))) + +(define (latex->image src) + (chdir "/tmp") + (with-mutex proc-mutex + (call-with-output-file "formula.tex" + (lambda (port) + (format port "\\def\\formula{~a} +\\documentclass[border=2pt]{standalone} +\\usepackage{amsmath} +\\usepackage{varwidth} +\\begin{document} +\\begin{varwidth}{\\linewidth} +\\[ \\formula \\] +\\end{varwidth} +\\end{document} +" src))) + (unless (eqv? 0 (status:exit-val (system "latex formula.tex"))) + (error "Cannot generate DVI" #f)) + (unless (eqv? 0 (status:exit-val (system "dvipng -D 300 formula.dvi"))) + (error "Cannot generate PNG" #f)) + (call-with-input-file "formula1.png" get-bytevector-all))) + +(define (new-captcha!) + (let* ((lower-bound (random 10)) + (upper-bound (+ lower-bound 1 (random 9))) + (expression (random-expression)) + (latex-src (sexp->latex (simplify-sexp (differentiate-sexp expression)))) + (solution (- (local-eval expression (let ((x upper-bound)) (the-environment))) + (local-eval expression (let ((x lower-bound)) (the-environment))))) + (id (dequeue-id! tex-challenge-id-queue))) + (hash-set! tex-challenges id solution) + (values id + (latex->image (format #f "\\int_{~a}^{~a} ~a \\, dx" + lower-bound + upper-bound + latex-src))))) + +(define deferred-queue-mutex (make-mutex)) +(define deferred-queue (list)) +(define maximum-free-captchas 16) + +(define (new-captcha-deferred!) + (define (repopulate-queue) + (let-values (((challenge-id image) (new-captcha!))) + (with-mutex deferred-queue-mutex + (set! deferred-queue (cons (list challenge-id image) deferred-queue))) + (unless (<= maximum-free-captchas (length deferred-queue)) + (repopulate-queue)))) + (call-with-new-thread repopulate-queue) + (with-mutex deferred-queue-mutex + (if (zero? (length deferred-queue)) + ;; High-pressure conditions; we're forced to generate one on the spot. + (new-captcha!) + ;; Otherwise, we can draw on work we did a while ago. + (let ((result (car deferred-queue))) + (set! deferred-queue (cdr deferred-queue)) + (apply values result))))) + +(define (validate-captcha! user-answer id) + (define epsilon 0.01) + (let ((solution (hash-ref tex-challenges id)) + (id-allocated (not (member id (id-queue-free tex-challenge-id-queue))))) + ;; FIXME: The predictable IDs means that its' easy for someone to screw with + ;; someone elses' captcha challenge (by invalidating it before they can + ;; submit it). Given the combination of our reaping algorithm and + ;; rate-limiting, does it make sense to only release the ID when the + ;; response is correct? + (when (and solution id-allocated) + (release-id! id tex-challenge-id-queue)) + (and solution + id-allocated + (<= (/ (abs (- solution (string->number user-answer))) + solution) + epsilon)))) + +(define (make-captcha-challenge! request body) + "API endpoint handler for requesting a captcha challenge" + (let-values (((challenge-id image) (new-captcha-deferred!))) + (values '((content-type . (application/json))) + (scm->json-string + `((challenge-id . ,challenge-id) + (image . ,(format #f "data:image/jpeg;charset=utf-8;base64,~a" + (base64-encode image)))))))) + + + +(define pow-challenge-id-queue (make-queue 1024)) +(define pow-challenges (make-hash-table 1024)) + +;; How many zeroes the SHA-256 hash has to be prefixed by to be a valid proof of work. +(define %hardness 4) + +(define (new-proof-of-work-challenge!) + (let ((id (dequeue-id! pow-challenge-id-queue)) + (challenge (base64-encode (gen-random-bv 32)))) + (hash-set! pow-challenges id challenge) + (values id challenge))) + +(define (validate-proof-of-work! prefix challenge-id) + (define zero-prefix (string-join (map (lambda (_) "0") (iota %hardness)) "")) + (when (member challenge-id (id-queue-free pow-challenge-id-queue)) + (panic "No such challenge ID")) + (let* ((challenge (hash-ref pow-challenges challenge-id)) + (hash-value (chain (list prefix challenge) + (string-concatenate _) + (string->bytevector _ "utf8") + (bytevector-hash _ (lookup-hash-algorithm 'sha256)) + (bytevector->base16-string _)))) + ;; Invariant from `unless' form: + ;; (not (member challenge-id (id-queue-free pow-challenge-id-queue))) + (when challenge + (release-id! challenge-id pow-challenge-id-queue)) + (and (= 32 (string-length prefix)) + (string-prefix? zero-prefix hash-value)))) + +(define (make-pow-challenge! request body) + "API endpoint handler for requesting a proof-of-work challenge" + (let-values (((challenge-id nonce) (new-proof-of-work-challenge!))) + (values '((content-type . (application/json))) + (scm->json-string + `((hardness . ,%hardness) + (challenge-id . ,challenge-id) + (nonce . ,nonce)))))) diff --git a/jakob/dynamic/config.scm b/jakob/dynamic/config.scm new file mode 100644 index 0000000..8fc9dea --- /dev/null +++ b/jakob/dynamic/config.scm @@ -0,0 +1,48 @@ +;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (jakob dynamic config) + #:export (%debug-enabled + %api-server-port + paramstring-for-dbname + absolute-url)) + +;; Whether or not to enable "debug mode", in which: +;; +;; - Log messages are written to stdout. +;; - Rate limiting is disabled. +(define %debug-enabled (make-parameter (or (getenv "API_SERVER_DEBUG") #f))) + +;; Port that the API server should listen on +(define %api-server-port (make-parameter (or (getenv "API_SERVER_PORT") 8080))) + +;; Should be fairly self-explanatory. +(define %postgresql-user (make-parameter (or (getenv "API_SERVER_DB_USER") "jakob_dynamic"))) +(define %postgresql-host (make-parameter (or (getenv "API_SERVER_DB_HOST") "localhost"))) +(define %postgresql-port (make-parameter (or (getenv "API_SERVER_DB_PORT") "5432"))) + +(define (paramstring-for-dbname dbname) + (format #f "host=~a port=~a user=~a dbname=~a" + (%postgresql-host) + (%postgresql-port) + (%postgresql-user) + dbname)) + +(define (absolute-url relative-path) + "Produce an absolute URL from the identifier RELATIVE-PATH" + (if (%debug-enabled) + (format #f "http://localhost:~a/~a" (%api-server-port) relative-path) + (string-append "https://jakob.space" relative-path))) diff --git a/jakob/dynamic/errors.scm b/jakob/dynamic/errors.scm new file mode 100644 index 0000000..05f9302 --- /dev/null +++ b/jakob/dynamic/errors.scm @@ -0,0 +1,39 @@ +;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (jakob dynamic errors) + #:use-module (rnrs conditions) + #:use-module (rnrs exceptions) + #:export (&reportable + + make-reportable-condition + reportable-condition? + + reportable-condition-code + reportable-condition-message + + panic)) + +;; Condition that can safely be presented to an API user +(define-condition-type &reportable &condition + make-reportable-condition + reportable-condition? + (code reportable-condition-code) + (message reportable-condition-message)) + +(define* (panic message #:key (code 400)) + "Raise MESSAGE as a &reportable condition" + (raise (condition (make-reportable-condition code message)))) diff --git a/jakob/dynamic/import-images.sh b/jakob/dynamic/import-images.sh new file mode 100644 index 0000000..23f6130 --- /dev/null +++ b/jakob/dynamic/import-images.sh @@ -0,0 +1,16 @@ +#!/usr/bin/env bash + +set -euo pipefail + +VANITY="$1" +shift + +for item in "$@"; do + filename=$(basename -- "$item") + extension="${filename##*.}" + filename="${filename%.*}" + uuid="$(uuidgen)" + cp "$item" "/home/jakob/gallery-images/$uuid.$extension" + convert "/home/jakob/gallery-images/$uuid.$extension" -thumbnail '100x100>' "/home/jakob/gallery-images/${uuid}_thumb.png" + psql jakob_gallery -c "INSERT INTO images (vanity, title, filename, thumb_filename, datetime) VALUES ('$VANITY', '$filename', '$uuid.$extension', '${uuid}_thumb.png', now());" +done diff --git a/jakob/dynamic/logging.scm b/jakob/dynamic/logging.scm new file mode 100644 index 0000000..c937c66 --- /dev/null +++ b/jakob/dynamic/logging.scm @@ -0,0 +1,39 @@ +;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (jakob dynamic logging) + #:use-module (ice-9 format) + #:use-module (jakob dynamic config) + #:use-module (srfi srfi-19) + #:export (log-append!)) + +(define %log-level (make-parameter 'info)) +(define %log-file-name + (make-parameter (if (%debug-enabled) "/dev/stdout" "/var/log/jakob-dynamic.log"))) + +(define (dominates message-level baseline-level) + "Determine if `a' should be shown for baseline log level `b'." + (define log-level-hierarchy '(debug info warn error)) + (>= (list-index log-level-hierarchy message-level) + (list-index log-level-hierarchy baseline-level))) + +(define (log-append! level message) + "Append `message', at `level', to the log buffer." + (when (dominates level (%log-level)) + (let ((output-port (open-file (%log-file-name) "a")) + (now (date->string (current-date) "~4"))) + (format output-port "[~a] ~a: ~a~%" now level message) + (close output-port)))) diff --git a/jakob/dynamic/rate-limiter.scm b/jakob/dynamic/rate-limiter.scm new file mode 100644 index 0000000..24239f6 --- /dev/null +++ b/jakob/dynamic/rate-limiter.scm @@ -0,0 +1,78 @@ +;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (jakob dynamic rate-limiter) + #:use-module (jakob dynamic errors) + #:use-module (jakob dynamic util) + #:use-module (json) + #:use-module (rnrs conditions) + #:use-module (rnrs exceptions) + #:use-module (srfi-197) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (web request) + #:use-module (web response) + #:export (rate-limit-wrap)) + +(define-record-type <requester-state> + (make-requester-state time request-bins) + requester-state? + (time requester-state-time) + (request-bins requester-state-bins)) + +(define active-rate-limits (make-hash-table)) + +(define (rate-limit-for-endpoint name) + (case name + ((put-reaction) 1) + ((get-event-rsvp) 1) + ((get-event-info) 8) + ((get-image) 8) + ((get-gallery) 8) + ((put-comment) 8) + ((get-comments) 1024) + (else 32))) + +(define (increment-key! hash-table key) + (let ((new-value (if (hash-ref hash-table key) + (+ 1 (hash-ref hash-table key)) + 1))) + (hash-set! hash-table key new-value))) + +(define (rate-limit-wrap proc) + (lambda (request body) + (unless (assoc-ref (request-headers request) 'x-forwarded-for) + (panic "X-Forwarded-For header not provided")) + (let ((endpoint-name (procedure-name proc)) + (requester (chain (assoc-ref (request-headers request) 'x-forwarded-for) + (string-split _ #\,) + (first _)))) + (unless (hash-ref active-rate-limits requester) + (hash-set! active-rate-limits + requester + (make-requester-state (current-time) (make-hash-table)))) + (increment-key! (requester-state-bins (hash-ref active-rate-limits requester)) endpoint-name) + ;; TODO: The `when' body is copy/pasted from above. I think this condition + ;; (time-based expiry) could be refactored. + (when (>= (current-time) + (+ (* 60 60) (requester-state-time (hash-ref active-rate-limits requester)))) + (hash-set! active-rate-limits + requester + (make-requester-state (current-time) (make-hash-table)))) + (when (and (> (hash-ref (requester-state-bins (hash-ref active-rate-limits requester)) endpoint-name) + (rate-limit-for-endpoint endpoint-name))) + (panic "Your IP address is currently being rate-limited." #:code 429)) + (proc request body)))) diff --git a/jakob/dynamic/schema-comments.sql b/jakob/dynamic/schema-comments.sql new file mode 100644 index 0000000..8519f4b --- /dev/null +++ b/jakob/dynamic/schema-comments.sql @@ -0,0 +1,18 @@ +CREATE TABLE comments( + id SERIAL PRIMARY KEY, + approved TIMESTAMP, + submitted TIMESTAMP NOT NULL, + slug VARCHAR(100) NOT NULL, + name VARCHAR(50) NOT NULL, + subject VARCHAR(100), + email VARCHAR(100), + url VARCHAR(100), + comment VARCHAR(1024) NOT NULL, + reactions VARCHAR(1024), + reply_to INT, + originating_network VARCHAR(100) +); + +-- Use `now' for `submitted'. + +-- INSERT INTO comments (submitted, slug, name, comment) VALUES (now(), 'test', 'Jakob', 'Hello, world!'); diff --git a/jakob/dynamic/schema-gallery.sql b/jakob/dynamic/schema-gallery.sql new file mode 100644 index 0000000..bad4100 --- /dev/null +++ b/jakob/dynamic/schema-gallery.sql @@ -0,0 +1,18 @@ +CREATE TABLE IF NOT EXISTS galleries ( + id SERIAL, + vanity char(12) NOT NULL, + title varchar(128), + description varchar(4096) NOT NULL, + datetime timestamp with time zone NOT NULL, + PRIMARY KEY (id) +); + +CREATE TABLE IF NOT EXISTS images ( + id SERIAL, + vanity char(12) NOT NULL, + title varchar(128), + filename varchar(64) NOT NULL, + thumb_filename varchar(64) NOT NULL, + datetime timestamp with time zone NOT NULL, + PRIMARY KEY (id) +); diff --git a/jakob/dynamic/schema-poll.sql b/jakob/dynamic/schema-poll.sql new file mode 100644 index 0000000..b15bdbd --- /dev/null +++ b/jakob/dynamic/schema-poll.sql @@ -0,0 +1,27 @@ +CREATE TABLE IF NOT EXISTS polls ( + id SERIAL, + title varchar(128) NOT NULL, + description varchar(16384) NOT NULL, + datetime timestamp with time zone NOT NULL, + questions varchar(16384) NOT NULL, + PRIMARY KEY (id) +); + +CREATE TABLE IF NOT EXISTS invitations ( + id SERIAL, + vanity char(12) NOT NULL, + comments varchar(1024) NOT NULL, + created_on timestamp with time zone default current_timestamp, + poll_id integer NOT NULL, + PRIMARY KEY (id) +); + +CREATE TABLE IF NOT EXISTS responses ( + id SERIAL, + invitation_code char(12) NOT NULL, + poll_id bigint NOT NULL, + response varchar(16384) NOT NULL, + PRIMARY KEY (id) +); + +-- `questions` and `response` are s-expressions. diff --git a/jakob/dynamic/schema-rsvp.sql b/jakob/dynamic/schema-rsvp.sql new file mode 100644 index 0000000..3e6a21f --- /dev/null +++ b/jakob/dynamic/schema-rsvp.sql @@ -0,0 +1,34 @@ +CREATE TABLE IF NOT EXISTS events ( + id SERIAL, + title varchar(128) NOT NULL, + description varchar(16384) NOT NULL, + datetime timestamp with time zone NOT NULL, + location varchar(128) NOT NULL, + PRIMARY KEY (id) +); + +CREATE TABLE IF NOT EXISTS invitations ( + id SERIAL, + vanity char(12) NOT NULL, + comments varchar(1024) NOT NULL, + created_on timestamp with time zone default current_timestamp, + capabilities bigint NOT NULL, + event_id integer NOT NULL, + PRIMARY KEY (id) +); + +CREATE TABLE IF NOT EXISTS rsvps ( + id SERIAL, + vanity char(12) NOT NULL, + invitation_id char(12) NOT NULL, + event_id bigint NOT NULL, + fullname varchar(128) NOT NULL, + email varchar(256) NOT NULL, + guests varchar(1024) NOT NULL, + attending varchar(32) NOT NULL, + PRIMARY KEY (id) +); + +-- `rsvps` contains the bare minimum. If we later decide we need additional +-- fields, we'll have an additional table mapping events.id to attribute names +-- and rsvps.id to attribute values. diff --git a/jakob/dynamic/util.scm b/jakob/dynamic/util.scm new file mode 100644 index 0000000..e34ae91 --- /dev/null +++ b/jakob/dynamic/util.scm @@ -0,0 +1,133 @@ +;;; Copyright © 2019 - 2023 Jakob L. Kreuze <zerodaysfordays@sdf.org> +;;; +;;; This program is free software; you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation; either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; <http://www.gnu.org/licenses/>. + +(define-module (jakob dynamic util) + #:use-module (ice-9 match) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:use-module (srfi srfi-26) + #:use-module (web request) + #:use-module (web uri) + #:export (assoc-value + acons-normalize + base64-length + decode-form + date<? + hash-append! + emoji? + from-tor? + from-i2p? + from-darknet?)) + +(define (assoc-value alist key) + "Return the `car' of `(assoc alist key)' if truthy" + (let ((result (assoc-ref alist key))) + (if result (car result) result))) + +(define (acons-list k v alist) + "Add V to K to alist as list" + (let ((value (assoc-ref alist k))) + (if value + (let ((alist (alist-delete k alist))) + (acons k (cons v value) alist)) + (acons k (list v) alist)))) + +(define (acons-normalize key value alist) + "Add KEY -> VALUE to ALIST such that no entries for KEY are duplicates" + (cons (cons key value) + (filter (lambda (pair) (not (equal? (car pair) key))) alist))) + +(define (list->alist lst) + "Build a alist of list based on a list of key and values. + + Multiple values can be associated with the same key" + (let next ((lst lst) + (out '())) + (if (null? lst) + out + (next (cdr lst) (acons-list (caar lst) (cdar lst) out))))) + +(define (decode-form bv) + "Convert BV querystring or form data to an alist" + (define string (if (string? bv) bv (utf8->string bv))) + (define pairs (map (cut string-split <> #\=) + ;; semi-colon and amp can be used as pair separator + (append-map (cut string-split <> #\;) + (string-split string #\&)))) + (list->alist (map (match-lambda + ((key value) + (cons (uri-decode key) (uri-decode value)))) pairs))) + +(define (base64-length n) + "The length of the base64 string encoding `n' bytes." + (inexact->exact (* 4 (ceiling (/ n 3.0))))) + +(define (date<? d1 d2) + "Return #t if D2 specifies a later date than D1" + (time<? (date->time-utc d1) (date->time-utc d2))) + +(define (hash-append! table key item) + "Append ITEM to the list specified by KEY in TABLE + +If KEY does not exist in TABLE, initialize kEY to (list ITEM)" + (if (hash-ref table key) + (hash-set! table key (cons item (hash-ref table key))) + (hash-set! table key (list item)))) + +(define (emoji? str) + "Determine if `str' is an 'acceptable' emoji character + +Acceptable is the following subset: + +- The 'Emoticons' block +- The 'Supplemental Symbols and Pictographs' block, excluding U+1F900 + through U+1F90B +- The hand symbols from the 'Miscellaneous Symbols and Pictographs' + block +- The hand symbols from the 'Dingbats' block +- U+1F37B and U+1F440 + +Notably, U+1F946 isn't normally treated an emoji, but it is here. I +think it should be! As an American, I should be able to use pictographs +to express my God-given constitutional rights!" + (and (string? str) + (= 1 (string-length str)) + (let ((codepoint (char->integer + (first (string->list str))))) + (or (<= #x1F600 codepoint #x1F64F) + (<= #x1F90C codepoint #x1F9FF) + (<= #x1F446 codepoint #x1F450) + (<= #x270A codepoint #x270D) + (= codepoint #x1F37B) + (= codepoint #x1F440))))) + +(define (from-tor? request) + "Return whether or not REQUEST was sent by the Tor daemon" + (let ((originating-ip (assoc-ref (request-headers request) 'x-forwarded-for))) + (or (string=? "127.0.0.1" originating-ip) + (string=? "::1" originating-ip)))) + +(define (from-i2p? request) + "Return whether or not REQUEST was sent by i2pd" + (let ((originating-ip (assoc-ref (request-headers request) 'x-forwarded-for))) + (and (or (string-prefix? "127." originating-ip) + (string-suffix? ":1" originating-ip)) + (not (from-tor? request))))) + +(define (from-darknet? request) + "Return whether or not REQUEST was sent by a darknet tunnel" + (or (from-tor? request) (from-i2p? request))) |