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.
This commit is contained in:
Eli Barzilay
parent
18d40dca3c
commit
ef915d0d3a
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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]{})
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user