From bd20d5071da3de0a9c15ce0a5bc3f40e7b6c2879 Mon Sep 17 00:00:00 2001 From: "Jakob L. Kreuze" Date: Fri, 18 Nov 2022 12:29:58 -0500 Subject: [dynamic] Initial comment/captcha system that doesn't work --- haunt/api.scm | 16 +- haunt/jakob/builder/blog.scm | 3 +- haunt/jakob/dynamic/aes.scm | 4 +- haunt/jakob/dynamic/base64.scm | 353 ---------------------- haunt/jakob/dynamic/capabilities/comment-form.scm | 41 ++- haunt/jakob/dynamic/capabilities/comments.scm | 11 +- haunt/jakob/dynamic/capabilities/rsvp.scm | 2 +- haunt/jakob/dynamic/captcha.scm | 74 ++++- haunt/static/css/style.css | 20 +- 9 files changed, 143 insertions(+), 381 deletions(-) delete mode 100644 haunt/jakob/dynamic/base64.scm diff --git a/haunt/api.scm b/haunt/api.scm index e9c5642..5b5fa2b 100644 --- a/haunt/api.scm +++ b/haunt/api.scm @@ -15,6 +15,8 @@ ;;; . (use-modules (ice-9 match) + (jakob dynamic capabilities comment-form) + (jakob dynamic capabilities comments) (jakob dynamic capabilities gallery) (jakob dynamic capabilities rsvp) (jakob dynamic logging) @@ -37,13 +39,14 @@ (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 "comment-form" _) get-comment-form) ;; ('(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) + (('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)) @@ -71,4 +74,5 @@ (not-found request))) (values (wrap-response response) resp-body))) -(run-server main-request-handler) +;; (run-server main-request-handler) +(run-server main-request-handler 'http '(#:port 8081)) diff --git a/haunt/jakob/builder/blog.scm b/haunt/jakob/builder/blog.scm index b1e19fa..3634de5 100644 --- a/haunt/jakob/builder/blog.scm +++ b/haunt/jakob/builder/blog.scm @@ -89,7 +89,8 @@ ;; ,@(render-comment-view (fetch-webmentions (post-identifier post)))) ,@(render-comment-view (fetch-comments (post-identifier post)))) (form - (@ (action "https://webmention.io/jakob.space/webmention") + (@ (id "webmention-form") + (action "https://webmention.io/jakob.space/webmention") (method "post")) (label "Have you written a " ,(hyperlink "https://indieweb.org/responses" "response") diff --git a/haunt/jakob/dynamic/aes.scm b/haunt/jakob/dynamic/aes.scm index 11d4819..b6e937d 100644 --- a/haunt/jakob/dynamic/aes.scm +++ b/haunt/jakob/dynamic/aes.scm @@ -18,7 +18,9 @@ #:use-module (gcrypt random) #:use-module (system foreign) #:use-module (rnrs bytevectors) - #:export (new-captcha)) + #:export (%aes-key-size + aes-256-encrypt + aes-256-decrypt)) (define %libnettle (dynamic-link "libnettle")) (define %aes256-rounds 14) diff --git a/haunt/jakob/dynamic/base64.scm b/haunt/jakob/dynamic/base64.scm deleted file mode 100644 index 149f7ba..0000000 --- a/haunt/jakob/dynamic/base64.scm +++ /dev/null @@ -1,353 +0,0 @@ -;; -*- 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 index b435089..70e5303 100644 --- a/haunt/jakob/dynamic/capabilities/comment-form.scm +++ b/haunt/jakob/dynamic/capabilities/comment-form.scm @@ -15,19 +15,56 @@ ;;; . (define-module (jakob dynamic capabilities comment-form) + #:use-module (gcrypt base64) #:use-module (haunt html) #:use-module (ice-9 match) + #:use-module (jakob dynamic captcha) #:use-module (jakob dynamic util) #:use-module (jakob theme) #:use-module (json) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-11) #:use-module (web request) #:use-module (web response) #:use-module (web uri) #:export (get-comment-form)) +(define (render-comment-form slug) + (let-values (((mac solution captcha-image) (new-captcha))) + `((div (@ (id "comment-form")) + (h1 "Comment form") + (form (@ (id "comment-input") (action "/api/comment") (method "post")) + (input (@ (type "text") (name "slug") (hidden #t) (value ,slug))) + (input (@ (type "text") (name "solution") (hidden #t) (value ,solution))) + (input (@ (type "text") (name "solution-mac") (hidden #t) (value ,mac))) + (fieldset + (legend "Commenter Info") + (label (@ (for "name")) "Name:") + (input (@ (type "text") (id "name") (name "name") (required #t) (size 24))) + (label (@ (for "email")) "Email (optional, used for Gravatar):") + (input (@ (type "text") (id "email") (name "email") (size 24))) + (label (@ (for "url")) "Webpage URL (optional):") + (input (@ (type "text") (id "url") (name "url") (size 24)))) + (fieldset + (legend "Comment") + (label (@ (for "subject")) "Subject (optional):") + (input (@ (type "text") (id "subject") (name "subject") (size 24))) + (label (@ (for "comment")) "Comment :") + (textarea (@ (id "coment") (name "comment") (rows 4) (cols 50)))) + (fieldset + (legend "Captcha") + (label (@ (for "captcha")) "Captcha:") + (img (@ (src ,(format #f "data:image/jpeg;charset=utf-8;base64,~a" + (base64-encode captcha-image))))) + (input (@ (type "text") (id "captcha") (name "captcha") (size 24))) + (input (@ (type "submit") (id "submit-form") (value "Submit"))))))))) + (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!"))))) + (let* ((path-encoded (uri-path (request-uri request))) + (path (split-and-decode-uri-path path-encoded)) + (slug (last path))) + (values '((content-type . (text/html))) + (sxml->html-string (theme #:content (render-comment-form slug) #:title "Comment prompt"))))) diff --git a/haunt/jakob/dynamic/capabilities/comments.scm b/haunt/jakob/dynamic/capabilities/comments.scm index d4159fa..3e873a6 100644 --- a/haunt/jakob/dynamic/capabilities/comments.scm +++ b/haunt/jakob/dynamic/capabilities/comments.scm @@ -16,6 +16,7 @@ (define-module (jakob dynamic capabilities comments) #:use-module (ice-9 match) + #:use-module (jakob dynamic captcha) #:use-module (jakob dynamic util) #:use-module (json) #:use-module (squee) @@ -75,9 +76,17 @@ This is a wrapper around `get-comments-by-slug'." (define (put-comment request body) "API endpoint handler for submitting a comment" (define (valid-comment? form-data) + (display form-data) (and (assoc "slug" form-data) (assoc "name" form-data) - (assoc "comment" form-data))) + (assoc "comment" form-data) + (assoc "captcha" form-data) + (assoc "solution" form-data) + (assoc "solution-mac" form-data) + (validate-captcha + (assoc-value form-data "captcha") + (assoc-value form-data "solution") + (assoc-value form-data "solution-mac")))) (define (insert-comment form-data) (exec-query conn "INSERT INTO comments (submitted, slug, name, subject, diff --git a/haunt/jakob/dynamic/capabilities/rsvp.scm b/haunt/jakob/dynamic/capabilities/rsvp.scm index c02b758..d7d6fb9 100644 --- a/haunt/jakob/dynamic/capabilities/rsvp.scm +++ b/haunt/jakob/dynamic/capabilities/rsvp.scm @@ -15,7 +15,7 @@ ;;; . (define-module (jakob dynamic capabilities rsvp) - #:use-module (base64) + #:use-module (gcrypt base64) #:use-module (ice-9 binary-ports) #:use-module (ice-9 match) #:use-module (jakob dynamic util) diff --git a/haunt/jakob/dynamic/captcha.scm b/haunt/jakob/dynamic/captcha.scm index b095ebf..3b192cb 100644 --- a/haunt/jakob/dynamic/captcha.scm +++ b/haunt/jakob/dynamic/captcha.scm @@ -14,8 +14,8 @@ ;;; along with this program. If not, see ;;; . -(define-module (captcha) - #:use-module (base64) +(define-module (jakob dynamic captcha) + #:use-module (gcrypt base64) #:use-module (gcrypt hash) #:use-module (gcrypt mac) #:use-module (gcrypt random) @@ -26,10 +26,13 @@ #:use-module (ice-9 popen) #:use-module (ice-9 rdelim) #:use-module (ice-9 threads) + #:use-module (jakob dynamic aes) #:use-module (rnrs bytevectors) #:use-module (srfi srfi-1) #:use-module (srfi srfi-19) - #:export (new-captcha)) + #:use-module (system foreign) + #:export (new-captcha + validate-captcha)) (define proc-mutex (make-mutex)) @@ -109,26 +112,71 @@ (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))) +;; These are ephemeral keys. At this point, it doesn't make sense to store keys +;; locally, since the server process is singular and long-running. +(define %tex-aes-key (gen-random-bv %aes-key-size)) +(define %tex-mac-key (gen-random-bv 64)) + +(define (encode-solution solution) + (define nonce (gen-random-bv 8)) + ;; This is horrible :D + (define encoded-solution + (pointer->bytevector (make-c-struct (list double) (list solution)) 8)) + (let ((result (make-bytevector 16))) + (bytevector-copy! nonce 0 result 0 8) + (bytevector-copy! encoded-solution 0 result 8 8) + result)) + +(define (decode-solution encoded) + (let ((result (make-bytevector 8))) + (bytevector-copy! encoded 8 result 0 8) + (first (parse-c-struct (bytevector->pointer result) (list double))))) (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-src (sexp->latex (simplify-sexp (differentiate-sexp expression)))) + (solution (- (local-eval expression (let ((x upper-bound)) (the-environment))) + (local-eval expression (let ((x lower-bound)) (the-environment))))) + (ciphertext (base64-encode (aes-256-encrypt %tex-aes-key (encode-solution solution))))) + (display solution) + (newline) + (display (decode-solution (aes-256-decrypt %tex-aes-key (base64-decode ciphertext)))) + (newline) + (values (sign-data-base64 %tex-mac-key ciphertext) + ciphertext (latex->image (format #f "\\int_{~a}^{~a} ~a \\, dx" lower-bound upper-bound latex-src))))) +(define (validate-captcha answer solution mac) + (define epsilon 0.1) + (display "Here!") + (newline) + (display "Valid signature? ") + (display (valid-base64-signature? %tex-mac-key solution mac)) + (newline) + (display "Signature was ") + (display mac) + (newline) + (display "Valid answer? ") + (display (<= (abs (- (decode-solution (aes-256-decrypt %tex-aes-key (base64-decode solution))) + (string->number answer))) + epsilon)) + (newline) + (display "Answer was ") + (display (decode-solution (aes-256-decrypt %tex-aes-key (base64-decode solution)))) + (newline) + (display "Solution given was ") + (display answer) + (newline) + (and (valid-base64-signature? %tex-mac-key solution mac) + (<= (abs (- (decode-solution (aes-256-decrypt %tex-aes-key (base64-decode solution))) + (string->number answer))) + epsilon))) + ;; How many zeroes the SHA-256 hash has to be prefixed by to be a valid proof of work. diff --git a/haunt/static/css/style.css b/haunt/static/css/style.css index 0b32082..4f6def3 100644 --- a/haunt/static/css/style.css +++ b/haunt/static/css/style.css @@ -233,20 +233,34 @@ ul#webmention-container .comment .comment-source-identifier { /* Webmention form. */ -form { +#webmention-form form { border-top: 2px solid #d2d6dd; padding-top: 1rem; } -form input { +#webmention-form form input { margin-top: 1rem; } -form input[type=url] { +#webmention-form form input[type=url] { display: block; width: 100%; } +/* Comment form. */ + +#comment-form label { + display: block; + width: 20em; + float: left; + clear: left; +} + +#comment-form input { + width: 20em; + float: left; +} + /* Source code. */ pre { -- cgit v1.3