suzanne.soy/racket-pkg-website
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Anti-spam. (What kind of spammer would abuse our login facility? Weird.)

Browse Source
This commit is contained in:
Tony Garnock-Jones 2021-02-18 10:25:30 +01:00
parent 020d9c47e8
commit aa95ca4fb8
2 changed files with 111 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
src/challenge.rkt Normal file
View 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
View File

@ -31,6 +31,7 @@
(require "static.rkt") (require "static.rkt")
(require "package-source.rkt") (require "package-source.rkt")
(require "http-utils.rkt") (require "http-utils.rkt")
(require "challenge.rkt")
(define static-urlprefix (define static-urlprefix
(or (@ (config) static-urlprefix) (or (@ (config) static-urlprefix)
@ -391,11 +392,15 @@
(create-session-from-authentication-success! email password success)]))) (create-session-from-authentication-success! email password success)])))
(define (register-form #:email [email ""] (define (register-form #:email [email ""]
#:email_for_code [email_for_code ""]
#:code [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 (with-site-config
(send/suspend/dispatch/dynamic (send/suspend/dispatch/dynamic
(lambda (embed-url) (lambda (embed-url)
(define challenge (generate-challenge))
(bootstrap-response "Register/Reset Account" (bootstrap-response "Register/Reset Account"
#:title-element "" #:title-element ""
`(div ((class "registration-step-container")) `(div ((class "registration-step-container"))
@ -412,10 +417,29 @@
(p "Enter your email address below, and we'll send you one.") (p "Enter your email address below, and we'll send you one.")
(form ((class "form-horizontal") (form ((class "form-horizontal")
(method "post") (method "post")
(action ,(embed-url notify-of-emailing)) (action ,(embed-url (check-challenge challenge)))
(role "form")) (role "form"))
,(form-group 1 3 (label "email" "Email address") ,(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")))) ,(form-group 4 5 (primary-button "Email me a code"))))
`(div `(div
@ -434,10 +458,10 @@
,(form-group 1 3 (label "password" "Confirm password") ,(form-group 1 3 (label "password" "Confirm password")
0 5 (password-input "confirm_password")) 0 5 (password-input "confirm_password"))
,@(maybe-splice ,@(maybe-splice
error-message step2-error-message
(form-group 4 5 (form-group 4 5
`(div ((class "alert alert-danger")) `(div ((class "alert alert-danger"))
(p ,error-message)))) (p ,step2-error-message))))
,(form-group 4 5 (primary-button "Continue"))))))))) ,(form-group 4 5 (primary-button "Continue")))))))))
(define (apply-account-code request) (define (apply-account-code request)
@ -445,7 +469,7 @@
(define (retry msg) (define (retry msg)
(register-form #:email email (register-form #:email email
#:code code #:code code
#:error-message msg)) #:step2-error-message msg))
(cond (cond
[(equal? (string-trim email) "") [(equal? (string-trim email) "")
(retry "Please enter your email address.")] (retry "Please enter your email address.")]
@ -468,10 +492,39 @@
;; Set a cookie and consider ourselves logged in. ;; Set a cookie and consider ourselves logged in.
(create-session-from-authentication-success! email password success)])])) (create-session-from-authentication-success! email password success)])]))
(define (notify-of-emailing request) (define ((check-challenge challenge) request)
(define-form-bindings request (email_for_code)) (define-form-bindings request (email_for_code question_answer))
(authenticate-with-server! email_for_code "" "") ;; TODO check result? (define (retry msg-a msg-b)
(summarise-code-emailing "Account registration/reset code emailed" email_for_code)) (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) (define (summarise-code-emailing reason email)
(with-site-config (with-site-config