From 2c666a53e847e6b49dbdf4fd22416872bb197f6b Mon Sep 17 00:00:00 2001 From: "Jakob L. Kreuze" Date: Tue, 15 Nov 2022 19:17:44 -0500 Subject: [dynamic] Move to `haunt' directory and `jakob' namespace There will likely be some refactoring later as part of this change, since we can unify the `util' namespaces. --- .gitmodules | 2 +- dynamic/README.md | 16 - dynamic/api.scm | 80 ----- dynamic/capabilities/comment-form.scm | 33 -- dynamic/capabilities/comments.scm | 152 --------- dynamic/capabilities/gallery.scm | 111 ------- dynamic/capabilities/rsvp.scm | 277 ---------------- dynamic/captcha.scm | 170 ---------- dynamic/import-images.sh | 16 - dynamic/logging.scm | 37 --- dynamic/schema-comments.sql | 16 - dynamic/schema-gallery.sql | 18 -- dynamic/schema-rsvp.sql | 34 -- dynamic/util.scm | 69 ---- ext-srfi-197 | 1 - haunt/api.scm | 74 +++++ haunt/jakob/dynamic/README.md | 16 + haunt/jakob/dynamic/base64.scm | 353 ++++++++++++++++++++ haunt/jakob/dynamic/capabilities/comment-form.scm | 33 ++ haunt/jakob/dynamic/capabilities/comments.scm | 153 +++++++++ haunt/jakob/dynamic/capabilities/gallery.scm | 111 +++++++ haunt/jakob/dynamic/capabilities/rsvp.scm | 277 ++++++++++++++++ haunt/jakob/dynamic/captcha.scm | 170 ++++++++++ haunt/jakob/dynamic/import-images.sh | 16 + haunt/jakob/dynamic/logging.scm | 37 +++ haunt/jakob/dynamic/schema-comments.sql | 16 + haunt/jakob/dynamic/schema-gallery.sql | 18 ++ haunt/jakob/dynamic/schema-rsvp.sql | 34 ++ haunt/jakob/dynamic/util.scm | 69 ++++ haunt/jakob/utils/comments.scm | 18 +- haunt/pages/about.sxml | 2 +- haunt/squee.scm | 372 ++++++++++++++++++++++ haunt/srfi-197.scm | 4 + srfi-197.scm | 4 - 34 files changed, 1763 insertions(+), 1046 deletions(-) delete mode 100644 dynamic/README.md delete mode 100644 dynamic/api.scm delete mode 100644 dynamic/capabilities/comment-form.scm delete mode 100644 dynamic/capabilities/comments.scm delete mode 100644 dynamic/capabilities/gallery.scm delete mode 100644 dynamic/capabilities/rsvp.scm delete mode 100644 dynamic/captcha.scm delete mode 100644 dynamic/import-images.sh delete mode 100644 dynamic/logging.scm delete mode 100644 dynamic/schema-comments.sql delete mode 100644 dynamic/schema-gallery.sql delete mode 100644 dynamic/schema-rsvp.sql delete mode 100644 dynamic/util.scm delete mode 160000 ext-srfi-197 create mode 100644 haunt/api.scm create mode 100644 haunt/jakob/dynamic/README.md create mode 100644 haunt/jakob/dynamic/base64.scm create mode 100644 haunt/jakob/dynamic/capabilities/comment-form.scm create mode 100644 haunt/jakob/dynamic/capabilities/comments.scm create mode 100644 haunt/jakob/dynamic/capabilities/gallery.scm create mode 100644 haunt/jakob/dynamic/capabilities/rsvp.scm create mode 100644 haunt/jakob/dynamic/captcha.scm create mode 100644 haunt/jakob/dynamic/import-images.sh create mode 100644 haunt/jakob/dynamic/logging.scm create mode 100644 haunt/jakob/dynamic/schema-comments.sql create mode 100644 haunt/jakob/dynamic/schema-gallery.sql create mode 100644 haunt/jakob/dynamic/schema-rsvp.sql create mode 100644 haunt/jakob/dynamic/util.scm create mode 100644 haunt/squee.scm create mode 100644 haunt/srfi-197.scm delete mode 100644 srfi-197.scm diff --git a/.gitmodules b/.gitmodules index 461dfa9..c94555d 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +1,3 @@ [submodule "ext-srfi-197"] - path = ext-srfi-197 + path = haunt/ext-srfi-197 url = https://github.com/ar-nelson/srfi-197 diff --git a/dynamic/README.md b/dynamic/README.md deleted file mode 100644 index 0f64827..0000000 --- a/dynamic/README.md +++ /dev/null @@ -1,16 +0,0 @@ -# Dynamic API for jakob.space - -This is a Guile back-end for all dynamic capabilities on jakob.space. It is -assumed that the web server proxies all requests matching a `/api` prefix to -this server. - -## Dependencies - -Depending on who you ask, the package management situation for Guile is either -disappointing, or a pleasant reminder of simpler times. This module leverages -two Guile modules which, to my knowledge, are not packaged in the typical Guile -extension fashion. The respective `.scm` files will need to be downloaded and -added to Guile load path. - -- [base64 from guile-lib](https://github.com/jacobrec/guile-lib/blob/master/base64.scm) -- [squee](https://notabug.org/cwebber/guile-squee/) diff --git a/dynamic/api.scm b/dynamic/api.scm deleted file mode 100644 index 451c5c6..0000000 --- a/dynamic/api.scm +++ /dev/null @@ -1,80 +0,0 @@ -;;; Copyright © 2019 - 2022 Jakob L. Kreuze -;;; -;;; 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 -;;; . - -(use-modules (dynamic capabilities comment-form) - (dynamic capabilities comments) - (dynamic capabilities gallery) - (dynamic capabilities rsvp) - (dynamic logging) - (srfi srfi-1) - (ice-9 match) - (web server) - (web request) - (web response) - (web uri)) - -(define (not-found request) - "Build a (somewhat) descriptive response for a non-existent resource." - (values (build-response #:code 404) - (string-append "Resource not found: " - (uri->string (request-uri request))))) - -(define (handle-api-request request body endpoint) - "Route handler for the API server." - (let ((method (request-method request)) - (originating-ip (assoc-ref (request-headers request) 'X-Forwarded-For)) - (args (uri-query (request-uri request)))) - (log-append! 'info (format #f "~a ~a (~a) (~a)" method endpoint args originating-ip))) - ((match (cons (request-method request) endpoint) - ('(GET "dynamic" "comment-form") get-comment-form) - ('(GET "challenge") make-challenge) - ('(GET "api" "comments") get-comments) - ('(POST "api" "comment") put-comment) - ('(POST "api" "react") put-reaction) - ('(GET "api" "gallery") get-gallery) - ('(GET "api" "gallery" "image") get-image) - ('(GET "api" "rsvp" "event-info") get-event-info) - ('(POST "api" "rsvp") post-event-rsvp) - (_ (lambda (. args) (not-found request)))) - request body)) - -(define (main-request-handler request body) - "Server entry-point; parse `request' and defer to routing system." - (define (wrap-response response) - ;; This is either a response, or an alist of headers. The latter case is - ;; simple to handle, but the former requires us to do a (rather unweildy) - ;; copy of the response to inject our headers. - (if (response? response) - (build-response - #:version (response-version response) - #:code (response-code response) - #:reason-phrase (response-reason-phrase response) - #:headers (cons '(Access-Control-Allow-Origin . "*") - (response-headers response)) - #:port (response-port response) - #:validate-headers? #t) - (cons '(Access-Control-Allow-Origin . "*") response))) - (let* ((path-encoded (uri-path (request-uri request))) - (path (split-and-decode-uri-path path-encoded))) - (define-values (response resp-body) - (if (or (string= "api" (first path)) - (string= "dynamic" (first path))) - ;; (handle-api-request request body (drop path 1)) - (handle-api-request request body path) - (not-found request))) - (values (wrap-response response) resp-body))) - -(run-server main-request-handler 'http `(#:addr ,INADDR_ANY #:port 8080)) diff --git a/dynamic/capabilities/comment-form.scm b/dynamic/capabilities/comment-form.scm deleted file mode 100644 index beded53..0000000 --- a/dynamic/capabilities/comment-form.scm +++ /dev/null @@ -1,33 +0,0 @@ -;;; Copyright © 2019 - 2022 Jakob L. Kreuze -;;; -;;; 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 -;;; . - -(define-module (dynamic capabilities comment-form) - #:use-module (dynamic util) - #:use-module (haunt html) - #:use-module (ice-9 match) - #:use-module (jakob theme) - #:use-module (json) - #:use-module (web request) - #:use-module (web response) - #:use-module (web uri) - #:export (get-comment-form)) - -(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'." - (values '((content-type . (text/html))) - (sxml->html-string (theme #:content '(p "Hello, world!"))))) diff --git a/dynamic/capabilities/comments.scm b/dynamic/capabilities/comments.scm deleted file mode 100644 index 945e382..0000000 --- a/dynamic/capabilities/comments.scm +++ /dev/null @@ -1,152 +0,0 @@ -;;; Copyright © 2019 - 2022 Jakob L. Kreuze -;;; -;;; 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 -;;; . - -(define-module (dynamic capabilities comments) - #:use-module (dynamic util) - #:use-module (ice-9 match) - #:use-module (json) - #:use-module (squee) - #: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 "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 (format-comment comment) - (match comment - ((id name subject email comment url reactions) - `((id . ,id) - (name . ,name) - (subject . ,subject) - (email . ,email) - (comment . ,comment) - (url . ,url) - (reactions . ,(if reactions - (with-input-from-string reactions read) - '())))))) - (let* ((query "SELECT id, name, subject, email, comment, url, reactions - FROM comments WHERE slug = $1 and approved IS NOT NULL") - (result (exec-query conn query (list slug)))) - (map format-comment 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'." - (let* ((query-string (uri-query (request-uri request))) - (params (if query-string - (decode-form query-string) - '())) - (slug (assoc-ref params "p"))) - (if slug - (values '((content-type . (application/json))) - (scm->json-string - (list->vector - (get-comments-by-slug (car slug))))) - (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "missing `slug' query parameter"))))))) - - - -(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))) - (define (insert-comment form-data) - (exec-query conn - "INSERT INTO comments (submitted, slug, name, subject, - email, url, comment) - VALUES (now(), $1, $2, $3, $4, $5, $6);" - (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"))) - (values '((content-type . (application/json))) - (scm->json-string `((success . #t))))) - (let ((form-data (decode-form body))) - (if (valid-comment? form-data) - (insert-comment form-data) - (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "missing `slug', `name', or `comment'"))))))) - - - -(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) - '()))) - (if (valid-reaction? form-data) - (let ((id (assoc-value form-data "id")) - (reaction (assoc-value form-data "reaction")) - (reactions (comment-reactions id))) - (if reactions - (begin - (set-reactions id (add-reaction reactions reaction)) - (values '((content-type . (application/json))) - (scm->json-string `((success . #t))))) - (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "no such comment")))))) - (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "missing `id', or `reaction'"))))))) - -;; (define (make-challenge request body) -;; (let-values (((uuid value image) (new-captcha))) -;; (hash-set! challenges uuid value) -;; (hash-for-each (lambda (x y) (display x) (newline)) challenges) -;; (values `((content-type . (application/base64)) -;; (access-control-allow-origin . "*") -;; (x-captcha-id . ,uuid)) -;; (base64-encode image)))) diff --git a/dynamic/capabilities/gallery.scm b/dynamic/capabilities/gallery.scm deleted file mode 100644 index 1d63061..0000000 --- a/dynamic/capabilities/gallery.scm +++ /dev/null @@ -1,111 +0,0 @@ -;;; Copyright © 2019 - 2022 Jakob L. Kreuze -;;; -;;; 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 -;;; . - -(define-module (dynamic capabilities gallery) - #:use-module (dynamic util) - #:use-module (ice-9 binary-ports) - #:use-module (ice-9 ftw) - #:use-module (ice-9 match) - #: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 "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")))) - (if (valid-gallery-code code) - (values '((content-type . (application/json))) - (scm->json-string `((info . ,(get-gallery-info code)) - (images . ,(get-gallery-images code))))) - (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "Invalid gallery code"))))))) - -(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")))) - (if (image-exists? file-name) - (read-image file-name) - (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "Invalid filename"))))))) diff --git a/dynamic/capabilities/rsvp.scm b/dynamic/capabilities/rsvp.scm deleted file mode 100644 index 4ac2eff..0000000 --- a/dynamic/capabilities/rsvp.scm +++ /dev/null @@ -1,277 +0,0 @@ -;;; Copyright © 2019 - 2022 Jakob L. Kreuze -;;; -;;; 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 -;;; . - -(define-module (dynamic capabilities rsvp) - #:use-module (base64) - #:use-module (dynamic util) - #:use-module (ice-9 binary-ports) - #:use-module (ice-9 match) - #: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 "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 - (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 `'." - (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))) - (cond ((not params) - (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "Invalid form data"))))) - ((not (valid-invite-code (rsvp-create-code params))) - (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "Invalid invitation code"))))) - (else - (let ((receipt-code (generate-vanity-code)) - (event-id (car (invitation->event-id (rsvp-create-code params))))) - (exec-query conn - "INSERT INTO rsvps (vanity, invitation_id, event_id, fullname, email, attending, guests) VALUES ($1, $2, $3, $4, $5, $6, $7)" - (list receipt-code - (rsvp-create-code params) - event-id - (rsvp-create-name params) - (rsvp-create-email params) - (rsvp-create-attending params) - (rsvp-create-guests params))) - (values '((content-type . (application/json))) - (scm->json-string - `((receipt . ,receipt-code))))))))) - - - -(define-record-type - (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 `'." - (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))) - (cond ((not params) - (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "Invalid form data"))))) - ((not (valid-receipt-code (rsvp-update-code params))) - (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "Invalid receipt code"))))) - (else - (exec-query conn - "UPDATE rsvps SET fullname = $2, email = $3, attending = $4, guests = $5 WHERE vanity = $1" - (list - (rsvp-update-code params) - (rsvp-update-name params) - (rsvp-update-email params) - (rsvp-update-attending params) - (rsvp-update-guests params))) - (values '((content-type . (application/json))) - (scm->json-string - `((receipt . ,(rsvp-update-code params))))))))) - - - -(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 (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "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 - (values (build-response #:code 400) - (scm->json-string - `((success . #f) - (error . "Invalid invitation or receipt code")))))))) diff --git a/dynamic/captcha.scm b/dynamic/captcha.scm deleted file mode 100644 index b095ebf..0000000 --- a/dynamic/captcha.scm +++ /dev/null @@ -1,170 +0,0 @@ -;;; Copyright © 2019 - 2022 Jakob L. Kreuze -;;; -;;; 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 -;;; . - -(define-module (captcha) - #:use-module (base64) - #:use-module (gcrypt hash) - #:use-module (gcrypt mac) - #:use-module (gcrypt random) - #:use-module (ice-9 binary-ports) - #: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 rdelim) - #:use-module (ice-9 threads) - #:use-module (rnrs bytevectors) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-19) - #:export (new-captcha)) - -(define proc-mutex (make-mutex)) - -(define (random-term) - (match (random 5) - (0 `(* ,(+ 1 (random 10)) x)) - (1 `(* ,(+ 1 (random 10)) (expt x ,(random 10)))) - (2 `(* ,(+ 1 (random 10)) (exp x))) - (3 `(* ,(+ 1 (random 10)) (cos x))) - (4 `(* ,(+ 1 (random 10)) (sin x))))) - -(define (sexp->latex sexp) - (match sexp - (('+ rest ...) (string-join (map sexp->latex rest) " + ")) - (('* rest ...) (string-join (map sexp->latex rest) " \\cdot ")) - (('sin term) (format #f "\\sin(~a)" (sexp->latex term))) - (('cos term) (format #f "\\cos(~a)" (sexp->latex term))) - (('expt term n) (format #f "~a^{~a}" (sexp->latex term) (sexp->latex n))) - (('exp term) (format #f "e^{~a}" (sexp->latex term))) - ('x "x") - (n (cond ((and (number? n) (positive? n)) (format #f "~a" n)) - ((and (number? n) (negative? n)) (format #f "(~a)" n)) - ((number? n) "0") - (else (error "Do not know how to convert to latex." n)))))) - -(define (differentiate-sexp sexp) - (match sexp - (('+ rest ...) `(+ ,@(map differentiate-sexp rest))) - (('* coeff term) (if (number? coeff) - `(* ,coeff ,(differentiate-sexp term)) - (error "Do not know how to differentiate."))) - (('sin term) `(* ,(differentiate-sexp term) (cos ,term))) - (('cos term) `(* -1 ,(differentiate-sexp term) (sin ,term))) - (('exp term) `(* ,(differentiate-sexp term) (exp ,term))) - (('expt term n) `(* ,n (expt ,term ,(- n 1)))) - ('x 1) - (n (if (number? n) - 0 - (error "Do not know how to differentiate."))))) - -(define (simplify-sexp sexp) - (match sexp - (('+ rest ...) `(+ ,@(map simplify-sexp rest))) - (('* 1 term) (simplify-sexp term)) - (('* 1 rest ...) (simplify-sexp `(* ,@rest))) - (('sin term) `(sin ,(simplify-sexp term))) - (('sin term) `(cos ,(simplify-sexp term))) - (('exp term) `(exp ,(simplify-sexp term))) - (('expt term 1) (simplify-sexp term)) - (('expt term n) `(expt ,(simplify-sexp term) ,(simplify-sexp n))) - (term term))) - -(define (random-expression) - (let ((n-terms (+ 2 (random 3)))) - `(+ ,@(map (lambda (x) (random-term)) (iota n-terms))))) - -(define (latex->image src) - (chdir "/tmp") - (with-mutex proc-mutex - (call-with-output-file "formula.tex" - (lambda (port) - (format port "\\def\\formula{~a} -\\documentclass[border=2pt]{standalone} -\\usepackage{amsmath} -\\usepackage{varwidth} -\\begin{document} -\\begin{varwidth}{\\linewidth} -\\[ \\formula \\] -\\end{varwidth} -\\end{document} -" src))) - (unless (eqv? 0 (status:exit-val (system "pdflatex formula.tex"))) - (error "Cannot generate PDF")) - (let* ((port (open-input-pipe "convert -density 300 formula.pdf -quality 90 png:-")) - (data (get-bytevector-all port))) - (unless (eqv? 0 (status:exit-val (close-pipe port))) - (error "Cannot generate PNG")) - data))) - -(define (new-uuid) - (with-mutex proc-mutex - (let* ((port (open-input-pipe "uuidgen")) - (str (read-line port))) - (close-pipe port) - str))) - -(define (new-captcha) - (let* ((lower-bound (random 10)) - (upper-bound (+ lower-bound 1 (random 9))) - (expression (random-expression)) - (latex-src (sexp->latex (simplify-sexp (differentiate-sexp expression))))) - (values (new-uuid) - (- (local-eval expression (let ((x upper-bound)) (the-environment))) - (local-eval expression (let ((x lower-bound)) (the-environment)))) - (latex->image (format #f "\\int_{~a}^{~a} ~a \\, dx" - lower-bound - upper-bound - latex-src))))) - - - -;; How many zeroes the SHA-256 hash has to be prefixed by to be a valid proof of work. -(define %hardness 4) - -;; This is an ephemeral key. At this point, it doesn't make sense to store keys -;; locally, since the server process is singular and long-running. -(define %pow-mac-key (gen-random-bv 64)) - -(define (proof-of-work) - (define challenge - (call-with-input-file "/dev/urandom" - (lambda (port) (base64-encode (get-bytevector-n port 32))))) - (define expiry-timestamp - (date->string - (time-utc->date (make-time 'time-utc 0 (+ 512 (time-second (current-time))))) - "~Y-~m-~d ~H:~M:~S")) - (define challenge-signature - (sign-data-base64 %pow-mac-key challenge)) - (define timestamp-signature - (sign-data-base64 %pow-mac-key expiry-timestamp)) - (values challenge challenge-signature expiry-timestamp timestamp-signature)) - -(define (check-proof-of-work prefix - challenge challenge-signature - expiry-timestamp timestamp-signature) - (define hash-value - (chain (list prefix challenge) - (string-concatenate _) - (string->bytevector _ "utf8") - (bytevector-hash _ (lookup-hash-algorithm 'sha256)) - (bytevector->base16-string _))) - (define zero-prefix (string-join (map (lambda (_) "0") (iota %hardness)) "")) - (and (= 32 (string-length prefix)) - (string-prefix? zero-prefix hash-value) - (valid-base64-signature? %pow-mac-key challenge challenge-signature) - (valid-base64-signature? %pow-mac-key expiry-timestamp timestamp-signature) - (time<=? (current-time) - (date->time-utc (string->date expiry-timestamp "~Y-~m-~d ~H:~M:~S"))))) diff --git a/dynamic/import-images.sh b/dynamic/import-images.sh deleted file mode 100644 index 23f6130..0000000 --- a/dynamic/import-images.sh +++ /dev/null @@ -1,16 +0,0 @@ -#!/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/dynamic/logging.scm b/dynamic/logging.scm deleted file mode 100644 index dab2464..0000000 --- a/dynamic/logging.scm +++ /dev/null @@ -1,37 +0,0 @@ -;;; Copyright © 2019 - 2022 Jakob L. Kreuze -;;; -;;; 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 -;;; . - -(define-module (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)) - (call-with-output-file (%log-file-name) - (lambda (port) - (let ((now (date->string (current-date) "~4"))) - (format port "[~a] ~a: ~a~%" now level message)))))) diff --git a/dynamic/schema-comments.sql b/dynamic/schema-comments.sql deleted file mode 100644 index b2cb652..0000000 --- a/dynamic/schema-comments.sql +++ /dev/null @@ -1,16 +0,0 @@ -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) -); - --- Use `now' for `submitted'. - --- INSERT INTO comments (submitted, slug, name, comment) VALUES (now(), 'test', 'Jakob', 'Hello, world!'); diff --git a/dynamic/schema-gallery.sql b/dynamic/schema-gallery.sql deleted file mode 100644 index bad4100..0000000 --- a/dynamic/schema-gallery.sql +++ /dev/null @@ -1,18 +0,0 @@ -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/dynamic/schema-rsvp.sql b/dynamic/schema-rsvp.sql deleted file mode 100644 index 3e6a21f..0000000 --- a/dynamic/schema-rsvp.sql +++ /dev/null @@ -1,34 +0,0 @@ -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/dynamic/util.scm b/dynamic/util.scm deleted file mode 100644 index b2e7221..0000000 --- a/dynamic/util.scm +++ /dev/null @@ -1,69 +0,0 @@ -;;; Copyright © 2019 - 2022 Jakob L. Kreuze -;;; -;;; 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 -;;; . - -(define-module (dynamic util) - #:use-module (ice-9 match) - #:use-module (rnrs bytevectors) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:use-module (web uri) - #:export (assoc-value - acons-normalize - base64-length - decode-form)) - -(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))))) diff --git a/ext-srfi-197 b/ext-srfi-197 deleted file mode 160000 index 78ced23..0000000 --- a/ext-srfi-197 +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 78ced23a1af519ee2969939138b3ffff442f339a diff --git a/haunt/api.scm b/haunt/api.scm new file mode 100644 index 0000000..e9c5642 --- /dev/null +++ b/haunt/api.scm @@ -0,0 +1,74 @@ +;;; Copyright © 2019 - 2022 Jakob L. Kreuze +;;; +;;; 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 +;;; . + +(use-modules (ice-9 match) + (jakob dynamic capabilities gallery) + (jakob dynamic capabilities rsvp) + (jakob dynamic logging) + (srfi srfi-1) + (web request) + (web response) + (web server) + (web uri)) + +(define (not-found request) + "Build a (somewhat) descriptive response for a non-existent resource." + (values (build-response #:code 404) + (string-append "Resource not found: " + (uri->string (request-uri request))))) + +(define (handle-api-request request body endpoint) + "Route handler for the API server." + (let ((method (request-method request)) + (originating-ip (assoc-ref (request-headers request) 'X-Forwarded-For)) + (args (uri-query (request-uri request)))) + (log-append! 'info (format #f "~a ~a (~a) (~a)" method endpoint args originating-ip))) + ((match (cons (request-method request) endpoint) + ;; ('(GET "challenge") make-challenge) + ;; ('(GET "comments") get-comments) + ;; ('(POST "comment") put-comment) + ('(GET "gallery") get-gallery) + ('(GET "gallery" "image") get-image) + ('(GET "rsvp" "event-info") get-event-info) + ('(POST "rsvp") post-event-rsvp) + (_ (lambda (. args) (not-found request)))) + request body)) + +(define (main-request-handler request body) + "Server entry-point; parse `request' and defer to routing system." + (define (wrap-response response) + ;; This is either a response, or an alist of headers. The latter case is + ;; simple to handle, but the former requires us to do a (rather unweildy) + ;; copy of the response to inject our headers. + (if (response? response) + (build-response + #:version (response-version response) + #:code (response-code response) + #:reason-phrase (response-reason-phrase response) + #:headers (cons '(Access-Control-Allow-Origin . "*") + (response-headers response)) + #:port (response-port response) + #:validate-headers? #t) + (cons '(Access-Control-Allow-Origin . "*") response))) + (let* ((path-encoded (uri-path (request-uri request))) + (path (split-and-decode-uri-path path-encoded))) + (define-values (response resp-body) + (if (string= "api" (first path)) + (handle-api-request request body (drop path 1)) + (not-found request))) + (values (wrap-response response) resp-body))) + +(run-server main-request-handler) diff --git a/haunt/jakob/dynamic/README.md b/haunt/jakob/dynamic/README.md new file mode 100644 index 0000000..0f64827 --- /dev/null +++ b/haunt/jakob/dynamic/README.md @@ -0,0 +1,16 @@ +# Dynamic API for jakob.space + +This is a Guile back-end for all dynamic capabilities on jakob.space. It is +assumed that the web server proxies all requests matching a `/api` prefix to +this server. + +## Dependencies + +Depending on who you ask, the package management situation for Guile is either +disappointing, or a pleasant reminder of simpler times. This module leverages +two Guile modules which, to my knowledge, are not packaged in the typical Guile +extension fashion. The respective `.scm` files will need to be downloaded and +added to Guile load path. + +- [base64 from guile-lib](https://github.com/jacobrec/guile-lib/blob/master/base64.scm) +- [squee](https://notabug.org/cwebber/guile-squee/) diff --git a/haunt/jakob/dynamic/base64.scm b/haunt/jakob/dynamic/base64.scm new file mode 100644 index 0000000..149f7ba --- /dev/null +++ b/haunt/jakob/dynamic/base64.scm @@ -0,0 +1,353 @@ +;; -*- mode: scheme; coding: utf-8 -*- +;; +;; This module was renamed from (weinholt text base64 (1 0 20100612)) to +;; (guix base64) by Nikita Karetnikov on +;; February 12, 2014. It was later renamed to (gcrypt base64) by +;; Christopher Allan Webber on May 20, 2017. +;; +;; Some optimizations made by Ludovic Courtès , 2015. +;; Turned into a Guile module (instead of R6RS). +;; +;; 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 . +;; +;; This file incorporates work covered by the following copyright and +;; permission notice: +;; +;; Copyright © 2009, 2010, 2012, 2013, 2018 Göran Weinholt +;; +;; Permission is hereby granted, free of charge, to any person obtaining a +;; copy of this software and associated documentation files (the "Software"), +;; to deal in the Software without restriction, including without limitation +;; the rights to use, copy, modify, merge, publish, distribute, sublicense, +;; and/or sell copies of the Software, and to permit persons to whom the +;; Software is furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be included in +;; all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL +;; THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +;; FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER +;; DEALINGS IN THE SOFTWARE. + +;; RFC 4648 Base-N Encodings + +(define-module (base64) + #:export (base64-encode + base64-decode + base64-alphabet + base64url-alphabet + get-delimited-base64 + put-delimited-base64) + #:use-module (srfi srfi-11) + #:use-module (srfi srfi-60) + #:use-module (rnrs bytevectors) + #:use-module (rnrs io ports)) + + +(define-syntax define-alias + (syntax-rules () + ((_ new old) + (define-syntax new (identifier-syntax old))))) + +;; Force the use of Guile's own primitives to avoid the overhead of its 'fx' +;; procedures. + +(define-alias fxbit-field bit-field) +(define-alias fxarithmetic-shift ash) +(define-alias fxarithmetic-shift-left ash) +(define-alias fxand logand) +(define-alias fxior logior) +(define-alias fxxor logxor) +(define-alias fx=? =) +(define-alias fx<=? <=) +(define-alias fxzero? zero?) +(define-alias fx+ +) +(define-alias fx- -) +(define-alias fxmod modulo) +(define-alias mod modulo) + +(define-syntax-rule (assert exp) + (unless exp + (throw 'assertion-failure 'exp))) + +(define base64-alphabet + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") + +(define base64url-alphabet + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_") + +(define base64-encode + (case-lambda + ;; Simple interface. Returns a string containing the canonical + ;; base64 representation of the given bytevector. + ((bv) + (base64-encode bv 0 (bytevector-length bv) #f #f base64-alphabet #f)) + ((bv start) + (base64-encode bv start (bytevector-length bv) #f #f base64-alphabet #f)) + ((bv start end) + (base64-encode bv start end #f #f base64-alphabet #f)) + ((bv start end line-length) + (base64-encode bv start end line-length #f base64-alphabet #f)) + ((bv start end line-length no-padding) + (base64-encode bv start end line-length no-padding base64-alphabet #f)) + ((bv start end line-length no-padding alphabet) + (base64-encode bv start end line-length no-padding alphabet #f)) + ;; Base64 encodes the bytes [start,end[ in the given bytevector. + ;; Lines are limited to line-length characters (unless #f), + ;; which must be a multiple of four. To omit the padding + ;; characters (#\=) set no-padding to a true value. If port is + ;; #f, returns a string. + ((bv start end line-length no-padding alphabet port) + (assert (or (not line-length) (zero? (mod line-length 4)))) + (let-values (((p extract) (if port + (values port (lambda () (values))) + (open-string-output-port)))) + (letrec ((put (if line-length + (let ((chars 0)) + (lambda (p c) + (when (fx=? chars line-length) + (set! chars 0) + (put-char p #\linefeed)) + (set! chars (fx+ chars 1)) + (put-char p c))) + put-char))) + (let lp ((i start)) + (cond ((= i end)) + ((<= (+ i 3) end) + (let ((x (bytevector-uint-ref bv i (endianness big) 3))) + (put p (string-ref alphabet (fxbit-field x 18 24))) + (put p (string-ref alphabet (fxbit-field x 12 18))) + (put p (string-ref alphabet (fxbit-field x 6 12))) + (put p (string-ref alphabet (fxbit-field x 0 6))) + (lp (+ i 3)))) + ((<= (+ i 2) end) + (let ((x (fxarithmetic-shift-left (bytevector-u16-ref bv i (endianness big)) 8))) + (put p (string-ref alphabet (fxbit-field x 18 24))) + (put p (string-ref alphabet (fxbit-field x 12 18))) + (put p (string-ref alphabet (fxbit-field x 6 12))) + (unless no-padding + (put p #\=)))) + (else + (let ((x (fxarithmetic-shift-left (bytevector-u8-ref bv i) 16))) + (put p (string-ref alphabet (fxbit-field x 18 24))) + (put p (string-ref alphabet (fxbit-field x 12 18))) + (unless no-padding + (put p #\=) + (put p #\=))))))) + (extract))))) + +;; Create a lookup table for the alphabet and remember the latest table. +(define get-decode-table + (let ((ascii-table #f) + (extra-table '()) ;in the unlikely case of unicode chars + (table-alphabet #f)) + (lambda (alphabet) + (unless (eq? alphabet table-alphabet) + ;; Rebuild the table. + (do ((ascii (make-vector 128 #f)) + (extra '()) + (i 0 (+ i 1))) + ((= i (string-length alphabet)) + (set! ascii-table ascii) + (set! extra-table extra)) + (let ((c (char->integer (string-ref alphabet i)))) + (if (fx<=? c 127) + (vector-set! ascii c i) + (set! extra (cons (cons c i) extra))))) + (set! table-alphabet alphabet)) + (values ascii-table extra-table)))) + +;; Decodes a base64 string, optionally ignoring non-alphabet +;; characters and lack of padding. +(define base64-decode + (case-lambda + ((str) + (base64-decode str base64-alphabet #f)) + ((str alphabet) + (base64-decode str alphabet #f)) + ((str alphabet port) + (base64-decode str alphabet port #t)) + ((str alphabet port strict?) + (base64-decode str alphabet port strict? #t)) + ((str alphabet port strict? strict-padding?) + (define (pad? c) (eqv? c (char->integer #\=))) + (let-values (((p extract) (if port + (values port (lambda () (values))) + (open-bytevector-output-port))) + ((ascii extra) (get-decode-table alphabet))) + (define-syntax lookup + (syntax-rules () + ((_ c) (or (and (fx<=? c 127) (vector-ref ascii c)) + (cond ((assv c extra) => cdr) + (else #f)))))) + (let lp-restart ((str str)) + (let* ((len (if strict? + (string-length str) + (let lp ((i (fx- (string-length str) 1))) + ;; Skip trailing invalid chars. + (cond ((fxzero? i) 0) + ((let ((c (char->integer (string-ref str i)))) + (or (lookup c) (pad? c))) + (fx+ i 1)) + (else (lp (fx- i 1)))))))) + (let lp ((i 0)) + (cond + ((fx=? i len) + (extract)) + ((fx<=? i (fx- len 4)) + (let lp* ((c1 (char->integer (string-ref str i))) + (c2 (char->integer (string-ref str (fx+ i 1)))) + (c3 (char->integer (string-ref str (fx+ i 2)))) + (c4 (char->integer (string-ref str (fx+ i 3)))) + (i i)) + (let ((i1 (lookup c1)) (i2 (lookup c2)) + (i3 (lookup c3)) (i4 (lookup c4))) + (cond + ((and i1 i2 i3 i4) + ;; All characters present and accounted for. + ;; The most common case. + (let ((x (fxior (fxarithmetic-shift-left i1 18) + (fxarithmetic-shift-left i2 12) + (fxarithmetic-shift-left i3 6) + i4))) + (put-u8 p (fxbit-field x 16 24)) + (put-u8 p (fxbit-field x 8 16)) + (put-u8 p (fxbit-field x 0 8)) + (lp (fx+ i 4)))) + ((and i1 i2 i3 (pad? c4) (= i (- len 4))) + ;; One padding character at the end of the input. + (let ((x (fxior (fxarithmetic-shift-left i1 18) + (fxarithmetic-shift-left i2 12) + (fxarithmetic-shift-left i3 6)))) + (put-u8 p (fxbit-field x 16 24)) + (put-u8 p (fxbit-field x 8 16)) + (lp (fx+ i 4)))) + ((and i1 i2 (pad? c3) (pad? c4) (= i (- len 4))) + ;; Two padding characters. + (let ((x (fxior (fxarithmetic-shift-left i1 18) + (fxarithmetic-shift-left i2 12)))) + (put-u8 p (fxbit-field x 16 24)) + (lp (fx+ i 4)))) + ((not strict?) + ;; Non-alphabet characters. + (let lp ((i i) (c* '()) (n 4)) + (cond ((fxzero? n) + ;; Found four valid characters. + (lp* (cadddr c*) (caddr c*) (cadr c*) (car c*) + (fx- i 4))) + ((fx=? i len) + (error 'base64-decode + "Invalid input in non-strict mode." + i c*)) + (else + ;; Gather alphabetic (or valid + ;; padding) characters. + (let ((c (char->integer (string-ref str i)))) + (cond ((or (lookup c) + (and (pad? c) + (fx<=? n 2) + (fx=? i (fx- len n)))) + (lp (fx+ i 1) (cons c c*) (fx- n 1))) + (else + (lp (fx+ i 1) c* n)))))))) + (else + (error 'base64-decode + "Invalid input in strict mode." + c1 c2 c3 c4)))))) + ((not strict-padding?) + ;; Append an appropriate amount of padding after the + ;; remaining characters. + (if (<= 2 (- len i) 3) + (lp-restart (string-append (substring str i (string-length str)) + (if (= (- len i) 2) "==" "="))) + (error 'base64-decode "The input is too short." i))) + (else + (error 'base64-decode + "The input is too short, it may be missing padding." + i)))))))))) + +(define (get-line-comp f port) + (if (port-eof? port) + (eof-object) + (f (get-line port)))) + +;; Reads the common -----BEGIN/END type----- delimited format from +;; the given port. Returns two values: a string with the type and a +;; bytevector containing the base64 decoded data. The second value +;; is the eof object if there is an eof before the BEGIN delimiter. +(define get-delimited-base64 + (case-lambda + ((port) + (get-delimited-base64 port #t)) + ((port strict) + (define (get-first-data-line port) + ;; Some MIME data has header fields in the same format as mail + ;; or http. These are ignored. + (let ((line (get-line-comp string-trim-both port))) + (cond ((eof-object? line) line) + ((string-index line #\:) + (let lp () ;read until empty line + (let ((line (get-line-comp string-trim-both port))) + (if (string=? line "") + (get-line-comp string-trim-both port) + (lp))))) + (else line)))) + (let ((line (get-line-comp string-trim-both port))) + (cond ((eof-object? line) + (values "" (eof-object))) + ((string=? line "") + (get-delimited-base64 port)) + ((and (string-prefix? "-----BEGIN " line) + (string-suffix? "-----" line)) + (let* ((type (substring line 11 (- (string-length line) 5))) + (endline (string-append "-----END " type "-----"))) + (let-values ([(outp extract) (open-bytevector-output-port)]) + (let lp ((previous "") (line (get-first-data-line port))) + (cond ((eof-object? line) + (error 'get-delimited-base64 + "unexpected end of file")) + ((string-prefix? "-" line) + (unless (string=? line endline) + (error 'get-delimited-base64 + "bad end delimiter" type line)) + (values type (extract))) + ((and (= (string-length line) 5) + (string-prefix? "=" line)) + ;; Skip Radix-64 checksum + (lp previous (get-line-comp string-trim-both port))) + ((not (fxzero? (fxmod (fx+ (string-length previous) + (string-length line)) + 4))) + ;; OpenSSH outputs lines with a bad length + (lp (string-append previous line) + (get-line-comp string-trim-both port))) + (else + (base64-decode (string-append previous line) base64-alphabet outp) + (lp "" (get-line-comp string-trim-both port)))))))) + (else ;skip garbage (like in openssl x509 -in foo -text output). + (get-delimited-base64 port))))))) + +(define put-delimited-base64 + (case-lambda + ((port type bv line-length) + (display (string-append "-----BEGIN " type "-----\n") port) + (base64-encode bv 0 (bytevector-length bv) + line-length #f base64-alphabet port) + (display (string-append "\n-----END " type "-----\n") port)) + ((port type bv) + (put-delimited-base64 port type bv 76)))) diff --git a/haunt/jakob/dynamic/capabilities/comment-form.scm b/haunt/jakob/dynamic/capabilities/comment-form.scm new file mode 100644 index 0000000..b435089 --- /dev/null +++ b/haunt/jakob/dynamic/capabilities/comment-form.scm @@ -0,0 +1,33 @@ +;;; Copyright © 2019 - 2022 Jakob L. Kreuze +;;; +;;; 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 +;;; . + +(define-module (jakob dynamic capabilities comment-form) + #:use-module (haunt html) + #:use-module (ice-9 match) + #:use-module (jakob dynamic util) + #:use-module (jakob theme) + #:use-module (json) + #:use-module (web request) + #:use-module (web response) + #:use-module (web uri) + #:export (get-comment-form)) + +(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'." + (values '((content-type . (text/html))) + (sxml->html-string (theme #:content '(p "Hello, world!"))))) diff --git a/haunt/jakob/dynamic/capabilities/comments.scm b/haunt/jakob/dynamic/capabilities/comments.scm new file mode 100644 index 0000000..d4159fa --- /dev/null +++ b/haunt/jakob/dynamic/capabilities/comments.scm @@ -0,0 +1,153 @@ +;;; Copyright © 2019 - 2022 Jakob L. Kreuze +;;; +;;; 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 +;;; . + +(define-module (jakob dynamic capabilities comments) + #:use-module (ice-9 match) + #:use-module (jakob dynamic util) + #:use-module (json) + #:use-module (squee) + #: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 "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 (format-comment comment) + (match comment + ((id name subject email comment url approved reactions) + `((id . ,id) + (name . ,name) + (subject . ,subject) + (email . ,email) + (comment . ,comment) + (url . ,url) + (publish-time . ,approved) + (reactions . ,(if reactions + (with-input-from-string reactions read) + '())))))) + (let* ((query "SELECT id, name, subject, email, comment, url, approved, reactions + FROM comments WHERE slug = $1 and approved IS NOT NULL") + (result (exec-query conn query (list slug)))) + (map format-comment 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'." + (let* ((query-string (uri-query (request-uri request))) + (params (if query-string + (decode-form query-string) + '())) + (slug (assoc-ref params "p"))) + (if slug + (values '((content-type . (application/json))) + (scm->json-string + (list->vector + (get-comments-by-slug (car slug))))) + (values (build-response #:code 400) + (scm->json-string + `((success . #f) + (error . "missing `slug' query parameter"))))))) + + + +(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))) + (define (insert-comment form-data) + (exec-query conn + "INSERT INTO comments (submitted, slug, name, subject, + email, url, comment) + VALUES (now(), $1, $2, $3, $4, $5, $6);" + (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"))) + (values '((content-type . (application/json))) + (scm->json-string `((success . #t))))) + (let ((form-data (decode-form body))) + (if (valid-comment? form-data) + (insert-comment form-data) + (values (build-response #:code 400) + (scm->json-string + `((success . #f) + (error . "missing `slug', `name', or `comment'"))))))) + + + +(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) + '()))) + (if (valid-reaction? form-data) + (let ((id (assoc-value form-data "id")) + (reaction (assoc-value form-data "reaction")) + (reactions (comment-reactions id))) + (if reactions + (begin + (set-reactions id (add-reaction reactions reaction)) + (values '((content-type . (application/json))) + (scm->json-string `((success . #t))))) + (values (build-response #:code 400) + (scm->json-string + `((success . #f) + (error . "no such comment")))))) + (values (build-response #:code 400) + (scm->json-string + `((success . #f) + (error . "missing `id', or `reaction'"))))))) + +;; (define (make-challenge request body) +;; (let-values (((uuid value image) (new-captcha))) +;; (hash-set! challenges uuid value) +;; (hash-for-each (lambda (x y) (display x) (newline)) challenges) +;; (values `((content-type . (application/base64)) +;; (access-control-allow-origin . "*") +;; (x-captcha-id . ,uuid)) +;; (base64-encode image)))) diff --git a/haunt/jakob/dynamic/capabilities/gallery.scm b/haunt/jakob/dynamic/capabilities/gallery.scm new file mode 100644 index 0000000..b8b46c9 --- /dev/null +++ b/haunt/jakob/dynamic/capabilities/gallery.scm @@ -0,0 +1,111 @@ +;;; Copyright © 2019 - 2022 Jakob L. Kreuze +;;; +;;; 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 +;;; . + +(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 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 "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")))) + (if (valid-gallery-code code) + (values '((content-type . (application/json))) + (scm->json-string `((info . ,(get-gallery-info code)) + (images . ,(get-gallery-images code))))) + (values (build-response #:code 400) + (scm->json-string + `((success . #f) + (error . "Invalid gallery code"))))))) + +(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")))) + (if (image-exists? file-name) + (read-image file-name) + (values (build-response #:code 400) + (scm->json-string + `((success . #f) + (error . "Invalid filename"))))))) diff --git a/haunt/jakob/dynamic/capabilities/rsvp.scm b/haunt/jakob/dynamic/capabilities/rsvp.scm new file mode 100644 index 0000000..c02b758 --- /dev/null +++ b/haunt/jakob/dynamic/capabilities/rsvp.scm @@ -0,0 +1,277 @@ +;;; Copyright © 2019 - 2022 Jakob L. Kreuze +;;; +;;; 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 +;;; . + +(define-module (jakob dynamic capabilities rsvp) + #:use-module (base64) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 match) + #: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 "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 + (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 `'." + (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))) + (cond ((not params) + (values (build-response #:code 400) + (scm->json-string + `((success . #f) + (error . "Invalid form data"))))) + ((not (valid-invite-code (rsvp-create-code params))) + (values (build-response #:code 400) + (scm->json-string + `((success . #f) + (error . "Invalid invitation code"))))) + (else + (let ((receipt-code (generate-vanity-code)) + (event-id (car (invitation->event-id (rsvp-create-code params))))) + (exec-query conn + "INSERT INTO rsvps (vanity, invitation_id, event_id, fullname, email, attending, guests) VALUES ($1, $2, $3, $4, $5, $6, $7)" + (list receipt-code + (rsvp-create-code params) + event-id + (rsvp-create-name params) + (rsvp-create-email params) + (rsvp-create-attending params) + (rsvp-create-guests params))) + (values '((content-type . (application/json))) + (scm->json-string + `((receipt . ,receipt-code))))))))) + + + +(define-record-type + (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 `'." + (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))) + (cond ((not params) + (values (build-response #:code 400) + (scm->json-string + `((success . #f) + (error . "Invalid form data"))))) + ((not (valid-receipt-code (rsvp-update-code params))) + (values (build-response #:code 400) + (scm->json-string + `((success . #f) + (error . "Invalid receipt code"))))) + (else + (exec-query conn + "UPDATE rsvps SET fullname = $2, email = $3, attending = $4, guests = $5 WHERE vanity = $1" + (list + (rsvp-update-code params) + (rsvp-update-name params) + (rsvp-update-email params) + (rsvp-update-attending params) + (rsvp-update-guests params))) + (values '((content-type . (application/json))) + (scm->json-string + `((receipt . ,(rsvp-update-code params))))))))) + + + +(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 (values (build-response #:code 400) + (scm->json-string + `((success . #f) + (error . "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 + (values (build-response #:code 400) + (scm->json-string + `((success . #f) + (error . "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..b095ebf --- /dev/null +++ b/haunt/jakob/dynamic/captcha.scm @@ -0,0 +1,170 @@ +;;; Copyright © 2019 - 2022 Jakob L. Kreuze +;;; +;;; 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 +;;; . + +(define-module (captcha) + #:use-module (base64) + #:use-module (gcrypt hash) + #:use-module (gcrypt mac) + #:use-module (gcrypt random) + #:use-module (ice-9 binary-ports) + #: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 rdelim) + #:use-module (ice-9 threads) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-19) + #:export (new-captcha)) + +(define proc-mutex (make-mutex)) + +(define (random-term) + (match (random 5) + (0 `(* ,(+ 1 (random 10)) x)) + (1 `(* ,(+ 1 (random 10)) (expt x ,(random 10)))) + (2 `(* ,(+ 1 (random 10)) (exp x))) + (3 `(* ,(+ 1 (random 10)) (cos x))) + (4 `(* ,(+ 1 (random 10)) (sin x))))) + +(define (sexp->latex sexp) + (match sexp + (('+ rest ...) (string-join (map sexp->latex rest) " + ")) + (('* rest ...) (string-join (map sexp->latex rest) " \\cdot ")) + (('sin term) (format #f "\\sin(~a)" (sexp->latex term))) + (('cos term) (format #f "\\cos(~a)" (sexp->latex term))) + (('expt term n) (format #f "~a^{~a}" (sexp->latex term) (sexp->latex n))) + (('exp term) (format #f "e^{~a}" (sexp->latex term))) + ('x "x") + (n (cond ((and (number? n) (positive? n)) (format #f "~a" n)) + ((and (number? n) (negative? n)) (format #f "(~a)" n)) + ((number? n) "0") + (else (error "Do not know how to convert to latex." n)))))) + +(define (differentiate-sexp sexp) + (match sexp + (('+ rest ...) `(+ ,@(map differentiate-sexp rest))) + (('* coeff term) (if (number? coeff) + `(* ,coeff ,(differentiate-sexp term)) + (error "Do not know how to differentiate."))) + (('sin term) `(* ,(differentiate-sexp term) (cos ,term))) + (('cos term) `(* -1 ,(differentiate-sexp term) (sin ,term))) + (('exp term) `(* ,(differentiate-sexp term) (exp ,term))) + (('expt term n) `(* ,n (expt ,term ,(- n 1)))) + ('x 1) + (n (if (number? n) + 0 + (error "Do not know how to differentiate."))))) + +(define (simplify-sexp sexp) + (match sexp + (('+ rest ...) `(+ ,@(map simplify-sexp rest))) + (('* 1 term) (simplify-sexp term)) + (('* 1 rest ...) (simplify-sexp `(* ,@rest))) + (('sin term) `(sin ,(simplify-sexp term))) + (('sin term) `(cos ,(simplify-sexp term))) + (('exp term) `(exp ,(simplify-sexp term))) + (('expt term 1) (simplify-sexp term)) + (('expt term n) `(expt ,(simplify-sexp term) ,(simplify-sexp n))) + (term term))) + +(define (random-expression) + (let ((n-terms (+ 2 (random 3)))) + `(+ ,@(map (lambda (x) (random-term)) (iota n-terms))))) + +(define (latex->image src) + (chdir "/tmp") + (with-mutex proc-mutex + (call-with-output-file "formula.tex" + (lambda (port) + (format port "\\def\\formula{~a} +\\documentclass[border=2pt]{standalone} +\\usepackage{amsmath} +\\usepackage{varwidth} +\\begin{document} +\\begin{varwidth}{\\linewidth} +\\[ \\formula \\] +\\end{varwidth} +\\end{document} +" src))) + (unless (eqv? 0 (status:exit-val (system "pdflatex formula.tex"))) + (error "Cannot generate PDF")) + (let* ((port (open-input-pipe "convert -density 300 formula.pdf -quality 90 png:-")) + (data (get-bytevector-all port))) + (unless (eqv? 0 (status:exit-val (close-pipe port))) + (error "Cannot generate PNG")) + data))) + +(define (new-uuid) + (with-mutex proc-mutex + (let* ((port (open-input-pipe "uuidgen")) + (str (read-line port))) + (close-pipe port) + str))) + +(define (new-captcha) + (let* ((lower-bound (random 10)) + (upper-bound (+ lower-bound 1 (random 9))) + (expression (random-expression)) + (latex-src (sexp->latex (simplify-sexp (differentiate-sexp expression))))) + (values (new-uuid) + (- (local-eval expression (let ((x upper-bound)) (the-environment))) + (local-eval expression (let ((x lower-bound)) (the-environment)))) + (latex->image (format #f "\\int_{~a}^{~a} ~a \\, dx" + lower-bound + upper-bound + latex-src))))) + + + +;; How many zeroes the SHA-256 hash has to be prefixed by to be a valid proof of work. +(define %hardness 4) + +;; This is an ephemeral key. At this point, it doesn't make sense to store keys +;; locally, since the server process is singular and long-running. +(define %pow-mac-key (gen-random-bv 64)) + +(define (proof-of-work) + (define challenge + (call-with-input-file "/dev/urandom" + (lambda (port) (base64-encode (get-bytevector-n port 32))))) + (define expiry-timestamp + (date->string + (time-utc->date (make-time 'time-utc 0 (+ 512 (time-second (current-time))))) + "~Y-~m-~d ~H:~M:~S")) + (define challenge-signature + (sign-data-base64 %pow-mac-key challenge)) + (define timestamp-signature + (sign-data-base64 %pow-mac-key expiry-timestamp)) + (values challenge challenge-signature expiry-timestamp timestamp-signature)) + +(define (check-proof-of-work prefix + challenge challenge-signature + expiry-timestamp timestamp-signature) + (define hash-value + (chain (list prefix challenge) + (string-concatenate _) + (string->bytevector _ "utf8") + (bytevector-hash _ (lookup-hash-algorithm 'sha256)) + (bytevector->base16-string _))) + (define zero-prefix (string-join (map (lambda (_) "0") (iota %hardness)) "")) + (and (= 32 (string-length prefix)) + (string-prefix? zero-prefix hash-value) + (valid-base64-signature? %pow-mac-key challenge challenge-signature) + (valid-base64-signature? %pow-mac-key expiry-timestamp timestamp-signature) + (time<=? (current-time) + (date->time-utc (string->date expiry-timestamp "~Y-~m-~d ~H:~M:~S"))))) 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..42b367d --- /dev/null +++ b/haunt/jakob/dynamic/logging.scm @@ -0,0 +1,37 @@ +;;; Copyright © 2019 - 2022 Jakob L. Kreuze +;;; +;;; 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 +;;; . + +(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)) + (call-with-output-file (%log-file-name) + (lambda (port) + (let ((now (date->string (current-date) "~4"))) + (format port "[~a] ~a: ~a~%" now level message)))))) diff --git a/haunt/jakob/dynamic/schema-comments.sql b/haunt/jakob/dynamic/schema-comments.sql new file mode 100644 index 0000000..b2cb652 --- /dev/null +++ b/haunt/jakob/dynamic/schema-comments.sql @@ -0,0 +1,16 @@ +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) +); + +-- 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..6cdb4e5 --- /dev/null +++ b/haunt/jakob/dynamic/util.scm @@ -0,0 +1,69 @@ +;;; Copyright © 2019 - 2022 Jakob L. Kreuze +;;; +;;; 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 +;;; . + +(define-module (jakob dynamic util) + #:use-module (ice-9 match) + #:use-module (rnrs bytevectors) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-26) + #:use-module (web uri) + #:export (assoc-value + acons-normalize + base64-length + decode-form)) + +(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))))) diff --git a/haunt/jakob/utils/comments.scm b/haunt/jakob/utils/comments.scm index 3f55345..45c97c5 100644 --- a/haunt/jakob/utils/comments.scm +++ b/haunt/jakob/utils/comments.scm @@ -16,8 +16,6 @@ (define-module (jakob utils comments) #:use-module (commonmark) - ;; #:use-module (dynamic capabilities comments) - #:use-module (dynamic util) #:use-module (gcrypt base16) #:use-module (gcrypt hash) #:use-module (ice-9 receive) @@ -26,6 +24,8 @@ #:use-module (srfi srfi-19) #:use-module (srfi srfi-43) #:use-module (srfi-197) + #:use-module (jakob dynamic capabilities comments) + #:use-module (jakob dynamic util) #:use-module (json) #:use-module (web client) #:use-module (web response) @@ -64,7 +64,7 @@ (let* ((author-name (assoc-ref comment 'name)) (author-url (assoc-ref comment 'url)) (author-photo (gravatar-url (assoc-ref comment 'email))) - (publish-datetime (assoc-ref comment 'published)) + (publish-datetime (assoc-ref comment 'publish-time)) (content-text (assoc-ref comment 'comment)) (content-reactions (assoc-ref comment 'reactions))) `(li (@ (class "p-comment h-cite comment comment-source-internal")) @@ -83,13 +83,11 @@ ,@(chain content-text (safe-markdown->sxml _))) (div (@ (class "metaline")) - (a (@ (class "u-url") - (href ,author-url)) - (time (@ (class "dt-published") - (datetime ,publish-datetime)) - ,(date->string - (string->date publish-datetime "~Y~m~d~H~M~S") - "~B ~e, ~Y at ~H:~M")))) + (time (@ (class "dt-published") + (datetime ,publish-datetime)) + ,(date->string + (string->date publish-datetime "~Y~m~d ~H~M~S.~N") + "~B ~e, ~Y at ~H:~M"))) (ul (@ (class "comment-reactions")) ,@(map (match-lambda ((emote . count) diff --git a/haunt/pages/about.sxml b/haunt/pages/about.sxml index 56b6abf..d8b7f74 100644 --- a/haunt/pages/about.sxml +++ b/haunt/pages/about.sxml @@ -330,7 +330,7 @@ old." (theme #:title "About" #:content - (ul (@ (class "horizontal-list")) + `((ul (@ (class "horizontal-list")) (li "Email: " (strong "zerodaysfordays at ‌​‌‌‌​‌‌‍‌​‌‌​​​​‍‌​‌‌​​​‌‍‌‌​‌‌​​​‍‌​‌​‌​‌‌‍‌‌​‌‌‌‌‌‍‌​‌‌‌​​‌‍‌​‌​‌​‌​‍‌​‌‌‌‌​​‍‌​‌‌​‌​​‍‌​‌‌​‌‌​‍‌​‌‌​​​‌‍‌​‌‌‌​​​‍‌‌​‌‌‌‌‌‍‌​‌​‌‌​​‍‌​‌​‌‌‌‌‍‌​‌‌‌‌‌​‍‌​‌‌​​‌​‍‌‌​‌‌‌‌‌‍‌​‌‌​​‌​‍‌​‌‌‌​‌​sdf.org")) (li "XMPP: " (strong "jakob at ‌​‌‌‌​‌‌‍‌​‌‌​​​​‍‌​‌‌​​​‌‍‌‌​‌‌​​​‍‌​‌​‌​‌‌‍‌‌​‌‌‌‌‌‍‌​‌‌‌​​‌‍‌​‌​‌​‌​‍‌​‌‌‌‌​​‍‌​‌‌​‌​​‍‌​‌‌​‌‌​‍‌​‌‌​​​‌‍‌​‌‌‌​​​‍‌‌​‌‌‌‌‌‍‌​‌​‌‌​​‍‌​‌​‌‌‌‌‍‌​‌‌‌‌‌​‍‌​‌‌​​‌​‍‌‌​‌‌‌‌‌‍‌​‌‌​​‌​‍‌​‌‌‌​‌​xmpp.is")) (li "IRC: " (strong "tsarfox on irc.libera.chat."))) diff --git a/haunt/squee.scm b/haunt/squee.scm new file mode 100644 index 0000000..443fa09 --- /dev/null +++ b/haunt/squee.scm @@ -0,0 +1,372 @@ +;;; squee --- A guile interface to postgres via the ffi + +;; Copyright (C) 2015 Christopher Allan Webber + +;; This library is free software; you can redistribute it and/or +;; modify it under the terms of the GNU Lesser General Public +;; License as published by the Free Software Foundation; either +;; version 3 of the License, or (at your option) any later version. +;; +;; This library is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;; Lesser General Public License for more details. +;; +;; You should have received a copy of the GNU Lesser General Public +;; License along with this library; if not, write to the Free Software +;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (squee) + #:use-module (system foreign) + #:use-module (rnrs enums) + #:use-module (ice-9 match) + #:use-module (ice-9 format) + #:use-module (srfi srfi-26) + #:export (;; The important ones + connect-to-postgres-paramstring + exec-query + pg-conn-finish + + ;; enums and indexes of enums + conn-status-enum conn-status-enum-index + polling-status-enum polling-status-index + exec-status-enum exec-status-enum-index + transaction-status-enum transaction-status-enum-index + verbosity-enum verbosity-enum-index + ping-enum ping-enum-index + + ;; **repl and error messages only!** + enum-set-ref + + ;; Connection stuff + pg-conn? wrap-pg-conn unwrap-pg-conn + + ;; @@: We don't export the result pointer though! + ;; as this needs to be cleared to avoid memory + ;; leaks... + ;; + ;; We might provide a (exec-with-result-ptr) + ;; that cleans up the result pointer after calling + ;; some thunk though? + ;; + ;; These are still useful for building your own + ;; serializer though... + result-num-rows result-num-cols result-get-value + result-serializer-simple-list result-metadata)) + +(define libpq (dynamic-link "libpq")) + +;; --------------------- +;; Enums from libpq-fe.h +;; --------------------- + +(define conn-status-enum + (make-enumeration + '(connection-ok + connection-bad + connection-started connection-made + connection-awaiting-response connection-auth-ok + connection-auth-ok connection-setenv + connection-ssl-startup + connection-needed))) + +(define conn-status-enum-index + (enum-set-indexer conn-status-enum)) + +(define polling-status-enum + (make-enumeration + '(polling-failed + polling-reading + polling-writing + polling-ok + polling-active))) + +(define polling-status-enum-index + (enum-set-indexer polling-status-enum)) + +(define exec-status-enum + (make-enumeration + '(empty-query + command-ok tuples-ok + copy-out copy-in + bad-response + nonfatal-error fatal-error + copy-both + single-tuple))) + +(define exec-status-enum-index + (enum-set-indexer exec-status-enum)) + +(define transaction-status-enum + (make-enumeration + '(idle active intrans inerror unknown))) + +(define transaction-status-enum-index + (enum-set-indexer transaction-status-enum)) + +(define verbosity-enum + (make-enumeration + '(terse default verbose))) + +(define verbosity-enum-index + (enum-set-indexer verbosity-enum)) + +(define ping-enum + (make-enumeration + '(ok reject no-response no-attempt))) + +(define ping-enum-index + (enum-set-indexer ping-enum)) + +(define-wrapped-pointer-type + pg-conn? + wrap-pg-conn unwrap-pg-conn + (lambda (pg-conn port) + (format port "#" + (pointer-address (unwrap-pg-conn pg-conn)) + (let ((status (pg-conn-status pg-conn))) + (cond ((eq? status (conn-status-enum-index 'connection-ok)) + "connected") + ((eq? status (conn-status-enum-index 'connection-bad)) + (let ((conn-error (pg-conn-error-message pg-conn))) + (if (equal? conn-error "") + "disconnected" + (format #f "disconnected, error: ~s" conn-error)))) + (#t + (symbol->string + (pg-conn-status-symbol pg-conn)))))))) + + +;; This one should NOT be exposed to the outside world! We have our +;; own result structure... + +(define-wrapped-pointer-type + result-ptr? + wrap-result-ptr unwrap-result-ptr + (lambda (result-ptr port) + (format port "#" + (pointer-address (unwrap-result-ptr result-ptr))))) + + +(define (enum-set-ref enum-set k) + "Take an ENUM-SET and get the item at position K + +This is O(n) but theoretically we don't use it much. +Again, REPL only!" + (list-ref (enum-set->list enum-set) k)) + + +(define-syntax-rule (define-foreign-libpq name return_type func_name arg_types) + (define name + (pointer->procedure return_type + (dynamic-func func_name libpq) + arg_types))) + + +(define-foreign-libpq %PQconnectdb '* "PQconnectdb" (list '*)) +(define-foreign-libpq %PQstatus int "PQstatus" (list '*)) +(define-foreign-libpq %PQerrorMessage '* "PQerrorMessage" (list '*)) +(define-foreign-libpq %PQfinish void "PQfinish" (list '*)) +(define-foreign-libpq %PQntuples int "PQntuples" (list '*)) +(define-foreign-libpq %PQnfields int "PQnfields" (list '*)) + + +(define-foreign-libpq %PQexec '* "PQexec" (list '* '*)) +(define-foreign-libpq %PQexecParams + '* ;; Returns a PGresult + "PQexecParams" + (list '* ;; connection + '* ;; command, a string + int ;; number of parameters + '* ;; paramTypes, ok to leave NULL + '* ;; paramValues, here goes your actual parameters! + '* ;; paramLengths, ok to leave NULL + '* ;; paramFormats, ok to leave NULL + int)) ;; resultFormat... probably 0! + +(define-foreign-libpq %PQresultStatus int "PQresultStatus" (list '*)) +(define-foreign-libpq %PQresStatus '* "PQresStatus" (list int)) +(define-foreign-libpq %PQresultErrorMessage '* "PQresultErrorMessage" (list '*)) +(define-foreign-libpq %PQclear void "PQclear" (list '*)) + +(define-foreign-libpq %PQcmdtuples '* "PQcmdTuples" (list '*)) +(define-foreign-libpq %PQntuples int "PQntuples" (list '*)) +(define-foreign-libpq %PQnfields int "PQnfields" (list '*)) +(define-foreign-libpq %PQgetisnull int "PQgetisnull" (list '* int int)) +(define-foreign-libpq %PQgetvalue '* "PQgetvalue" (list '* int int)) + + +;; Via mark_weaver. Thanks Mark! +;; +;; So, apparently we can use a struct of strings just like an array +;; of strings. Because magic, and because Mark thinks the C standard +;; allows it enough! + +(define (string-pointer-list->string-array ls) + "Take a list of strings, generate a C-compatible list of free strings" + (make-c-struct + (make-list (+ 1 (length ls)) '*) + (append ls (list %null-pointer)))) + +(define (pg-conn-status pg-conn) + "Get the connection status from a postgres connection" + (%PQstatus (unwrap-pg-conn pg-conn))) + +(define (pg-conn-status-symbol pg-conn) + "Human readable version of the pg-conn status. + +Inefficient... don't use this in normal code... it's just for you and +the REPL! (Well, we do use it for errors, because those are +comparatively \"rare\" so this is okay.) Compare against the enum +value of the symbol instead." + (let ((status (pg-conn-status pg-conn))) + (if (< status (length (enum-set->list conn-status-enum))) + (enum-set-ref conn-status-enum + (pg-conn-status pg-conn)) + ;; Weird, this is bigger than our enum of statuses + (string->symbol + (format #f "unknown-status-~a" status))))) + + +(define (pg-conn-error-message pg-conn) + "Get an error message for this connection" + (pointer->string (%PQerrorMessage (unwrap-pg-conn pg-conn)))) + + +(define (pg-conn-finish pg-conn) + "Close out a database connection. + +If the connection is already closed, this simply returns #f." + (if (eq? (pg-conn-status pg-conn) + (conn-status-enum-index 'connection-ok)) + (begin + (%PQfinish (unwrap-pg-conn pg-conn)) + #t) + #f)) + +(define (connect-to-postgres-paramstring paramstring) + "Open a connection to the database via a parameter string" + (let* ((conn-pointer (%PQconnectdb (string->pointer paramstring))) + (pg-conn (wrap-pg-conn conn-pointer))) + (if (eq? conn-pointer %null-pointer) + (throw 'psql-connect-error + #f "Unable to establish connection")) + (let ((status (pg-conn-status pg-conn))) + (if (eq? status (conn-status-enum-index 'connection-ok)) + pg-conn + (throw 'psql-connect-error + (enum-set-ref conn-status-enum status) + (pg-conn-error-message pg-conn)))))) + + +(define (result-num-rows result-ptr) + (%PQntuples (unwrap-result-ptr result-ptr))) + +(define (result-num-cols result-ptr) + (%PQnfields (unwrap-result-ptr result-ptr))) + +(define (result-get-value result-ptr row col) + (let ((res (unwrap-result-ptr result-ptr))) + (and (eqv? (%PQgetisnull res row col) 0) + (pointer->string + (%PQgetvalue res row col))))) + + +;; @@: We ought to also have a vector version... +;; and other serializations... +(define (result-serializer-simple-list result-ptr) + "Get a simple list of lists representing the result of the query" + (let ((rows-range (iota (result-num-rows result-ptr))) + (cols-range (iota (result-num-cols result-ptr)))) + (map + (lambda (row-i) + (map + (lambda (col-i) + (result-get-value result-ptr row-i col-i)) + cols-range)) + rows-range))) + +;; TODO +(define (result-metadata result-ptr) + #f) + + +(define (result-ptr-clear result-ptr) + (%PQclear (unwrap-result-ptr result-ptr))) + +(define (result-error-message result-ptr) + (%PQresultErrorMessage (unwrap-result-ptr result-ptr))) + + +(define* (exec-query pg-conn command #:optional (params '()) + #:key (serializer result-serializer-simple-list)) + (let* ((param-pointers + (map (lambda (param) + (if param + (string->pointer param) + %null-pointer)) + params)) + (command-pointer + (string->pointer command)) + (param-array-pointer + (string-pointer-list->string-array param-pointers)) + (result-ptr + (wrap-result-ptr + (if (null? params) + (%PQexec + (unwrap-pg-conn pg-conn) + command-pointer) + (%PQexecParams + (unwrap-pg-conn pg-conn) + command-pointer + (length params) + %null-pointer + param-array-pointer + %null-pointer %null-pointer 0))))) + + ;; Protect the pointers, and thus the memory regions they point to + ;; from garbage collection, until %PQexecParams has returned + (identity param-pointers) + (identity command-pointer) + (identity param-array-pointer) + + (if (eq? result-ptr %null-pointer) + ;; Presumably a database connection issue... + (throw 'psql-query-error + ;; See below for psql-query-error param definition + #f #f (pg-conn-error-message pg-conn))) + + (let ((status (%PQresultStatus (unwrap-result-ptr result-ptr)))) + (cond + ;; This is the kind of query that returns tuples + ((eq? status (exec-status-enum-index 'tuples-ok)) + (let ((serialized-result (serializer result-ptr)) + (metadata (result-metadata result-ptr))) + ;; Gotta clear the result to prevent memory leaks + (result-ptr-clear result-ptr) + (values serialized-result metadata))) + + ;; This doesn't return tuples, eg it's a DELETE or something. + ((eq? status (exec-status-enum-index 'command-ok)) + (let ((metadata (result-metadata result-ptr)) + (rows (%PQcmdtuples (unwrap-result-ptr result-ptr)))) + ;; Gotta clear the result to prevent memory leaks + (result-ptr-clear result-ptr) + ;; Return the number of affected rows. + (values (string->number + (pointer->string rows)) metadata))) + + ;; Uhoh, anything else is an error! + (#t + (let ((status-message (pointer->string (%PQresStatus status))) + (error-message (pointer->string + (%PQresultErrorMessage (unwrap-result-ptr + result-ptr))))) + (result-ptr-clear result-ptr) + (throw 'psql-query-error + ;; @@: Do we need result-status? + ;; (error-symbol result-status result-error-message) + (enum-set-ref exec-status-enum status) + status-message error-message))))))) + +;; (define conn (connect-to-postgres-paramstring "dbname=sandbox")) diff --git a/haunt/srfi-197.scm b/haunt/srfi-197.scm new file mode 100644 index 0000000..93fc0ab --- /dev/null +++ b/haunt/srfi-197.scm @@ -0,0 +1,4 @@ +(define-module (srfi-197) + #:export (chain chain-and chain-when chain-lambda nest nest-reverse)) + +(include "ext-srfi-197/srfi-197-syntax-case.scm") diff --git a/srfi-197.scm b/srfi-197.scm deleted file mode 100644 index 93fc0ab..0000000 --- a/srfi-197.scm +++ /dev/null @@ -1,4 +0,0 @@ -(define-module (srfi-197) - #:export (chain chain-and chain-when chain-lambda nest nest-reverse)) - -(include "ext-srfi-197/srfi-197-syntax-case.scm") -- cgit v1.3