Anti-spam. (What kind of spammer would abuse our login facility? Weird.)
This commit is contained in:
Tony Garnock-Jones
parent
020d9c47e8
commit
aa95ca4fb8
48
src/challenge.rkt
Normal file
48
src/challenge.rkt
Normal file
|
|
@ -0,0 +1,48 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide (struct-out challenge)
|
||||
generate-challenge
|
||||
challenge-passed?)
|
||||
|
||||
(require racket/pretty)
|
||||
|
||||
(struct challenge (expr question answer) #:transparent)
|
||||
|
||||
(define (random-element lst)
|
||||
(list-ref lst (random (length lst))))
|
||||
|
||||
(define (generate-expr)
|
||||
(if (>= (random) 0.5)
|
||||
`(,(random-element '(car cadr caddr))
|
||||
(map (lambda (v) (+ ,(random 4) (* v ,(random 4))))
|
||||
(list ,(random 4) ,(random 4) ,(random 4))))
|
||||
(let ()
|
||||
(define (random-op) (random-element '(+ * -)))
|
||||
(define (e fuel)
|
||||
(if (zero? fuel)
|
||||
(random 10)
|
||||
(cons (random-op)
|
||||
(for/list [(i (in-range (+ 1 (random 2))))]
|
||||
(e (- fuel 1))))))
|
||||
(e 2))))
|
||||
|
||||
(define (generate-challenge)
|
||||
(define expr (generate-expr))
|
||||
(challenge expr
|
||||
`(div
|
||||
(p (b "What is the result of evaluating:"))
|
||||
(pre (code ,(pretty-format expr 40 #:mode 'write))))
|
||||
(eval expr (make-base-namespace))))
|
||||
|
||||
(define (safe-string->value str)
|
||||
(parameterize (;; Hmm, this is a big list. Did I miss any important ones?
|
||||
(read-accept-box #f)
|
||||
(read-accept-compiled #f)
|
||||
(read-accept-graph #f)
|
||||
(read-accept-reader #f)
|
||||
(read-accept-lang #f))
|
||||
(read (open-input-string str))))
|
||||
|
||||
(define (challenge-passed? challenge response-str)
|
||||
(define response (safe-string->value response-str))
|
||||
(equal? response (challenge-answer challenge)))
|
||||
73
src/site.rkt
73
src/site.rkt
|
|
@ -31,6 +31,7 @@
|
|||
(require "static.rkt")
|
||||
(require "package-source.rkt")
|
||||
(require "http-utils.rkt")
|
||||
(require "challenge.rkt")
|
||||
|
||||
(define static-urlprefix
|
||||
(or (@ (config) static-urlprefix)
|
||||
|
|
@ -391,11 +392,15 @@
|
|||
(create-session-from-authentication-success! email password success)])))
|
||||
|
||||
(define (register-form #:email [email ""]
|
||||
#:email_for_code [email_for_code ""]
|
||||
#:code [code ""]
|
||||
#:error-message [error-message #f])
|
||||
#:step1a-error-message [step1a-error-message #f]
|
||||
#:step1b-error-message [step1b-error-message #f]
|
||||
#:step2-error-message [step2-error-message #f])
|
||||
(with-site-config
|
||||
(send/suspend/dispatch/dynamic
|
||||
(lambda (embed-url)
|
||||
(define challenge (generate-challenge))
|
||||
(bootstrap-response "Register/Reset Account"
|
||||
#:title-element ""
|
||||
`(div ((class "registration-step-container"))
|
||||
|
|
@ -412,10 +417,29 @@
|
|||
(p "Enter your email address below, and we'll send you one.")
|
||||
(form ((class "form-horizontal")
|
||||
(method "post")
|
||||
(action ,(embed-url notify-of-emailing))
|
||||
(action ,(embed-url (check-challenge challenge)))
|
||||
(role "form"))
|
||||
,(form-group 1 3 (label "email" "Email address")
|
||||
0 5 (email-input "email_for_code"))
|
||||
0 5 (email-input "email_for_code" email_for_code))
|
||||
,@(maybe-splice
|
||||
step1a-error-message
|
||||
(form-group 4 5
|
||||
`(div ((class "alert alert-danger"))
|
||||
(p ,step1a-error-message))))
|
||||
,(form-group 1 3 (label "antispam" "Anti-spam")
|
||||
0 5 `(div ((class "form-control-static"))
|
||||
(p "Please help us defend our "
|
||||
"infrastructure from spammers "
|
||||
"by answering the following question.")
|
||||
,@(maybe-splice
|
||||
step1b-error-message
|
||||
`(div ((class "alert alert-danger"))
|
||||
(p ,step1b-error-message)))
|
||||
,(challenge-question challenge)
|
||||
,(form-group
|
||||
0 2 `(p ((class "form-control-static"))
|
||||
(b "Answer:"))
|
||||
0 10 (text-input "question_answer"))))
|
||||
,(form-group 4 5 (primary-button "Email me a code"))))
|
||||
|
||||
`(div
|
||||
|
|
@ -434,10 +458,10 @@
|
|||
,(form-group 1 3 (label "password" "Confirm password")
|
||||
0 5 (password-input "confirm_password"))
|
||||
,@(maybe-splice
|
||||
error-message
|
||||
step2-error-message
|
||||
(form-group 4 5
|
||||
`(div ((class "alert alert-danger"))
|
||||
(p ,error-message))))
|
||||
(p ,step2-error-message))))
|
||||
,(form-group 4 5 (primary-button "Continue")))))))))
|
||||
|
||||
(define (apply-account-code request)
|
||||
|
|
@ -445,7 +469,7 @@
|
|||
(define (retry msg)
|
||||
(register-form #:email email
|
||||
#:code code
|
||||
#:error-message msg))
|
||||
#:step2-error-message msg))
|
||||
(cond
|
||||
[(equal? (string-trim email) "")
|
||||
(retry "Please enter your email address.")]
|
||||
|
|
@ -468,10 +492,39 @@
|
|||
;; Set a cookie and consider ourselves logged in.
|
||||
(create-session-from-authentication-success! email password success)])]))
|
||||
|
||||
(define (notify-of-emailing request)
|
||||
(define-form-bindings request (email_for_code))
|
||||
(authenticate-with-server! email_for_code "" "") ;; TODO check result?
|
||||
(summarise-code-emailing "Account registration/reset code emailed" email_for_code))
|
||||
(define ((check-challenge challenge) request)
|
||||
(define-form-bindings request (email_for_code question_answer))
|
||||
(define (retry msg-a msg-b)
|
||||
(register-form #:email_for_code email_for_code
|
||||
#:step1a-error-message msg-a
|
||||
#:step1b-error-message msg-b))
|
||||
(cond
|
||||
[(equal? (string-trim email_for_code) "")
|
||||
(log-info "REGISTRATION/RESET EMAIL: address missing")
|
||||
(retry "Please enter your email address."
|
||||
"Don't forget to answer the new question!")]
|
||||
[(equal? (string-trim question_answer) "")
|
||||
(log-info "REGISTRATION/RESET EMAIL: no challenge answer provided")
|
||||
(retry #f
|
||||
"Please answer the anti-spam question. (It changes each time!)")]
|
||||
[(not (challenge-passed? challenge question_answer))
|
||||
(log-info "REGISTRATION/RESET EMAIL: challenge answer incorrect")
|
||||
(log-info " ✗ email: ~v" email_for_code)
|
||||
(log-info " ✗ challenge expr: ~a" (challenge-expr challenge))
|
||||
(log-info " ✗ expected answer: ~v" (~a (challenge-answer challenge)))
|
||||
(log-info " ✗ provided answer: ~v" question_answer)
|
||||
(log-info " ✗ HTTP request details: ~v" request)
|
||||
(retry #f
|
||||
"Unfortunately, that was not the correct answer. Please try this new question.")]
|
||||
[else
|
||||
(log-info "REGISTRATION/RESET EMAIL: sent")
|
||||
(log-info " ✓ email: ~v" email_for_code)
|
||||
(log-info " ✓ challenge expr: ~a" (challenge-expr challenge))
|
||||
(log-info " ✓ expected answer: ~v" (~a (challenge-answer challenge)))
|
||||
(log-info " ✓ provided answer: ~v" question_answer)
|
||||
(log-info " ✓ HTTP request details: ~v" request)
|
||||
(authenticate-with-server! email_for_code "" "") ;; TODO check result?
|
||||
(summarise-code-emailing "Account registration/reset code emailed" email_for_code)]))
|
||||
|
||||
(define (summarise-code-emailing reason email)
|
||||
(with-site-config
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user