diff options
Diffstat (limited to 'haunt/jakob/dynamic')
| -rw-r--r-- | haunt/jakob/dynamic/aes.scm | 66 | ||||
| -rw-r--r-- | haunt/jakob/dynamic/captcha.scm | 138 |
2 files changed, 84 insertions, 120 deletions
diff --git a/haunt/jakob/dynamic/aes.scm b/haunt/jakob/dynamic/aes.scm deleted file mode 100644 index b6e937d..0000000 --- a/haunt/jakob/dynamic/aes.scm +++ /dev/null @@ -1,66 +0,0 @@ -;;; Copyright © 2019 - 2022 Jakob L. Kreuze <zerodaysfordays@sdf.org> -;;; -;;; This program is free software; you can redistribute it and/or -;;; modify it under the terms of the GNU General Public License as -;;; published by the Free Software Foundation; either version 3 of the -;;; License, or (at your option) any later version. -;;; -;;; This program is distributed in the hope that it will be useful, -;;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;;; General Public License for more details. -;;; -;;; You should have received a copy of the GNU General Public License -;;; along with this program. If not, see -;;; <http://www.gnu.org/licenses/>. - -(define-module (jakob dynamic aes) - #:use-module (gcrypt random) - #:use-module (system foreign) - #:use-module (rnrs bytevectors) - #:export (%aes-key-size - aes-256-encrypt - aes-256-decrypt)) - -(define %libnettle (dynamic-link "libnettle")) -(define %aes256-rounds 14) - -(define %aes-key-size (/ 256 8)) -(define %aes-block-size (/ 128 8)) -(define %tex-aes-key (gen-random-bv %aes-key-size)) - -;; Assume `data' is a bytevector of length `%aes-block-size'. -(define (aes-256-encrypt key data) - (let ((dest (make-bytevector %aes-block-size)) - (%ctx (make-c-struct (map (lambda (_) uint32) (iota (* 4 (+ 1 %aes256-rounds)))) - (map (lambda (_) 0) (iota (* 4 (+ 1 %aes256-rounds)))))) - (%aes-256-encrypt - (pointer->procedure void - (dynamic-func "nettle_aes256_encrypt" %libnettle) - (list '* size_t '* '*))) - (%aes-256-set-encrypt-key - (pointer->procedure void - (dynamic-func "nettle_aes256_set_encrypt_key" %libnettle) - (list '* '*)))) - (%aes-256-set-encrypt-key %ctx (bytevector->pointer %tex-aes-key)) - (%aes-256-encrypt %ctx %aes-block-size (bytevector->pointer dest) (bytevector->pointer data)) - dest)) - -(define (aes-256-decrypt key data) - (let ((dest (make-bytevector %aes-block-size)) - (%ctx (make-c-struct (map (lambda (_) uint32) (iota (* 4 (+ 1 %aes256-rounds)))) - (map (lambda (_) 0) (iota (* 4 (+ 1 %aes256-rounds)))))) - (%aes-256-decrypt - (pointer->procedure void - (dynamic-func "nettle_aes256_decrypt" %libnettle) - (list '* size_t '* '*))) - (%aes-256-set-decrypt-key - (pointer->procedure void - (dynamic-func "nettle_aes256_set_decrypt_key" %libnettle) - (list '* '*)))) - (%aes-256-set-decrypt-key %ctx (bytevector->pointer %tex-aes-key)) - (%aes-256-decrypt %ctx %aes-block-size (bytevector->pointer dest) (bytevector->pointer data)) - dest)) - -;; (utf8->string (aes-256-decrypt %tex-aes-key (aes-256-encrypt %tex-aes-key (string->utf8 "AAAABBBBC hello!")))) -;; => "AAAABBBBC hello!" diff --git a/haunt/jakob/dynamic/captcha.scm b/haunt/jakob/dynamic/captcha.scm index 3b192cb..faa6006 100644 --- a/haunt/jakob/dynamic/captcha.scm +++ b/haunt/jakob/dynamic/captcha.scm @@ -26,15 +26,86 @@ #: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 (rnrs base) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) #:use-module (srfi srfi-19) #:use-module (system foreign) - #:export (new-captcha + #:export (make-queue + id-queue-allocated + release-id! + dequeue-id! + + new-captcha validate-captcha)) +(define-record-type <id-queue> + (make-id-queue mutex free-ids allocated-ids) + id-queue? + (mutex id-queue-mutex) + (free-ids id-queue-free set-id-queue-free!) + (allocated-ids id-queue-allocated set-id-queue-allocated!)) + +(define (make-queue n) + (make-id-queue (make-mutex) (iota n) (list))) + +(define max-challenges 1024) +(define min-free-id-threshold 32) +(define time-to-live-seconds (* 20 60)) +(define challenge-queue-mutex (make-mutex)) + +(define (release-id! id queue) + (with-mutex (id-queue-mutex queue) + (display (id-queue-allocated queue)) + (newline) + (display (find (lambda (x) (equal? id (car x))) (id-queue-allocated queue))) + (newline) + (assert (find (lambda (x) (equal? id (car x))) (id-queue-allocated queue))) + (assert (not (member id (id-queue-free queue)))) + (set-id-queue-free! + queue + (append! (id-queue-free queue) (list id))) + (set-id-queue-allocated! + queue + (filter! (lambda (x) (not (equal? id (car x)))) + (id-queue-allocated queue))))) + +(define (dequeue-id! queue) + (with-mutex (id-queue-mutex queue) + (when (< (length (id-queue-free queue)) min-free-id-threshold) + (for-each + (match-lambda + ((cons id created-time) + (when (>= (- (time-second (current-time)) + (time-second created-time)) + time-to-live-seconds) + (assert (not (member id (id-queue-free queue)))) + (set-id-queue-free! + queue + (append! (id-queue-free queue) (list id))) + (set-id-queue-allocated! + queue + (filter! (lambda (x) (not (equal? id (car x)))) + (id-queue-allocated queue)))))) + (list-copy (id-queue-allocated queue)))) + (let* ((n (random (length (id-queue-free queue)))) + (id (list-ref (id-queue-free queue) n))) + (set-id-queue-free! + queue + (delete! id (id-queue-free queue))) + (set-id-queue-allocated! + queue + (append! (id-queue-allocated queue) + (list (cons id (current-time))))) + id))) + + + (define proc-mutex (make-mutex)) +(define tex-challenge-id-queue (iota max-challenges)) +(define tex-challenge-allocated-id-queue (list)) +(define tex-challenges (make-hash-table max-challenges)) (define (random-term) (match (random 5) @@ -112,70 +183,29 @@ (error "Cannot generate PNG")) data))) -;; 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) +(define (new-captcha!) (let* ((lower-bound (random 10)) (upper-bound (+ lower-bound 1 (random 9))) (expression (random-expression)) (latex-src (sexp->latex (simplify-sexp (differentiate-sexp expression)))) (solution (- (local-eval expression (let ((x upper-bound)) (the-environment))) (local-eval expression (let ((x lower-bound)) (the-environment))))) - (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 + (id (dequeue-id! tex-challenge-id-queue tex-challenge-allocated-id-queue))) + (hash-set! tex-challenges id solution) + (values id (latex->image (format #f "\\int_{~a}^{~a} ~a \\, dx" lower-bound upper-bound latex-src))))) -(define (validate-captcha answer solution mac) +(define (validate-captcha! answer id) (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))) + (let ((solution (hash-ref tex-challenges id))) + (when solution + (release-id! id tex-challenge-id-queue tex-challenge-allocated-id-queue)) + (and solution + (<= (abs (- solution (string->number answer))) + epsilon)))) |