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

Add a popup question in case there's a captcha challenge.

Browse Source 
See in-code comments for how this is just a rough feature to be used if
needed (and improved when it becomes necessary).  That can just as well
go to the FIXME of using a string constant.
This commit is contained in:
Eli Barzilay 2011-06-01 17:40:25 -04:00
parent 18d40dca3c
commit ef915d0d3a
2 changed files with 75 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

96
collects/help/bug-report.rkt
View File

@ -4,6 +4,7 @@
racket/gui/base racket/gui/base
framework framework
racket/class racket/class
racket/port
net/url net/url
net/uri-codec net/uri-codec
browser/htmltext browser/htmltext
@ -20,6 +21,11 @@
(string->url (string-append "http://bugs.racket-lang.org/" path))) (string->url (string-append "http://bugs.racket-lang.org/" path)))
(define bug-report-url (bug-server-url "bug-report.cgi")) (define bug-report-url (bug-server-url "bug-report.cgi"))
(define captcha-text-url (bug-server-url "captcha-text")) (define captcha-text-url (bug-server-url "captcha-text"))
(define (get-captcha-text)
(let* ([s (port->string (get-pure-port captcha-text-url))]
[s (regexp-replace #px"^\\s+" s "")]
[s (regexp-replace #px"\\s+$" s "")])
(and ((string-length s) . > . 0) s)))
(preferences:set-default 'drracket:email "" string? #:aliases '(drscheme:email)) (preferences:set-default 'drracket:email "" string? #:aliases '(drscheme:email))
(preferences:set-default 'drracket:full-name "" string? #:aliases '(drscheme:full-name)) (preferences:set-default 'drracket:full-name "" string? #:aliases '(drscheme:full-name))
@ -189,49 +195,71 @@
(send single active-child finished-panel) (send single active-child finished-panel)
(send finished-close focus)) (send finished-close focus))
; send-bug-report : (-> void) ;; send-bug-report : (-> void)
;; initiates sending the bug report and switches the GUI's mode ;; initiates sending the bug report and switches the GUI's mode
(define (send-bug-report) (define (send-bug-report)
(define query (get-query))
(define post-data
(parameterize ([current-alist-separator-mode 'amp])
(string->bytes/utf-8 (alist->form-urlencoded query))))
(set! cancel-kill-cust (make-custodian)) (set! cancel-kill-cust (make-custodian))
(define response-chan (make-channel)) (define response-chan (make-channel))
(define exn-chan (make-channel)) (define exn-chan (make-channel))
(define worker-thread (define worker-thread
(parameterize ([current-custodian cancel-kill-cust]) (parameterize ([current-custodian cancel-kill-cust]
[current-alist-separator-mode 'amp])
(thread (thread
(λ () (λ ()
;; Note that this UI is not great: every submission asks for a
;; captcha and nothing is kept. This is fine since this is only in
;; case it needs to be used in the future -- if/when that happens,
;; the code can be improved to remember some of it, and the server
;; can have some better policy to send the same captcha to the same
;; client. So the only case where you'd suffer the bad UI is if a
;; captcha is added *and* you have this version of the code (which
;; will be outdated by that time).
(define captcha-question (get-captcha-text))
(define captcha-answer
(and captcha-question
(get-text-from-user
"Are you human?" ; FIXME: use string-constant
captcha-question bug-frame)))
(define post-data
(let* ([q (get-query)]
[q (if captcha-answer
`([captcha . ,captcha-answer]
;; send back the question too: if things get really
;; bad, then the server can make up random captchas
;; and check the reply against the challenge that
;; was used
[captcha-question . ,captcha-question]
,@q)
q)])
(string->bytes/utf-8 (alist->form-urlencoded q))))
(with-handlers ([exn:fail? (λ (x) (channel-put exn-chan x))]) (with-handlers ([exn:fail? (λ (x) (channel-put exn-chan x))])
(parameterize ([current-alist-separator-mode 'amp]) (call/input-url
(call/input-url bug-report-url
bug-report-url (lambda (x) (post-impure-port x post-data))
(lambda (x) (post-impure-port x post-data)) (lambda (port)
(lambda (port) (define error?
(define error? (cond [(regexp-match #rx"^HTTP/[0-9.]+ +([0-9]+) *(.*)$"
(cond [(regexp-match #rx"^HTTP/[0-9.]+ +([0-9]+) *(.*)$" (read-line port 'any))
(read-line port 'any)) => (lambda (m)
=> (lambda (m) ;; ignore the status text -- the reply should
;; ignore the status text -- the reply should ;; have a better indication of what went wrong
;; have a better indication of what went wrong ((string->number (cadr m)) . >= . 400))]
((string->number (cadr m)) . >= . 400))] [else #f]))
[else #f])) ;; skip HTTP headers
;; skip HTTP headers (regexp-match-positions #rx"\r?\n\r?\n" port)
(regexp-match-positions #rx"\r?\n\r?\n" port) (if error?
(if error? ;; error status => show as error
;; error status => show as error (begin (with-pending-text
(begin (with-pending-text (λ ()
(λ () (send pending-text erase)
(send pending-text erase) (render-html-to-text port pending-text #t #f)))
(render-html-to-text port pending-text #t #f))) (channel-put exn-chan #f)) ; #f = "already rendered"
(channel-put exn-chan #f)) ; #f = "already rendered" ;; (hopefully) a good result
;; (hopefully) a good result (let ([response-text (new html-text%)])
(let ([response-text (new html-text%)]) (render-html-to-text port response-text #t #f)
(render-html-to-text port response-text #t #f) (send response-text auto-wrap #t)
(send response-text auto-wrap #t) (send response-text lock #t)
(send response-text lock #t) (channel-put response-chan response-text))))))))))
(channel-put response-chan response-text)))))))))))
(define (render-error to-render) (define (render-error to-render)
(cond (cond
[(string? to-render) [(string? to-render)

16
collects/meta/web/minis/bugs.rkt
View File

@ -265,9 +265,15 @@
;; be used in the future if spam bug reports that use drracket (or ;; be used in the future if spam bug reports that use drracket (or
;; racket code) directly become a problem. In this case, adding a ;; racket code) directly become a problem. In this case, adding a
;; challenge here will make existing installations start asking for an ;; challenge here will make existing installations start asking for an
;; answer. (And this could be done with a changes-on-each-build ;; answer. Note that the text should be a complete text for a
;; basis, or some script that will create and remember short-lived ;; question, including a "?" and instructions. It is used as-is in
;; captcha challenges.) Note that the text should be a complete text ;; the `message' argument for `get-text-from-user'.
;; for a question, including a "?" and instructions. It is used as is ;;
;; in the `message' argument for `get-text-from-user'. ;; When there is a captcha challenge, the existing code will send back
;; not only the answer (as the value of the `captcha' field), but also
;; the question (as a `captcha-question' field). A first-level
;; captcha could be doing that it does today: change rarely on each
;; page build, and further extensions can be to generate random
;; captchas, and use the question text to validate (and/or expire)
;; challenges.
@plain[#:file "captcha-text" #:newline #f]{}) @plain[#:file "captcha-text" #:newline #f]{})