1 files changed, 84 insertions, 54 deletions
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))))