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

error

Browse Source 
svn: r3941
This commit is contained in:
Jay McCarthy 2006-08-03 16:46:25 +00:00
parent d9409858fd
commit 2fde0eeab7
1 changed files with 20 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
collects/web-server/response.ss
View File

@ -122,7 +122,7 @@
(lambda () (lambda ()
(apply f conn args) (apply f conn args)
(flush-output (connection-o-port conn)))))))) (flush-output (connection-o-port conn))))))))
;; ************************************************** ;; **************************************************
;; output-response: connection response -> void ;; output-response: connection response -> void
@ -177,7 +177,7 @@
(define ext:output-response (define ext:output-response
(ext:wrap output-response)) (ext:wrap output-response))
;; response/full->size: response/full -> number ;; response/full->size: response/full -> number
;; compute the size for a response/full ;; compute the size for a response/full
(define (response/full->size resp/f) (define (response/full->size resp/f)
@ -204,7 +204,7 @@
(define ext:output-file (define ext:output-file
(ext:wrap output-file)) (ext:wrap output-file))
;; ************************************************** ;; **************************************************
;; output-response/method: connection response/full symbol -> void ;; output-response/method: connection response/full symbol -> void
;; If it is a head request output headers only, otherwise output as usual ;; If it is a head request output headers only, otherwise output as usual
@ -218,7 +218,7 @@
(define ext:output-response/method (define ext:output-response/method
(ext:wrap output-response/method)) (ext:wrap output-response/method))
;; ************************************************** ;; **************************************************
;; output-headers/response: connection response (listof (listof string)) -> void ;; output-headers/response: connection response (listof (listof string)) -> void
;; Write the headers for a response to an output port ;; Write the headers for a response to an output port
@ -278,10 +278,6 @@
;; Turn an exn:invalid-xexpr into a response. ;; Turn an exn:invalid-xexpr into a response.
(define (xexpr-exn->response exn x) (define (xexpr-exn->response exn x)
;;; Does it matter what number I use for pretty-print-size-hook?
(pretty-print-size-hook (lambda (v display? op) 20))
(pretty-print-print-hook (pretty-print-hook/web-errors
(exn:invalid-xexpr-code exn)))
(make-response/full (make-response/full
500 "Servlet Error" 500 "Servlet Error"
(current-seconds) (current-seconds)
@ -295,27 +291,22 @@
"<pre>" (exn-message exn) "</pre>" "<pre>" (exn-message exn) "</pre>"
"<h2>The Full Xexpr Is</h2>" "<h2>The Full Xexpr Is</h2>"
"<pre>" "<pre>"
(let ((o (open-output-string))) (let ([o (open-output-string)])
(pretty-print x o) (parameterize ([current-output-port o])
(pretty-print-invalid-xexpr exn x))
(get-output-string o)) (get-output-string o))
"</pre>")))) "</pre>"))))
;; Format everything normally, except for the erroneous data. (define (pretty-print-invalid-xexpr exn xexpr)
(define (pretty-print-hook/web-errors err) (define code (exn:invalid-xexpr-code exn))
(letrec ((f-aux (lambda (v) (parameterize ([pretty-print-size-hook (lambda (v display? out)
(cond (and (equal? v code)
((equal? v err) (string-length (format (if display? "~a" "~v") v))))]
(format [pretty-print-print-hook (lambda (v display? out)
(string-append (fprintf out
"<span style='font-weight: bold; " (string-append
"color: red; background-color: white;'>" "<font color=\"red\">"
"~a</span>") v)) (if display? "~a" "~v")
((list? v) (string-append "(" "</font>")
(string-join (map f-aux v) v))])
" ") (pretty-print xexpr))))
")"))
(else (format "~a" v))))))
(lambda (v display? op)
((if display? display write) (f-aux v) op))))
)