summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--haunt/jakob/dynamic/aes.scm66
-rw-r--r--haunt/jakob/dynamic/captcha.scm138
-rw-r--r--haunt/tests/captcha.scm39
3 files changed, 123 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))))
diff --git a/haunt/tests/captcha.scm b/haunt/tests/captcha.scm
new file mode 100644
index 0000000..547fd5a
--- /dev/null
+++ b/haunt/tests/captcha.scm
@@ -0,0 +1,39 @@
+;;; 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/>.
+
+(use-modules (jakob dynamic captcha)
+ (srfi srfi-64))
+
+(test-begin "id-queue-test")
+
+(define queue (make-queue 64))
+
+(define id1 (dequeue-id! queue))
+(define id2 (dequeue-id! queue))
+
+;; Two IDs are unique, if drawn in such a way that one is not invalidated by the
+;; time the other is drawn.
+(test-assert (number? id1))
+(test-assert (number? id2))
+(test-assert (not (= id1 id2)))
+
+;; IDs can be released and are appropriately removed from the allocated list.
+(test-assert (positive? (length (id-queue-allocated queue))))
+(release-id! id1 queue)
+(release-id! id2 queue)
+(test-assert (zero? (length (id-queue-allocated queue))))
+
+(test-end "id-queue-test")
generated by cgit v1.3 (git 2.53.0) at 2026-08-29 14:49:19 +0000