diff --git a/collects/tests/web-server/private/util-test.ss b/collects/tests/web-server/private/util-test.ss
index 8ef7ecb0f2..c8d1feccf5 100644
--- a/collects/tests/web-server/private/util-test.ss
+++ b/collects/tests/web-server/private/util-test.ss
@@ -19,19 +19,6 @@
(test-exn "0" exn:fail:contract? (lambda () (contract port-number? 0 'pos 'neg)))
(test-exn "10000000" exn:fail:contract? (lambda () (contract port-number? 10000000 'pos 'neg))))
- (test-equal? "pretty-print-invalid-xexpr"
- (let ([os (open-output-string)]
- [txe `(html (head (title "Foo"))
- (body (a ([href url]) "Text")))])
- (parameterize ([current-output-port os])
- (with-handlers ([exn:invalid-xexpr?
- (lambda (exn)
- (pretty-print-invalid-xexpr exn txe))])
- (validate-xexpr txe)
- #f))
- (get-output-string os))
- "(html (head (title \"Foo\")) (body (a ((href url)) \"Text\")))\n")
-
(test-suite
"url-replace-path"
(test-case
diff --git a/collects/web-server/configuration/responders.ss b/collects/web-server/configuration/responders.ss
index b59e6dc0e8..67312335cb 100644
--- a/collects/web-server/configuration/responders.ss
+++ b/collects/web-server/configuration/responders.ss
@@ -3,6 +3,7 @@
mzlib/list
net/url)
(require web-server/http/response-structs
+ web-server/private/xexpr
web-server/http/request-structs)
(define (format-stack-trace trace)
@@ -29,7 +30,7 @@
(div ([class "title"]) "Exception")
(p
"The application raised an exception with the message:"
- (pre ,(exn-message exn)))
+ (pre ,(reformat-xexpr-exn (exn-message exn))))
(p
"Stack trace:"
,(format-stack-trace
diff --git a/collects/web-server/default-web-root/htdocs/error.css b/collects/web-server/default-web-root/htdocs/error.css
index ec070d0f82..7c96cd29b6 100644
--- a/collects/web-server/default-web-root/htdocs/error.css
+++ b/collects/web-server/default-web-root/htdocs/error.css
@@ -23,3 +23,8 @@
padding: 5px;
border: 1px solid #ff99ff;
}
+
+.error {
+ color: red;
+ font-size: large;
+}
\ No newline at end of file
diff --git a/collects/web-server/private/util.ss b/collects/web-server/private/util.ss
index 8d03dcd060..1da37184dd 100644
--- a/collects/web-server/private/util.ss
+++ b/collects/web-server/private/util.ss
@@ -3,8 +3,6 @@
mzlib/plt-match
mzlib/contract
mzlib/serialize
- mzlib/pretty
- xml/xml
net/url)
(define path-element?
(or/c path-string? (symbols 'up 'same)))
@@ -14,7 +12,6 @@
(provide/contract
[path-element? contract?]
[port-number? contract?]
- [pretty-print-invalid-xexpr (exn:invalid-xexpr? any/c . -> . void)]
[url-replace-path (((listof path/param?) . -> . (listof path/param?)) url? . -> . url?)]
[explode-path* (path-string? . -> . (listof path-element?))]
[path-without-base (path-string? path-string? . -> . (listof path-element?))]
@@ -31,20 +28,6 @@
[read/bytes (bytes? . -> . serializable?)]
[write/bytes (serializable? . -> . bytes?)])
-(define (pretty-print-invalid-xexpr exn xexpr)
- (define code (exn:invalid-xexpr-code exn))
- (parameterize ([pretty-print-size-hook (lambda (v display? out)
- (and (equal? v code)
- (string-length (format (if display? "~a" "~v") v))))]
- [pretty-print-print-hook (lambda (v display? out)
- (fprintf out
- (string-append
- ""
- (if display? "~a" "~v")
- "")
- v))])
- (pretty-print xexpr)))
-
(define (read/string str)
(read (open-input-string str)))
(define (write/string v)
diff --git a/collects/web-server/private/xexpr.ss b/collects/web-server/private/xexpr.ss
new file mode 100644
index 0000000000..f0d828e351
--- /dev/null
+++ b/collects/web-server/private/xexpr.ss
@@ -0,0 +1,117 @@
+#lang scheme
+(require scheme/pretty
+ xml/xml)
+
+(provide/contract
+ [format-xexpr/errors (any/c . -> . string?)]
+ [reformat-xexpr-exn (string? . -> . xexpr/c)])
+
+; Formating Xexprs
+(define (format-xexpr/errors v)
+ (pretty-format (format-xexpr v)))
+
+(define-struct xexpr-error (message content)
+ #:property prop:custom-write
+ (lambda (v port write?)
+ (display "" port)
+ ; XXX Can this be XML escaped?
+ (print (xexpr-error-content v) port)
+ (display "" port)))
+(define mark-error make-xexpr-error)
+
+(define (xexpr-datum? v)
+ (or (string? v)
+ (symbol? v)
+ (exact-nonnegative-integer? v)
+ (comment? v)
+ (pi? v)
+ (cdata? v)))
+
+(define (format-xexpr v)
+ (cond
+ [(pair? v)
+ (cond
+ [(empty? v)
+ (mark-error "Not a valid Xexpr element (No tag; Tag must be a symbol.)" v)]
+ [(symbol? (car v))
+ (list* (car v)
+ (format-elements+attributes (cdr v)))]
+ [else
+ (list* (mark-error "Not a valid Xexpr element tag (Must be a symbol.)" (car v))
+ (format-elements+attributes (cdr v)))])]
+ [(xexpr-datum? v) v]
+ [else
+ (mark-error "Not a valid Xexpr datum (Must be a string, symbol, exact nonnegative integer, comment, PI, or cdata.)" v)]))
+
+(define (format-elements+attributes l)
+ (match l
+ ; ()
+ [(list) empty]
+ ; (datum ...)
+ [(list-rest (? xexpr-datum?) other-elems)
+ (format-elements l)]
+ ; ((p ...) ...)
+ [(list-rest (list-rest (? symbol?) inner-elems) other-elems)
+ (format-elements l)]
+ ; (attrs ...)
+ [(list-rest attrs elems)
+ (list* (format-attributes attrs)
+ (format-elements elems))]
+ [else
+ (mark-error
+ "Not a valid Xexpr tag content list. (Must be either (1) a list of Xexprs or (2) An attribute list followed by a list of Xexprs.)"
+ l)]))
+
+(define (format-elements l)
+ (map format-xexpr l))
+
+(define (format-attributes l)
+ (match l
+ [(list) empty]
+ [(list-rest attr attrs)
+ (list* (format-attribute attr)
+ (format-attributes attrs))]
+ [else
+ (mark-error
+ "Not a valid attribute list (Must be list of attributes. An attribute is a list containing a symbol and a string.)"
+ l)]))
+
+(define (format-attribute l)
+ (match l
+ [(list (? symbol? attr) (? string? val))
+ l]
+ [(list (? symbol? attr) val)
+ (list attr (mark-error "Not a valid attribute value (Must be string.)" val))]
+ [(list attr (? string? val))
+ (list (mark-error "Not a valid attribute name (Must be symbol.)" attr) val)]
+ [else
+ (mark-error "Not a valid attribute (Must be a list of a symbol and a string.)" l)]))
+
+; Reformating Xexpr errors
+(define (parse-xexpr-error s)
+ (with-input-from-string
+ s (lambda ()
+ (define violator (read))
+ (define c:broke (read))
+ (define c:the (read))
+ (define c:contract (read))
+ (define contract-expr (read))
+ (define c:on (read))
+ (define contracted (read))
+ (define c:semi (read-char))
+ (define xml:msg (read-line))
+ (define blank (read-line))
+ (define c:context (read-line))
+ (define not-xexpr (read))
+ (values violator contract-expr contracted xml:msg not-xexpr))))
+
+(define (reformat-xexpr-exn m)
+ (with-handlers (#;[exn? (lambda _ m)])
+ (define-values (violator contract-expr contracted xml:msg not-xexpr)
+ (parse-xexpr-error m))
+ `(span ,(format "~a broke the contract~n~a~non ~a;~a~n~nContext:~n"
+ violator (pretty-format contract-expr) contracted
+ xml:msg)
+ ,(make-cdata #f #f (format-xexpr/errors not-xexpr)))))
diff --git a/collects/web-server/scribblings/private.scrbl b/collects/web-server/scribblings/private.scrbl
index 4140d285a0..24707b68b7 100644
--- a/collects/web-server/scribblings/private.scrbl
+++ b/collects/web-server/scribblings/private.scrbl
@@ -433,13 +433,6 @@ needs. They are provided by @filepath{private/util.ss}.
@subsection{Exceptions}
-@defproc[(pretty-print-invalid-xexpr [exn exn:invalid-xexpr?]
- [v any/c])
- void]{
- Prints @scheme[v] as if it were almost an X-expression highlighting the error
- according to @scheme[exn].
-}
-
@defproc[(network-error [s symbol?]
[fmt string?]
[v any/c] ...)
diff --git a/collects/xml/private/xexpr.ss b/collects/xml/private/xexpr.ss
index 529776d183..05ec921117 100644
--- a/collects/xml/private/xexpr.ss
+++ b/collects/xml/private/xexpr.ss
@@ -84,7 +84,7 @@
(cdr x)))
(false (make-exn:invalid-xexpr
(format
- "Expected a symbol as the element name, given ~a"
+ "Expected a symbol as the element name, given ~s"
(car x))
(current-continuation-marks)
x)))))
@@ -92,7 +92,7 @@
(make-exn:invalid-xexpr
(format (string-append
"Expected a string, symbol, number, comment, "
- "processing instruction, or list, given ~a")
+ "processing instruction, or list, given ~s")
x)
(current-continuation-marks)
x)))))