diff options
Diffstat (limited to 'haunt/jakob')
| -rw-r--r-- | haunt/jakob/dynamic/captcha.scm | 46 |
1 files changed, 34 insertions, 12 deletions
diff --git a/haunt/jakob/dynamic/captcha.scm b/haunt/jakob/dynamic/captcha.scm index 2e185d3..61f1d33 100644 --- a/haunt/jakob/dynamic/captcha.scm +++ b/haunt/jakob/dynamic/captcha.scm @@ -33,6 +33,7 @@ #:use-module (srfi srfi-19) #:use-module (system foreign) #:export (make-queue + id-queue-free id-queue-allocated release-id! dequeue-id! @@ -41,40 +42,47 @@ validate-captcha)) (define-record-type <id-queue> - (make-id-queue mutex free-ids allocated-ids) + (make-id-queue mutex min-free-threshold 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!)) + (mutex id-queue-mutex) + (min-free-threshold id-queue-min-free-threshold) + (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* (make-queue n #:key (min-free-threshold 32)) + "Construct a stateful queue for tracking captcha IDs + +The parameter N specifies how many free IDs should initially be allocated. The +optional keyword argument MIN-FREE-THRESHOLD specifies when `dequeue-id!' should +iterate through the allocated list and free anything exceeding an +internally-defined `time-to-live-seconds'." + (make-id-queue (make-mutex) min-free-threshold (iota n) (list))) (define (append-to-free-queue! id queue) + "Add ID to the end of the free list of QUEUE" (set-id-queue-free! queue (append! (id-queue-free queue) (list id)))) (define (remove-from-free-queue! id queue) + "Remove ID from the free list of QUEUE" (set-id-queue-free! queue (delete! id (id-queue-free queue)))) (define (append-to-allocated-queue! id queue) + "Add ID to the end of the allocated list of QUEUE" (set-id-queue-allocated! queue (append! (id-queue-allocated queue) (list (list id (current-time)))))) (define (remove-from-allocated-queue! id queue) + "Remove ID from the allocated list of QUEUE" (set-id-queue-allocated! queue (filter! (lambda (x) (not (equal? id (car x)))) (id-queue-allocated queue)))) -(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) + "Release ID to the free list of QUEUE" (with-mutex (id-queue-mutex queue) (assert (find (lambda (x) (equal? id (car x))) (id-queue-allocated queue))) (assert (not (member id (id-queue-free queue)))) @@ -82,8 +90,12 @@ (remove-from-allocated-queue! id queue))) (define (dequeue-id! queue) + "Draw a random ID from QUEUE and mark it as allocated" + (define time-to-live-seconds (* 20 60)) (with-mutex (id-queue-mutex queue) - (when (< (length (id-queue-free queue)) min-free-id-threshold) + ;; Initial pass to "unintrusively" free any stale IDs. + (when (< (length (id-queue-free queue)) + (id-queue-min-free-threshold queue)) (for-each (match-lambda ((id created-time) @@ -92,6 +104,15 @@ time-to-live-seconds) (remove-from-allocated-queue! id queue)))) (list-copy (id-queue-allocated queue)))) + ;; If we're still over the threshold, we'll need to be more intrusive. + ;; Ideally, this is avoided by rate-limiting. + (when (< (length (id-queue-free queue)) + (id-queue-min-free-threshold queue)) + (let* ((to-take (- (id-queue-min-free-threshold queue) + (length (id-queue-free queue)))) + (to-free (map car (take (id-queue-allocated queue) to-take)))) + (set-id-queue-allocated! queue (drop (id-queue-allocated queue) to-take)) + (set-id-queue-free! queue (append! (id-queue-free queue) to-free)))) (let* ((n (random (length (id-queue-free queue)))) (id (list-ref (id-queue-free queue) n))) (remove-from-free-queue! id queue) @@ -100,6 +121,7 @@ +(define max-challenges 1024) (define proc-mutex (make-mutex)) (define tex-challenge-id-queue (iota max-challenges)) (define tex-challenge-allocated-id-queue (list)) |