From 18d40dca3c9abfad3163e62a408fc5fd8139712b Mon Sep 17 00:00:00 2001
From: Eli Barzilay <eli@barzilay.org>
Date: Wed, 1 Jun 2011 16:41:43 -0400
Subject: [PATCH] Use `post-impure-port' to submit the bugreport, and check the
 resulting HTTP status for an error code.

If there was an error, then render the HTML like other errors, so the
user can now hit back and try to fix things.
---
 collects/help/bug-report.rkt | 37 +++++++++++++++++++++++++++---------
 1 file changed, 28 insertions(+), 9 deletions(-)

diff --git a/collects/help/bug-report.rkt b/collects/help/bug-report.rkt
index 8334aafc95..08a5398d58 100644
--- a/collects/help/bug-report.rkt
+++ b/collects/help/bug-report.rkt
@@ -207,24 +207,43 @@
              (parameterize ([current-alist-separator-mode 'amp])
                (call/input-url
                 bug-report-url
-                (lambda (x) (post-pure-port x post-data))
+                (lambda (x) (post-impure-port x post-data))
                 (lambda (port)
-                  (define 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 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)
          (let ([str (string-append "<pre>\n\nERROR:\n"to-render"\n</pre>\n")])
            (render-error (open-input-string str)))]
         [(exn? to-render) (render-error (exn-message to-render))]
-        [(input-port? to-render)
+        [(or (input-port? to-render) (not to-render))
          (queue-callback
           (λ ()
-            (with-pending-text
-             (λ () (render-html-to-text to-render pending-text #t #f)))
+            (when to-render
+              (with-pending-text
+               (λ () (render-html-to-text to-render pending-text #t #f))))
             (send pending-back enable #t)
             (send pending-abort enable #f)))]
         [else (error 'render-error "internal error")]))