From ef915d0d3a5375abb61527c929a24b31a420b2ee Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 1 Jun 2011 17:40:25 -0400 Subject: [PATCH] Add a popup question in case there's a captcha challenge. 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. --- collects/help/bug-report.rkt | 100 ++++++++++++++++++++----------- collects/meta/web/minis/bugs.rkt | 16 +++-- 2 files changed, 75 insertions(+), 41 deletions(-) diff --git a/collects/help/bug-report.rkt b/collects/help/bug-report.rkt index 08a5398d58..ec60725bbb 100644 --- a/collects/help/bug-report.rkt +++ b/collects/help/bug-report.rkt @@ -4,6 +4,7 @@ racket/gui/base framework racket/class + racket/port net/url net/uri-codec browser/htmltext @@ -20,6 +21,11 @@ (string->url (string-append "http://bugs.racket-lang.org/" path))) (define bug-report-url (bug-server-url "bug-report.cgi")) (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:full-name "" string? #:aliases '(drscheme:full-name)) @@ -45,7 +51,7 @@ (loop (cdr open-frames))))]))] [else (report-bug/new-frame this-bug-id frame-mixin)])) - + (define (report-bug/new-frame this-bug-id frame-mixin) (define bug-frame% (class (frame-mixin (frame:standard-menus-mixin frame:basic%)) @@ -188,50 +194,72 @@ (unsave-bug-report (saved-report-id init-bug-report)) (send single active-child finished-panel) (send finished-close focus)) - - ; send-bug-report : (-> void) + + ;; send-bug-report : (-> void) ;; initiates sending the bug report and switches the GUI's mode (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)) (define response-chan (make-channel)) (define exn-chan (make-channel)) (define worker-thread - (parameterize ([current-custodian cancel-kill-cust]) + (parameterize ([current-custodian cancel-kill-cust] + [current-alist-separator-mode 'amp]) (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))]) - (parameterize ([current-alist-separator-mode 'amp]) - (call/input-url - bug-report-url - (lambda (x) (post-impure-port x post-data)) - (lambda (port) - (define error? - (cond [(regexp-match #rx"^HTTP/[0-9.]+ +([0-9]+) *(.*)$" - (read-line port 'any)) - => (lambda (m) - ;; ignore the status text -- the reply should - ;; have a better indication of what went wrong - ((string->number (cadr m)) . >= . 400))] - [else #f])) - ;; skip HTTP headers - (regexp-match-positions #rx"\r?\n\r?\n" port) - (if error? - ;; error status => show as error - (begin (with-pending-text - (λ () - (send pending-text erase) - (render-html-to-text port pending-text #t #f))) - (channel-put exn-chan #f)) ; #f = "already rendered" - ;; (hopefully) a good result - (let ([response-text (new html-text%)]) - (render-html-to-text port response-text #t #f) - (send response-text auto-wrap #t) - (send response-text lock #t) - (channel-put response-chan response-text))))))))))) + (call/input-url + bug-report-url + (lambda (x) (post-impure-port x post-data)) + (lambda (port) + (define error? + (cond [(regexp-match #rx"^HTTP/[0-9.]+ +([0-9]+) *(.*)$" + (read-line port 'any)) + => (lambda (m) + ;; ignore the status text -- the reply should + ;; have a better indication of what went wrong + ((string->number (cadr m)) . >= . 400))] + [else #f])) + ;; skip HTTP headers + (regexp-match-positions #rx"\r?\n\r?\n" port) + (if error? + ;; error status => show as error + (begin (with-pending-text + (λ () + (send pending-text erase) + (render-html-to-text port pending-text #t #f))) + (channel-put exn-chan #f)) ; #f = "already rendered" + ;; (hopefully) a good result + (let ([response-text (new html-text%)]) + (render-html-to-text port response-text #t #f) + (send response-text auto-wrap #t) + (send response-text lock #t) + (channel-put response-chan response-text)))))))))) (define (render-error to-render) (cond [(string? to-render) diff --git a/collects/meta/web/minis/bugs.rkt b/collects/meta/web/minis/bugs.rkt index 2855413903..8a9e14c678 100644 --- a/collects/meta/web/minis/bugs.rkt +++ b/collects/meta/web/minis/bugs.rkt @@ -265,9 +265,15 @@ ;; be used in the future if spam bug reports that use drracket (or ;; racket code) directly become a problem. In this case, adding a ;; challenge here will make existing installations start asking for an - ;; answer. (And this could be done with a changes-on-each-build - ;; basis, or some script that will create and remember short-lived - ;; captcha challenges.) Note that the text should be a complete text - ;; for a question, including a "?" and instructions. It is used as is - ;; in the `message' argument for `get-text-from-user'. + ;; answer. Note that the text should be a complete text 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]{})