diff options
Diffstat (limited to 'haunt/jakob')
| -rw-r--r-- | haunt/jakob/dynamic/captcha.scm | 91 |
1 files changed, 53 insertions, 38 deletions
diff --git a/haunt/jakob/dynamic/captcha.scm b/haunt/jakob/dynamic/captcha.scm index 4cb62d3..ab90f55 100644 --- a/haunt/jakob/dynamic/captcha.scm +++ b/haunt/jakob/dynamic/captcha.scm @@ -15,23 +15,27 @@ ;;; <http://www.gnu.org/licenses/>. (define-module (jakob dynamic captcha) + #:use-module (gcrypt base16) #:use-module (gcrypt 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 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 (json) #:use-module (rnrs bytevectors) - #:use-module (rnrs base) + #:use-module ((rnrs base) #:select (assert)) + #:use-module (rnrs exceptions) + #:use-module (srfi-197) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-11) #:use-module (srfi srfi-19) - #:use-module (system foreign) + #:use-module (srfi srfi-35) #:export (make-queue id-queue-free id-queue-allocated @@ -39,7 +43,10 @@ dequeue-id! new-captcha! - validate-captcha!)) + validate-captcha! + + make-pow-challenge! + validate-proof-of-work!)) (define-record-type <id-queue> (make-id-queue mutex min-free-threshold free-ids allocated-ids) @@ -220,7 +227,13 @@ internally-defined `time-to-live-seconds'." (define epsilon 0.1) (let ((solution (hash-ref tex-challenges id)) (id-allocated (not (member id (id-queue-free tex-challenge-id-queue))))) - (when solution (release-id! id tex-challenge-id-queue)) + ;; FIXME: The predictable IDs means that its' easy for someone to screw with + ;; someone elses' captcha challenge (by invalidating it before they can + ;; submit it). Given the combination of our reaping algorithm and + ;; rate-limiting, does it make sense to only release the ID when the + ;; response is correct? + (when (and solution id-allocated) + (release-id! id tex-challenge-id-queue)) (and solution id-allocated (<= (abs (- solution (string->number user-answer))) @@ -228,40 +241,42 @@ internally-defined `time-to-live-seconds'." +(define pow-challenge-id-queue (make-queue 1024)) +(define pow-challenges (make-hash-table 1024)) + ;; 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 (new-proof-of-work-challenge!) + (let ((id (dequeue-id! pow-challenge-id-queue)) + (challenge (base64-encode (gen-random-bv 32)))) + (hash-set! pow-challenges id challenge) + (values id challenge))) -(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 (validate-proof-of-work! prefix challenge-id) (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"))))) + (unless (member challenge-id (id-queue-free pow-challenge-id-queue)) + (raise (condition (&message + (message "No such challenge ID"))))) + (let* ((challenge (hash-ref pow-challenges challenge-id)) + (hash-value (chain (list prefix challenge) + (string-concatenate _) + (string->bytevector _ "utf8") + (bytevector-hash _ (lookup-hash-algorithm 'sha256)) + (bytevector->base16-string _)))) + ;; Invariant from `unless' form: + ;; (not (member challenge-id (id-queue-free pow-challenge-id-queue))) + (when challenge + (release-id! challenge-id pow-challenge-id-queue)) + (and (= 32 (string-length prefix)) + (not (member challenge-id (id-queue-free pow-challenge-id-queue))) + (string-prefix? zero-prefix hash-value)))) + +(define (make-pow-challenge! request body) + "API endpoint handler for requesting a proof-of-work challenge" + (let-values (((challenge-id nonce) (new-proof-of-work-challenge!))) + (values '((content-type . (application/json))) + (scm->json-string + `((hardness . ,%hardness) + (challenge-id . ,challenge-id) + (nonce . ,nonce)))))) |