root/render/captcha.scm

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))