1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77
(define-module (render captcha) #:use-module (srfi srfi-19) ;; date #:use-module (web server) #:use-module (web request) #:use-module (web response) #:use-module (web uri) #:use-module (ice-9 match) #:use-module (webserver-utils) #:use-module (sxml simple) #:use-module (utils) #:use-module (plugin captcha-interface) #:export (make-captcha captcha-did-solve-correct captcha-failure captcha-sxml)) (define captcha-did-solve-correct car) (define captcha-failure cadr) (define captcha-sxml cddr) (define *challenges* (make-hash-table)) (define (make-challenge-entry challenge) (cons (current-time) challenge)) (define challenge-entry-date car) (define challenge-entry-value cdr) (define (challenge-entry-valid entry) (define start (time-second (challenge-entry-date entry))) (define now (time-second (current-time))) (define diff (- now start)) ;; must solve in 15 minutes (< diff (* 60 15))) (define (clear-old-challenges) (define to-delete '()) (hash-for-each (lambda (k v) (when (not (challenge-entry-valid v)) (set! to-delete (cons k to-delete)))) *challenges*) (for-each (lambda (k) (hash-remove! *challenges* k)) to-delete)) (define (make-captcha captcha form-method request body) ;; very shoddy user id (define user-id (string-append (or (request-ip request) "") "-" (or (request-header-for-name request 'user-agent) "") "-" (symbol->string (captcha-plugin-name captcha)))) (define existing-challenge (hash-ref *challenges* user-id)) (define failure (and existing-challenge (or (check-fail "captcha timed out" (challenge-entry-valid existing-challenge)) (check-fail "incorrect captcha" ((captcha-plugin-validate-input captcha) (challenge-entry-value existing-challenge) (lambda (name) (match form-method ('get (request-query-for-name request name)) ('post (post-query-for-name body name)) (else (error "TODO implement"))))))))) (define did-solve-correct (and existing-challenge (not failure))) (define challenge (and #t ;; (not did-solve-correct) ((captcha-plugin-generate-challenge captcha)))) (define page (and #t ;; (not did-solve-correct) ((captcha-plugin-render-challenge captcha) challenge))) (define final-page (if did-solve-correct `(;; (p "Valid!") ,page) page)) ;; remove old (when existing-challenge (hash-remove! *challenges* user-id)) (clear-old-challenges) ;; register new (hash-set! *challenges* user-id (make-challenge-entry challenge)) (cons* did-solve-correct failure final-page))