1 files changed, 170 insertions, 0 deletions
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 <zerodaysfordays@sdf.org>
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 3 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program. If not, see
+;;; <http://www.gnu.org/licenses/>.
+
+(define-module (captcha)
+  #:use-module (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")))))